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

- Added hgeol 

- Fixed repository side eol to be LF
This commit is contained in:
Andreas Schneider 2010-07-25 00:18:54 +02:00
parent 0d84ac4b5d
commit 49599fdcf4
110 changed files with 40208 additions and 40202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.hgeol Normal file
View File

@ -0,0 +1,6 @@
[patterns]
**.* = native
bin/nodraw.txt = CRLF
[repository]
native = LF

74
Client/Tools/UfrmConfirmation.lfm
View File

@ -1,37 +1,37 @@
object frmConfirmation: TfrmConfirmation
Left = 290
Height = 43
Top = 171
Width = 108
BorderIcons = []
BorderStyle = bsToolWindow
Caption = 'Apply?'
ClientHeight = 43
ClientWidth = 108
Font.Height = -11
LCLVersion = '0.9.25'
object btnYes: TButton
Left = 8
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Caption = 'Yes'
Default = True
ModalResult = 6
ParentFont = True
TabOrder = 0
end
object btnNo: TButton
Left = 56
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'No'
ModalResult = 7
ParentFont = True
TabOrder = 1
end
end
object frmConfirmation: TfrmConfirmation
Left = 290
Height = 43
Top = 171
Width = 108
BorderIcons = []
BorderStyle = bsToolWindow
Caption = 'Apply?'
ClientHeight = 43
ClientWidth = 108
Font.Height = -11
LCLVersion = '0.9.25'
object btnYes: TButton
Left = 8
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Caption = 'Yes'
Default = True
ModalResult = 6
ParentFont = True
TabOrder = 0
end
object btnNo: TButton
Left = 56
Height = 25
Top = 8
Width = 40
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'No'
ModalResult = 7
ParentFont = True
TabOrder = 1
end
end

114
Client/Tools/UfrmConfirmation.pas
View File

@ -1,57 +1,57 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmConfirmation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TfrmConfirmation }
TfrmConfirmation = class(TForm)
btnYes: TButton;
btnNo: TButton;
private
{ private declarations }
public
{ public declarations }
end;
var
frmConfirmation: TfrmConfirmation;
implementation
initialization
{$I UfrmConfirmation.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmConfirmation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TfrmConfirmation }
TfrmConfirmation = class(TForm)
btnYes: TButton;
btnNo: TButton;
private
{ private declarations }
public
{ public declarations }
end;
var
frmConfirmation: TfrmConfirmation;
implementation
initialization
{$I UfrmConfirmation.lrs}
end.

246
Client/Tools/UfrmDrawSettings.lfm
View File

@ -1,123 +1,123 @@
inherited frmDrawSettings: TfrmDrawSettings
Left = 268
Height = 180
Top = 165
Width = 242
ActiveControl = rbTileList
Caption = 'Draw settings'
ClientHeight = 180
ClientWidth = 242
OnCreate = FormCreate
object rbTileList: TRadioButton[0]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 8
Height = 22
Top = 8
Width = 146
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Bottom = 4
Caption = 'Use tile from the list'
Checked = True
State = cbChecked
TabOrder = 0
end
object rbRandom: TRadioButton[1]
AnchorSideLeft.Control = rbTileList
AnchorSideTop.Control = rbTileList
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 34
Width = 213
BorderSpacing.Top = 4
Caption = 'Use tiles from the random pool'
TabOrder = 1
TabStop = False
end
object gbHue: TGroupBox[2]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = seRandomHeight
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 8
Height = 49
Top = 132
Width = 226
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 8
Caption = 'Hue (Statics only)'
ClientHeight = 45
ClientWidth = 222
TabOrder = 2
object pbHue: TPaintBox
Cursor = crHandPoint
Left = 4
Height = 41
Top = 0
Width = 214
Align = alClient
BorderSpacing.Left = 4
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
OnClick = pbHueClick
OnPaint = pbHuePaint
end
end
object cbRandomHeight: TCheckBox[3]
AnchorSideLeft.Control = cbForceAltitude
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 102
Width = 149
BorderSpacing.Top = 12
Caption = 'Add Random Altitude'
TabOrder = 3
end
object seRandomHeight: TSpinEdit[4]
AnchorSideTop.Control = cbRandomHeight
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 103
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
TabOrder = 4
end
object cbForceAltitude: TCheckBox[5]
AnchorSideLeft.Control = rbRandom
AnchorSideTop.Control = rbRandom
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 68
Width = 111
BorderSpacing.Top = 12
Caption = 'Force altitude:'
TabOrder = 5
end
object seForceAltitude: TSpinEdit[6]
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 69
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
MaxValue = 127
MinValue = -128
TabOrder = 6
end
inherited tmClose: TTimer[7]
end
end
inherited frmDrawSettings: TfrmDrawSettings
Left = 268
Height = 180
Top = 165
Width = 242
ActiveControl = rbTileList
Caption = 'Draw settings'
ClientHeight = 180
ClientWidth = 242
OnCreate = FormCreate
object rbTileList: TRadioButton[0]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 8
Height = 22
Top = 8
Width = 146
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Bottom = 4
Caption = 'Use tile from the list'
Checked = True
State = cbChecked
TabOrder = 0
end
object rbRandom: TRadioButton[1]
AnchorSideLeft.Control = rbTileList
AnchorSideTop.Control = rbTileList
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 34
Width = 213
BorderSpacing.Top = 4
Caption = 'Use tiles from the random pool'
TabOrder = 1
TabStop = False
end
object gbHue: TGroupBox[2]
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = seRandomHeight
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 8
Height = 49
Top = 132
Width = 226
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 8
Caption = 'Hue (Statics only)'
ClientHeight = 45
ClientWidth = 222
TabOrder = 2
object pbHue: TPaintBox
Cursor = crHandPoint
Left = 4
Height = 41
Top = 0
Width = 214
Align = alClient
BorderSpacing.Left = 4
BorderSpacing.Right = 4
BorderSpacing.Bottom = 4
OnClick = pbHueClick
OnPaint = pbHuePaint
end
end
object cbRandomHeight: TCheckBox[3]
AnchorSideLeft.Control = cbForceAltitude
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 102
Width = 149
BorderSpacing.Top = 12
Caption = 'Add Random Altitude'
TabOrder = 3
end
object seRandomHeight: TSpinEdit[4]
AnchorSideTop.Control = cbRandomHeight
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 103
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
TabOrder = 4
end
object cbForceAltitude: TCheckBox[5]
AnchorSideLeft.Control = rbRandom
AnchorSideTop.Control = rbRandom
AnchorSideTop.Side = asrBottom
Left = 8
Height = 22
Top = 68
Width = 111
BorderSpacing.Top = 12
Caption = 'Force altitude:'
TabOrder = 5
end
object seForceAltitude: TSpinEdit[6]
AnchorSideTop.Control = cbForceAltitude
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 184
Height = 21
Top = 69
Width = 50
Anchors = [akTop, akRight]
BorderSpacing.Right = 8
MaxValue = 127
MinValue = -128
TabOrder = 6
end
inherited tmClose: TTimer[7]
end
end

258
Client/Tools/UfrmDrawSettings.pas
View File

@ -1,129 +1,129 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmDrawSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Spin, ExtCtrls, LMessages, UfrmToolWindow;
type
{ TfrmDrawSettings }
TfrmDrawSettings = class(TfrmToolWindow)
cbForceAltitude: TCheckBox;
cbRandomHeight: TCheckBox;
gbHue: TGroupBox;
pbHue: TPaintBox;
rbRandom: TRadioButton;
rbTileList: TRadioButton;
seForceAltitude: TSpinEdit;
seRandomHeight: TSpinEdit;
procedure FormCreate(Sender: TObject);
procedure pbHueClick(Sender: TObject);
procedure pbHuePaint(Sender: TObject);
procedure seForceAltitudeChange(Sender: TObject);
procedure seRandomHeightChange(Sender: TObject);
private
FCanClose: Boolean;
function CanClose: Boolean; override;
procedure OnHueClose(Sender: TObject; var ACloseAction: TCloseAction);
end;
var
frmDrawSettings: TfrmDrawSettings;
implementation
uses
UGameResources, UHue, UfrmHueSettings;
{ TfrmDrawSettings }
procedure TfrmDrawSettings.pbHueClick(Sender: TObject);
begin
frmHueSettings.Left := Mouse.CursorPos.x - 8;
frmHueSettings.Top := Mouse.CursorPos.y - 8;
frmHueSettings.OnClose := @OnHueClose;
frmHueSettings.Show;
FCanClose := False;
end;
procedure TfrmDrawSettings.FormCreate(Sender: TObject);
begin
FCanClose := True;
end;
procedure TfrmDrawSettings.pbHuePaint(Sender: TObject);
var
hue: THue;
begin
if frmHueSettings <> nil then
begin
if frmHueSettings.lbHue.ItemIndex > 0 then
hue := ResMan.Hue.Hues[frmHueSettings.lbHue.ItemIndex - 1]
else
hue := nil;
TfrmHueSettings.DrawHue(hue, pbHue.Canvas, pbHue.Canvas.ClipRect,
frmHueSettings.lbHue.Items.Strings[frmHueSettings.lbHue.ItemIndex]);
end;
end;
procedure TfrmDrawSettings.seForceAltitudeChange(Sender: TObject);
begin
cbForceAltitude.Checked := True;
end;
procedure TfrmDrawSettings.seRandomHeightChange(Sender: TObject);
begin
cbRandomHeight.Checked := True;
end;
function TfrmDrawSettings.CanClose: Boolean;
begin
Result := FCanClose and inherited CanClose;
end;
procedure TfrmDrawSettings.OnHueClose(Sender: TObject;
var ACloseAction: TCloseAction);
var
msg: TLMessage;
begin
FCanClose := True;
frmHueSettings.OnClose := nil;
pbHue.Repaint;
MouseLeave(msg);
end;
initialization
{$I UfrmDrawSettings.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmDrawSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Spin, ExtCtrls, LMessages, UfrmToolWindow;
type
{ TfrmDrawSettings }
TfrmDrawSettings = class(TfrmToolWindow)
cbForceAltitude: TCheckBox;
cbRandomHeight: TCheckBox;
gbHue: TGroupBox;
pbHue: TPaintBox;
rbRandom: TRadioButton;
rbTileList: TRadioButton;
seForceAltitude: TSpinEdit;
seRandomHeight: TSpinEdit;
procedure FormCreate(Sender: TObject);
procedure pbHueClick(Sender: TObject);
procedure pbHuePaint(Sender: TObject);
procedure seForceAltitudeChange(Sender: TObject);
procedure seRandomHeightChange(Sender: TObject);
private
FCanClose: Boolean;
function CanClose: Boolean; override;
procedure OnHueClose(Sender: TObject; var ACloseAction: TCloseAction);
end;
var
frmDrawSettings: TfrmDrawSettings;
implementation
uses
UGameResources, UHue, UfrmHueSettings;
{ TfrmDrawSettings }
procedure TfrmDrawSettings.pbHueClick(Sender: TObject);
begin
frmHueSettings.Left := Mouse.CursorPos.x - 8;
frmHueSettings.Top := Mouse.CursorPos.y - 8;
frmHueSettings.OnClose := @OnHueClose;
frmHueSettings.Show;
FCanClose := False;
end;
procedure TfrmDrawSettings.FormCreate(Sender: TObject);
begin
FCanClose := True;
end;
procedure TfrmDrawSettings.pbHuePaint(Sender: TObject);
var
hue: THue;
begin
if frmHueSettings <> nil then
begin
if frmHueSettings.lbHue.ItemIndex > 0 then
hue := ResMan.Hue.Hues[frmHueSettings.lbHue.ItemIndex - 1]
else
hue := nil;
TfrmHueSettings.DrawHue(hue, pbHue.Canvas, pbHue.Canvas.ClipRect,
frmHueSettings.lbHue.Items.Strings[frmHueSettings.lbHue.ItemIndex]);
end;
end;
procedure TfrmDrawSettings.seForceAltitudeChange(Sender: TObject);
begin
cbForceAltitude.Checked := True;
end;
procedure TfrmDrawSettings.seRandomHeightChange(Sender: TObject);
begin
cbRandomHeight.Checked := True;
end;
function TfrmDrawSettings.CanClose: Boolean;
begin
Result := FCanClose and inherited CanClose;
end;
procedure TfrmDrawSettings.OnHueClose(Sender: TObject;
var ACloseAction: TCloseAction);
var
msg: TLMessage;
begin
FCanClose := True;
frmHueSettings.OnClose := nil;
pbHue.Repaint;
MouseLeave(msg);
end;
initialization
{$I UfrmDrawSettings.lrs}
end.

634
Client/Tools/UfrmFilter.lfm
View File

@ -1,317 +1,317 @@
object frmFilter: TfrmFilter
Left = 290
Height = 492
Top = 171
Width = 232
ActiveControl = rgFilterType.RadioButton0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsToolWindow
Caption = 'Filter'
ClientHeight = 492
ClientWidth = 232
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
LCLVersion = '0.9.29'
object rgFilterType: TRadioGroup
Left = 4
Height = 40
Top = 4
Width = 224
Align = alTop
AutoFill = True
BorderSpacing.Around = 4
Caption = 'Filter rule'
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 26
ClientWidth = 222
Columns = 2
ItemIndex = 0
Items.Strings = (
'Exclusive'
'Inclusive'
)
OnClick = rgFilterTypeClick
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 4
Height = 259
Top = 48
Width = 224
Align = alClient
BorderSpacing.Around = 4
Caption = 'Tile filter'
ClientHeight = 245
ClientWidth = 222
TabOrder = 1
object Label1: TLabel
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = cbTileFilter
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
Left = 4
Height = 30
Top = 30
Width = 214
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 4
Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.'
ParentColor = False
WordWrap = True
end
object btnClear: TSpeedButton
AnchorSideLeft.Control = btnDelete
AnchorSideLeft.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrCenter
AnchorSideBottom.Control = btnDelete
AnchorSideBottom.Side = asrBottom
Left = 30
Height = 22
Hint = 'Clear'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000003ADCFE004800
3A00FEFF4800FCFF1C00FCFF1C0080FF9C00003BD700AF9AFF00002CC600FDEB
9B000000000000000000000000000000000000000000000000000EECFF00B2FC
FF000046C00078D0FF000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
EFFF0000EDFF0000EDFFCBF3FC008905000024AEEF00E4A81C000000DB00B29E
FF0088000D000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
F7FF3242F7FF141BF1FF0000EDFFFCFF1C00FCFF1C0080FF9C0004000000FFBC
00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
F5FF161BF5FF3343F7FF141BF1FF0000EDFFE4FF5C000050FF004C0000000000
F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF000008000052FF000000
FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF0000CC0088005B000000
FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00B8FF00E3FFA8000000
FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF08009000FCFF72000000
FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF02000000E4FF5C000000
FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FFFCFF1C00000000000000
FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000CCFF4C000000
FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
FEFF5461FEFF2227FCFF0000FBFFFCFF1C00000000000000000008000000EFEF
EF00EFEFEF00EFEFEF000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
FDFF0000FDFF0000FDFF000000000000000000000000000000009034DE009034
DE00D86FDF00D86FDF00E0A223004AC6080000000000580000005870DF000C70
DF000000000000000000000000002070DF000000000000000000
}
NumGlyphs = 0
OnClick = btnClearClick
ShowHint = True
ParentShowHint = False
end
object btnDelete: TSpeedButton
AnchorSideLeft.Control = GroupBox1
AnchorSideBottom.Control = GroupBox1
AnchorSideBottom.Side = asrBottom
Left = 4
Height = 22
Hint = 'Delete'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
BorderSpacing.Around = 4
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000004F91AB005588
9C0043718A004E6974003E4B4C00457796003E6A950037556C005C7E8800548B
A00031464100FFFFFF002B3238002D3B430074B9C8007FC4D5004788A7004A92
B500435E6F002E3040002E3538003D5E7B003853BEFF3551BDFF304BBCFF2E4E
B8FF303B3600FFFFFF00313637002C2D2B00588997007BC3D400365F8400396E
9A003B6282003A5564004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
E4FF334DC1FF2B4AB7FFFFFFFF0036423900486B710061B4CE00396F9600375C
83004085B1004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
EEFF9EA0F4FF515DD7FF2B4AB7FFFFFFFF00354C4C004D94AF00375D7F003348
5C005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FFFFFFFF004A90A6003B5864003D5B
6A004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF57929C00498BA40047676D005C62
D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF54839500FFFFFF005F63
DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF6FA2AF00000000006469
DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF58B2E00000000000676A
DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF000000000800000000E8
1D007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF000000000000000001000100DB12
C0006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF00000000000000002401AD00BA02
AE002301AE006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
FBFFBAC7FCFF707BE9FF4C5BCCFFBB02F00000010000D8000000000000000000
000008000000010008006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
F4FF6670E2FF535ED1FF5031DE005031DE002501AC00B902AD000D040400F804
0500F20005000A0106000C040500F8040600686ADDFF6364DCFF6164DAFF5D63
D9FFF2000700F804610000000000710900005031DE005031DE004034DE004034
DE0068B0E00068B0E0000E049300F8049500F2009500070102000F049500F804
0200F2000200080104000E040200F8040400F200040009010500
}
NumGlyphs = 0
OnClick = btnDeleteClick
ShowHint = True
ParentShowHint = False
end
object vdtFilter: TVirtualDrawTree
Tag = 1
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = btnDelete
Cursor = 63
Left = 4
Height = 151
Top = 64
Width = 214
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Around = 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.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
OnDragOver = vdtFilterDragOver
OnDragDrop = vdtFilterDragDrop
OnDrawNode = vdtFilterDrawNode
end
object cbTileFilter: TCheckBox
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = GroupBox1
Left = 4
Height = 22
Top = 4
Width = 85
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbTileFilterChange
TabOrder = 1
end
end
object GroupBox2: TGroupBox
Left = 4
Height = 168
Top = 320
Width = 224
Align = alBottom
BorderSpacing.Around = 4
Caption = 'Hue filter'
ClientHeight = 154
ClientWidth = 222
TabOrder = 2
object cbHueFilter: TCheckBox
Left = 4
Height = 22
Top = 4
Width = 214
Align = alTop
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbHueFilterChange
TabOrder = 0
end
object vdtHues: TVirtualDrawTree
Cursor = 63
Left = 4
Height = 120
Top = 30
Width = 214
Align = alClient
BorderSpacing.Around = 4
Header.AutoSizeIndex = 2
Header.Columns = <
item
Position = 0
Width = 20
end
item
Position = 1
Text = 'Hue'
Width = 38
end
item
Position = 2
Text = 'Name'
Width = 154
end>
Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
PopupMenu = pmHues
TabOrder = 1
TreeOptions.MiscOptions = [toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnChecked = vdtHuesChecked
OnDrawNode = vdtHuesDrawNode
end
end
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 5
Top = 311
Width = 232
Align = alBottom
ResizeAnchor = akBottom
end
object pmHues: TPopupMenu
left = 148
top = 404
object mnuCheckHues: TMenuItem
Caption = 'Check all hues'
OnClick = mnuCheckHuesClick
end
object mnuUncheckHues: TMenuItem
Caption = 'Uncheck all hues'
OnClick = mnuUncheckHuesClick
end
end
end
object frmFilter: TfrmFilter
Left = 290
Height = 492
Top = 171
Width = 232
ActiveControl = rgFilterType.RadioButton0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsToolWindow
Caption = 'Filter'
ClientHeight = 492
ClientWidth = 232
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
LCLVersion = '0.9.29'
object rgFilterType: TRadioGroup
Left = 4
Height = 40
Top = 4
Width = 224
Align = alTop
AutoFill = True
BorderSpacing.Around = 4
Caption = 'Filter rule'
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 26
ClientWidth = 222
Columns = 2
ItemIndex = 0
Items.Strings = (
'Exclusive'
'Inclusive'
)
OnClick = rgFilterTypeClick
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 4
Height = 259
Top = 48
Width = 224
Align = alClient
BorderSpacing.Around = 4
Caption = 'Tile filter'
ClientHeight = 245
ClientWidth = 222
TabOrder = 1
object Label1: TLabel
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = cbTileFilter
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
Left = 4
Height = 30
Top = 30
Width = 214
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 4
Caption = 'Drag and Drop static tiles from the tile list on this list to add them to the filter.'
ParentColor = False
WordWrap = True
end
object btnClear: TSpeedButton
AnchorSideLeft.Control = btnDelete
AnchorSideLeft.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrCenter
AnchorSideBottom.Control = btnDelete
AnchorSideBottom.Side = asrBottom
Left = 30
Height = 22
Hint = 'Clear'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000003ADCFE004800
3A00FEFF4800FCFF1C00FCFF1C0080FF9C00003BD700AF9AFF00002CC600FDEB
9B000000000000000000000000000000000000000000000000000EECFF00B2FC
FF000046C00078D0FF000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
EFFF0000EDFF0000EDFFCBF3FC008905000024AEEF00E4A81C000000DB00B29E
FF0088000D000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
F7FF3242F7FF141BF1FF0000EDFFFCFF1C00FCFF1C0080FF9C0004000000FFBC
00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
F5FF161BF5FF3343F7FF141BF1FF0000EDFFE4FF5C000050FF004C0000000000
F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF000008000052FF000000
FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF0000CC0088005B000000
FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00B8FF00E3FFA8000000
FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF08009000FCFF72000000
FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF02000000E4FF5C000000
FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FFFCFF1C00000000000000
FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000CCFF4C000000
FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
FEFF5461FEFF2227FCFF0000FBFFFCFF1C00000000000000000008000000EFEF
EF00EFEFEF00EFEFEF000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
FDFF0000FDFF0000FDFF000000000000000000000000000000009034DE009034
DE00D86FDF00D86FDF00E0A223004AC6080000000000580000005870DF000C70
DF000000000000000000000000002070DF000000000000000000
}
NumGlyphs = 0
OnClick = btnClearClick
ShowHint = True
ParentShowHint = False
end
object btnDelete: TSpeedButton
AnchorSideLeft.Control = GroupBox1
AnchorSideBottom.Control = GroupBox1
AnchorSideBottom.Side = asrBottom
Left = 4
Height = 22
Hint = 'Delete'
Top = 219
Width = 22
Anchors = [akLeft, akBottom]
BorderSpacing.Around = 4
Color = clBtnFace
Glyph.Data = {
36040000424D3604000000000000360000002800000010000000100000000100
20000000000000040000640000006400000000000000000000004F91AB005588
9C0043718A004E6974003E4B4C00457796003E6A950037556C005C7E8800548B
A00031464100FFFFFF002B3238002D3B430074B9C8007FC4D5004788A7004A92
B500435E6F002E3040002E3538003D5E7B003853BEFF3551BDFF304BBCFF2E4E
B8FF303B3600FFFFFF00313637002C2D2B00588997007BC3D400365F8400396E
9A003B6282003A5564004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
E4FF334DC1FF2B4AB7FFFFFFFF0036423900486B710061B4CE00396F9600375C
83004085B1004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
EEFF9EA0F4FF515DD7FF2B4AB7FFFFFFFF00354C4C004D94AF00375D7F003348
5C005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FFFFFFFF004A90A6003B5864003D5B
6A004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF57929C00498BA40047676D005C62
D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF54839500FFFFFF005F63
DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF6FA2AF00000000006469
DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF58B2E00000000000676A
DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF000000000800000000E8
1D007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF000000000000000001000100DB12
C0006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF00000000000000002401AD00BA02
AE002301AE006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
FBFFBAC7FCFF707BE9FF4C5BCCFFBB02F00000010000D8000000000000000000
000008000000010008006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
F4FF6670E2FF535ED1FF5031DE005031DE002501AC00B902AD000D040400F804
0500F20005000A0106000C040500F8040600686ADDFF6364DCFF6164DAFF5D63
D9FFF2000700F804610000000000710900005031DE005031DE004034DE004034
DE0068B0E00068B0E0000E049300F8049500F2009500070102000F049500F804
0200F2000200080104000E040200F8040400F200040009010500
}
NumGlyphs = 0
OnClick = btnDeleteClick
ShowHint = True
ParentShowHint = False
end
object vdtFilter: TVirtualDrawTree
Tag = 1
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = GroupBox1
AnchorSideRight.Side = asrBottom
AnchorSideBottom.Control = btnDelete
Cursor = 63
Left = 4
Height = 151
Top = 64
Width = 214
Anchors = [akTop, akLeft, akRight, akBottom]
BorderSpacing.Around = 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.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
OnDragOver = vdtFilterDragOver
OnDragDrop = vdtFilterDragDrop
OnDrawNode = vdtFilterDrawNode
end
object cbTileFilter: TCheckBox
AnchorSideLeft.Control = GroupBox1
AnchorSideTop.Control = GroupBox1
Left = 4
Height = 22
Top = 4
Width = 85
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbTileFilterChange
TabOrder = 1
end
end
object GroupBox2: TGroupBox
Left = 4
Height = 168
Top = 320
Width = 224
Align = alBottom
BorderSpacing.Around = 4
Caption = 'Hue filter'
ClientHeight = 154
ClientWidth = 222
TabOrder = 2
object cbHueFilter: TCheckBox
Left = 4
Height = 22
Top = 4
Width = 214
Align = alTop
BorderSpacing.Around = 4
Caption = 'Filter active'
OnChange = cbHueFilterChange
TabOrder = 0
end
object vdtHues: TVirtualDrawTree
Cursor = 63
Left = 4
Height = 120
Top = 30
Width = 214
Align = alClient
BorderSpacing.Around = 4
Header.AutoSizeIndex = 2
Header.Columns = <
item
Position = 0
Width = 20
end
item
Position = 1
Text = 'Hue'
Width = 38
end
item
Position = 2
Text = 'Name'
Width = 154
end>
Header.DefaultHeight = 17
Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
PopupMenu = pmHues
TabOrder = 1
TreeOptions.MiscOptions = [toCheckSupport, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnChecked = vdtHuesChecked
OnDrawNode = vdtHuesDrawNode
end
end
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 5
Top = 311
Width = 232
Align = alBottom
ResizeAnchor = akBottom
end
object pmHues: TPopupMenu
left = 148
top = 404
object mnuCheckHues: TMenuItem
Caption = 'Check all hues'
OnClick = mnuCheckHuesClick
end
object mnuUncheckHues: TMenuItem
Caption = 'Uncheck all hues'
OnClick = mnuUncheckHuesClick
end
end
end

44
Client/Tools/UfrmLightlevel.lfm
View File

@ -1,22 +1,22 @@
inherited frmLightlevel: TfrmLightlevel
Height = 171
Width = 40
ActiveControl = tbLightlevel
Caption = 'Lightlevel'
ClientHeight = 171
ClientWidth = 40
object tbLightlevel: TTrackBar[0]
Left = 0
Height = 171
Top = 0
Width = 40
Max = 32
OnChange = tbLightlevelChange
Orientation = trVertical
Position = 0
Align = alClient
TabOrder = 0
end
inherited tmClose: TTimer[1]
end
end
inherited frmLightlevel: TfrmLightlevel
Height = 171
Width = 40
ActiveControl = tbLightlevel
Caption = 'Lightlevel'
ClientHeight = 171
ClientWidth = 40
object tbLightlevel: TTrackBar[0]
Left = 0
Height = 171
Top = 0
Width = 40
Max = 32
OnChange = tbLightlevelChange
Orientation = trVertical
Position = 0
Align = alClient
TabOrder = 0
end
inherited tmClose: TTimer[1]
end
end

208
Client/Tools/UfrmToolWindow.pas
View File

@ -1,104 +1,104 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmToolWindow;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
LCLIntf, LMessages, ExtCtrls;
type
{ TfrmToolWindow }
TfrmToolWindow = class(TForm)
tmClose: TTimer;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject); virtual;
procedure FormShow(Sender: TObject); virtual;
procedure tmCloseTimer(Sender: TObject);
protected
function CanClose: Boolean; virtual;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmToolWindow: TfrmToolWindow;
implementation
{ TfrmToolWindow }
procedure TfrmToolWindow.FormDeactivate(Sender: TObject);
begin
if CanClose then
Close;
end;
procedure TfrmToolWindow.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmToolWindow.FormShow(Sender: TObject);
begin
Top := Mouse.CursorPos.y - 8;
Left := Mouse.CursorPos.x - 8;
OnDeactivate := nil;
tmClose.Enabled := True;
end;
procedure TfrmToolWindow.tmCloseTimer(Sender: TObject);
begin
tmClose.Enabled := False;
OnDeactivate := @FormDeactivate;
if CanClose then
Close;
end;
function TfrmToolWindow.CanClose: Boolean;
begin
Result := not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos));
end;
procedure TfrmToolWindow.MouseLeave(var msg: TLMessage);
begin
if CanClose then
Close;
end;
initialization
{$I UfrmToolWindow.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmToolWindow;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
LCLIntf, LMessages, ExtCtrls;
type
{ TfrmToolWindow }
TfrmToolWindow = class(TForm)
tmClose: TTimer;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject); virtual;
procedure FormShow(Sender: TObject); virtual;
procedure tmCloseTimer(Sender: TObject);
protected
function CanClose: Boolean; virtual;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmToolWindow: TfrmToolWindow;
implementation
{ TfrmToolWindow }
procedure TfrmToolWindow.FormDeactivate(Sender: TObject);
begin
if CanClose then
Close;
end;
procedure TfrmToolWindow.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmToolWindow.FormShow(Sender: TObject);
begin
Top := Mouse.CursorPos.y - 8;
Left := Mouse.CursorPos.x - 8;
OnDeactivate := nil;
tmClose.Enabled := True;
end;
procedure TfrmToolWindow.tmCloseTimer(Sender: TObject);
begin
tmClose.Enabled := False;
OnDeactivate := @FormDeactivate;
if CanClose then
Close;
end;
function TfrmToolWindow.CanClose: Boolean;
begin
Result := not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos));
end;
procedure TfrmToolWindow.MouseLeave(var msg: TLMessage);
begin
if CanClose then
Close;
end;
initialization
{$I UfrmToolWindow.lrs}
end.

250
Client/UGameResources.pas
View File

@ -1,125 +1,125 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UGameResources;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UArtProvider, UTileDataProvider, UTexmapProvider,
ULandscape, UHueProvider, UAnimDataProvider, ULightProvider;
type
{ TGameResourceManager }
TGameResourceManager = class
constructor Create(ADataDir: String);
destructor Destroy; override;
protected
{ Members }
FDataDir: String;
FArtProvider: TArtProvider;
FTiledataProvider: TTiledataProvider;
FAnimdataProvider: TAnimdataProvider;
FTexmapProvider: TTexmapProvider;
FHueProvider: THueProvider;
FLightProvider: TLightProvider;
FLandscape: TLandscape;
public
{ Fields }
property Art: TArtProvider read FArtProvider;
property Hue: THueProvider read FHueProvider;
property Landscape: TLandscape read FLandscape;
property Tiledata: TTiledataProvider read FTiledataProvider;
property Animdata: TAnimDataProvider read FAnimdataProvider;
property Texmaps: TTexmapProvider read FTexmapProvider;
property Lights: TLightProvider read FLightProvider;
{ Methods }
function GetFile(AFileName: String): String;
procedure InitLandscape(AWidth, AHeight: Word);
end;
var
GameResourceManager: TGameResourceManager;
ResMan: TGameResourceManager absolute GameResourceManager;
procedure InitGameResourceManager(ADataDir: String);
implementation
procedure InitGameResourceManager(ADataDir: String);
begin
FreeAndNil(GameResourceManager);
GameResourceManager := TGameResourceManager.Create(ADataDir);
end;
{ TGameResourceManager }
constructor TGameResourceManager.Create(ADataDir: String);
begin
inherited Create;
FDataDir := IncludeTrailingPathDelimiter(ADataDir);
FArtProvider := TArtProvider.Create(GetFile('art.mul'), GetFile('artidx.mul'), True);
FTiledataProvider := TTiledataProvider.Create(GetFile('tiledata.mul'), True);
FAnimdataProvider := TAnimDataProvider.Create(GetFile('animdata.mul'), True);
FTexmapProvider := TTexmapProvider.Create(GetFile('texmaps.mul'),
GetFile('texidx.mul'), True);
FHueProvider := THueProvider.Create(GetFile('hues.mul'), True);
FLightProvider := TLightProvider.Create(GetFile('light.mul'),
GetFile('lightidx.mul'), True);
end;
destructor TGameResourceManager.Destroy;
begin
FreeAndNil(FArtProvider);
FreeAndNil(FTiledataProvider);
FreeAndNil(FAnimdataProvider);
FreeAndNil(FTexmapProvider);
FreeAndNil(FHueProvider);
FreeAndNil(FLightProvider);
FreeAndNil(FLandscape);
inherited Destroy;
end;
function TGameResourceManager.GetFile(AFileName: String): String;
begin
Result := FDataDir + AFileName;
end;
procedure TGameResourceManager.InitLandscape(AWidth, AHeight: Word);
begin
FreeAndNil(FLandscape);
FLandscape := TLandscape.Create(AWidth, AHeight);
end;
finalization
FreeAndNil(GameResourceManager);
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UGameResources;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UArtProvider, UTileDataProvider, UTexmapProvider,
ULandscape, UHueProvider, UAnimDataProvider, ULightProvider;
type
{ TGameResourceManager }
TGameResourceManager = class
constructor Create(ADataDir: String);
destructor Destroy; override;
protected
{ Members }
FDataDir: String;
FArtProvider: TArtProvider;
FTiledataProvider: TTiledataProvider;
FAnimdataProvider: TAnimdataProvider;
FTexmapProvider: TTexmapProvider;
FHueProvider: THueProvider;
FLightProvider: TLightProvider;
FLandscape: TLandscape;
public
{ Fields }
property Art: TArtProvider read FArtProvider;
property Hue: THueProvider read FHueProvider;
property Landscape: TLandscape read FLandscape;
property Tiledata: TTiledataProvider read FTiledataProvider;
property Animdata: TAnimDataProvider read FAnimdataProvider;
property Texmaps: TTexmapProvider read FTexmapProvider;
property Lights: TLightProvider read FLightProvider;
{ Methods }
function GetFile(AFileName: String): String;
procedure InitLandscape(AWidth, AHeight: Word);
end;
var
GameResourceManager: TGameResourceManager;
ResMan: TGameResourceManager absolute GameResourceManager;
procedure InitGameResourceManager(ADataDir: String);
implementation
procedure InitGameResourceManager(ADataDir: String);
begin
FreeAndNil(GameResourceManager);
GameResourceManager := TGameResourceManager.Create(ADataDir);
end;
{ TGameResourceManager }
constructor TGameResourceManager.Create(ADataDir: String);
begin
inherited Create;
FDataDir := IncludeTrailingPathDelimiter(ADataDir);
FArtProvider := TArtProvider.Create(GetFile('art.mul'), GetFile('artidx.mul'), True);
FTiledataProvider := TTiledataProvider.Create(GetFile('tiledata.mul'), True);
FAnimdataProvider := TAnimDataProvider.Create(GetFile('animdata.mul'), True);
FTexmapProvider := TTexmapProvider.Create(GetFile('texmaps.mul'),
GetFile('texidx.mul'), True);
FHueProvider := THueProvider.Create(GetFile('hues.mul'), True);
FLightProvider := TLightProvider.Create(GetFile('light.mul'),
GetFile('lightidx.mul'), True);
end;
destructor TGameResourceManager.Destroy;
begin
FreeAndNil(FArtProvider);
FreeAndNil(FTiledataProvider);
FreeAndNil(FAnimdataProvider);
FreeAndNil(FTexmapProvider);
FreeAndNil(FHueProvider);
FreeAndNil(FLightProvider);
FreeAndNil(FLandscape);
inherited Destroy;
end;
function TGameResourceManager.GetFile(AFileName: String): String;
begin
Result := FDataDir + AFileName;
end;
procedure TGameResourceManager.InitLandscape(AWidth, AHeight: Word);
begin
FreeAndNil(FLandscape);
FLandscape := TLandscape.Create(AWidth, AHeight);
end;
finalization
FreeAndNil(GameResourceManager);
end.

510
Client/UOverlayUI.pas
View File

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

300
Client/UPacketHandlers.pas
View File

@ -1,150 +1,150 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
SysUtils, dzlib, UEnhancedMemoryStream;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UAdminHandling;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
//writeln('compressed size: ', ABuffer.Size);
targetSize := ABuffer.ReadCardinal;
//writeln('uncompressed size: ', targetSize);
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream);
uncompStream.Unlock;
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.Socket.Disconnect;
ANetState.ReceiveQueue.Clear;}
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
//$02 --> ConnectionHandling, done by TdmNetwork
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);;
//$04 --> handled by TLandscape
//$06-$0B --> handled by TLandscape
//$0C --> ClientHandling, done by TfrmMain
//$0D --> RadarMapHandling, done by TfrmRadarMap
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
SysUtils, dzlib, UEnhancedMemoryStream;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UAdminHandling;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
//writeln('compressed size: ', ABuffer.Size);
targetSize := ABuffer.ReadCardinal;
//writeln('uncompressed size: ', targetSize);
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream);
uncompStream.Unlock;
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.Socket.Disconnect;
ANetState.ReceiveQueue.Clear;}
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
//$02 --> ConnectionHandling, done by TdmNetwork
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);;
//$04 --> handled by TLandscape
//$06-$0B --> handled by TLandscape
//$0C --> ClientHandling, done by TfrmMain
//$0D --> RadarMapHandling, done by TfrmRadarMap
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.

746
Client/UPackets.pas
View File

@ -1,373 +1,373 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UStatics;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TLoginRequestPacket }
TLoginRequestPacket = class(TPacket)
constructor Create(AUsername, APassword: string);
end;
{ TQuitPacket }
TQuitPacket = class(TPacket)
constructor Create;
end;
{ TRequestBlocksPacket }
TRequestBlocksPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray);
end;
{ TFreeBlockPacket }
TFreeBlockPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
end;
{ TStaticPacket }
TStaticPacket = class(TPacket)
protected
procedure WriteStaticItem(AStaticItem: TStaticItem);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewZ: Word);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewHue: Word);
end;
{ TUpdateClientPosPacket }
TUpdateClientPosPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TChatMessagePacket }
TChatMessagePacket = class(TPacket)
constructor Create(AMessage: string);
end;
{ TGotoClientPosPacket }
TGotoClientPosPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestRadarChecksumPacket }
TRequestRadarChecksumPacket = class(TPacket)
constructor Create;
end;
{ TRequestRadarMapPacket }
TRequestRadarMapPacket = class(TPacket)
constructor Create;
end;
{ TNoOpPacket }
TNoOpPacket = class(TPacket)
constructor Create;
end;
implementation
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TStream;
begin
inherited Create($01, 0);
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
sourceStream := APacket.Stream;
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TLoginRequestPacket }
constructor TLoginRequestPacket.Create(AUsername, APassword: string);
begin
inherited Create($02, 0);
FStream.WriteByte($03);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
end;
{ TQuitPacket }
constructor TQuitPacket.Create;
begin
inherited Create($02, 0);
FStream.WriteByte($05);
end;
{ TRequestBlocksPacket }
constructor TRequestBlocksPacket.Create(ACoords: TBlockCoordsArray);
begin
inherited Create($04, 0);
FStream.Write(ACoords[0], Length(ACoords) * SizeOf(TBlockCoords));
end;
{ TFreeBlockPacket }
constructor TFreeBlockPacket.Create(AX, AY: Word);
begin
inherited Create($05, 5);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
begin
inherited Create($06, 8);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
end;
{ TStaticPacket }
procedure TStaticPacket.WriteStaticItem(AStaticItem: TStaticItem);
begin
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word);
begin
inherited Create($07, 10);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
WriteStaticItem(AStaticItem);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
WriteStaticItem(AStaticItem);
FStream.WriteShortInt(ANewZ);
end;
constructor TElevateStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word; ANewZ: Word);
begin
inherited Create($09, 11);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
constructor TMoveStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewX, ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewHue);
end;
constructor THueStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewHue);
end;
{ TUpdateClientPosPacket }
constructor TUpdateClientPosPacket.Create(AX, AY: Word);
begin
inherited Create($0C, 0);
FStream.WriteByte($04);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TChatMessagePacket }
constructor TChatMessagePacket.Create(AMessage: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AMessage);
end;
{ TGotoClientPosPacket }
constructor TGotoClientPosPacket.Create(AUsername: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestRadarChecksumPacket }
constructor TRequestRadarChecksumPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($01);
end;
{ TRequestRadarMapPacket }
constructor TRequestRadarMapPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($02);
end;
{ TNoOpPacket }
constructor TNoOpPacket.Create;
begin
inherited Create($FF, 1);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UStatics;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TLoginRequestPacket }
TLoginRequestPacket = class(TPacket)
constructor Create(AUsername, APassword: string);
end;
{ TQuitPacket }
TQuitPacket = class(TPacket)
constructor Create;
end;
{ TRequestBlocksPacket }
TRequestBlocksPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray);
end;
{ TFreeBlockPacket }
TFreeBlockPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
end;
{ TStaticPacket }
TStaticPacket = class(TPacket)
protected
procedure WriteStaticItem(AStaticItem: TStaticItem);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewZ: Word);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TStaticPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
constructor Create(AX, AY: Word; AZ: ShortInt; ATileID: Word; AHue: Word;
ANewHue: Word);
end;
{ TUpdateClientPosPacket }
TUpdateClientPosPacket = class(TPacket)
constructor Create(AX, AY: Word);
end;
{ TChatMessagePacket }
TChatMessagePacket = class(TPacket)
constructor Create(AMessage: string);
end;
{ TGotoClientPosPacket }
TGotoClientPosPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestRadarChecksumPacket }
TRequestRadarChecksumPacket = class(TPacket)
constructor Create;
end;
{ TRequestRadarMapPacket }
TRequestRadarMapPacket = class(TPacket)
constructor Create;
end;
{ TNoOpPacket }
TNoOpPacket = class(TPacket)
constructor Create;
end;
implementation
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TStream;
begin
inherited Create($01, 0);
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
sourceStream := APacket.Stream;
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TLoginRequestPacket }
constructor TLoginRequestPacket.Create(AUsername, APassword: string);
begin
inherited Create($02, 0);
FStream.WriteByte($03);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
end;
{ TQuitPacket }
constructor TQuitPacket.Create;
begin
inherited Create($02, 0);
FStream.WriteByte($05);
end;
{ TRequestBlocksPacket }
constructor TRequestBlocksPacket.Create(ACoords: TBlockCoordsArray);
begin
inherited Create($04, 0);
FStream.Write(ACoords[0], Length(ACoords) * SizeOf(TBlockCoords));
end;
{ TFreeBlockPacket }
constructor TFreeBlockPacket.Create(AX, AY: Word);
begin
inherited Create($05, 5);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word);
begin
inherited Create($06, 8);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
end;
{ TStaticPacket }
procedure TStaticPacket.WriteStaticItem(AStaticItem: TStaticItem);
begin
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word);
begin
inherited Create($07, 10);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
WriteStaticItem(AStaticItem);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
WriteStaticItem(AStaticItem);
FStream.WriteShortInt(ANewZ);
end;
constructor TElevateStaticPacket.Create(AX, AY: Word; AZ: ShortInt;
ATileID: Word; AHue: Word; ANewZ: Word);
begin
inherited Create($09, 11);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
constructor TMoveStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewX, ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
WriteStaticItem(AStaticItem);
FStream.WriteWord(ANewHue);
end;
constructor THueStaticPacket.Create(AX, AY: Word; AZ: ShortInt; ATileID: Word;
AHue: Word; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
FStream.WriteShortInt(AZ);
FStream.WriteWord(ATileID);
FStream.WriteWord(AHue);
FStream.WriteWord(ANewHue);
end;
{ TUpdateClientPosPacket }
constructor TUpdateClientPosPacket.Create(AX, AY: Word);
begin
inherited Create($0C, 0);
FStream.WriteByte($04);
FStream.WriteWord(AX);
FStream.WriteWord(AY);
end;
{ TChatMessagePacket }
constructor TChatMessagePacket.Create(AMessage: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AMessage);
end;
{ TGotoClientPosPacket }
constructor TGotoClientPosPacket.Create(AUsername: string);
begin
inherited Create($0C, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestRadarChecksumPacket }
constructor TRequestRadarChecksumPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($01);
end;
{ TRequestRadarMapPacket }
constructor TRequestRadarMapPacket.Create;
begin
inherited Create($0D, 2);
FStream.WriteByte($02);
end;
{ TNoOpPacket }
constructor TNoOpPacket.Create;
begin
inherited Create($FF, 1);
end;
end.

210
Client/UResourceManager.pas
View File

@ -1,105 +1,105 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UResourceManager;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
{ TResourceManager }
TResourceManager = class
constructor Create(AFileName: string);
destructor Destroy; override;
protected
FFileStream: TFileStream;
FCount: Integer;
FLookupTable: array of Cardinal;
FCurrentResource: Integer;
FResourceStream: TMemoryStream;
public
function GetResource(AIndex: Integer): TStream;
end;
var
ResourceManager: TResourceManager;
implementation
{ TResourceManager }
constructor TResourceManager.Create(AFileName: string);
begin
inherited Create;
FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
FFileStream.Position := 0;
FFileStream.Read(FCount, SizeOf(Integer));
SetLength(FLookupTable, FCount);
FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal));
FCurrentResource := -1;
end;
destructor TResourceManager.Destroy;
begin
FreeAndNil(FFileStream);
FreeAndNil(FResourceStream);
inherited Destroy;
end;
function TResourceManager.GetResource(AIndex: Integer): TStream;
var
size: Cardinal;
begin
if AIndex <> FCurrentResource then
begin
FFileStream.Position := FLookupTable[AIndex];
FResourceStream.Free;
FResourceStream := TMemoryStream.Create;
FFileStream.Read(size, SizeOf(Cardinal));
FResourceStream.CopyFrom(FFileStream, size);
FCurrentResource := AIndex;
end;
FResourceStream.Position := 0;
Result := FResourceStream;
end;
initialization
begin
ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat'));
end;
finalization
begin
if ResourceManager <> nil then FreeAndNil(ResourceManager);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UResourceManager;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
{ TResourceManager }
TResourceManager = class
constructor Create(AFileName: string);
destructor Destroy; override;
protected
FFileStream: TFileStream;
FCount: Integer;
FLookupTable: array of Cardinal;
FCurrentResource: Integer;
FResourceStream: TMemoryStream;
public
function GetResource(AIndex: Integer): TStream;
end;
var
ResourceManager: TResourceManager;
implementation
{ TResourceManager }
constructor TResourceManager.Create(AFileName: string);
begin
inherited Create;
FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
FFileStream.Position := 0;
FFileStream.Read(FCount, SizeOf(Integer));
SetLength(FLookupTable, FCount);
FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal));
FCurrentResource := -1;
end;
destructor TResourceManager.Destroy;
begin
FreeAndNil(FFileStream);
FreeAndNil(FResourceStream);
inherited Destroy;
end;
function TResourceManager.GetResource(AIndex: Integer): TStream;
var
size: Cardinal;
begin
if AIndex <> FCurrentResource then
begin
FFileStream.Position := FLookupTable[AIndex];
FResourceStream.Free;
FResourceStream := TMemoryStream.Create;
FFileStream.Read(size, SizeOf(Cardinal));
FResourceStream.CopyFrom(FFileStream, size);
FCurrentResource := AIndex;
end;
FResourceStream.Position := 0;
Result := FResourceStream;
end;
initialization
begin
ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat'));
end;
finalization
begin
if ResourceManager <> nil then FreeAndNil(ResourceManager);
end;
end.

742
Client/UdmNetwork.pas
View File

@ -1,371 +1,371 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UdmNetwork;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils;
type
{ TdmNetwork }
TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent;
tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject);
protected
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel;
{$I version.inc}
{ TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin;
end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]);
end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
DoLogin;
end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
begin
MessageDlg('Connection error', msg, mtError, [mbOK], 0);
if not TCPClient.Connected then
TCPClientDisconnect(aSocket);
end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var
buffer: array[0..4095] of byte;
size: Integer;
begin
repeat
size := TCPClient.Get(buffer, 4096);
if size > 0 then
FReceiveQueue.Enqueue(buffer, size);
until size <= 0;
ProcessQueue;
end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin
FLastPacket := Now;
end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin
if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create);
end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var
size: Integer;
begin
while FSendQueue.Size > 0 do
begin
FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then
FSendQueue.Dequeue(size)
else
Break;
end;
end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
subID: Byte;
loginState: TLoginState;
width, height: Word;
serverState: TServerState;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if ABuffer.ReadCardinal = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect;
end;
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint;
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmLightlevel := TfrmLightlevel.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
if loginState = lsInvalidUser then
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
end;
end;
$04: //Server state
begin
serverState := TServerState(ABuffer.ReadByte);
if serverState = ssRunning then
begin
frmInitialize.UnsetModal;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
case serverState of
ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.';
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
end;
tmNoOp.Enabled := False;
frmInitialize.Show;
frmInitialize.SetModal;
end;
end;
end;
end;
procedure TdmNetwork.ProcessQueue;
var
packetHandler: TPacketHandler;
size: Cardinal;
begin
FReceiveQueue.Position := 0;
while FReceiveQueue.Size >= 1 do
begin
packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
if packetHandler <> nil then
begin
size := packetHandler.PacketLength;
if size = 0 then
begin
if FReceiveQueue.Size > 5 then
size := FReceiveQueue.ReadCardinal
else
Break; //wait for more data
end;
if FReceiveQueue.Size >= size then
begin
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
packetHandler.Process(FReceiveQueue);
FReceiveQueue.Unlock;
FReceiveQueue.Dequeue(size);
end else
Break; //wait for more data
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
Disconnect;
FReceiveQueue.Clear;
end;
end;
end;
procedure TdmNetwork.DoLogin;
begin
tmNoOp.Enabled := False;
frmLogin := TfrmLogin.Create(dmNetwork);
if frmInitialize = nil then
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmAccountControl);
FreeAndNil(frmConfirmation);
FreeAndNil(frmDrawSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmVirtualLayer);
FreeAndNil(frmAbout);
FreeAndNil(frmRegionControl);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
FreeAndNil(frmLightlevel);
if frmMain <> nil then
begin
frmMain.ApplicationProperties1.OnIdle := nil;
FreeAndNil(frmMain);
end;
FreeAndNil(GameResourceManager);
frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
begin
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := frmLogin.edData.Text;
frmInitialize.lblStatus.Caption := 'Connecting';
frmInitialize.Show;
Break;
end else
MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0);
end;
frmLogin.Close;
FreeAndNil(frmLogin);
end;
procedure TdmNetwork.Send(APacket: TPacket);
var
source: TEnhancedMemoryStream;
begin
if TCPClient.Connected then
begin
FSendQueue.Seek(0, soFromEnd);
source := APacket.Stream;
FSendQueue.CopyFrom(source, 0);
OnCanSend(nil);
end;
APacket.Free;
end;
procedure TdmNetwork.Disconnect;
begin
Send(TQuitPacket.Create);
end;
procedure TdmNetwork.CheckClose(ASender: TForm);
begin
if ((frmLogin = nil) or (ASender = frmLogin)) and
((frmMain = nil) or (ASender = frmMain)) and
((frmInitialize = nil) or (not frmInitialize.Visible)) then
begin
Application.Terminate;
end;
end;
initialization
{$I UdmNetwork.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UdmNetwork;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Dialogs, lNetComponents, lNet,
UEnhancedMemoryStream, UPacket, UEnums, ExtCtrls, dateutils;
type
{ TdmNetwork }
TdmNetwork = class(TDataModule)
TCPClient: TLTCPComponent;
tmNoOp: TTimer;
procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure TCPClientConnect(aSocket: TLSocket);
procedure TCPClientDisconnect(aSocket: TLSocket);
procedure TCPClientError(const msg: string; aSocket: TLSocket);
procedure TCPClientReceive(aSocket: TLSocket);
procedure tmNoOpStartTimer(Sender: TObject);
procedure tmNoOpTimer(Sender: TObject);
protected
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FUsername: string;
FPassword: string;
FAccessLevel: TAccessLevel;
FDataDir: string;
FLastPacket: TDateTime;
procedure OnCanSend(ASocket: TLSocket);
procedure OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
procedure ProcessQueue;
procedure DoLogin;
public
property Username: string read FUsername;
property AccessLevel: TAccessLevel read FAccessLevel write FAccessLevel;
procedure Send(APacket: TPacket);
procedure Disconnect;
procedure CheckClose(ASender: TForm);
end;
var
dmNetwork: TdmNetwork;
implementation
uses
UPacketHandlers, UPackets, UfrmMain, UfrmLogin, UfrmInitialize,
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel;
{$I version.inc}
{ TdmNetwork }
procedure TdmNetwork.DataModuleCreate(Sender: TObject);
begin
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
TCPClient.OnCanSend := @OnCanSend;
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlingPacket);
DoLogin;
end;
procedure TdmNetwork.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSendQueue);
FreeAndNil(FReceiveQueue);
FreeAndNil(PacketHandlers[$02]);
end;
procedure TdmNetwork.TCPClientConnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
end;
procedure TdmNetwork.TCPClientDisconnect(aSocket: TLSocket);
begin
FSendQueue.Clear;
FReceiveQueue.Clear;
DoLogin;
end;
procedure TdmNetwork.TCPClientError(const msg: string; aSocket: TLSocket);
begin
MessageDlg('Connection error', msg, mtError, [mbOK], 0);
if not TCPClient.Connected then
TCPClientDisconnect(aSocket);
end;
procedure TdmNetwork.TCPClientReceive(aSocket: TLSocket);
var
buffer: array[0..4095] of byte;
size: Integer;
begin
repeat
size := TCPClient.Get(buffer, 4096);
if size > 0 then
FReceiveQueue.Enqueue(buffer, size);
until size <= 0;
ProcessQueue;
end;
procedure TdmNetwork.tmNoOpStartTimer(Sender: TObject);
begin
FLastPacket := Now;
end;
procedure TdmNetwork.tmNoOpTimer(Sender: TObject);
begin
if SecondsBetween(FLastPacket, Now) > 25 then
Send(TNoOpPacket.Create);
end;
procedure TdmNetwork.OnCanSend(ASocket: TLSocket);
var
size: Integer;
begin
while FSendQueue.Size > 0 do
begin
FLastPacket := Now;
size := TCPClient.Send(FSendQueue.Memory^, FSendQueue.Size);
if size > 0 then
FSendQueue.Dequeue(size)
else
Break;
end;
end;
procedure TdmNetwork.OnConnectionHandlingPacket(ABuffer: TEnhancedMemoryStream);
var
subID: Byte;
loginState: TLoginState;
width, height: Word;
serverState: TServerState;
begin
subID := ABuffer.ReadByte;
case subID of
$01:
begin
if ABuffer.ReadCardinal = ProtocolVersion then
begin
frmInitialize.lblStatus.Caption := 'Authenticating';
Send(TLoginRequestPacket.Create(FUsername, FPassword));
end else
begin
MessageDlg('Error', 'Invalid protocol version. Maybe your client is outdated.', mtError, [mbOK], 0);
Disconnect;
end;
end;
$03:
begin
loginState := TLoginState(ABuffer.ReadByte);
if loginState = lsOK then
begin
frmInitialize.lblStatus.Caption := 'Initializing';
frmInitialize.Repaint;
frmInitialize.lblStatus.Repaint;
Application.ProcessMessages;
FAccessLevel := TAccessLevel(ABuffer.ReadByte);
InitGameResourceManager(FDataDir);
width := ABuffer.ReadWord;
height := ABuffer.ReadWord;
ResMan.InitLandscape(width, height);
ResMan.Landscape.UpdateWriteMap(ABuffer);
frmMain := TfrmMain.Create(dmNetwork);
frmRadarMap := TfrmRadarMap.Create(frmMain);
frmLargeScaleCommand := TfrmLargeScaleCommand.Create(frmMain);
frmRegionControl := TfrmRegionControl.Create(frmMain);
frmAccountControl := TfrmAccountControl.Create(frmMain);
frmEditAccount := TfrmEditAccount.Create(frmAccountControl);
frmConfirmation := TfrmConfirmation.Create(frmMain);
frmDrawSettings := TfrmDrawSettings.Create(frmMain);
frmMoveSettings := TfrmMoveSettings.Create(frmMain);
frmElevateSettings := TfrmElevateSettings.Create(frmMain);
frmHueSettings := TfrmHueSettings.Create(frmMain);
frmBoundaries := TfrmBoundaries.Create(frmMain);
frmFilter := TfrmFilter.Create(frmMain);
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmLightlevel := TfrmLightlevel.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
if loginState = lsInvalidUser then
MessageDlg('Error', 'The username you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsInvalidPassword then
MessageDlg('Error', 'The password you specified is incorrect.', mtWarning, [mbOK], 0)
else if loginState = lsAlreadyLoggedIn then
MessageDlg('Error', 'There is already a client logged in using that account.', mtWarning, [mbOK], 0)
else if loginState = lsNoAccess then
MessageDlg('Error', 'This account has no access.', mtWarning, [mbOK], 0);
end;
end;
$04: //Server state
begin
serverState := TServerState(ABuffer.ReadByte);
if serverState = ssRunning then
begin
frmInitialize.UnsetModal;
frmInitialize.Hide;
tmNoOp.Enabled := True;
end else
begin
case serverState of
ssFrozen: frmInitialize.lblStatus.Caption := 'The server is currently paused.';
ssOther: frmInitialize.lblStatus.Caption := ABuffer.ReadStringNull
end;
tmNoOp.Enabled := False;
frmInitialize.Show;
frmInitialize.SetModal;
end;
end;
end;
end;
procedure TdmNetwork.ProcessQueue;
var
packetHandler: TPacketHandler;
size: Cardinal;
begin
FReceiveQueue.Position := 0;
while FReceiveQueue.Size >= 1 do
begin
packetHandler := PacketHandlers[FReceiveQueue.ReadByte];
if packetHandler <> nil then
begin
size := packetHandler.PacketLength;
if size = 0 then
begin
if FReceiveQueue.Size > 5 then
size := FReceiveQueue.ReadCardinal
else
Break; //wait for more data
end;
if FReceiveQueue.Size >= size then
begin
FReceiveQueue.Lock(FReceiveQueue.Position, size - FReceiveQueue.Position); //prevent handler from reading too much
packetHandler.Process(FReceiveQueue);
FReceiveQueue.Unlock;
FReceiveQueue.Dequeue(size);
end else
Break; //wait for more data
end else
begin
{Writeln('Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);}
Disconnect;
FReceiveQueue.Clear;
end;
end;
end;
procedure TdmNetwork.DoLogin;
begin
tmNoOp.Enabled := False;
frmLogin := TfrmLogin.Create(dmNetwork);
if frmInitialize = nil then
frmInitialize := TfrmInitialize.Create(dmNetwork);
FreeAndNil(frmEditAccount);
FreeAndNil(frmAccountControl);
FreeAndNil(frmConfirmation);
FreeAndNil(frmDrawSettings);
FreeAndNil(frmMoveSettings);
FreeAndNil(frmElevateSettings);
FreeAndNil(frmHueSettings);
FreeAndNil(frmBoundaries);
FreeAndNil(frmFilter);
FreeAndNil(frmVirtualLayer);
FreeAndNil(frmAbout);
FreeAndNil(frmRegionControl);
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
FreeAndNil(frmLightlevel);
if frmMain <> nil then
begin
frmMain.ApplicationProperties1.OnIdle := nil;
FreeAndNil(frmMain);
end;
FreeAndNil(GameResourceManager);
frmInitialize.Hide;
while frmLogin.ShowModal = mrOK do
begin
if TCPClient.Connect(frmLogin.edHost.Text, frmLogin.edPort.Value) then
begin
FUsername := frmLogin.edUsername.Text;
FPassword := frmLogin.edPassword.Text;
FDataDir := frmLogin.edData.Text;
frmInitialize.lblStatus.Caption := 'Connecting';
frmInitialize.Show;
Break;
end else
MessageDlg('Error', 'Cannot connect to the specified server.', mtError, [mbOK], 0);
end;
frmLogin.Close;
FreeAndNil(frmLogin);
end;
procedure TdmNetwork.Send(APacket: TPacket);
var
source: TEnhancedMemoryStream;
begin
if TCPClient.Connected then
begin
FSendQueue.Seek(0, soFromEnd);
source := APacket.Stream;
FSendQueue.CopyFrom(source, 0);
OnCanSend(nil);
end;
APacket.Free;
end;
procedure TdmNetwork.Disconnect;
begin
Send(TQuitPacket.Create);
end;
procedure TdmNetwork.CheckClose(ASender: TForm);
begin
if ((frmLogin = nil) or (ASender = frmLogin)) and
((frmMain = nil) or (ASender = frmMain)) and
((frmInitialize = nil) or (not frmInitialize.Visible)) then
begin
Application.Terminate;
end;
end;
initialization
{$I UdmNetwork.lrs}
end.

762
Client/UfrmAccountControl.lfm
View File

@ -1,381 +1,381 @@
object frmAccountControl: TfrmAccountControl
Left = 290
Height = 378
Top = 171
Width = 369
ActiveControl = vstAccounts
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Account Management'
ClientHeight = 378
ClientWidth = 369
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
Position = poOwnerFormCenter
LCLVersion = '0.9.29'
object tbMain: TToolBar
Left = 0
Height = 26
Top = 0
Width = 369
Caption = 'tbMain'
Images = ilToolbar
TabOrder = 0
object tbRefresh: TToolButton
Left = 1
Hint = 'Refresh'
Top = 2
Caption = 'Refresh'
ImageIndex = 0
ParentShowHint = False
ShowHint = True
OnClick = tbRefreshClick
end
object tbAddUser: TToolButton
Left = 32
Hint = 'Add User'
Top = 2
Caption = 'Add User'
ImageIndex = 1
ParentShowHint = False
ShowHint = True
OnClick = tbAddUserClick
end
object tbEditUser: TToolButton
Left = 55
Hint = 'Edit User'
Top = 2
Caption = 'Edit User'
ImageIndex = 2
ParentShowHint = False
ShowHint = True
OnClick = tbEditUserClick
end
object tbDeleteUser: TToolButton
Left = 78
Hint = 'Delete User'
Top = 2
Caption = 'Delete User'
ImageIndex = 3
ParentShowHint = False
ShowHint = True
OnClick = tbDeleteUserClick
end
object tbSeparator1: TToolButton
Left = 24
Top = 2
Width = 8
Caption = 'tbSeparator1'
Style = tbsDivider
end
end
object vstAccounts: TVirtualStringTree
Left = 0
Height = 352
Top = 26
Width = 369
Align = alClient
DefaultText = 'Node'
Header.AutoSizeIndex = 1
Header.Columns = <
item
Position = 0
Width = 30
end
item
Position = 1
Text = 'Username'
Width = 200
end
item
Position = 2
Text = 'Accesslevel'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
Images = ilAccesslevel
TabOrder = 1
TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnDblClick = vstAccountsDblClick
OnFreeNode = vstAccountsFreeNode
OnGetText = vstAccountsGetText
OnGetImageIndex = vstAccountsGetImageIndex
end
object ilToolbar: TImageList
left = 144
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000047994FFF419149FF000000000000
0000000000000000000000000000000000000000000000000000000000005BB4
65FF56AD5FFF50A65AFF4B9E53FF45964DFF60A868FF5BA262FF347E3AFF0000
000000000000000000000000000000000000000000005EB968FF79C383FF89CA
92FF94D09CFF95D19EFF90CF99FF8CCB94FF87C98FFF80C487FF4E9554FF276D
2CFF000000000000000000000000000000005CB667FF85C98EFF9BD4A4FF8FCE
98FF92CF9AFF8DCC95FF88CA90FF83C68BFF7EC485FF79C17FFF478D4CFF2265
25FF0000000000000000000000000000000075BF7EFF98D2A1FF94CF9CFF86C7
8DFF5EA765FF398640FF347E3AFF2E7633FF49904FFF458B4AFF206324FF0000
000000000000000000000000000054AB5EFF80C389FF8DCC95FF83C48AFF3D8B
44FF37833EFF000000000000000000000000236627FF1F6123FF000000000000
00000000000000000000000000004DA155FF47994FFF419149FF3B8842FF3580
3CFF000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000004DA155FF4799
4FFF419149FF3B8842FF35803CFF000000000000000000000000000000000000
000063C06EFF5FBB6AFF0000000000000000000000004B9E53FF45964DFF86C6
8EFF88C98FFF6FB376FF2E7633FF0000000000000000000000000000000062BE
6DFF7BC785FF77C281FF54AB5EFF4EA357FF499B51FF63AC6BFF83C38BFF87C9
8FFF82C689FF509756FF0000000000000000000000000000000060BC6CFF79C4
83FF9ED7A7FF9BD4A4FF97D29FFF92CF9AFF8DCC95FF88CA90FF7AC282FF7EC4
85FF5DA463FF266B2AFF000000000000000000000000000000005BB465FF73BD
7CFF96D19FFF94CF9CFF8FCD96FF8ACA91FF85C78BFF7ABE81FF65AD6CFF4B92
51FF246829FF0000000000000000000000000000000000000000000000004EA3
57FF66B06EFF61AA68FF3D8B44FF37833EFF327B37FF2C7432FF276D2CFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000419149FF3B8842FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFAEAB78FF609772FF4F8E
66FF428357FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFA79B61FF61AB81FF95D4B4FFBAE6
D0FF6ABB8FFF2D8F57FF196B37FF00000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF4A885DFF90D3B1FF92D6B1FFFFFF
FFFF65BC8CFF67BC8FFF196B37FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF317B4CFF9CD4B6FFFFFFFFFFFFFF
FFFFFFFFFFFF95D2B2FF196B37FF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF226E3AFF62BA8BFF60BA87FFFFFF
FFFF60B987FF67BC8FFF196B37FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5C572DFF288C53FF64BA8DFF95D2
B2FF64BA8DFF288C53FF196B37FF000000000000000000000000000000000000
00000000000000000000000000000000000000000000196B37FF196B37FF196B
37FF196B37FF196B37FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000012488DFF104B90FF0F488AFF11427DFF15335BFF00000000000000000000
000000000000000000000000000000000000000000000000000000000000114E
96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF000000000000
00000000000000000000000000000000000000000000000000000F4B97FF1258
9FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF000000000000
00000000000000000000000000000000000000000000000000000C3E87FF7C97
B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF000000000000
00000000000000000000000000000000000000000000000000001F5E9BFFD9E8
F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000000058A5
D8FF85B1DBFF469DD0FF000000000000000000000000000000002A5B92FFA6CA
EEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2884B7FF77BEE7FFB4D2
F0FFE5F3FFFFACD2EFFF488CC7FF0000000000000000000000006A3C25FF346D
A7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF2E8ABFFF7ED3EBFFB2E3F9FF8BC0
E7FFAED3F6FFC4E0FCFF669FD3FF000000000000000000000000BC481CFFF4E2
D4FF4E7BA9FF4D7BA8FF4D7BA8FF428CBAFF7DD4EEFFC4F6FDFF6CDDF6FF6DCA
EDFF63A3D7FF5D9BD2FF000000000000000000000000C44C1FFFF6E4D6FFFFE4
A4FFFFD472FFFFC969FFBFBB86FF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
F2FF4099DFFF0000000000000000000000008A5444FFFCC8ABFFFFD198FFFEC7
6DFFFEBF68FFB0A780FF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4691
D4FF686672FF0000000000000000287CCEFF78B3EAFFB39E94FFFFB760FFFFB6
63FFB3A37DFF76B8D3FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4795D8FF75B2
EAFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB84FFA792
74FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF5196D2FF96645DFF83BC
EFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF6035FF4389
AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF4988B7FF9C5442FF7A646DFF2E7E
CEFF6DA2D3FF0000000000000000000000000000000000000000B35020FF2D64
81FF94C7F9FF91C9F9FF4185C9FF2362A4FF89493DFFB24F24FF000000000000
000000000000000000000000000000000000000000000000000000000000113D
55FF285F87FF4988BDFF428DBCFF000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFF9590A0FF295DC1FF0542
BBFF0B45B0FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFF95828BFF3D74CEFF8DB5F7FFB8D6
FEFF72A8F5FF2D6BCAFF0000000000000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF2450ABFF8DB5F6FF4D92FFFF1177
FFFF2186FFFF408AEBFF0344B9FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF0542BCFFAECDFEFFFFFFFFFFFFFF
FFFFFFFFFFFF187FEFFF0442BCFF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF1F52AFFF639DF4FF187FFFFF0076
F8FF0076EEFF0368E1FF0345B9FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5F4C74FF2763C6FF2177E6FF0579
EAFF0164DDFF044DBDFF00000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000345B9FF0442
BCFF0345B9FF0000000000000000
}
end
object ilAccesslevel: TImageList
left = 176
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000A3A3A3FFA0A0A0FF9D9D9DFF9A9A9AFF979797FF949494FF000000000000
000000000000000000000000000000000000000000000000000000000000A2A2
A2FFBCBCBCFFCACACAFFCCCCCCFFCACACAFFC2C2C2FFADADADFF8C8C8CFF0000
0000000000000000000000000000000000000000000000000000A1A1A1FFC4C4
C4FFBEBEBEFFA1A1A1FF969696FF939393FF979797FFAEAEAEFFAEAEAEFF8484
84FF000000000000000000000000000000000000000000000000BABABAFFBFBF
BFFF989898FF00000000000000000000000000000000878787FFA8A8A8FF9E9E
9EFF00000000000000000000000000000000000000009D9D9DFFC4C4C4FFA1A1
A1FF000000000000000000000000000000000000000000000000898989FFA9A9
A9FF797979FF00000000000000000000000000000000999999FFC6C6C6FF9494
94FF0000000000000000000000000000000000000000000000007D7D7DFFABAB
ABFF767676FF00000000000000000000000061C3E1FF88A0A8FF919191FF8E8E
8EFF5AB9DCFF55B8DFFF51B5DEFF4DB1DDFF49ADDCFF46A8D7FF787878FF7676
76FF657E8DFF3199D8FF000000000000000060C2E1FFC9F3FCFFCBF3FDFFD4F6
FEFFD7F6FFFFD8F4FFFFE0F8FFFFDFF8FFFFDAF5FFFFCDF1FCFFC2EDFAFFBDEB
FAFFBDEBFAFF2B93D6FF00000000000000005CBFE0FFC8F3FCFF75DFF9FF89E6
FDFF95E7FFFF9AE5FFFFAAEEFFFFA8EDFFFF99E3FFFF74D5F9FF59CCF3FF4FC8
F1FFBBE9FAFF248DD5FF000000000000000058BBDFFFC7F1FCFF6FDCF9FF56BB
EDFF61BDEFFF9BE7FFFF35A6E2FF4BA4E1FF90E2FFFF49ADE9FF38A4E3FF49C4
F0FFB8E8F9FF1E88D4FF000000000000000053B7DEFFC6F0FCFF6AD9F8FF7CE2
FDFF90E8FFFF99E9FFFF329FDFFF548BB2FF8AE2FFFF6AD0F9FF50C5F1FF46C1
F0FFB6E7F9FF1883D3FF00000000000000004EB2DDFFC3EFFBFF65D6F8FF4CB6
ECFF5ABDEFFF95EBFFFF3097DDFF4D82ABFF84E1FFFF41A9E9FF329FE1FF42BE
EFFFB4E5F9FF137ED2FF000000000000000049ADDCFFC1EEFBFF5FD3F7FF6CDB
FCFF7FE5FFFF8FEDFFFF97F2FFFF93EDFFFF7CDFFFFF5BCCF8FF46BEEFFF3CBA
EEFFB3E3F9FF0E79D1FF000000000000000043A8DBFFBFECFBFF59CFF5FF41B0
ECFF4EBAEFFF5AC2EFFF60C6EFFF5CC4EFFF4CB6EFFF37A5E6FF2A9AE1FF38B8
EEFFB1E3F8FF0975D0FF00000000000000003DA3DAFFBCEBFAFFBCEBFCFFBFEE
FEFFC6F4FFFFCEF8FFFFD3FAFFFFD0F8FFFFC7F2FFFFBAE9FCFFB3E4F9FFB0E2
F8FFB0E2F8FF0571CFFF0000000000000000369DD9FF3199D8FF2C94D7FF2890
D6FF238CD5FF1E88D4FF1A84D3FF1580D2FF117CD1FF0E79D1FF0A76D0FF0773
CFFF0470CFFF016ECEFF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF2D6196FF0F4988FF2C6093FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF255A93FF0C3E76FF245485FF0E3E73FF265584FF163E69FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001136
67FF2A4B71FF4C759EFF3B638EFF11355BFF28527BFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001848
78FF9BB7D1FFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFF96B3CEFF1A4C7EFF0000
000000000000000000000000000000000000000000000000000000000000305D
8FFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2E629AFF0000
0000000000000000000000000000000000000000000000000000000000003D3D
3DFF416F9EFF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF4176A6FF373737FF0000
0000000000000000000000000000000000000000000000000000494949FF4B4B
4BFF989898FF5C5C5CFF557CA3FF557CA3FF4C4C4CFF989898FF4E4E4EFF4C4C
4CFF0000000000000000000000000000000000000000777777FF4C4C4CFF4E4E
4EFF979797FF595959FFABABABFFA5A5A5FF545454FF868686FF626262FF4A4A
4AFF0000000000000000000000000000000000000000636363FFA4A4A4FF5050
50FF525252FF5B5B5BFFB8B8B8FFC1C1C1FF575757FF4D4D4DFF5A5A5AFF7E7E
7EFF606060FF000000000000000000000000287CCEFF78B3EAFF7A7A7AFF8383
83FF7E7E7EFF5D5D5DFF494949FF4C4C4CFF555555FF646464FF5F5F5FFF6D6D
6DFF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF5F5F5FFF8F8F
8FFF7A7A7AFF777777FF6D6D6DFF4E4E4EFF727272FF6F6F6FFF848484FF5555
55FF83BCEFFF2A77CAFF0000000000000000000000002579CDFF5E5E5EFF4F4F
4FFF848484FF848484FF808080FF545454FF838383FF848484FF4A4A4AFF4545
45FF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000003D3D
3DFF4D4D4DFF494949FF474747FF474747FF454545FF474747FF383838FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000027B2E5FF1BA7F3FF1CACF4FF1CA8F4FF1BA1F1FF27ACDEFF000000000000
00000000000000000000000000000000000000000000000000000000000028B5
E5FF1BB6F5FF1CB6F5FF1CB6F5FF1CB2F5FF1CABF4FF1DAAF0FF28B0E0FF0000
0000000000000000000000000000000000000000000000000000000000001DBA
F5FF1CB6F5FF1CAAF4FF1CACF4FF1CACF4FF1CACF3FF1CA1F0FF1C93E4FF0000
0000000000000000000000000000000000000000000000000000000000001B9E
F3FF62ABCEFF8AB7E4FF3EC6EBFF1C9FEDFF1DA4EEFF1EA5EBFF1C9AE9FF0000
0000000000000000000000000000000000000000000000000000000000001E6D
ADFFBDD7EFFFA3C9EDFF9DC5E8FF44CEEFFF5BCDEFFFA8DCF1FF207CBDFF0000
0000000000000000000000000000000000000000000000000000000000002C61
8EFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D6299FF0000
0000000000000000000000000000000000000000000000000000000000004C72
49FF347499FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF357AA1FF4A6A46FF0000
000000000000000000000000000000000000000000000000000079935DFF2785
4EFFB3F5C8FF49898FFF4B7FA0FF4B7FA0FF49898FFFA9E8BAFF26844DFF738C
59FF0000000000000000000000000000000000000000AFE0ACFF37945DFF9FFD
C6FF91EFB8FF78D69FFF6FCD96FF69C68FFF62BF88FF73CF98FF94F0B9FF3088
51FF788754FF000000000000000000000000849D6CFF45A26BFF82E0A9FF82E0
A9FF6FCD96FF69C790FF64C28BFF5EBC85FF57B57EFF50AE77FF6BC891FF67C0
8AFF4F9A66FF769264FF0000000000000000287CCEFF78B3EAFF5AB881FF62C0
89FF62C089FF5FBD86FF5AB881FF55B37CFF4FAD76FF49A770FF419E67FF4DAB
74FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF409E67FF6ECC
95FF5BB881FF58B57EFF53B17AFF4FAC75FF54B17AFF51AD76FF67C18AFF3B92
5CFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF429D67FF318F
58FF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF2D8A53FF2F88
53FF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000668C
57FF428B55FF338952FF2E8851FF2D8750FF2E854EFF39854EFF4F824EFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF0F498AFF0F4988FF0E4581FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF0F498FFF0C3E76FF0C3E73FF0E3E73FF113F70FF0F3661FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001037
73FF7893B5FF8AB7E4FF6793C3FF11355BFF15395FFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001F5C
99FFBDD7EFFFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFFB7D3EBFF2365A4FF0000
000000000000000000000000000000000000000000000000000000000000395F
89FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2F6299FF0000
000000000000000000000000000000000000000000000000000000000000966B
3EFF537291FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF51799AFF8C643CFF0000
0000000000000000000000000000000000000000000000000000A57645FFB17D
3FFFD8BEA0FF968271FF5572A4FF435EB5FFA2795FFFD9BEA0FFB48042FFA875
46FF0000000000000000000000000000000000000000C29A70FFB27D41FFB480
42FFDCBF9EFFBE8A4CFFC4B6BCFF5E67C8FFB3814DFFD3B088FFC29159FFAF7A
3EFF9F6F41FF000000000000000000000000A5774AFFC3925BFFE2CAB0FFB682
44FFB78345FFB88855FF4A5BD0FF5060D2FFBA874CFFB37F41FFBF8A4EFFD0A9
7DFFBE8D57FF9C6F46FF0000000000000000287CCEFF78B3EAFFCEA679FFD2AE
83FFD0A97DFFB78859FF4D4EA6FF77627CFFB6844BFFC4935CFFC18E55FFC79A
67FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFFC18F55FFD8B9
94FFCEA678FFCCA375FFBA9370FFB27F44FFCA9F6EFFC89C69FFD3AE85FFB884
49FF83BCEFFF2A77CAFF0000000000000000000000002579CDFFC08E54FFB581
43FFD3AF85FFD3AF85FFD1AB7FFFB98547FFD2AE83FFD3AF85FFB07B3FFFA976
3CFF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000009966
34FFAF7A41FFAE793DFFAD783CFFAD783CFFAA7539FFAA753CFF936131FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000
}
end
end
object frmAccountControl: TfrmAccountControl
Left = 290
Height = 378
Top = 171
Width = 369
ActiveControl = vstAccounts
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Account Management'
ClientHeight = 378
ClientWidth = 369
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
Position = poOwnerFormCenter
LCLVersion = '0.9.29'
object tbMain: TToolBar
Left = 0
Height = 26
Top = 0
Width = 369
Caption = 'tbMain'
Images = ilToolbar
TabOrder = 0
object tbRefresh: TToolButton
Left = 1
Hint = 'Refresh'
Top = 2
Caption = 'Refresh'
ImageIndex = 0
ParentShowHint = False
ShowHint = True
OnClick = tbRefreshClick
end
object tbAddUser: TToolButton
Left = 32
Hint = 'Add User'
Top = 2
Caption = 'Add User'
ImageIndex = 1
ParentShowHint = False
ShowHint = True
OnClick = tbAddUserClick
end
object tbEditUser: TToolButton
Left = 55
Hint = 'Edit User'
Top = 2
Caption = 'Edit User'
ImageIndex = 2
ParentShowHint = False
ShowHint = True
OnClick = tbEditUserClick
end
object tbDeleteUser: TToolButton
Left = 78
Hint = 'Delete User'
Top = 2
Caption = 'Delete User'
ImageIndex = 3
ParentShowHint = False
ShowHint = True
OnClick = tbDeleteUserClick
end
object tbSeparator1: TToolButton
Left = 24
Top = 2
Width = 8
Caption = 'tbSeparator1'
Style = tbsDivider
end
end
object vstAccounts: TVirtualStringTree
Left = 0
Height = 352
Top = 26
Width = 369
Align = alClient
DefaultText = 'Node'
Header.AutoSizeIndex = 1
Header.Columns = <
item
Position = 0
Width = 30
end
item
Position = 1
Text = 'Username'
Width = 200
end
item
Position = 2
Text = 'Accesslevel'
Width = 100
end>
Header.DefaultHeight = 17
Header.Options = [hoColumnResize, hoDrag, hoVisible]
Header.ParentFont = True
Header.Style = hsFlatButtons
Images = ilAccesslevel
TabOrder = 1
TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
TreeOptions.SelectionOptions = [toFullRowSelect]
OnDblClick = vstAccountsDblClick
OnFreeNode = vstAccountsFreeNode
OnGetText = vstAccountsGetText
OnGetImageIndex = vstAccountsGetImageIndex
end
object ilToolbar: TImageList
left = 144
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000047994FFF419149FF000000000000
0000000000000000000000000000000000000000000000000000000000005BB4
65FF56AD5FFF50A65AFF4B9E53FF45964DFF60A868FF5BA262FF347E3AFF0000
000000000000000000000000000000000000000000005EB968FF79C383FF89CA
92FF94D09CFF95D19EFF90CF99FF8CCB94FF87C98FFF80C487FF4E9554FF276D
2CFF000000000000000000000000000000005CB667FF85C98EFF9BD4A4FF8FCE
98FF92CF9AFF8DCC95FF88CA90FF83C68BFF7EC485FF79C17FFF478D4CFF2265
25FF0000000000000000000000000000000075BF7EFF98D2A1FF94CF9CFF86C7
8DFF5EA765FF398640FF347E3AFF2E7633FF49904FFF458B4AFF206324FF0000
000000000000000000000000000054AB5EFF80C389FF8DCC95FF83C48AFF3D8B
44FF37833EFF000000000000000000000000236627FF1F6123FF000000000000
00000000000000000000000000004DA155FF47994FFF419149FF3B8842FF3580
3CFF000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000004DA155FF4799
4FFF419149FF3B8842FF35803CFF000000000000000000000000000000000000
000063C06EFF5FBB6AFF0000000000000000000000004B9E53FF45964DFF86C6
8EFF88C98FFF6FB376FF2E7633FF0000000000000000000000000000000062BE
6DFF7BC785FF77C281FF54AB5EFF4EA357FF499B51FF63AC6BFF83C38BFF87C9
8FFF82C689FF509756FF0000000000000000000000000000000060BC6CFF79C4
83FF9ED7A7FF9BD4A4FF97D29FFF92CF9AFF8DCC95FF88CA90FF7AC282FF7EC4
85FF5DA463FF266B2AFF000000000000000000000000000000005BB465FF73BD
7CFF96D19FFF94CF9CFF8FCD96FF8ACA91FF85C78BFF7ABE81FF65AD6CFF4B92
51FF246829FF0000000000000000000000000000000000000000000000004EA3
57FF66B06EFF61AA68FF3D8B44FF37833EFF327B37FF2C7432FF276D2CFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000419149FF3B8842FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFAEAB78FF609772FF4F8E
66FF428357FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFA79B61FF61AB81FF95D4B4FFBAE6
D0FF6ABB8FFF2D8F57FF196B37FF00000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF4A885DFF90D3B1FF92D6B1FFFFFF
FFFF65BC8CFF67BC8FFF196B37FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF317B4CFF9CD4B6FFFFFFFFFFFFFF
FFFFFFFFFFFF95D2B2FF196B37FF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF226E3AFF62BA8BFF60BA87FFFFFF
FFFF60B987FF67BC8FFF196B37FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5C572DFF288C53FF64BA8DFF95D2
B2FF64BA8DFF288C53FF196B37FF000000000000000000000000000000000000
00000000000000000000000000000000000000000000196B37FF196B37FF196B
37FF196B37FF196B37FF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000012488DFF104B90FF0F488AFF11427DFF15335BFF00000000000000000000
000000000000000000000000000000000000000000000000000000000000114E
96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF000000000000
00000000000000000000000000000000000000000000000000000F4B97FF1258
9FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF000000000000
00000000000000000000000000000000000000000000000000000C3E87FF7C97
B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF000000000000
00000000000000000000000000000000000000000000000000001F5E9BFFD9E8
F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000000058A5
D8FF85B1DBFF469DD0FF000000000000000000000000000000002A5B92FFA6CA
EEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2884B7FF77BEE7FFB4D2
F0FFE5F3FFFFACD2EFFF488CC7FF0000000000000000000000006A3C25FF346D
A7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF2E8ABFFF7ED3EBFFB2E3F9FF8BC0
E7FFAED3F6FFC4E0FCFF669FD3FF000000000000000000000000BC481CFFF4E2
D4FF4E7BA9FF4D7BA8FF4D7BA8FF428CBAFF7DD4EEFFC4F6FDFF6CDDF6FF6DCA
EDFF63A3D7FF5D9BD2FF000000000000000000000000C44C1FFFF6E4D6FFFFE4
A4FFFFD472FFFFC969FFBFBB86FF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
F2FF4099DFFF0000000000000000000000008A5444FFFCC8ABFFFFD198FFFEC7
6DFFFEBF68FFB0A780FF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4691
D4FF686672FF0000000000000000287CCEFF78B3EAFFB39E94FFFFB760FFFFB6
63FFB3A37DFF76B8D3FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4795D8FF75B2
EAFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB84FFA792
74FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF5196D2FF96645DFF83BC
EFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF6035FF4389
AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF4988B7FF9C5442FF7A646DFF2E7E
CEFF6DA2D3FF0000000000000000000000000000000000000000B35020FF2D64
81FF94C7F9FF91C9F9FF4185C9FF2362A4FF89493DFFB24F24FF000000000000
000000000000000000000000000000000000000000000000000000000000113D
55FF285F87FF4988BDFF428DBCFF000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
0000000000000000000000000000000000000000000000000000000000000F4B
97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
0000000000000000000000000000000000000000000000000000000000000C3E
87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
0000000000000000000000000000000000000000000000000000000000001F5E
9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
0000000000000000000000000000000000000000000000000000000000002A5B
92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
0000000000000000000000000000000000000000000000000000000000006A3C
25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
000000000000000000000000000000000000000000000000000000000000BC48
1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFF9590A0FF295DC1FF0542
BBFF0B45B0FF000000000000000000000000000000008A5444FFFCC8ABFFFFD1
98FFFEC76DFFFEBF68FFFEB964FFFEB15EFF95828BFF3D74CEFF8DB5F7FFB8D6
FEFF72A8F5FF2D6BCAFF0000000000000000287CCEFF78B3EAFFB39E94FFFFB7
60FFFFB663FFFEB261FFFEAC5DFFFEA559FF2450ABFF8DB5F6FF4D92FFFF1177
FFFF2186FFFF408AEBFF0344B9FF00000000297DD1FF82BAEEFF9F6658FFF5BB
84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FF0542BCFFAECDFEFFFFFFFFFFFFFF
FFFFFFFFFFFF187FEFFF0442BCFF00000000000000002579CDFF866161FFBF60
35FFFEB961FFFEB962FFFEB962FFFEB962FF1F52AFFF639DF4FF187FFFFF0076
F8FF0076EEFF0368E1FF0345B9FF00000000000000000000000000000000B350
20FFA0401FFFAA4522FFAC4622FFAB4422FF5F4C74FF2763C6FF2177E6FF0579
EAFF0164DDFF044DBDFF00000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000345B9FF0442
BCFF0345B9FF0000000000000000
}
end
object ilAccesslevel: TImageList
left = 176
Bitmap = {
4C69040000001000000010000000000000000000000000000000000000000000
0000A3A3A3FFA0A0A0FF9D9D9DFF9A9A9AFF979797FF949494FF000000000000
000000000000000000000000000000000000000000000000000000000000A2A2
A2FFBCBCBCFFCACACAFFCCCCCCFFCACACAFFC2C2C2FFADADADFF8C8C8CFF0000
0000000000000000000000000000000000000000000000000000A1A1A1FFC4C4
C4FFBEBEBEFFA1A1A1FF969696FF939393FF979797FFAEAEAEFFAEAEAEFF8484
84FF000000000000000000000000000000000000000000000000BABABAFFBFBF
BFFF989898FF00000000000000000000000000000000878787FFA8A8A8FF9E9E
9EFF00000000000000000000000000000000000000009D9D9DFFC4C4C4FFA1A1
A1FF000000000000000000000000000000000000000000000000898989FFA9A9
A9FF797979FF00000000000000000000000000000000999999FFC6C6C6FF9494
94FF0000000000000000000000000000000000000000000000007D7D7DFFABAB
ABFF767676FF00000000000000000000000061C3E1FF88A0A8FF919191FF8E8E
8EFF5AB9DCFF55B8DFFF51B5DEFF4DB1DDFF49ADDCFF46A8D7FF787878FF7676
76FF657E8DFF3199D8FF000000000000000060C2E1FFC9F3FCFFCBF3FDFFD4F6
FEFFD7F6FFFFD8F4FFFFE0F8FFFFDFF8FFFFDAF5FFFFCDF1FCFFC2EDFAFFBDEB
FAFFBDEBFAFF2B93D6FF00000000000000005CBFE0FFC8F3FCFF75DFF9FF89E6
FDFF95E7FFFF9AE5FFFFAAEEFFFFA8EDFFFF99E3FFFF74D5F9FF59CCF3FF4FC8
F1FFBBE9FAFF248DD5FF000000000000000058BBDFFFC7F1FCFF6FDCF9FF56BB
EDFF61BDEFFF9BE7FFFF35A6E2FF4BA4E1FF90E2FFFF49ADE9FF38A4E3FF49C4
F0FFB8E8F9FF1E88D4FF000000000000000053B7DEFFC6F0FCFF6AD9F8FF7CE2
FDFF90E8FFFF99E9FFFF329FDFFF548BB2FF8AE2FFFF6AD0F9FF50C5F1FF46C1
F0FFB6E7F9FF1883D3FF00000000000000004EB2DDFFC3EFFBFF65D6F8FF4CB6
ECFF5ABDEFFF95EBFFFF3097DDFF4D82ABFF84E1FFFF41A9E9FF329FE1FF42BE
EFFFB4E5F9FF137ED2FF000000000000000049ADDCFFC1EEFBFF5FD3F7FF6CDB
FCFF7FE5FFFF8FEDFFFF97F2FFFF93EDFFFF7CDFFFFF5BCCF8FF46BEEFFF3CBA
EEFFB3E3F9FF0E79D1FF000000000000000043A8DBFFBFECFBFF59CFF5FF41B0
ECFF4EBAEFFF5AC2EFFF60C6EFFF5CC4EFFF4CB6EFFF37A5E6FF2A9AE1FF38B8
EEFFB1E3F8FF0975D0FF00000000000000003DA3DAFFBCEBFAFFBCEBFCFFBFEE
FEFFC6F4FFFFCEF8FFFFD3FAFFFFD0F8FFFFC7F2FFFFBAE9FCFFB3E4F9FFB0E2
F8FFB0E2F8FF0571CFFF0000000000000000369DD9FF3199D8FF2C94D7FF2890
D6FF238CD5FF1E88D4FF1A84D3FF1580D2FF117CD1FF0E79D1FF0A76D0FF0773
CFFF0470CFFF016ECEFF00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF2D6196FF0F4988FF2C6093FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF255A93FF0C3E76FF245485FF0E3E73FF265584FF163E69FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001136
67FF2A4B71FF4C759EFF3B638EFF11355BFF28527BFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001848
78FF9BB7D1FFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFF96B3CEFF1A4C7EFF0000
000000000000000000000000000000000000000000000000000000000000305D
8FFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2E629AFF0000
0000000000000000000000000000000000000000000000000000000000003D3D
3DFF416F9EFF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF4176A6FF373737FF0000
0000000000000000000000000000000000000000000000000000494949FF4B4B
4BFF989898FF5C5C5CFF557CA3FF557CA3FF4C4C4CFF989898FF4E4E4EFF4C4C
4CFF0000000000000000000000000000000000000000777777FF4C4C4CFF4E4E
4EFF979797FF595959FFABABABFFA5A5A5FF545454FF868686FF626262FF4A4A
4AFF0000000000000000000000000000000000000000636363FFA4A4A4FF5050
50FF525252FF5B5B5BFFB8B8B8FFC1C1C1FF575757FF4D4D4DFF5A5A5AFF7E7E
7EFF606060FF000000000000000000000000287CCEFF78B3EAFF7A7A7AFF8383
83FF7E7E7EFF5D5D5DFF494949FF4C4C4CFF555555FF646464FF5F5F5FFF6D6D
6DFF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF5F5F5FFF8F8F
8FFF7A7A7AFF777777FF6D6D6DFF4E4E4EFF727272FF6F6F6FFF848484FF5555
55FF83BCEFFF2A77CAFF0000000000000000000000002579CDFF5E5E5EFF4F4F
4FFF848484FF848484FF808080FF545454FF838383FF848484FF4A4A4AFF4545
45FF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000003D3D
3DFF4D4D4DFF494949FF474747FF474747FF454545FF474747FF383838FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000027B2E5FF1BA7F3FF1CACF4FF1CA8F4FF1BA1F1FF27ACDEFF000000000000
00000000000000000000000000000000000000000000000000000000000028B5
E5FF1BB6F5FF1CB6F5FF1CB6F5FF1CB2F5FF1CABF4FF1DAAF0FF28B0E0FF0000
0000000000000000000000000000000000000000000000000000000000001DBA
F5FF1CB6F5FF1CAAF4FF1CACF4FF1CACF4FF1CACF3FF1CA1F0FF1C93E4FF0000
0000000000000000000000000000000000000000000000000000000000001B9E
F3FF62ABCEFF8AB7E4FF3EC6EBFF1C9FEDFF1DA4EEFF1EA5EBFF1C9AE9FF0000
0000000000000000000000000000000000000000000000000000000000001E6D
ADFFBDD7EFFFA3C9EDFF9DC5E8FF44CEEFFF5BCDEFFFA8DCF1FF207CBDFF0000
0000000000000000000000000000000000000000000000000000000000002C61
8EFFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D6299FF0000
0000000000000000000000000000000000000000000000000000000000004C72
49FF347499FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF357AA1FF4A6A46FF0000
000000000000000000000000000000000000000000000000000079935DFF2785
4EFFB3F5C8FF49898FFF4B7FA0FF4B7FA0FF49898FFFA9E8BAFF26844DFF738C
59FF0000000000000000000000000000000000000000AFE0ACFF37945DFF9FFD
C6FF91EFB8FF78D69FFF6FCD96FF69C68FFF62BF88FF73CF98FF94F0B9FF3088
51FF788754FF000000000000000000000000849D6CFF45A26BFF82E0A9FF82E0
A9FF6FCD96FF69C790FF64C28BFF5EBC85FF57B57EFF50AE77FF6BC891FF67C0
8AFF4F9A66FF769264FF0000000000000000287CCEFF78B3EAFF5AB881FF62C0
89FF62C089FF5FBD86FF5AB881FF55B37CFF4FAD76FF49A770FF419E67FF4DAB
74FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF409E67FF6ECC
95FF5BB881FF58B57EFF53B17AFF4FAC75FF54B17AFF51AD76FF67C18AFF3B92
5CFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF429D67FF318F
58FF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF63C18AFF2D8A53FF2F88
53FF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000668C
57FF428B55FF338952FF2E8851FF2D8750FF2E854EFF39854EFF4F824EFF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000565D68FF133F7AFF0D3E7DFF0C3C76FF123969FF4E5663FF000000000000
0000000000000000000000000000000000000000000000000000000000005F63
69FF284D7DFF0F498AFF0F4988FF0E4581FF0C3E73FF1B3D60FF595E63FF0000
0000000000000000000000000000000000000000000000000000000000003752
79FF0F498FFF0C3E76FF0C3E73FF0E3E73FF113F70FF0F3661FF143050FF0000
0000000000000000000000000000000000000000000000000000000000001037
73FF7893B5FF8AB7E4FF6793C3FF11355BFF15395FFF1C3959FF103255FF0000
0000000000000000000000000000000000000000000000000000000000001F5C
99FFBDD7EFFFA3C9EDFF9FC5E8FF74A1CDFF81B0DDFFB7D3EBFF2365A4FF0000
000000000000000000000000000000000000000000000000000000000000395F
89FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2F6299FF0000
000000000000000000000000000000000000000000000000000000000000966B
3EFF537291FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF51799AFF8C643CFF0000
0000000000000000000000000000000000000000000000000000A57645FFB17D
3FFFD8BEA0FF968271FF5572A4FF435EB5FFA2795FFFD9BEA0FFB48042FFA875
46FF0000000000000000000000000000000000000000C29A70FFB27D41FFB480
42FFDCBF9EFFBE8A4CFFC4B6BCFF5E67C8FFB3814DFFD3B088FFC29159FFAF7A
3EFF9F6F41FF000000000000000000000000A5774AFFC3925BFFE2CAB0FFB682
44FFB78345FFB88855FF4A5BD0FF5060D2FFBA874CFFB37F41FFBF8A4EFFD0A9
7DFFBE8D57FF9C6F46FF0000000000000000287CCEFF78B3EAFFCEA679FFD2AE
83FFD0A97DFFB78859FF4D4EA6FF77627CFFB6844BFFC4935CFFC18E55FFC79A
67FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFFC18F55FFD8B9
94FFCEA678FFCCA375FFBA9370FFB27F44FFCA9F6EFFC89C69FFD3AE85FFB884
49FF83BCEFFF2A77CAFF0000000000000000000000002579CDFFC08E54FFB581
43FFD3AF85FFD3AF85FFD1AB7FFFB98547FFD2AE83FFD3AF85FFB07B3FFFA976
3CFF2E7ECEFF6DA2D3FF00000000000000000000000000000000000000009966
34FFAF7A41FFAE793DFFAD783CFFAD783CFFAA7539FFAA753CFF936131FF0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000
}
end
end

822
Client/UfrmAccountControl.pas
View File

@ -1,411 +1,411 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2008 Andreas Schneider
*)
unit UfrmAccountControl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
VirtualTrees, Math, UEnhancedMemoryStream, UEnums;
type
{ TfrmAccountControl }
TfrmAccountControl = class(TForm)
ilToolbar: TImageList;
ilAccesslevel: TImageList;
tbMain: TToolBar;
tbRefresh: TToolButton;
tbAddUser: TToolButton;
tbEditUser: TToolButton;
tbDeleteUser: TToolButton;
tbSeparator1: TToolButton;
vstAccounts: TVirtualStringTree;
procedure tbEditUserClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tbAddUserClick(Sender: TObject);
procedure tbDeleteUserClick(Sender: TObject);
procedure tbRefreshClick(Sender: TObject);
procedure vstAccountsDblClick(Sender: TObject);
procedure vstAccountsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure vstAccountsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
protected
procedure OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
function FindNode(AUsername: string): PVirtualNode;
end;
var
frmAccountControl: TfrmAccountControl;
implementation
uses
UdmNetwork, UPacket, UPacketHandlers, UAdminHandling, UfrmEditAccount;
type
PAccountInfo = ^TAccountInfo;
TAccountInfo = record
Username: string;
AccessLevel: TAccessLevel;
Regions: TStringList;
end;
{ TModifyUserPacket }
TModifyUserPacket = class(TPacket)
constructor Create(AUsername, APassword: string; AAccessLevel: TAccessLevel;
ARegions: TStrings);
end;
{ TDeleteUserPacket }
TDeleteUserPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestUserListPacket }
TRequestUserListPacket = class(TPacket)
constructor Create;
end;
{ TModifyUserPacket }
constructor TModifyUserPacket.Create(AUsername, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStrings);
var
regionCount: Byte;
i: Integer;
begin
inherited Create($03, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
FStream.WriteByte(Byte(AAccessLevel));
regionCount := Min(ARegions.Count, 256);
FStream.WriteByte(regionCount);
for i := 0 to regionCount - 1 do
FStream.WriteStringNull(ARegions.Strings[i]);
end;
{ TDeleteUserPacket }
constructor TDeleteUserPacket.Create(AUsername: string);
begin
inherited Create($03, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestUserListPacket }
constructor TRequestUserListPacket.Create;
begin
inherited Create($03, 0);
FStream.WriteByte($07);
end;
{ TfrmAccountControl }
procedure TfrmAccountControl.FormCreate(Sender: TObject);
begin
vstAccounts.NodeDataSize := SizeOf(TAccountInfo);
AssignAdminPacketHandler($05, TPacketHandler.Create(0, @OnModifyUserResponse));
AssignAdminPacketHandler($06, TPacketHandler.Create(0, @OnDeleteUserResponse));
AssignAdminPacketHandler($07, TPacketHandler.Create(0, @OnListUsersPacket));
end;
procedure TfrmAccountControl.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmAccountControl.tbEditUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
regions: TStrings;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
with frmEditAccount do
begin
edUsername.Text := accountInfo^.Username;
edUsername.Color := clBtnFace;
edUsername.ReadOnly := True;
edPassword.Text := '';
lblPasswordHint.Visible := True;
SetAccessLevel(accountInfo^.AccessLevel);
SetRegions(accountInfo^.Regions);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text,
edPassword.Text, GetAccessLevel, regions));
regions.Free;
end;
end;
end;
end;
procedure TfrmAccountControl.FormDestroy(Sender: TObject);
begin
if AdminPacketHandlers[$05] <> nil then FreeAndNil(AdminPacketHandlers[$05]);
if AdminPacketHandlers[$06] <> nil then FreeAndNil(AdminPacketHandlers[$06]);
if AdminPacketHandlers[$07] <> nil then FreeAndNil(AdminPacketHandlers[$07]);
end;
procedure TfrmAccountControl.FormShow(Sender: TObject);
begin
tbRefreshClick(Sender);
end;
procedure TfrmAccountControl.tbAddUserClick(Sender: TObject);
var
regions: TStrings;
begin
with frmEditAccount do
begin
edUsername.Text := '';
edUsername.Color := clWindow;
edUsername.ReadOnly := False;
edPassword.Text := '';
lblPasswordHint.Visible := False;
cbAccessLevel.ItemIndex := 2;
SetRegions(nil);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text, edPassword.Text,
GetAccessLevel, regions));
regions.Free;
end;
end;
end;
procedure TfrmAccountControl.tbDeleteUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
if MessageDlg('Confirmation', Format('Do you really want to delete "%s"?',
[accountInfo^.Username]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
dmNetwork.Send(TDeleteUserPacket.Create(accountInfo^.Username));
end;
end;
procedure TfrmAccountControl.tbRefreshClick(Sender: TObject);
begin
dmNetwork.Send(TRequestUserListPacket.Create);
end;
procedure TfrmAccountControl.vstAccountsDblClick(Sender: TObject);
begin
tbEditUserClick(Sender);
end;
procedure TfrmAccountControl.vstAccountsFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
accountInfo: PAccountInfo;
begin
accountInfo := vstAccounts.GetNodeData(Node);
accountInfo^.Username := '';
if accountInfo^.Regions <> nil then FreeAndNil(accountInfo^.Regions);
end;
procedure TfrmAccountControl.vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
accountInfo: PAccountInfo;
begin
if Column = 0 then
begin
accountInfo := Sender.GetNodeData(Node);
case accountInfo^.AccessLevel of
alNone: ImageIndex := 0;
alView: ImageIndex := 1;
alNormal: ImageIndex := 2;
alAdministrator: ImageIndex := 3;
end;
end;
end;
procedure TfrmAccountControl.vstAccountsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
accountInfo: PAccountInfo;
begin
accountInfo := Sender.GetNodeData(Node);
case Column of
1: CellText := accountInfo^.Username;
2: CellText := GetAccessLevelString(accountInfo^.AccessLevel);
else
CellText := '';
end;
end;
procedure TfrmAccountControl.OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
modifyStatus: TModifyUserStatus;
username: string;
accountInfo: PAccountInfo;
i, regions: Integer;
begin
modifyStatus := TModifyUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case modifyStatus of
muAdded:
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := username;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been added.', [username]),
mtInformation, [mbOK], 0);
end;
muModified:
begin
node := FindNode(username);
if node <> nil then
begin
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions.Clear;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been modified.', [username]),
mtInformation, [mbOK], 0);
end;
end;
muInvalidUsername:
MessageDlg('Error', Format('The username "%s" is not valid.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
deleteStatus: TDeleteUserStatus;
username: string;
begin
deleteStatus := TDeleteUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case deleteStatus of
duDeleted:
begin
node := FindNode(username);
if node <> nil then
begin
vstAccounts.DeleteNode(node);
Messagedlg('Success', Format('The user "%s" has been deleted.', [username]),
mtInformation, [mbOK], 0);
end;
end;
duNotFound:
MessageDlg('Error', Format('The user "%s" could not be deleted. Maybe ' +
'your list is out of date or you tried to delete yourself.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
accountInfo: PAccountInfo;
i, j, count, regions: Integer;
begin
vstAccounts.BeginUpdate;
vstAccounts.Clear;
count := ABuffer.ReadWord;
for i := 1 to count do
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := ABuffer.ReadStringNull;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for j := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
end;
vstAccounts.EndUpdate;
end;
function TfrmAccountControl.FindNode(AUsername: string): PVirtualNode;
var
node: PVirtualNode;
accountInfo: PAccountInfo;
begin
Result := nil;
node := vstAccounts.GetFirst;
while (node <> nil) and (Result = nil) do
begin
accountInfo := vstAccounts.GetNodeData(node);
if accountInfo^.Username = AUsername then
Result := node;
node := vstAccounts.GetNext(node);
end;
end;
initialization
{$I UfrmAccountControl.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2008 Andreas Schneider
*)
unit UfrmAccountControl;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ComCtrls,
VirtualTrees, Math, UEnhancedMemoryStream, UEnums;
type
{ TfrmAccountControl }
TfrmAccountControl = class(TForm)
ilToolbar: TImageList;
ilAccesslevel: TImageList;
tbMain: TToolBar;
tbRefresh: TToolButton;
tbAddUser: TToolButton;
tbEditUser: TToolButton;
tbDeleteUser: TToolButton;
tbSeparator1: TToolButton;
vstAccounts: TVirtualStringTree;
procedure tbEditUserClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tbAddUserClick(Sender: TObject);
procedure tbDeleteUserClick(Sender: TObject);
procedure tbRefreshClick(Sender: TObject);
procedure vstAccountsDblClick(Sender: TObject);
procedure vstAccountsFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
procedure vstAccountsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
Column: TColumnIndex; TextType: TVSTTextType; var CellText: String);
protected
procedure OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
procedure OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
function FindNode(AUsername: string): PVirtualNode;
end;
var
frmAccountControl: TfrmAccountControl;
implementation
uses
UdmNetwork, UPacket, UPacketHandlers, UAdminHandling, UfrmEditAccount;
type
PAccountInfo = ^TAccountInfo;
TAccountInfo = record
Username: string;
AccessLevel: TAccessLevel;
Regions: TStringList;
end;
{ TModifyUserPacket }
TModifyUserPacket = class(TPacket)
constructor Create(AUsername, APassword: string; AAccessLevel: TAccessLevel;
ARegions: TStrings);
end;
{ TDeleteUserPacket }
TDeleteUserPacket = class(TPacket)
constructor Create(AUsername: string);
end;
{ TRequestUserListPacket }
TRequestUserListPacket = class(TPacket)
constructor Create;
end;
{ TModifyUserPacket }
constructor TModifyUserPacket.Create(AUsername, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStrings);
var
regionCount: Byte;
i: Integer;
begin
inherited Create($03, 0);
FStream.WriteByte($05);
FStream.WriteStringNull(AUsername);
FStream.WriteStringNull(APassword);
FStream.WriteByte(Byte(AAccessLevel));
regionCount := Min(ARegions.Count, 256);
FStream.WriteByte(regionCount);
for i := 0 to regionCount - 1 do
FStream.WriteStringNull(ARegions.Strings[i]);
end;
{ TDeleteUserPacket }
constructor TDeleteUserPacket.Create(AUsername: string);
begin
inherited Create($03, 0);
FStream.WriteByte($06);
FStream.WriteStringNull(AUsername);
end;
{ TRequestUserListPacket }
constructor TRequestUserListPacket.Create;
begin
inherited Create($03, 0);
FStream.WriteByte($07);
end;
{ TfrmAccountControl }
procedure TfrmAccountControl.FormCreate(Sender: TObject);
begin
vstAccounts.NodeDataSize := SizeOf(TAccountInfo);
AssignAdminPacketHandler($05, TPacketHandler.Create(0, @OnModifyUserResponse));
AssignAdminPacketHandler($06, TPacketHandler.Create(0, @OnDeleteUserResponse));
AssignAdminPacketHandler($07, TPacketHandler.Create(0, @OnListUsersPacket));
end;
procedure TfrmAccountControl.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmAccountControl.tbEditUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
regions: TStrings;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
with frmEditAccount do
begin
edUsername.Text := accountInfo^.Username;
edUsername.Color := clBtnFace;
edUsername.ReadOnly := True;
edPassword.Text := '';
lblPasswordHint.Visible := True;
SetAccessLevel(accountInfo^.AccessLevel);
SetRegions(accountInfo^.Regions);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text,
edPassword.Text, GetAccessLevel, regions));
regions.Free;
end;
end;
end;
end;
procedure TfrmAccountControl.FormDestroy(Sender: TObject);
begin
if AdminPacketHandlers[$05] <> nil then FreeAndNil(AdminPacketHandlers[$05]);
if AdminPacketHandlers[$06] <> nil then FreeAndNil(AdminPacketHandlers[$06]);
if AdminPacketHandlers[$07] <> nil then FreeAndNil(AdminPacketHandlers[$07]);
end;
procedure TfrmAccountControl.FormShow(Sender: TObject);
begin
tbRefreshClick(Sender);
end;
procedure TfrmAccountControl.tbAddUserClick(Sender: TObject);
var
regions: TStrings;
begin
with frmEditAccount do
begin
edUsername.Text := '';
edUsername.Color := clWindow;
edUsername.ReadOnly := False;
edPassword.Text := '';
lblPasswordHint.Visible := False;
cbAccessLevel.ItemIndex := 2;
SetRegions(nil);
if ShowModal = mrOK then
begin
regions := GetRegions;
dmNetwork.Send(TModifyUserPacket.Create(edUsername.Text, edPassword.Text,
GetAccessLevel, regions));
regions.Free;
end;
end;
end;
procedure TfrmAccountControl.tbDeleteUserClick(Sender: TObject);
var
selected: PVirtualNode;
accountInfo: PAccountInfo;
begin
selected := vstAccounts.GetFirstSelected;
if selected <> nil then
begin
accountInfo := vstAccounts.GetNodeData(selected);
if MessageDlg('Confirmation', Format('Do you really want to delete "%s"?',
[accountInfo^.Username]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
dmNetwork.Send(TDeleteUserPacket.Create(accountInfo^.Username));
end;
end;
procedure TfrmAccountControl.tbRefreshClick(Sender: TObject);
begin
dmNetwork.Send(TRequestUserListPacket.Create);
end;
procedure TfrmAccountControl.vstAccountsDblClick(Sender: TObject);
begin
tbEditUserClick(Sender);
end;
procedure TfrmAccountControl.vstAccountsFreeNode(Sender: TBaseVirtualTree;
Node: PVirtualNode);
var
accountInfo: PAccountInfo;
begin
accountInfo := vstAccounts.GetNodeData(Node);
accountInfo^.Username := '';
if accountInfo^.Regions <> nil then FreeAndNil(accountInfo^.Regions);
end;
procedure TfrmAccountControl.vstAccountsGetImageIndex(Sender: TBaseVirtualTree;
Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
var Ghosted: Boolean; var ImageIndex: Integer);
var
accountInfo: PAccountInfo;
begin
if Column = 0 then
begin
accountInfo := Sender.GetNodeData(Node);
case accountInfo^.AccessLevel of
alNone: ImageIndex := 0;
alView: ImageIndex := 1;
alNormal: ImageIndex := 2;
alAdministrator: ImageIndex := 3;
end;
end;
end;
procedure TfrmAccountControl.vstAccountsGetText(Sender: TBaseVirtualTree;
Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
var CellText: String);
var
accountInfo: PAccountInfo;
begin
accountInfo := Sender.GetNodeData(Node);
case Column of
1: CellText := accountInfo^.Username;
2: CellText := GetAccessLevelString(accountInfo^.AccessLevel);
else
CellText := '';
end;
end;
procedure TfrmAccountControl.OnModifyUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
modifyStatus: TModifyUserStatus;
username: string;
accountInfo: PAccountInfo;
i, regions: Integer;
begin
modifyStatus := TModifyUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case modifyStatus of
muAdded:
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := username;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been added.', [username]),
mtInformation, [mbOK], 0);
end;
muModified:
begin
node := FindNode(username);
if node <> nil then
begin
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions.Clear;
regions := ABuffer.ReadByte;
for i := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
Messagedlg('Success', Format('The user "%s" has been modified.', [username]),
mtInformation, [mbOK], 0);
end;
end;
muInvalidUsername:
MessageDlg('Error', Format('The username "%s" is not valid.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnDeleteUserResponse(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
deleteStatus: TDeleteUserStatus;
username: string;
begin
deleteStatus := TDeleteUserStatus(ABuffer.ReadByte);
username := ABuffer.ReadStringNull;
case deleteStatus of
duDeleted:
begin
node := FindNode(username);
if node <> nil then
begin
vstAccounts.DeleteNode(node);
Messagedlg('Success', Format('The user "%s" has been deleted.', [username]),
mtInformation, [mbOK], 0);
end;
end;
duNotFound:
MessageDlg('Error', Format('The user "%s" could not be deleted. Maybe ' +
'your list is out of date or you tried to delete yourself.', [username]),
mtError, [mbOK], 0);
end;
end;
procedure TfrmAccountControl.OnListUsersPacket(ABuffer: TEnhancedMemoryStream);
var
node: PVirtualNode;
accountInfo: PAccountInfo;
i, j, count, regions: Integer;
begin
vstAccounts.BeginUpdate;
vstAccounts.Clear;
count := ABuffer.ReadWord;
for i := 1 to count do
begin
node := vstAccounts.AddChild(nil);
accountInfo := vstAccounts.GetNodeData(node);
accountInfo^.Username := ABuffer.ReadStringNull;
accountInfo^.AccessLevel := TAccessLevel(ABuffer.ReadByte);
accountInfo^.Regions := TStringList.Create;
regions := ABuffer.ReadByte;
for j := 0 to regions - 1 do
accountInfo^.Regions.Add(ABuffer.ReadStringNull);
end;
vstAccounts.EndUpdate;
end;
function TfrmAccountControl.FindNode(AUsername: string): PVirtualNode;
var
node: PVirtualNode;
accountInfo: PAccountInfo;
begin
Result := nil;
node := vstAccounts.GetFirst;
while (node <> nil) and (Result = nil) do
begin
accountInfo := vstAccounts.GetNodeData(node);
if accountInfo^.Username = AUsername then
Result := node;
node := vstAccounts.GetNext(node);
end;
end;
initialization
{$I UfrmAccountControl.lrs}
end.

334
Client/UfrmEditAccount.lfm
View File

@ -1,167 +1,167 @@
object frmEditAccount: TfrmEditAccount
Left = 290
Height = 214
Top = 171
Width = 261
ActiveControl = PageControl1
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Edit Account'
ClientHeight = 214
ClientWidth = 261
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
ParentFont = False
Position = poOwnerFormCenter
LCLVersion = '0.9.27'
object PageControl1: TPageControl
Height = 173
Width = 261
ActivePage = tsGeneral
Align = alClient
TabIndex = 0
TabOrder = 0
object tsGeneral: TTabSheet
Caption = 'General'
ClientHeight = 148
ClientWidth = 259
object lblPasswordHint: TLabel
Left = 86
Height = 28
Top = 64
Width = 160
AutoSize = False
Caption = 'Leave empty to leave the password unchanged.'
Enabled = False
ParentColor = False
WordWrap = True
end
object lblUsername: TLabel
Left = 6
Height = 14
Top = 12
Width = 58
Caption = 'Username:'
ParentColor = False
end
object lblPassword: TLabel
Left = 6
Height = 14
Top = 44
Width = 54
Caption = 'Password:'
ParentColor = False
end
object lblAccessLevel: TLabel
Left = 6
Height = 14
Top = 108
Width = 63
Caption = 'Accesslevel:'
ParentColor = False
end
object edUsername: TEdit
Left = 86
Height = 23
Top = 8
Width = 160
Color = clBtnFace
ReadOnly = True
TabOrder = 0
end
object edPassword: TEdit
Left = 86
Height = 23
Top = 40
Width = 160
EchoMode = emPassword
PasswordChar = '*'
TabOrder = 1
end
object cbAccessLevel: TComboBox
Left = 86
Height = 25
Top = 104
Width = 160
Items.Strings = (
'None'
'Viewer'
'Normal'
'Administrator'
)
Style = csDropDownList
TabOrder = 2
end
end
object tsRegions: TTabSheet
Caption = 'Regions'
ClientHeight = 148
ClientWidth = 259
object Label1: TLabel
Left = 8
Height = 14
Top = 8
Width = 243
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 4
Caption = 'Allowed Regions:'
ParentColor = False
end
object cbRegions: TCheckListBox
Left = 8
Height = 114
Top = 26
Width = 243
Align = alClient
BorderSpacing.Left = 8
BorderSpacing.Top = 4
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
ItemHeight = 13
TabOrder = 0
TopIndex = -1
end
end
end
object Panel1: TPanel
Left = 8
Height = 25
Top = 181
Width = 245
Align = alBottom
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 25
ClientWidth = 245
TabOrder = 1
object btnCancel: TButton
Left = 170
Height = 25
Width = 75
Align = alRight
BorderSpacing.Left = 4
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 0
end
object btnOK: TButton
Left = 91
Height = 25
Width = 75
Align = alRight
BorderSpacing.Right = 4
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
end
object frmEditAccount: TfrmEditAccount
Left = 290
Height = 214
Top = 171
Width = 261
ActiveControl = PageControl1
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Edit Account'
ClientHeight = 214
ClientWidth = 261
Font.Height = -11
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
ParentFont = False
Position = poOwnerFormCenter
LCLVersion = '0.9.27'
object PageControl1: TPageControl
Height = 173
Width = 261
ActivePage = tsGeneral
Align = alClient
TabIndex = 0
TabOrder = 0
object tsGeneral: TTabSheet
Caption = 'General'
ClientHeight = 148
ClientWidth = 259
object lblPasswordHint: TLabel
Left = 86
Height = 28
Top = 64
Width = 160
AutoSize = False
Caption = 'Leave empty to leave the password unchanged.'
Enabled = False
ParentColor = False
WordWrap = True
end
object lblUsername: TLabel
Left = 6
Height = 14
Top = 12
Width = 58
Caption = 'Username:'
ParentColor = False
end
object lblPassword: TLabel
Left = 6
Height = 14
Top = 44
Width = 54
Caption = 'Password:'
ParentColor = False
end
object lblAccessLevel: TLabel
Left = 6
Height = 14
Top = 108
Width = 63
Caption = 'Accesslevel:'
ParentColor = False
end
object edUsername: TEdit
Left = 86
Height = 23
Top = 8
Width = 160
Color = clBtnFace
ReadOnly = True
TabOrder = 0
end
object edPassword: TEdit
Left = 86
Height = 23
Top = 40
Width = 160
EchoMode = emPassword
PasswordChar = '*'
TabOrder = 1
end
object cbAccessLevel: TComboBox
Left = 86
Height = 25
Top = 104
Width = 160
Items.Strings = (
'None'
'Viewer'
'Normal'
'Administrator'
)
Style = csDropDownList
TabOrder = 2
end
end
object tsRegions: TTabSheet
Caption = 'Regions'
ClientHeight = 148
ClientWidth = 259
object Label1: TLabel
Left = 8
Height = 14
Top = 8
Width = 243
Align = alTop
BorderSpacing.Left = 8
BorderSpacing.Top = 8
BorderSpacing.Right = 8
BorderSpacing.Bottom = 4
Caption = 'Allowed Regions:'
ParentColor = False
end
object cbRegions: TCheckListBox
Left = 8
Height = 114
Top = 26
Width = 243
Align = alClient
BorderSpacing.Left = 8
BorderSpacing.Top = 4
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
ItemHeight = 13
TabOrder = 0
TopIndex = -1
end
end
end
object Panel1: TPanel
Left = 8
Height = 25
Top = 181
Width = 245
Align = alBottom
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 25
ClientWidth = 245
TabOrder = 1
object btnCancel: TButton
Left = 170
Height = 25
Width = 75
Align = alRight
BorderSpacing.Left = 4
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 0
end
object btnOK: TButton
Left = 91
Height = 25
Width = 75
Align = alRight
BorderSpacing.Right = 4
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
end

80
Client/UfrmInitialize.lfm
View File

@ -1,40 +1,40 @@
object frmInitialize: TfrmInitialize
Left = 290
Height = 65
Top = 171
Width = 241
BorderIcons = []
BorderStyle = bsDialog
Caption = 'Please wait ...'
ClientHeight = 65
ClientWidth = 241
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '0.9.25'
object pnlMain: TPanel
Left = 8
Height = 50
Top = 8
Width = 226
BevelInner = bvRaised
BevelOuter = bvLowered
ClientHeight = 50
ClientWidth = 226
ParentFont = True
TabOrder = 0
object lblStatus: TLabel
Left = 8
Height = 32
Top = 8
Width = 208
Alignment = taCenter
AutoSize = False
Layout = tlCenter
ParentColor = False
ParentFont = True
WordWrap = True
end
end
end
object frmInitialize: TfrmInitialize
Left = 290
Height = 65
Top = 171
Width = 241
BorderIcons = []
BorderStyle = bsDialog
Caption = 'Please wait ...'
ClientHeight = 65
ClientWidth = 241
Font.Height = -11
OnClose = FormClose
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '0.9.25'
object pnlMain: TPanel
Left = 8
Height = 50
Top = 8
Width = 226
BevelInner = bvRaised
BevelOuter = bvLowered
ClientHeight = 50
ClientWidth = 226
ParentFont = True
TabOrder = 0
object lblStatus: TLabel
Left = 8
Height = 32
Top = 8
Width = 208
Alignment = taCenter
AutoSize = False
Layout = tlCenter
ParentColor = False
ParentFont = True
WordWrap = True
end
end
end

192
Client/UfrmInitialize.pas
View File

@ -1,96 +1,96 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmInitialize;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LCLIntf, LCLType, WSForms;
type
{ TfrmInitialize }
TfrmInitialize = class(TForm)
lblStatus: TLabel;
pnlMain: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FActiveWindow: HWND;
FModal: Boolean;
public
procedure SetModal;
procedure UnsetModal;
end;
var
frmInitialize: TfrmInitialize;
implementation
{ TfrmInitialize }
procedure TfrmInitialize.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caNone;
end;
procedure TfrmInitialize.FormCreate(Sender: TObject);
begin
FModal := False;
end;
procedure TfrmInitialize.SetModal;
begin
if FModal then Exit;
FActiveWindow := GetActiveWindow;
TWSCustomFormClass(WidgetSetClass).ShowModal(Self);
{FormStyle := fsStayOnTop;
Screen.MoveFormToFocusFront(Self);
Screen.MoveFormToZFront(Self);}
FModal := True;
end;
procedure TfrmInitialize.UnsetModal;
begin
if not FModal then Exit;
TWSCustomFormClass(WidgetSetClass).CloseModal(Self);
if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow);
FActiveWindow := 0;
//FormStyle := fsNormal;
FModal := False;
end;
initialization
{$I UfrmInitialize.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmInitialize;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LCLIntf, LCLType, WSForms;
type
{ TfrmInitialize }
TfrmInitialize = class(TForm)
lblStatus: TLabel;
pnlMain: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FActiveWindow: HWND;
FModal: Boolean;
public
procedure SetModal;
procedure UnsetModal;
end;
var
frmInitialize: TfrmInitialize;
implementation
{ TfrmInitialize }
procedure TfrmInitialize.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caNone;
end;
procedure TfrmInitialize.FormCreate(Sender: TObject);
begin
FModal := False;
end;
procedure TfrmInitialize.SetModal;
begin
if FModal then Exit;
FActiveWindow := GetActiveWindow;
TWSCustomFormClass(WidgetSetClass).ShowModal(Self);
{FormStyle := fsStayOnTop;
Screen.MoveFormToFocusFront(Self);
Screen.MoveFormToZFront(Self);}
FModal := True;
end;
procedure TfrmInitialize.UnsetModal;
begin
if not FModal then Exit;
TWSCustomFormClass(WidgetSetClass).CloseModal(Self);
if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow);
FActiveWindow := 0;
//FormStyle := fsNormal;
FModal := False;
end;
initialization
{$I UfrmInitialize.lrs}
end.

3146
Client/UfrmLargeScaleCommand.lfm
View File

File diff suppressed because it is too large Load Diff

1564
Client/UfrmLargeScaleCommand.pas
View File

File diff suppressed because it is too large Load Diff

1368
Client/UfrmLogin.lfm
View File

File diff suppressed because it is too large Load Diff

384
Client/UfrmLogin.pas
View File

@ -1,192 +1,192 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmLogin;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, EditBtn, Buttons, IniFiles;
type
{ TfrmLogin }
TfrmLogin = class(TForm)
btnOK: TButton;
btnCancel: TButton;
cbProfile: TComboBox;
edData: TDirectoryEdit;
edHost: TEdit;
edUsername: TEdit;
edPassword: TEdit;
gbConnection: TGroupBox;
gbData: TGroupBox;
gbActions: TGroupBox;
gbProfiles: TGroupBox;
imgHost: TImage;
imgUsername: TImage;
imgPassword: TImage;
lblCopyright: TLabel;
lblHost: TLabel;
lblUsername: TLabel;
lblPassword: TLabel;
edPort: TSpinEdit;
lblData: TLabel;
btnSaveProfile: TSpeedButton;
btnDeleteProfile: TSpeedButton;
procedure btnCancelClick(Sender: TObject);
procedure btnDeleteProfileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnSaveProfileClick(Sender: TObject);
procedure cbProfileChange(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FProfilePath: string;
public
{ public declarations }
end;
var
frmLogin: TfrmLogin;
implementation
uses
UdmNetwork;
{$I version.inc}
{ TfrmLogin }
procedure TfrmLogin.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject);
begin
if cbProfile.ItemIndex > -1 then
begin
DeleteFile(FProfilePath + cbProfile.Text + '.ini');
cbProfile.Items.Delete(cbProfile.ItemIndex);
end;
end;
procedure TfrmLogin.btnOKClick(Sender: TObject);
var
path: string;
begin
path := IncludeTrailingPathDelimiter(edData.Text);
if (not FileExists(path + 'art.mul')) or
(not FileExists(path + 'artidx.mul')) or
(not FileExists(path + 'hues.mul')) or
(not FileExists(path + 'tiledata.mul')) or
(not FileExists(path + 'animdata.mul')) or
(not FileExists(path + 'texmaps.mul')) or
(not FileExists(path + 'texidx.mul')) or
(not FileExists(path + 'light.mul')) or
(not FileExists(path + 'lightidx.mul')) then
begin
MessageDlg('Incorrect directory', 'The data path you specified does not '
+ 'seem to be correct.', mtWarning, [mbOK], 0);
edData.SetFocus;
end else
ModalResult := mrOK;
end;
procedure TfrmLogin.btnSaveProfileClick(Sender: TObject);
var
profileName: string;
profile: TIniFile;
begin
profileName := cbProfile.Text;
if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then
begin
profile := TIniFile.Create(FProfilePath + profileName + '.ini');
profile.WriteString('Connection', 'Host', edHost.Text);
profile.WriteInteger('Connection', 'Port', edPort.Value);
profile.WriteString('Connection', 'Username', edUsername.Text);
profile.WriteString('Data', 'Path', edData.Text);
profile.Free;
cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName);
if cbProfile.ItemIndex = -1 then
begin
cbProfile.Items.Add(profileName);
cbProfile.ItemIndex := cbProfile.Items.Count - 1;
end;
end;
end;
procedure TfrmLogin.cbProfileChange(Sender: TObject);
var
profile: TIniFile;
begin
if cbProfile.ItemIndex > -1 then
begin
profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini');
edHost.Text := profile.ReadString('Connection', 'Host', '');
edPort.Value := profile.ReadInteger('Connection', 'Port', 2597);
edUsername.Text := profile.ReadString('Connection', 'Username', '');
edPassword.Text := '';
edData.Text := profile.ReadString('Data', 'Path', '');
edPassword.SetFocus;
profile.Free;
end;
end;
procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if ModalResult <> mrOK then
dmNetwork.CheckClose(Self);
end;
procedure TfrmLogin.FormCreate(Sender: TObject);
var
searchRec: TSearchRec;
begin
lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s',
[ProductVersion, Copyright]);
FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim;
ForceDirectories(FProfilePath);
if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then
begin
repeat
cbProfile.Items.Add(ChangeFileExt(searchRec.Name, ''));
until FindNext(searchRec) <> 0;
end;
FindClose(searchRec);
end;
initialization
{$I UfrmLogin.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UfrmLogin;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, EditBtn, Buttons, IniFiles;
type
{ TfrmLogin }
TfrmLogin = class(TForm)
btnOK: TButton;
btnCancel: TButton;
cbProfile: TComboBox;
edData: TDirectoryEdit;
edHost: TEdit;
edUsername: TEdit;
edPassword: TEdit;
gbConnection: TGroupBox;
gbData: TGroupBox;
gbActions: TGroupBox;
gbProfiles: TGroupBox;
imgHost: TImage;
imgUsername: TImage;
imgPassword: TImage;
lblCopyright: TLabel;
lblHost: TLabel;
lblUsername: TLabel;
lblPassword: TLabel;
edPort: TSpinEdit;
lblData: TLabel;
btnSaveProfile: TSpeedButton;
btnDeleteProfile: TSpeedButton;
procedure btnCancelClick(Sender: TObject);
procedure btnDeleteProfileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnSaveProfileClick(Sender: TObject);
procedure cbProfileChange(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
protected
FProfilePath: string;
public
{ public declarations }
end;
var
frmLogin: TfrmLogin;
implementation
uses
UdmNetwork;
{$I version.inc}
{ TfrmLogin }
procedure TfrmLogin.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject);
begin
if cbProfile.ItemIndex > -1 then
begin
DeleteFile(FProfilePath + cbProfile.Text + '.ini');
cbProfile.Items.Delete(cbProfile.ItemIndex);
end;
end;
procedure TfrmLogin.btnOKClick(Sender: TObject);
var
path: string;
begin
path := IncludeTrailingPathDelimiter(edData.Text);
if (not FileExists(path + 'art.mul')) or
(not FileExists(path + 'artidx.mul')) or
(not FileExists(path + 'hues.mul')) or
(not FileExists(path + 'tiledata.mul')) or
(not FileExists(path + 'animdata.mul')) or
(not FileExists(path + 'texmaps.mul')) or
(not FileExists(path + 'texidx.mul')) or
(not FileExists(path + 'light.mul')) or
(not FileExists(path + 'lightidx.mul')) then
begin
MessageDlg('Incorrect directory', 'The data path you specified does not '
+ 'seem to be correct.', mtWarning, [mbOK], 0);
edData.SetFocus;
end else
ModalResult := mrOK;
end;
procedure TfrmLogin.btnSaveProfileClick(Sender: TObject);
var
profileName: string;
profile: TIniFile;
begin
profileName := cbProfile.Text;
if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then
begin
profile := TIniFile.Create(FProfilePath + profileName + '.ini');
profile.WriteString('Connection', 'Host', edHost.Text);
profile.WriteInteger('Connection', 'Port', edPort.Value);
profile.WriteString('Connection', 'Username', edUsername.Text);
profile.WriteString('Data', 'Path', edData.Text);
profile.Free;
cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName);
if cbProfile.ItemIndex = -1 then
begin
cbProfile.Items.Add(profileName);
cbProfile.ItemIndex := cbProfile.Items.Count - 1;
end;
end;
end;
procedure TfrmLogin.cbProfileChange(Sender: TObject);
var
profile: TIniFile;
begin
if cbProfile.ItemIndex > -1 then
begin
profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini');
edHost.Text := profile.ReadString('Connection', 'Host', '');
edPort.Value := profile.ReadInteger('Connection', 'Port', 2597);
edUsername.Text := profile.ReadString('Connection', 'Username', '');
edPassword.Text := '';
edData.Text := profile.ReadString('Data', 'Path', '');
edPassword.SetFocus;
profile.Free;
end;
end;
procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if ModalResult <> mrOK then
dmNetwork.CheckClose(Self);
end;
procedure TfrmLogin.FormCreate(Sender: TObject);
var
searchRec: TSearchRec;
begin
lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s',
[ProductVersion, Copyright]);
FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim;
ForceDirectories(FProfilePath);
if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then
begin
repeat
cbProfile.Items.Add(ChangeFileExt(searchRec.Name, ''));
until FindNext(searchRec) <> 0;
end;
FindClose(searchRec);
end;
initialization
{$I UfrmLogin.lrs}
end.

1270
Client/UfrmRegionControl.lfm
View File

File diff suppressed because it is too large Load Diff

1480
Client/UfrmRegionControl.pas
View File

File diff suppressed because it is too large Load Diff

802
Imaging/JpegLib/imjcapimin.pas
View File

@ -1,401 +1,401 @@
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
case.
Most of the routines intended to be called directly by an application
are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcomapi,
imjmemmgr,
imjcmarker;
{ Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct)));
end;
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.dest := NIL;
cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready }
cinfo^.global_state := CSTATE_START;
end;
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
var
i : int;
qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR;
begin
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then
qtbl^.sent_table := suppress;
end;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
end;
end;
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var
iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then
begin
{ Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo);
end
else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do
begin
cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
{ Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
end;
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
var
write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do
begin
Dec(datalen);
write_marker_byte (cinfo, dataptr^);
Inc(dataptr);
end;
end;
{ Same, but piecemeal. }
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end;
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin
cinfo^.marker^.write_marker_byte (cinfo, val);
end;
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo);
{ Write them tables! }
cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. }
cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space
of their own from the library memory manager, and didn't want it to go
away during write_tables. So now we do nothing. This will cause a
memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case.
An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). }
end;
end.
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
case.
Most of the routines intended to be called directly by an application
are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcomapi,
imjmemmgr,
imjcmarker;
{ Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct)));
end;
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.dest := NIL;
cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready }
cinfo^.global_state := CSTATE_START;
end;
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
var
i : int;
qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR;
begin
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then
qtbl^.sent_table := suppress;
end;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
end;
end;
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var
iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then
begin
{ Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo);
end
else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do
begin
cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
{ Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
end;
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
var
write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do
begin
Dec(datalen);
write_marker_byte (cinfo, dataptr^);
Inc(dataptr);
end;
end;
{ Same, but piecemeal. }
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end;
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin
cinfo^.marker^.write_marker_byte (cinfo, val);
end;
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo);
{ Write them tables! }
cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. }
cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space
of their own from the library memory manager, and didn't want it to go
away during write_tables. So now we do nothing. This will cause a
memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case.
An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). }
end;
end.

444
Imaging/JpegLib/imjcapistd.pas
View File

@ -1,222 +1,222 @@
unit imjcapistd;
{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the compression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-compression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_compress, it will end up linking in the entire compressor.
We thus must separate this file from jcapimin.c to avoid linking the
whole compression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcapimin, imjcinit;
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
implementation
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (write_all_tables) then
jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written }
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Perform master selection of active modules }
jinit_compress_master(cinfo);
{ Set up for the first pass }
cinfo^.master^.prepare_for_pass (cinfo);
{ Ready for application to drive first pass through jpeg_write_scanlines
or jpeg_write_raw_data. }
cinfo^.next_scanline := 0;
if cinfo^.raw_data_in then
cinfo^.global_state := CSTATE_RAW_OK
else
cinfo^.global_state := CSTATE_SCANNING;
end;
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
var
row_ctr, rows_left : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_scanlines. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_scanlines. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Ignore any extra scanlines at bottom of image. }
rows_left := cinfo^.image_height - cinfo^.next_scanline;
if (num_lines > rows_left) then
num_lines := rows_left;
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines);
Inc(cinfo^.next_scanline, row_ctr);
jpeg_write_scanlines := row_ctr;
end;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_write_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long(cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long(cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_raw_data. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_raw_data. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Verify that at least one iMCU row has been passed. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE;
if (num_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Directly compress the row. }
if (not cinfo^.coef^.compress_data (cinfo, data)) then
begin
{ If compressor did not consume the whole row, suspend processing. }
jpeg_write_raw_data := 0;
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.next_scanline, lines_per_iMCU_row);
jpeg_write_raw_data := lines_per_iMCU_row;
end;
end.
unit imjcapistd;
{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the compression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-compression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_compress, it will end up linking in the entire compressor.
We thus must separate this file from jcapimin.c to avoid linking the
whole compression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcapimin, imjcinit;
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
implementation
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (write_all_tables) then
jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written }
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Perform master selection of active modules }
jinit_compress_master(cinfo);
{ Set up for the first pass }
cinfo^.master^.prepare_for_pass (cinfo);
{ Ready for application to drive first pass through jpeg_write_scanlines
or jpeg_write_raw_data. }
cinfo^.next_scanline := 0;
if cinfo^.raw_data_in then
cinfo^.global_state := CSTATE_RAW_OK
else
cinfo^.global_state := CSTATE_SCANNING;
end;
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
var
row_ctr, rows_left : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_scanlines. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_scanlines. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Ignore any extra scanlines at bottom of image. }
rows_left := cinfo^.image_height - cinfo^.next_scanline;
if (num_lines > rows_left) then
num_lines := rows_left;
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines);
Inc(cinfo^.next_scanline, row_ctr);
jpeg_write_scanlines := row_ctr;
end;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_write_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long(cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long(cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_raw_data. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_raw_data. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Verify that at least one iMCU row has been passed. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE;
if (num_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Directly compress the row. }
if (not cinfo^.coef^.compress_data (cinfo, data)) then
begin
{ If compressor did not consume the whole row, suspend processing. }
jpeg_write_raw_data := 0;
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.next_scanline, lines_per_iMCU_row);
jpeg_write_raw_data := lines_per_iMCU_row;
end;
end.

1042
Imaging/JpegLib/imjccoefct.pas
View File

File diff suppressed because it is too large Load Diff

1066
Imaging/JpegLib/imjccolor.pas
View File

File diff suppressed because it is too large Load Diff

1028
Imaging/JpegLib/imjcdctmgr.pas
View File

File diff suppressed because it is too large Load Diff

2232
Imaging/JpegLib/imjchuff.pas
View File

File diff suppressed because it is too large Load Diff

190
Imaging/JpegLib/imjcinit.pas
View File

@ -1,95 +1,95 @@
unit imjcinit;
{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file contains initialization logic for the JPEG compressor.
This routine is in charge of selecting the modules to be executed and
making an initialization call to each one.
Logically, this code belongs in jcmaster.c. It's split out because
linking this routine implies linking the entire compression library.
For a transcoding-only application, we want to be able to use jcmaster.c
without linking in the whole library. }
interface
{$I imjconfig.inc}
uses
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
{$ifdef C_PROGRESSIVE_SUPPORTED}
imjcphuff,
{$endif}
imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct,
imjcdctmgr, imjccoefct, imjcmainct, imjcmarker;
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
implementation
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
begin
{ Initialize master control (includes parameter checking/processing) }
jinit_c_master_control(cinfo, FALSE { full compression });
{ Preprocessing }
if (not cinfo^.raw_data_in) then
begin
jinit_color_converter(cinfo);
jinit_downsampler(cinfo);
jinit_c_prep_controller(cinfo, FALSE { never need full buffer here });
end;
{ Forward DCT }
jinit_forward_dct(cinfo);
{ Entropy encoding: either Huffman or arithmetic coding. }
if (cinfo^.arith_code) then
begin
ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL);
end
else
begin
if (cinfo^.progressive_mode) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
jinit_phuff_encoder(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
jinit_huff_encoder(cinfo);
end;
{ Need a full-image coefficient buffer in any multi-pass mode. }
jinit_c_coef_controller(cinfo,
(cinfo^.num_scans > 1) or (cinfo^.optimize_coding));
jinit_c_main_controller(cinfo, FALSE { never need full buffer here });
jinit_marker_writer(cinfo);
{ We can now tell the memory manager to allocate virtual arrays. }
cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo));
{ Write the datastream header (SOI) immediately.
Frame and scan headers are postponed till later.
This lets application insert special markers after the SOI. }
cinfo^.marker^.write_file_header (cinfo);
end;
end.
unit imjcinit;
{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file contains initialization logic for the JPEG compressor.
This routine is in charge of selecting the modules to be executed and
making an initialization call to each one.
Logically, this code belongs in jcmaster.c. It's split out because
linking this routine implies linking the entire compression library.
For a transcoding-only application, we want to be able to use jcmaster.c
without linking in the whole library. }
interface
{$I imjconfig.inc}
uses
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
{$ifdef C_PROGRESSIVE_SUPPORTED}
imjcphuff,
{$endif}
imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct,
imjcdctmgr, imjccoefct, imjcmainct, imjcmarker;
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
implementation
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
begin
{ Initialize master control (includes parameter checking/processing) }
jinit_c_master_control(cinfo, FALSE { full compression });
{ Preprocessing }
if (not cinfo^.raw_data_in) then
begin
jinit_color_converter(cinfo);
jinit_downsampler(cinfo);
jinit_c_prep_controller(cinfo, FALSE { never need full buffer here });
end;
{ Forward DCT }
jinit_forward_dct(cinfo);
{ Entropy encoding: either Huffman or arithmetic coding. }
if (cinfo^.arith_code) then
begin
ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL);
end
else
begin
if (cinfo^.progressive_mode) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
jinit_phuff_encoder(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
jinit_huff_encoder(cinfo);
end;
{ Need a full-image coefficient buffer in any multi-pass mode. }
jinit_c_coef_controller(cinfo,
(cinfo^.num_scans > 1) or (cinfo^.optimize_coding));
jinit_c_main_controller(cinfo, FALSE { never need full buffer here });
jinit_marker_writer(cinfo);
{ We can now tell the memory manager to allocate virtual arrays. }
cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo));
{ Write the datastream header (SOI) immediately.
Frame and scan headers are postponed till later.
This lets application insert special markers after the SOI. }
cinfo^.marker^.write_file_header (cinfo);
end;
end.

686
Imaging/JpegLib/imjcmainct.pas
View File

@ -1,343 +1,343 @@
unit imjcmainct;
{ This file contains the main buffer controller for compression.
The main buffer lies between the pre-processor and the JPEG
compressor proper; it holds downsampled data in the JPEG colorspace. }
{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Note: currently, there is no operating mode in which a full-image buffer
is needed at this step. If there were, that mode could not be used with
"raw data" input, since this module is bypassed in that case. However,
we've left the code here for possible use in special applications. }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
imjutils,
{$endif}
imjpeglib;
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_main_ptr = ^my_main_controller;
my_main_controller = record
pub : jpeg_c_main_controller; { public fields }
cur_iMCU_row : JDIMENSION; { number of current iMCU row }
rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row }
suspended : boolean; { remember if we suspended output }
pass_mode : J_BUF_MODE; { current operating mode }
{ If using just a strip buffer, this points to the entire set of buffers
(we allocate one for each component). In the full-image case, this
points to the currently accessible strips of the virtual arrays. }
buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ If using full-image storage, this array holds pointers to virtual-array
control blocks for each component. Unused if not full-image storage. }
whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr;
{$endif}
end; {my_main_controller}
{ Forward declarations }
{METHODDEF}
procedure process_data_simple_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr: JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{METHODDEF}
procedure process_data_buffer_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_main (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
{ Do nothing in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
main^.cur_iMCU_row := 0; { initialize counters }
main^.rowgroup_ctr := 0;
main^.suspended := FALSE;
main^.pass_mode := pass_mode; { save mode for use by process_data }
case (pass_mode) of
JBUF_PASS_THRU:
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
if (main^.whole_image[0] <> NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
main^.pub.process_data := process_data_simple_main;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
JBUF_SAVE_SOURCE,
JBUF_CRANK_DEST,
JBUF_SAVE_AND_PASS:
begin
if (main^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
main^.pub.process_data := process_data_buffer_main;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
end;
{ Process some data.
This routine handles the simple pass-through mode,
where we have only a strip buffer. }
{METHODDEF}
procedure process_data_simple_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Read input data if we haven't filled the main buffer yet }
if (main^.rowgroup_ctr < DCTSIZE) then
cinfo^.prep^.pre_process_data (cinfo,
input_buf,
in_row_ctr,
in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION(DCTSIZE));
{ If we don't have a full iMCU row buffered, return to application for
more data. Note that preprocessor will always pad to fill the iMCU row
at the bottom of the image. }
if (main^.rowgroup_ctr <> DCTSIZE) then
exit;
{ Send the completed row to the compressor }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Process some data.
This routine handles all of the modes that use a full-size buffer. }
{METHODDEF}
procedure process_data_buffer_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
writing : boolean;
begin
main := my_main_ptr (cinfo^.main);
writing := (main^.pass_mode <> JBUF_CRANK_DEST);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Realign the virtual buffers if at the start of an iMCU row. }
if (main^.rowgroup_ctr = 0) then
begin
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.access_virt_sarray
(j_common_ptr (cinfo), main^.whole_image[ci],
main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing);
Inc(compptr);
end;
{ In a read pass, pretend we just read some source data. }
if (not writing) then
begin
Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE);
main^.rowgroup_ctr := DCTSIZE;
end;
end;
{ If a write pass, read input data until the current iMCU row is full. }
{ Note: preprocessor will pad if necessary to fill the last iMCU row. }
if (writing) then
begin
cinfo^.prep^.pre_process_data (cinfo,
input_buf, in_row_ctr, in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION (DCTSIZE));
{ Return to application if we need more data to fill the iMCU row. }
if (main^.rowgroup_ctr < DCTSIZE) then
exit;
end;
{ Emit data, unless this is a sink-only pass. }
if (main^.pass_mode <> JBUF_SAVE_SOURCE) then
begin
if (not cinfo^.coef^.compress_data (cinfo,
JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
end;
{ If get here, we are done with this iMCU row. Mark buffer empty. }
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$endif} { FULL_MAIN_BUFFER_SUPPORTED }
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
main := my_main_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_main_controller)) );
cinfo^.main := jpeg_c_main_controller_ptr(main);
main^.pub.start_pass := start_pass_main;
{ We don't need to create a buffer in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
{ Create the buffer. It holds downsampled data, so each component
may be of a different size. }
if (need_full_buffer) then
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Allocate a full-image virtual array for each component }
{ Note we pad the bottom to a multiple of the iMCU height }
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (jround_up( long (compptr^.height_in_blocks),
long (compptr^.v_samp_factor)) * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
end
else
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
main^.whole_image[0] := NIL; { flag for no virtual arrays }
{$endif}
{ Allocate a strip buffer for each component }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
end;
end;
end.
unit imjcmainct;
{ This file contains the main buffer controller for compression.
The main buffer lies between the pre-processor and the JPEG
compressor proper; it holds downsampled data in the JPEG colorspace. }
{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Note: currently, there is no operating mode in which a full-image buffer
is needed at this step. If there were, that mode could not be used with
"raw data" input, since this module is bypassed in that case. However,
we've left the code here for possible use in special applications. }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
imjutils,
{$endif}
imjpeglib;
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_main_ptr = ^my_main_controller;
my_main_controller = record
pub : jpeg_c_main_controller; { public fields }
cur_iMCU_row : JDIMENSION; { number of current iMCU row }
rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row }
suspended : boolean; { remember if we suspended output }
pass_mode : J_BUF_MODE; { current operating mode }
{ If using just a strip buffer, this points to the entire set of buffers
(we allocate one for each component). In the full-image case, this
points to the currently accessible strips of the virtual arrays. }
buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ If using full-image storage, this array holds pointers to virtual-array
control blocks for each component. Unused if not full-image storage. }
whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr;
{$endif}
end; {my_main_controller}
{ Forward declarations }
{METHODDEF}
procedure process_data_simple_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr: JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{METHODDEF}
procedure process_data_buffer_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_main (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
{ Do nothing in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
main^.cur_iMCU_row := 0; { initialize counters }
main^.rowgroup_ctr := 0;
main^.suspended := FALSE;
main^.pass_mode := pass_mode; { save mode for use by process_data }
case (pass_mode) of
JBUF_PASS_THRU:
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
if (main^.whole_image[0] <> NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
main^.pub.process_data := process_data_simple_main;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
JBUF_SAVE_SOURCE,
JBUF_CRANK_DEST,
JBUF_SAVE_AND_PASS:
begin
if (main^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
main^.pub.process_data := process_data_buffer_main;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
end;
{ Process some data.
This routine handles the simple pass-through mode,
where we have only a strip buffer. }
{METHODDEF}
procedure process_data_simple_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Read input data if we haven't filled the main buffer yet }
if (main^.rowgroup_ctr < DCTSIZE) then
cinfo^.prep^.pre_process_data (cinfo,
input_buf,
in_row_ctr,
in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION(DCTSIZE));
{ If we don't have a full iMCU row buffered, return to application for
more data. Note that preprocessor will always pad to fill the iMCU row
at the bottom of the image. }
if (main^.rowgroup_ctr <> DCTSIZE) then
exit;
{ Send the completed row to the compressor }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Process some data.
This routine handles all of the modes that use a full-size buffer. }
{METHODDEF}
procedure process_data_buffer_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
writing : boolean;
begin
main := my_main_ptr (cinfo^.main);
writing := (main^.pass_mode <> JBUF_CRANK_DEST);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Realign the virtual buffers if at the start of an iMCU row. }
if (main^.rowgroup_ctr = 0) then
begin
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.access_virt_sarray
(j_common_ptr (cinfo), main^.whole_image[ci],
main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing);
Inc(compptr);
end;
{ In a read pass, pretend we just read some source data. }
if (not writing) then
begin
Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE);
main^.rowgroup_ctr := DCTSIZE;
end;
end;
{ If a write pass, read input data until the current iMCU row is full. }
{ Note: preprocessor will pad if necessary to fill the last iMCU row. }
if (writing) then
begin
cinfo^.prep^.pre_process_data (cinfo,
input_buf, in_row_ctr, in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION (DCTSIZE));
{ Return to application if we need more data to fill the iMCU row. }
if (main^.rowgroup_ctr < DCTSIZE) then
exit;
end;
{ Emit data, unless this is a sink-only pass. }
if (main^.pass_mode <> JBUF_SAVE_SOURCE) then
begin
if (not cinfo^.coef^.compress_data (cinfo,
JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
end;
{ If get here, we are done with this iMCU row. Mark buffer empty. }
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$endif} { FULL_MAIN_BUFFER_SUPPORTED }
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
main := my_main_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_main_controller)) );
cinfo^.main := jpeg_c_main_controller_ptr(main);
main^.pub.start_pass := start_pass_main;
{ We don't need to create a buffer in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
{ Create the buffer. It holds downsampled data, so each component
may be of a different size. }
if (need_full_buffer) then
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Allocate a full-image virtual array for each component }
{ Note we pad the bottom to a multiple of the iMCU height }
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (jround_up( long (compptr^.height_in_blocks),
long (compptr^.v_samp_factor)) * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
end
else
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
main^.whole_image[0] := NIL; { flag for no virtual arrays }
{$endif}
{ Allocate a strip buffer for each component }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
end;
end;
end.

1448
Imaging/JpegLib/imjcmarker.pas
View File

File diff suppressed because it is too large Load Diff

1402
Imaging/JpegLib/imjcmaster.pas
View File

File diff suppressed because it is too large Load Diff

260
Imaging/JpegLib/imjcomapi.pas
View File

@ -1,130 +1,130 @@
unit imjcomapi;
{ This file contains application interface routines that are used for both
compression and decompression. }
{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
{ Destruction of a JPEG object. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
implementation
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself.
For this, we merely clean up all the nonpermanent memory pools.
Note that temp files (virtual arrays) are not allowed to belong to
the permanent pool, so we will be able to close all temp files here.
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
var
pool : int;
begin
{ Do nothing if called on a not-initialized or destroyed JPEG object. }
if (cinfo^.mem = NIL) then
exit;
{ Releasing pools in reverse order might help avoid fragmentation
with some (brain-damaged) malloc libraries. }
for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do
begin
cinfo^.mem^.free_pool (cinfo, pool);
end;
{ Reset overall state for possible reuse of object }
if (cinfo^.is_decompressor) then
begin
cinfo^.global_state := DSTATE_START;
{ Try to keep application from accessing now-deleted marker list.
A bit kludgy to do it here, but this is the most central place. }
j_decompress_ptr(cinfo)^.marker_list := NIL;
end
else
begin
cinfo^.global_state := CSTATE_START;
end;
end;
{ Destruction of a JPEG object.
Everything gets deallocated except the master jpeg_compress_struct itself
and the error manager struct. Both of these are supplied by the application
and must be freed, if necessary, by the application. (Often they are on
the stack and so don't need to be freed anyway.)
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
begin
{ We need only tell the memory manager to release everything. }
{ NB: mem pointer is NIL if memory mgr failed to initialize. }
if (cinfo^.mem <> NIL) then
cinfo^.mem^.self_destruct (cinfo);
cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice }
cinfo^.global_state := 0; { mark it destroyed }
end;
{ Convenience routines for allocating quantization and Huffman tables.
(Would jutils.c be a more reasonable place to put these?) }
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
var
tbl : JQUANT_TBL_PTR;
begin
tbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_quant_table := tbl;
end;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
var
tbl : JHUFF_TBL_PTR;
begin
tbl := JHUFF_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_huff_table := tbl;
end;
end.
unit imjcomapi;
{ This file contains application interface routines that are used for both
compression and decompression. }
{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
{ Destruction of a JPEG object. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
implementation
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself.
For this, we merely clean up all the nonpermanent memory pools.
Note that temp files (virtual arrays) are not allowed to belong to
the permanent pool, so we will be able to close all temp files here.
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
var
pool : int;
begin
{ Do nothing if called on a not-initialized or destroyed JPEG object. }
if (cinfo^.mem = NIL) then
exit;
{ Releasing pools in reverse order might help avoid fragmentation
with some (brain-damaged) malloc libraries. }
for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do
begin
cinfo^.mem^.free_pool (cinfo, pool);
end;
{ Reset overall state for possible reuse of object }
if (cinfo^.is_decompressor) then
begin
cinfo^.global_state := DSTATE_START;
{ Try to keep application from accessing now-deleted marker list.
A bit kludgy to do it here, but this is the most central place. }
j_decompress_ptr(cinfo)^.marker_list := NIL;
end
else
begin
cinfo^.global_state := CSTATE_START;
end;
end;
{ Destruction of a JPEG object.
Everything gets deallocated except the master jpeg_compress_struct itself
and the error manager struct. Both of these are supplied by the application
and must be freed, if necessary, by the application. (Often they are on
the stack and so don't need to be freed anyway.)
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
begin
{ We need only tell the memory manager to release everything. }
{ NB: mem pointer is NIL if memory mgr failed to initialize. }
if (cinfo^.mem <> NIL) then
cinfo^.mem^.self_destruct (cinfo);
cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice }
cinfo^.global_state := 0; { mark it destroyed }
end;
{ Convenience routines for allocating quantization and Huffman tables.
(Would jutils.c be a more reasonable place to put these?) }
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
var
tbl : JQUANT_TBL_PTR;
begin
tbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_quant_table := tbl;
end;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
var
tbl : JHUFF_TBL_PTR;
begin
tbl := JHUFF_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_huff_table := tbl;
end;
end.

248
Imaging/JpegLib/imjconfig.inc
View File

@ -1,124 +1,124 @@
{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- }
{ These defines indicate whether to include various optional functions.
Undefining some of these symbols will produce a smaller but less capable
library. Note that you can leave certain source files out of the
compilation/linking process if you've #undef'd the corresponding symbols.
(You may HAVE to do that if your compiler doesn't like null source files.)}
{ Arithmetic coding is unsupported for legal reasons. Complaints to IBM. }
{ Capability options common to encoder and decoder: }
{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm }
{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method }
{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW }
{ Encoder capability options: }
{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? }
{ Note: if you selected 12-bit data precision, it is dangerous to turn off
ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit
precision, so jchuff.c normally uses entropy optimization to compute
usable tables for higher precision. If you don't want to do optimization,
you'll have to supply different default Huffman tables.
The exact same statements apply for progressive JPEG: the default tables
don't work for progressive mode. (This may get fixed, however.) }
{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? }
{ Decoder capability options: }
{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? }
{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) }
{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? }
{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? }
{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? }
{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? }
{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? }
{ If you happen not to want the image transform support, disable it here }
{$define TRANSFORMS_SUPPORTED}
{ more capability options later, no doubt }
{$ifopt I+} {$define IOcheck} {$endif}
{ ------------------------------------------------------------------------ }
{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() }
{$define FMEMCOPY}
{$define FMEMZERO}
{$define DCTSIZE_IS_8} { e.g. unroll the inner loop }
{$define RIGHT_SHIFT_IS_UNSIGNED}
{$undef AVOID_TABLES}
{$undef FAST_DIVIDE}
{$define BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
{ for test of 12 bit JPEG code only. !! }
{-- $undef BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
//{$define RGB_RED_IS_0}
{ !CHANGE: This must be defined for Delphi/Kylix/FPC }
{$define RGB_RED_IS_2} { RGB byte order }
{$define RGB_PIXELSIZE_IS_3}
{$define SLOW_SHIFT_32}
{$undef NO_ZERO_ROW_TEST}
{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c }
{$define XMS_SUPPORTED}
{$define EMS_SUPPORTED}
{$undef MEM_STATS} { Write out memory usage }
{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
{$define PROGRESS_REPORT}
{$define TWO_FILE_COMMANDLINE}
{$undef BMP_SUPPORTED}
{$undef PPM_SUPPORTED}
{$undef GIF_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$define EXT_SWITCH}
{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples }
{$undef BMP_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$endif}
{!CHANGE: Allowed only for Delphi}
{$undef BASM16} { for TP7 - use BASM for fast multiply }
{$ifdef Win32}
{$ifndef FPC}
{$define BASM} { jidctint with BASM for Delphi 2/3 }
{$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 }
{$endif}
{$endif}
{$ifdef FPC}
{$MODE DELPHI}
{$endif}
{!CHANGE: Added this}
{$define Delphi_Stream}
{$Q-}
{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- }
{ These defines indicate whether to include various optional functions.
Undefining some of these symbols will produce a smaller but less capable
library. Note that you can leave certain source files out of the
compilation/linking process if you've #undef'd the corresponding symbols.
(You may HAVE to do that if your compiler doesn't like null source files.)}
{ Arithmetic coding is unsupported for legal reasons. Complaints to IBM. }
{ Capability options common to encoder and decoder: }
{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm }
{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method }
{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW }
{ Encoder capability options: }
{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? }
{ Note: if you selected 12-bit data precision, it is dangerous to turn off
ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit
precision, so jchuff.c normally uses entropy optimization to compute
usable tables for higher precision. If you don't want to do optimization,
you'll have to supply different default Huffman tables.
The exact same statements apply for progressive JPEG: the default tables
don't work for progressive mode. (This may get fixed, however.) }
{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? }
{ Decoder capability options: }
{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? }
{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) }
{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? }
{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? }
{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? }
{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? }
{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? }
{ If you happen not to want the image transform support, disable it here }
{$define TRANSFORMS_SUPPORTED}
{ more capability options later, no doubt }
{$ifopt I+} {$define IOcheck} {$endif}
{ ------------------------------------------------------------------------ }
{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() }
{$define FMEMCOPY}
{$define FMEMZERO}
{$define DCTSIZE_IS_8} { e.g. unroll the inner loop }
{$define RIGHT_SHIFT_IS_UNSIGNED}
{$undef AVOID_TABLES}
{$undef FAST_DIVIDE}
{$define BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
{ for test of 12 bit JPEG code only. !! }
{-- $undef BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
//{$define RGB_RED_IS_0}
{ !CHANGE: This must be defined for Delphi/Kylix/FPC }
{$define RGB_RED_IS_2} { RGB byte order }
{$define RGB_PIXELSIZE_IS_3}
{$define SLOW_SHIFT_32}
{$undef NO_ZERO_ROW_TEST}
{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c }
{$define XMS_SUPPORTED}
{$define EMS_SUPPORTED}
{$undef MEM_STATS} { Write out memory usage }
{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
{$define PROGRESS_REPORT}
{$define TWO_FILE_COMMANDLINE}
{$undef BMP_SUPPORTED}
{$undef PPM_SUPPORTED}
{$undef GIF_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$define EXT_SWITCH}
{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples }
{$undef BMP_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$endif}
{!CHANGE: Allowed only for Delphi}
{$undef BASM16} { for TP7 - use BASM for fast multiply }
{$ifdef Win32}
{$ifndef FPC}
{$define BASM} { jidctint with BASM for Delphi 2/3 }
{$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 }
{$endif}
{$endif}
{$ifdef FPC}
{$MODE DELPHI}
{$endif}
{!CHANGE: Added this}
{$define Delphi_Stream}
{$Q-}

1402
Imaging/JpegLib/imjcparam.pas
View File

File diff suppressed because it is too large Load Diff

1924
Imaging/JpegLib/imjcphuff.pas
View File

File diff suppressed because it is too large Load Diff

812
Imaging/JpegLib/imjcprepct.pas
View File

@ -1,406 +1,406 @@
unit imjcprepct;
{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the compression preprocessing controller.
This controller manages the color conversion, downsampling,
and edge expansion steps.
Most of the complexity here is associated with buffering input rows
as required by the downsampler. See the comments at the head of
jcsample.c for the downsampler's needs. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude,
imjutils;
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ At present, jcsample.c can request context rows only for smoothing.
In the future, we might also need context rows for CCIR601 sampling
or other more-complex downsampling procedures. The code to support
context rows should be compiled only if needed. }
{$ifdef INPUT_SMOOTHING_SUPPORTED}
{$define CONTEXT_ROWS_SUPPORTED}
{$endif}
{ For the simple (no-context-row) case, we just need to buffer one
row group's worth of pixels for the downsampling step. At the bottom of
the image, we pad to a full row group by replicating the last pixel row.
The downsampler's last output row is then replicated if needed to pad
out to a full iMCU row.
When providing context rows, we must buffer three row groups' worth of
pixels. Three row groups are physically allocated, but the row pointer
arrays are made five row groups high, with the extra pointers above and
below "wrapping around" to point to the last and first real row groups.
This allows the downsampler to access the proper context rows.
At the top and bottom of the image, we create dummy context rows by
copying the first or last real pixel row. This copying could be avoided
by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the
trouble on the compression side. }
{ Private buffer controller object }
type
my_prep_ptr = ^my_prep_controller;
my_prep_controller = record
pub : jpeg_c_prep_controller; { public fields }
{ Downsampling input buffer. This buffer holds color-converted data
until we have enough to do a downsample step. }
color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
rows_to_go : JDIMENSION; { counts rows remaining in source image }
next_buf_row : int; { index of next row to store in color_buf }
{$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case }
this_row_group : int; { starting row index of group to process }
next_buf_stop : int; { downsample when we reach this index }
{$endif}
end; {my_prep_controller;}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_prep (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE );
var
prep : my_prep_ptr;
begin
prep := my_prep_ptr (cinfo^.prep);
if (pass_mode <> JBUF_PASS_THRU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{ Initialize total-height counter for detecting bottom of image }
prep^.rows_to_go := cinfo^.image_height;
{ Mark the conversion buffer empty }
prep^.next_buf_row := 0;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Preset additional state variables for context mode.
These aren't used in non-context mode, so we needn't test which mode. }
prep^.this_row_group := 0;
{ Set next_buf_stop to stop after two row groups have been read in. }
prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor;
{$endif}
end;
{ Expand an image vertically from height input_rows to height output_rows,
by duplicating the bottom row. }
{LOCAL}
procedure expand_bottom_edge (image_data : JSAMPARRAY;
num_cols : JDIMENSION;
input_rows : int;
output_rows : int);
var
{register} row : int;
begin
for row := input_rows to pred(output_rows) do
begin
jcopy_sample_rows(image_data, input_rows-1, image_data, row,
1, num_cols);
end;
end;
{ Process some data in the simple no-context case.
Preprocessor output data is counted in "row groups". A row group
is defined to be v_samp_factor sample rows of each component.
Downsampling will produce this much data from each max_v_samp_factor
input rows. }
{METHODDEF}
procedure pre_process_data (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
inrows : JDIMENSION;
compptr : jpeg_component_info_ptr;
var
local_input_buf : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
while (in_row_ctr < in_rows_avail) and
(out_row_group_ctr < out_row_groups_avail) do
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row;
{numrows := int( MIN(JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr]));
cinfo^.cconvert^.color_convert (cinfo, local_input_buf,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.next_buf_row),
numrows);
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
{ If at bottom of image, pad to fill the conversion buffer. }
if (prep^.rows_to_go = 0) and
(prep^.next_buf_row < cinfo^.max_v_samp_factor) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, cinfo^.max_v_samp_factor);
end;
prep^.next_buf_row := cinfo^.max_v_samp_factor;
end;
{ If we've filled the conversion buffer, empty it. }
if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (0),
output_buf,
out_row_group_ctr);
prep^.next_buf_row := 0;
Inc(out_row_group_ctr);;
end;
{ If at bottom of image, pad the output to a full iMCU height.
Note we assume the caller is providing a one-iMCU-height output buffer! }
if (prep^.rows_to_go = 0) and
(out_row_group_ctr < out_row_groups_avail) then
begin
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(output_buf^[ci],
compptr^.width_in_blocks * DCTSIZE,
int (out_row_group_ctr) * compptr^.v_samp_factor,
int (out_row_groups_avail) * compptr^.v_samp_factor);
Inc(compptr);
end;
out_row_group_ctr := out_row_groups_avail;
break; { can exit outer loop without test }
end;
end;
end;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Process some data in the context case. }
{METHODDEF}
procedure pre_process_context (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
buf_height : int;
inrows : JDIMENSION;
var
row : int;
begin
prep := my_prep_ptr (cinfo^.prep);
buf_height := cinfo^.max_v_samp_factor * 3;
while (out_row_group_ctr < out_row_groups_avail) do
begin
if (in_row_ctr < in_rows_avail) then
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := prep^.next_buf_stop - prep^.next_buf_row;
{numrows := int ( MIN( JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
cinfo^.cconvert^.color_convert (cinfo,
JSAMPARRAY(@input_buf^[in_row_ctr]),
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (prep^.next_buf_row),
numrows);
{ Pad at top of image, if first time through }
if (prep^.rows_to_go = cinfo^.image_height) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
for row := 1 to cinfo^.max_v_samp_factor do
begin
jcopy_sample_rows(prep^.color_buf[ci], 0,
prep^.color_buf[ci], -row,
1, cinfo^.image_width);
end;
end;
end;
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
end
else
begin
{ Return for more data, unless we are at the bottom of the image. }
if (prep^.rows_to_go <> 0) then
break;
{ When at bottom of image, pad to fill the conversion buffer. }
if (prep^.next_buf_row < prep^.next_buf_stop) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, prep^.next_buf_stop);
end;
prep^.next_buf_row := prep^.next_buf_stop;
end;
end;
{ If we've gotten enough data, downsample a row group. }
if (prep^.next_buf_row = prep^.next_buf_stop) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.this_row_group),
output_buf,
out_row_group_ctr);
Inc(out_row_group_ctr);
{ Advance pointers with wraparound as necessary. }
Inc(prep^.this_row_group, cinfo^.max_v_samp_factor);
if (prep^.this_row_group >= buf_height) then
prep^.this_row_group := 0;
if (prep^.next_buf_row >= buf_height) then
prep^.next_buf_row := 0;
prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor;
end;
end;
end;
{ Create the wrapped-around downsampling input buffer needed for context mode. }
{LOCAL}
procedure create_context_buffer (cinfo : j_compress_ptr);
var
prep : my_prep_ptr;
rgroup_height : int;
ci, i : int;
compptr : jpeg_component_info_ptr;
true_buffer, fake_buffer : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
rgroup_height := cinfo^.max_v_samp_factor;
{ Grab enough space for fake row pointers for all the components;
we need five row groups' worth of pointers for each component. }
fake_buffer := JSAMPARRAY(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(cinfo^.num_components * 5 * rgroup_height) *
SIZEOF(JSAMPROW)) );
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate the actual buffer space (3 row groups) for this component.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
true_buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION (3 * rgroup_height));
{ Copy true buffer row pointers into the middle of the fake row array }
MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer,
3 * rgroup_height * SIZEOF(JSAMPROW));
{ Fill in the above and below wraparound pointers }
for i := 0 to pred(rgroup_height) do
begin
fake_buffer^[i] := true_buffer^[2 * rgroup_height + i];
fake_buffer^[4 * rgroup_height + i] := true_buffer^[i];
end;
prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]);
Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component }
Inc(compptr);
end;
end;
{$endif} { CONTEXT_ROWS_SUPPORTED }
{ Initialize preprocessing controller. }
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
prep : my_prep_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
if (need_full_buffer) then { safety check }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
prep := my_prep_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_prep_controller)) );
cinfo^.prep := jpeg_c_prep_controller_ptr(prep);
prep^.pub.start_pass := start_pass_prep;
{ Allocate the color conversion buffer.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
if (cinfo^.downsample^.need_context_rows) then
begin
{ Set up to provide context rows }
{$ifdef CONTEXT_ROWS_SUPPORTED}
prep^.pub.pre_process_data := pre_process_context;
create_context_buffer(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
{ No context, just make it tall enough for one row group }
prep^.pub.pre_process_data := pre_process_data;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION(cinfo^.max_v_samp_factor) );
Inc(compptr);
end;
end;
end;
end.
unit imjcprepct;
{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the compression preprocessing controller.
This controller manages the color conversion, downsampling,
and edge expansion steps.
Most of the complexity here is associated with buffering input rows
as required by the downsampler. See the comments at the head of
jcsample.c for the downsampler's needs. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude,
imjutils;
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ At present, jcsample.c can request context rows only for smoothing.
In the future, we might also need context rows for CCIR601 sampling
or other more-complex downsampling procedures. The code to support
context rows should be compiled only if needed. }
{$ifdef INPUT_SMOOTHING_SUPPORTED}
{$define CONTEXT_ROWS_SUPPORTED}
{$endif}
{ For the simple (no-context-row) case, we just need to buffer one
row group's worth of pixels for the downsampling step. At the bottom of
the image, we pad to a full row group by replicating the last pixel row.
The downsampler's last output row is then replicated if needed to pad
out to a full iMCU row.
When providing context rows, we must buffer three row groups' worth of
pixels. Three row groups are physically allocated, but the row pointer
arrays are made five row groups high, with the extra pointers above and
below "wrapping around" to point to the last and first real row groups.
This allows the downsampler to access the proper context rows.
At the top and bottom of the image, we create dummy context rows by
copying the first or last real pixel row. This copying could be avoided
by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the
trouble on the compression side. }
{ Private buffer controller object }
type
my_prep_ptr = ^my_prep_controller;
my_prep_controller = record
pub : jpeg_c_prep_controller; { public fields }
{ Downsampling input buffer. This buffer holds color-converted data
until we have enough to do a downsample step. }
color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
rows_to_go : JDIMENSION; { counts rows remaining in source image }
next_buf_row : int; { index of next row to store in color_buf }
{$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case }
this_row_group : int; { starting row index of group to process }
next_buf_stop : int; { downsample when we reach this index }
{$endif}
end; {my_prep_controller;}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_prep (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE );
var
prep : my_prep_ptr;
begin
prep := my_prep_ptr (cinfo^.prep);
if (pass_mode <> JBUF_PASS_THRU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{ Initialize total-height counter for detecting bottom of image }
prep^.rows_to_go := cinfo^.image_height;
{ Mark the conversion buffer empty }
prep^.next_buf_row := 0;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Preset additional state variables for context mode.
These aren't used in non-context mode, so we needn't test which mode. }
prep^.this_row_group := 0;
{ Set next_buf_stop to stop after two row groups have been read in. }
prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor;
{$endif}
end;
{ Expand an image vertically from height input_rows to height output_rows,
by duplicating the bottom row. }
{LOCAL}
procedure expand_bottom_edge (image_data : JSAMPARRAY;
num_cols : JDIMENSION;
input_rows : int;
output_rows : int);
var
{register} row : int;
begin
for row := input_rows to pred(output_rows) do
begin
jcopy_sample_rows(image_data, input_rows-1, image_data, row,
1, num_cols);
end;
end;
{ Process some data in the simple no-context case.
Preprocessor output data is counted in "row groups". A row group
is defined to be v_samp_factor sample rows of each component.
Downsampling will produce this much data from each max_v_samp_factor
input rows. }
{METHODDEF}
procedure pre_process_data (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
inrows : JDIMENSION;
compptr : jpeg_component_info_ptr;
var
local_input_buf : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
while (in_row_ctr < in_rows_avail) and
(out_row_group_ctr < out_row_groups_avail) do
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row;
{numrows := int( MIN(JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr]));
cinfo^.cconvert^.color_convert (cinfo, local_input_buf,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.next_buf_row),
numrows);
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
{ If at bottom of image, pad to fill the conversion buffer. }
if (prep^.rows_to_go = 0) and
(prep^.next_buf_row < cinfo^.max_v_samp_factor) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, cinfo^.max_v_samp_factor);
end;
prep^.next_buf_row := cinfo^.max_v_samp_factor;
end;
{ If we've filled the conversion buffer, empty it. }
if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (0),
output_buf,
out_row_group_ctr);
prep^.next_buf_row := 0;
Inc(out_row_group_ctr);;
end;
{ If at bottom of image, pad the output to a full iMCU height.
Note we assume the caller is providing a one-iMCU-height output buffer! }
if (prep^.rows_to_go = 0) and
(out_row_group_ctr < out_row_groups_avail) then
begin
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(output_buf^[ci],
compptr^.width_in_blocks * DCTSIZE,
int (out_row_group_ctr) * compptr^.v_samp_factor,
int (out_row_groups_avail) * compptr^.v_samp_factor);
Inc(compptr);
end;
out_row_group_ctr := out_row_groups_avail;
break; { can exit outer loop without test }
end;
end;
end;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Process some data in the context case. }
{METHODDEF}
procedure pre_process_context (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
buf_height : int;
inrows : JDIMENSION;
var
row : int;
begin
prep := my_prep_ptr (cinfo^.prep);
buf_height := cinfo^.max_v_samp_factor * 3;
while (out_row_group_ctr < out_row_groups_avail) do
begin
if (in_row_ctr < in_rows_avail) then
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := prep^.next_buf_stop - prep^.next_buf_row;
{numrows := int ( MIN( JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
cinfo^.cconvert^.color_convert (cinfo,
JSAMPARRAY(@input_buf^[in_row_ctr]),
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (prep^.next_buf_row),
numrows);
{ Pad at top of image, if first time through }
if (prep^.rows_to_go = cinfo^.image_height) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
for row := 1 to cinfo^.max_v_samp_factor do
begin
jcopy_sample_rows(prep^.color_buf[ci], 0,
prep^.color_buf[ci], -row,
1, cinfo^.image_width);
end;
end;
end;
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
end
else
begin
{ Return for more data, unless we are at the bottom of the image. }
if (prep^.rows_to_go <> 0) then
break;
{ When at bottom of image, pad to fill the conversion buffer. }
if (prep^.next_buf_row < prep^.next_buf_stop) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, prep^.next_buf_stop);
end;
prep^.next_buf_row := prep^.next_buf_stop;
end;
end;
{ If we've gotten enough data, downsample a row group. }
if (prep^.next_buf_row = prep^.next_buf_stop) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.this_row_group),
output_buf,
out_row_group_ctr);
Inc(out_row_group_ctr);
{ Advance pointers with wraparound as necessary. }
Inc(prep^.this_row_group, cinfo^.max_v_samp_factor);
if (prep^.this_row_group >= buf_height) then
prep^.this_row_group := 0;
if (prep^.next_buf_row >= buf_height) then
prep^.next_buf_row := 0;
prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor;
end;
end;
end;
{ Create the wrapped-around downsampling input buffer needed for context mode. }
{LOCAL}
procedure create_context_buffer (cinfo : j_compress_ptr);
var
prep : my_prep_ptr;
rgroup_height : int;
ci, i : int;
compptr : jpeg_component_info_ptr;
true_buffer, fake_buffer : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
rgroup_height := cinfo^.max_v_samp_factor;
{ Grab enough space for fake row pointers for all the components;
we need five row groups' worth of pointers for each component. }
fake_buffer := JSAMPARRAY(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(cinfo^.num_components * 5 * rgroup_height) *
SIZEOF(JSAMPROW)) );
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate the actual buffer space (3 row groups) for this component.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
true_buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION (3 * rgroup_height));
{ Copy true buffer row pointers into the middle of the fake row array }
MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer,
3 * rgroup_height * SIZEOF(JSAMPROW));
{ Fill in the above and below wraparound pointers }
for i := 0 to pred(rgroup_height) do
begin
fake_buffer^[i] := true_buffer^[2 * rgroup_height + i];
fake_buffer^[4 * rgroup_height + i] := true_buffer^[i];
end;
prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]);
Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component }
Inc(compptr);
end;
end;
{$endif} { CONTEXT_ROWS_SUPPORTED }
{ Initialize preprocessing controller. }
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
prep : my_prep_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
if (need_full_buffer) then { safety check }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
prep := my_prep_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_prep_controller)) );
cinfo^.prep := jpeg_c_prep_controller_ptr(prep);
prep^.pub.start_pass := start_pass_prep;
{ Allocate the color conversion buffer.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
if (cinfo^.downsample^.need_context_rows) then
begin
{ Set up to provide context rows }
{$ifdef CONTEXT_ROWS_SUPPORTED}
prep^.pub.pre_process_data := pre_process_context;
create_context_buffer(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
{ No context, just make it tall enough for one row group }
prep^.pub.pre_process_data := pre_process_data;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION(cinfo^.max_v_samp_factor) );
Inc(compptr);
end;
end;
end;
end.

1262
Imaging/JpegLib/imjcsample.pas
View File

File diff suppressed because it is too large Load Diff

1010
Imaging/JpegLib/imjdapimin.pas
View File

File diff suppressed because it is too large Load Diff

754
Imaging/JpegLib/imjdapistd.pas
View File

@ -1,377 +1,377 @@
unit imjdapistd;
{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the decompression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-decompression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_decompress, it will end up linking in the entire decompressor.
We thus must separate this file from jdapimin.c to avoid linking the
whole decompression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdmaster;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
implementation
{ Forward declarations }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward;
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
var
retcode : int;
begin
if (cinfo^.global_state = DSTATE_READY) then
begin
{ First call: initialize master control, select active modules }
jinit_master_decompress(cinfo);
if (cinfo^.buffered_image) then
begin
{ No more work here; expecting jpeg_start_output next }
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_start_decompress := TRUE;
exit;
end;
cinfo^.global_state := DSTATE_PRELOAD;
end;
if (cinfo^.global_state = DSTATE_PRELOAD) then
begin
{ If file has multiple scans, absorb them all into the coef buffer }
if (cinfo^.inputctl^.has_multiple_scans) then
begin
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
while TRUE do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
{ Absorb some more input }
retcode := cinfo^.inputctl^.consume_input (cinfo);
if (retcode = JPEG_SUSPENDED) then
begin
jpeg_start_decompress := FALSE;
exit;
end;
if (retcode = JPEG_REACHED_EOI) then
break;
{ Advance progress counter if appropriate }
if (cinfo^.progress <> NIL) and
((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then
begin
Inc(cinfo^.progress^.pass_counter);
if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then
begin
{ jdmaster underestimated number of scans; ratchet up one scan }
Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows));
end;
end;
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end;
cinfo^.output_scan_number := cinfo^.input_scan_number;
end
else
if (cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any dummy output passes, and set up for the final pass }
jpeg_start_decompress := output_pass_setup(cinfo);
end;
{ Set up for an output pass, and perform any dummy pass(es) needed.
Common subroutine for jpeg_start_decompress and jpeg_start_output.
Entry: global_state := DSTATE_PRESCAN only if previously suspended.
Exit: If done, returns TRUE and sets global_state for proper output mode.
If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean;
var
last_scanline : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_PRESCAN) then
begin
{ First call: do pass setup }
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
cinfo^.global_state := DSTATE_PRESCAN;
end;
{ Loop over any required dummy passes }
while (cinfo^.master^.is_dummy_pass) do
begin
{$ifdef QUANT_2PASS_SUPPORTED}
{ Crank through the dummy pass }
while (cinfo^.output_scanline < cinfo^.output_height) do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
last_scanline := cinfo^.output_scanline;
cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL),
cinfo^.output_scanline, {var}
JDIMENSION(0));
if (cinfo^.output_scanline = last_scanline) then
begin
output_pass_setup := FALSE; { No progress made, must suspend }
exit;
end;
end;
{ Finish up dummy pass, and set up for another one }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { QUANT_2PASS_SUPPORTED }
end;
{ Ready for application to drive output pass through
jpeg_read_scanlines or jpeg_read_raw_data. }
if cinfo^.raw_data_out then
cinfo^.global_state := DSTATE_RAW_OK
else
cinfo^.global_state := DSTATE_SCANNING;
output_pass_setup := TRUE;
end;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
var
row_ctr : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_scanlines := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines);
Inc(cinfo^.output_scanline, row_ctr);
jpeg_read_scanlines := row_ctr;
end;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Verify that at least one iMCU row can be returned. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size;
if (max_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Decompress directly into user's buffer. }
if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then
begin
jpeg_read_raw_data := 0; { suspension forced, can do nothing more }
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.output_scanline, lines_per_iMCU_row);
jpeg_read_raw_data := lines_per_iMCU_row;
end;
{ Additional entry points for buffered-image mode. }
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
begin
if (cinfo^.global_state <> DSTATE_BUFIMAGE) and
(cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Limit scan number to valid range }
if (scan_number <= 0) then
scan_number := 1;
if (cinfo^.inputctl^.eoi_reached) and
(scan_number > cinfo^.input_scan_number) then
scan_number := cinfo^.input_scan_number;
cinfo^.output_scan_number := scan_number;
{ Perform any dummy output passes, and set up for the real pass }
jpeg_start_output := output_pass_setup(cinfo);
end;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
begin
if ((cinfo^.global_state = DSTATE_SCANNING) or
(cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then
begin
{ Terminate this pass. }
{ We do not require the whole pass to have been completed. }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.global_state := DSTATE_BUFPOST;
end
else
if (cinfo^.global_state <> DSTATE_BUFPOST) then
begin
{ BUFPOST := repeat call after a suspension, anything else is error }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end;
{ Read markers looking for SOS or EOI }
while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and
(not cinfo^.inputctl^.eoi_reached) do
begin
if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then
begin
jpeg_finish_output := FALSE; { Suspend, come back later }
exit;
end;
end;
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_finish_output := TRUE;
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end.
unit imjdapistd;
{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the decompression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-decompression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_decompress, it will end up linking in the entire decompressor.
We thus must separate this file from jdapimin.c to avoid linking the
whole decompression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdmaster;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
implementation
{ Forward declarations }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward;
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
var
retcode : int;
begin
if (cinfo^.global_state = DSTATE_READY) then
begin
{ First call: initialize master control, select active modules }
jinit_master_decompress(cinfo);
if (cinfo^.buffered_image) then
begin
{ No more work here; expecting jpeg_start_output next }
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_start_decompress := TRUE;
exit;
end;
cinfo^.global_state := DSTATE_PRELOAD;
end;
if (cinfo^.global_state = DSTATE_PRELOAD) then
begin
{ If file has multiple scans, absorb them all into the coef buffer }
if (cinfo^.inputctl^.has_multiple_scans) then
begin
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
while TRUE do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
{ Absorb some more input }
retcode := cinfo^.inputctl^.consume_input (cinfo);
if (retcode = JPEG_SUSPENDED) then
begin
jpeg_start_decompress := FALSE;
exit;
end;
if (retcode = JPEG_REACHED_EOI) then
break;
{ Advance progress counter if appropriate }
if (cinfo^.progress <> NIL) and
((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then
begin
Inc(cinfo^.progress^.pass_counter);
if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then
begin
{ jdmaster underestimated number of scans; ratchet up one scan }
Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows));
end;
end;
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end;
cinfo^.output_scan_number := cinfo^.input_scan_number;
end
else
if (cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any dummy output passes, and set up for the final pass }
jpeg_start_decompress := output_pass_setup(cinfo);
end;
{ Set up for an output pass, and perform any dummy pass(es) needed.
Common subroutine for jpeg_start_decompress and jpeg_start_output.
Entry: global_state := DSTATE_PRESCAN only if previously suspended.
Exit: If done, returns TRUE and sets global_state for proper output mode.
If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean;
var
last_scanline : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_PRESCAN) then
begin
{ First call: do pass setup }
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
cinfo^.global_state := DSTATE_PRESCAN;
end;
{ Loop over any required dummy passes }
while (cinfo^.master^.is_dummy_pass) do
begin
{$ifdef QUANT_2PASS_SUPPORTED}
{ Crank through the dummy pass }
while (cinfo^.output_scanline < cinfo^.output_height) do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
last_scanline := cinfo^.output_scanline;
cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL),
cinfo^.output_scanline, {var}
JDIMENSION(0));
if (cinfo^.output_scanline = last_scanline) then
begin
output_pass_setup := FALSE; { No progress made, must suspend }
exit;
end;
end;
{ Finish up dummy pass, and set up for another one }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { QUANT_2PASS_SUPPORTED }
end;
{ Ready for application to drive output pass through
jpeg_read_scanlines or jpeg_read_raw_data. }
if cinfo^.raw_data_out then
cinfo^.global_state := DSTATE_RAW_OK
else
cinfo^.global_state := DSTATE_SCANNING;
output_pass_setup := TRUE;
end;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
var
row_ctr : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_scanlines := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines);
Inc(cinfo^.output_scanline, row_ctr);
jpeg_read_scanlines := row_ctr;
end;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Verify that at least one iMCU row can be returned. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size;
if (max_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Decompress directly into user's buffer. }
if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then
begin
jpeg_read_raw_data := 0; { suspension forced, can do nothing more }
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.output_scanline, lines_per_iMCU_row);
jpeg_read_raw_data := lines_per_iMCU_row;
end;
{ Additional entry points for buffered-image mode. }
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
begin
if (cinfo^.global_state <> DSTATE_BUFIMAGE) and
(cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Limit scan number to valid range }
if (scan_number <= 0) then
scan_number := 1;
if (cinfo^.inputctl^.eoi_reached) and
(scan_number > cinfo^.input_scan_number) then
scan_number := cinfo^.input_scan_number;
cinfo^.output_scan_number := scan_number;
{ Perform any dummy output passes, and set up for the real pass }
jpeg_start_output := output_pass_setup(cinfo);
end;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
begin
if ((cinfo^.global_state = DSTATE_SCANNING) or
(cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then
begin
{ Terminate this pass. }
{ We do not require the whole pass to have been completed. }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.global_state := DSTATE_BUFPOST;
end
else
if (cinfo^.global_state <> DSTATE_BUFPOST) then
begin
{ BUFPOST := repeat call after a suspension, anything else is error }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end;
{ Read markers looking for SOS or EOI }
while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and
(not cinfo^.inputctl^.eoi_reached) do
begin
if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then
begin
jpeg_finish_output := FALSE; { Suspend, come back later }
exit;
end;
end;
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_finish_output := TRUE;
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end.

1790
Imaging/JpegLib/imjdcoefct.pas
View File

File diff suppressed because it is too large Load Diff

1002
Imaging/JpegLib/imjdcolor.pas
View File

File diff suppressed because it is too large Load Diff

218
Imaging/JpegLib/imjdct.pas
View File

@ -1,109 +1,109 @@
unit imjdct;
{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This include file contains common declarations for the forward and
inverse DCT modules. These declarations are private to the DCT managers
(jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms.
The individual DCT algorithms are kept in separate files to ease
machine-dependent tuning (e.g., assembly coding). }
interface
{$I imjconfig.inc}
uses
imjmorecfg;
{ A forward DCT routine is given a pointer to a work area of type DCTELEM[];
the DCT is to be performed in-place in that buffer. Type DCTELEM is int
for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT
implementations use an array of type FAST_FLOAT, instead.)
The DCT inputs are expected to be signed (range +-CENTERJSAMPLE).
The DCT outputs are returned scaled up by a factor of 8; they therefore
have a range of +-8K for 8-bit data, +-128K for 12-bit data. This
convention improves accuracy in integer implementations and saves some
work in floating-point ones.
Quantization of the output coefficients is done by jcdctmgr.c. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
DCTELEM = int; { 16 or 32 bits is fine }
{$else}
type { must have 32 bits }
DCTELEM = INT32;
{$endif}
type
jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1;
DCTELEM_FIELD = array[jTDctElem] of DCTELEM;
DCTELEM_FIELD_PTR = ^DCTELEM_FIELD;
DCTELEMPTR = ^DCTELEM;
type
forward_DCT_method_ptr = procedure(var data : array of DCTELEM);
float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT);
{ An inverse DCT routine is given a pointer to the input JBLOCK and a pointer
to an output sample array. The routine must dequantize the input data as
well as perform the IDCT; for dequantization, it uses the multiplier table
pointed to by compptr->dct_table. The output data is to be placed into the
sample array starting at a specified column. (Any row offset needed will
be applied to the array pointer before it is passed to the IDCT code.)
Note that the number of samples emitted by the IDCT routine is
DCT_scaled_size * DCT_scaled_size. }
{ typedef inverse_DCT_method_ptr is declared in jpegint.h }
{ Each IDCT routine has its own ideas about the best dct_table element type. }
type
ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster }
const
IFAST_SCALE_BITS = 2; { fractional bits in scale factors }
{$else}
type
IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers }
const
IFAST_SCALE_BITS = 13; { fractional bits in scale factors }
{$endif}
type
FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type }
const
RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples }
type
jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1;
ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE;
ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD;
ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE;
jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1;
FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE;
FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD;
FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE;
jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1;
IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE;
IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD;
IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE;
type
jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1;
FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT;
FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD;
FAST_FLOAT_PTR = ^FAST_FLOAT;
implementation
end.
unit imjdct;
{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This include file contains common declarations for the forward and
inverse DCT modules. These declarations are private to the DCT managers
(jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms.
The individual DCT algorithms are kept in separate files to ease
machine-dependent tuning (e.g., assembly coding). }
interface
{$I imjconfig.inc}
uses
imjmorecfg;
{ A forward DCT routine is given a pointer to a work area of type DCTELEM[];
the DCT is to be performed in-place in that buffer. Type DCTELEM is int
for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT
implementations use an array of type FAST_FLOAT, instead.)
The DCT inputs are expected to be signed (range +-CENTERJSAMPLE).
The DCT outputs are returned scaled up by a factor of 8; they therefore
have a range of +-8K for 8-bit data, +-128K for 12-bit data. This
convention improves accuracy in integer implementations and saves some
work in floating-point ones.
Quantization of the output coefficients is done by jcdctmgr.c. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
DCTELEM = int; { 16 or 32 bits is fine }
{$else}
type { must have 32 bits }
DCTELEM = INT32;
{$endif}
type
jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1;
DCTELEM_FIELD = array[jTDctElem] of DCTELEM;
DCTELEM_FIELD_PTR = ^DCTELEM_FIELD;
DCTELEMPTR = ^DCTELEM;
type
forward_DCT_method_ptr = procedure(var data : array of DCTELEM);
float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT);
{ An inverse DCT routine is given a pointer to the input JBLOCK and a pointer
to an output sample array. The routine must dequantize the input data as
well as perform the IDCT; for dequantization, it uses the multiplier table
pointed to by compptr->dct_table. The output data is to be placed into the
sample array starting at a specified column. (Any row offset needed will
be applied to the array pointer before it is passed to the IDCT code.)
Note that the number of samples emitted by the IDCT routine is
DCT_scaled_size * DCT_scaled_size. }
{ typedef inverse_DCT_method_ptr is declared in jpegint.h }
{ Each IDCT routine has its own ideas about the best dct_table element type. }
type
ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster }
const
IFAST_SCALE_BITS = 2; { fractional bits in scale factors }
{$else}
type
IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers }
const
IFAST_SCALE_BITS = 13; { fractional bits in scale factors }
{$endif}
type
FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type }
const
RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples }
type
jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1;
ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE;
ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD;
ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE;
jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1;
FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE;
FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD;
FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE;
jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1;
IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE;
IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD;
IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE;
type
jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1;
FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT;
FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD;
FAST_FLOAT_PTR = ^FAST_FLOAT;
implementation
end.

660
Imaging/JpegLib/imjddctmgr.pas
View File

@ -1,330 +1,330 @@
unit imjddctmgr;
{ Original : jddctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the inverse-DCT management logic.
This code selects a particular IDCT implementation to be used,
and it performs related housekeeping chores. No code in this file
is executed per IDCT step, only during output pass setup.
Note that the IDCT routines are responsible for performing coefficient
dequantization as well as the IDCT proper. This module sets up the
dequantization multiplier table needed by the IDCT routine. }
interface
{$I imjconfig.inc}
{$N+}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdct, { Private declarations for DCT subsystem }
imjidctfst,
{$IFDEF BASM}
imjidctasm,
{$ELSE}
imjidctint,
{$ENDIF}
imjidctflt,
imjidctred;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
implementation
{ The decompressor input side (jdinput.c) saves away the appropriate
quantization table for each component at the start of the first scan
involving that component. (This is necessary in order to correctly
decode files that reuse Q-table slots.)
When we are ready to make an output pass, the saved Q-table is converted
to a multiplier table that will actually be used by the IDCT routine.
The multiplier table contents are IDCT-method-dependent. To support
application changes in IDCT method between scans, we can remake the
multiplier tables if necessary.
In buffered-image mode, the first output pass may occur before any data
has been seen for some components, and thus before their Q-tables have
been saved away. To handle this case, multiplier tables are preset
to zeroes; the result of the IDCT will be a neutral gray level. }
{ Private subobject for this module }
type
my_idct_ptr = ^my_idct_controller;
my_idct_controller = record
pub : jpeg_inverse_dct; { public fields }
{ This array contains the IDCT method code that each multiplier table
is currently set up for, or -1 if it's not yet set up.
The actual multiplier tables are pointed to by dct_table in the
per-component comp_info structures. }
cur_method : array[0..MAX_COMPONENTS-1] of int;
end; {my_idct_controller;}
{ Allocated multiplier tables: big enough for any supported variant }
type
multiplier_table = record
case byte of
0:(islow_array : array[0..DCTSIZE2-1] of ISLOW_MULT_TYPE);
{$ifdef DCT_IFAST_SUPPORTED}
1:(ifast_array : array[0..DCTSIZE2-1] of IFAST_MULT_TYPE);
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
2:(float_array : array[0..DCTSIZE2-1] of FLOAT_MULT_TYPE);
{$endif}
end;
{ The current scaled-IDCT routines require ISLOW-style multiplier tables,
so be sure to compile that code if either ISLOW or SCALING is requested. }
{$ifdef DCT_ISLOW_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$else}
{$ifdef IDCT_SCALING_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$endif}
{$endif}
{ Prepare for an output pass.
Here we select the proper IDCT routine for each component and build
a matching multiplier table. }
{METHODDEF}
procedure start_pass (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci, i : int;
compptr : jpeg_component_info_ptr;
method : J_DCT_METHOD;
method_ptr : inverse_DCT_method_ptr;
qtbl : JQUANT_TBL_PTR;
{$ifdef PROVIDE_ISLOW_TABLES}
var
ismtbl : ISLOW_MULT_TYPE_FIELD_PTR;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
const
CONST_BITS = 14;
const
aanscales : array[0..DCTSIZE2-1] of INT16 =
({ precomputed values scaled up by 14 bits }
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270,
21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906,
19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315,
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552,
8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446,
4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247);
var
ifmtbl : IFAST_MULT_TYPE_FIELD_PTR;
{SHIFT_TEMPS}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
const
aanscalefactor : array[0..DCTSIZE-1] of double =
(1.0, 1.387039845, 1.306562965, 1.175875602,
1.0, 0.785694958, 0.541196100, 0.275899379);
var
fmtbl : FLOAT_MULT_TYPE_FIELD_PTR;
row, col : int;
{$endif}
begin
idct := my_idct_ptr (cinfo^.idct);
method := J_DCT_METHOD(0);
method_ptr := NIL;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Select the proper IDCT routine for this component's scaling }
case (compptr^.DCT_scaled_size) of
{$ifdef IDCT_SCALING_SUPPORTED}
1:begin
method_ptr := jpeg_idct_1x1;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
2:begin
method_ptr := jpeg_idct_2x2;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
4:begin
method_ptr := jpeg_idct_4x4;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
{$endif}
DCTSIZE:
case (cinfo^.dct_method) of
{$ifdef DCT_ISLOW_SUPPORTED}
JDCT_ISLOW:
begin
method_ptr := @jpeg_idct_islow;
method := JDCT_ISLOW;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
method_ptr := @jpeg_idct_ifast;
method := JDCT_IFAST;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
method_ptr := @jpeg_idct_float;
method := JDCT_FLOAT;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
else
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_DCTSIZE, compptr^.DCT_scaled_size);
end;
idct^.pub.inverse_DCT[ci] := method_ptr;
{ Create multiplier table from quant table.
However, we can skip this if the component is uninteresting
or if we already built the table. Also, if no quant table
has yet been saved for the component, we leave the
multiplier table all-zero; we'll be reading zeroes from the
coefficient controller's buffer anyway. }
if (not compptr^.component_needed) or (idct^.cur_method[ci] = int(method)) then
continue;
qtbl := compptr^.quant_table;
if (qtbl = NIL) then { happens if no data yet for component }
continue;
idct^.cur_method[ci] := int(method);
case (method) of
{$ifdef PROVIDE_ISLOW_TABLES}
JDCT_ISLOW:
begin
{ For LL&M IDCT method, multipliers are equal to raw quantization
coefficients, but are stored as ints to ensure access efficiency. }
ismtbl := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ismtbl^[i] := ISLOW_MULT_TYPE (qtbl^.quantval[i]);
end;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
{ For AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7
For integer operation, the multiplier table is to be scaled by
IFAST_SCALE_BITS. }
ifmtbl := IFAST_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ifmtbl^[i] := IFAST_MULT_TYPE(
DESCALE( INT32 (qtbl^.quantval[i]) * INT32 (aanscales[i]),
CONST_BITS-IFAST_SCALE_BITS) );
end;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
{ For float AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 }
fmtbl := FLOAT_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
i := 0;
for row := 0 to pred(DCTSIZE) do
begin
for col := 0 to pred(DCTSIZE) do
begin
fmtbl^[i] := {FLOAT_MULT_TYPE} (
{double} qtbl^.quantval[i] *
aanscalefactor[row] * aanscalefactor[col] );
Inc(i);
end;
end;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
break;
end;
Inc(compptr);
end;
end;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
idct := my_idct_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_idct_controller)) );
cinfo^.idct := jpeg_inverse_dct_ptr (idct);
idct^.pub.start_pass := start_pass;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate and pre-zero a multiplier table for each component }
compptr^.dct_table :=
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(multiplier_table));
MEMZERO(compptr^.dct_table, SIZEOF(multiplier_table));
{ Mark multiplier table not yet set up for any method }
idct^.cur_method[ci] := -1;
Inc(compptr);
end;
end;
end.
unit imjddctmgr;
{ Original : jddctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the inverse-DCT management logic.
This code selects a particular IDCT implementation to be used,
and it performs related housekeeping chores. No code in this file
is executed per IDCT step, only during output pass setup.
Note that the IDCT routines are responsible for performing coefficient
dequantization as well as the IDCT proper. This module sets up the
dequantization multiplier table needed by the IDCT routine. }
interface
{$I imjconfig.inc}
{$N+}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdct, { Private declarations for DCT subsystem }
imjidctfst,
{$IFDEF BASM}
imjidctasm,
{$ELSE}
imjidctint,
{$ENDIF}
imjidctflt,
imjidctred;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
implementation
{ The decompressor input side (jdinput.c) saves away the appropriate
quantization table for each component at the start of the first scan
involving that component. (This is necessary in order to correctly
decode files that reuse Q-table slots.)
When we are ready to make an output pass, the saved Q-table is converted
to a multiplier table that will actually be used by the IDCT routine.
The multiplier table contents are IDCT-method-dependent. To support
application changes in IDCT method between scans, we can remake the
multiplier tables if necessary.
In buffered-image mode, the first output pass may occur before any data
has been seen for some components, and thus before their Q-tables have
been saved away. To handle this case, multiplier tables are preset
to zeroes; the result of the IDCT will be a neutral gray level. }
{ Private subobject for this module }
type
my_idct_ptr = ^my_idct_controller;
my_idct_controller = record
pub : jpeg_inverse_dct; { public fields }
{ This array contains the IDCT method code that each multiplier table
is currently set up for, or -1 if it's not yet set up.
The actual multiplier tables are pointed to by dct_table in the
per-component comp_info structures. }
cur_method : array[0..MAX_COMPONENTS-1] of int;
end; {my_idct_controller;}
{ Allocated multiplier tables: big enough for any supported variant }
type
multiplier_table = record
case byte of
0:(islow_array : array[0..DCTSIZE2-1] of ISLOW_MULT_TYPE);
{$ifdef DCT_IFAST_SUPPORTED}
1:(ifast_array : array[0..DCTSIZE2-1] of IFAST_MULT_TYPE);
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
2:(float_array : array[0..DCTSIZE2-1] of FLOAT_MULT_TYPE);
{$endif}
end;
{ The current scaled-IDCT routines require ISLOW-style multiplier tables,
so be sure to compile that code if either ISLOW or SCALING is requested. }
{$ifdef DCT_ISLOW_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$else}
{$ifdef IDCT_SCALING_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$endif}
{$endif}
{ Prepare for an output pass.
Here we select the proper IDCT routine for each component and build
a matching multiplier table. }
{METHODDEF}
procedure start_pass (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci, i : int;
compptr : jpeg_component_info_ptr;
method : J_DCT_METHOD;
method_ptr : inverse_DCT_method_ptr;
qtbl : JQUANT_TBL_PTR;
{$ifdef PROVIDE_ISLOW_TABLES}
var
ismtbl : ISLOW_MULT_TYPE_FIELD_PTR;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
const
CONST_BITS = 14;
const
aanscales : array[0..DCTSIZE2-1] of INT16 =
({ precomputed values scaled up by 14 bits }
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270,
21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906,
19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315,
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552,
8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446,
4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247);
var
ifmtbl : IFAST_MULT_TYPE_FIELD_PTR;
{SHIFT_TEMPS}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
const
aanscalefactor : array[0..DCTSIZE-1] of double =
(1.0, 1.387039845, 1.306562965, 1.175875602,
1.0, 0.785694958, 0.541196100, 0.275899379);
var
fmtbl : FLOAT_MULT_TYPE_FIELD_PTR;
row, col : int;
{$endif}
begin
idct := my_idct_ptr (cinfo^.idct);
method := J_DCT_METHOD(0);
method_ptr := NIL;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Select the proper IDCT routine for this component's scaling }
case (compptr^.DCT_scaled_size) of
{$ifdef IDCT_SCALING_SUPPORTED}
1:begin
method_ptr := jpeg_idct_1x1;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
2:begin
method_ptr := jpeg_idct_2x2;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
4:begin
method_ptr := jpeg_idct_4x4;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
{$endif}
DCTSIZE:
case (cinfo^.dct_method) of
{$ifdef DCT_ISLOW_SUPPORTED}
JDCT_ISLOW:
begin
method_ptr := @jpeg_idct_islow;
method := JDCT_ISLOW;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
method_ptr := @jpeg_idct_ifast;
method := JDCT_IFAST;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
method_ptr := @jpeg_idct_float;
method := JDCT_FLOAT;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
else
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_DCTSIZE, compptr^.DCT_scaled_size);
end;
idct^.pub.inverse_DCT[ci] := method_ptr;
{ Create multiplier table from quant table.
However, we can skip this if the component is uninteresting
or if we already built the table. Also, if no quant table
has yet been saved for the component, we leave the
multiplier table all-zero; we'll be reading zeroes from the
coefficient controller's buffer anyway. }
if (not compptr^.component_needed) or (idct^.cur_method[ci] = int(method)) then
continue;
qtbl := compptr^.quant_table;
if (qtbl = NIL) then { happens if no data yet for component }
continue;
idct^.cur_method[ci] := int(method);
case (method) of
{$ifdef PROVIDE_ISLOW_TABLES}
JDCT_ISLOW:
begin
{ For LL&M IDCT method, multipliers are equal to raw quantization
coefficients, but are stored as ints to ensure access efficiency. }
ismtbl := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ismtbl^[i] := ISLOW_MULT_TYPE (qtbl^.quantval[i]);
end;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
{ For AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7
For integer operation, the multiplier table is to be scaled by
IFAST_SCALE_BITS. }
ifmtbl := IFAST_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ifmtbl^[i] := IFAST_MULT_TYPE(
DESCALE( INT32 (qtbl^.quantval[i]) * INT32 (aanscales[i]),
CONST_BITS-IFAST_SCALE_BITS) );
end;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
{ For float AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 }
fmtbl := FLOAT_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
i := 0;
for row := 0 to pred(DCTSIZE) do
begin
for col := 0 to pred(DCTSIZE) do
begin
fmtbl^[i] := {FLOAT_MULT_TYPE} (
{double} qtbl^.quantval[i] *
aanscalefactor[row] * aanscalefactor[col] );
Inc(i);
end;
end;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
break;
end;
Inc(compptr);
end;
end;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
idct := my_idct_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_idct_controller)) );
cinfo^.idct := jpeg_inverse_dct_ptr (idct);
idct^.pub.start_pass := start_pass;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate and pre-zero a multiplier table for each component }
compptr^.dct_table :=
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(multiplier_table));
MEMZERO(compptr^.dct_table, SIZEOF(multiplier_table));
{ Mark multiplier table not yet set up for any method }
idct^.cur_method[ci] := -1;
Inc(compptr);
end;
end;
end.

994
Imaging/JpegLib/imjdeferr.pas
View File

@ -1,497 +1,497 @@
unit imjdeferr;
{ This file defines the error and message codes for the cjpeg/djpeg
applications. These strings are not needed as part of the JPEG library
proper.
Edit this file to add new codes, or to translate the message strings to
some other language. }
{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ To define the enum list of message codes, include this file without
defining macro JMESSAGE. To create a message string table, include it
again with a suitable JMESSAGE definition (see jerror.c for an example). }
{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. }
{ This file contains software version identification. }
const
JVERSION = '6a 7-Feb-96';
JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane';
JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali';
{ Create the message string table.
We do this from the master message list in jerror.h by re-reading
jerror.h with a suitable definition for macro JMESSAGE.
The message table is made an external symbol just in case any applications
want to refer to it directly. }
type
J_MESSAGE_CODE =(
JMSG_NOMESSAGE,
JERR_ARITH_NOTIMPL,
JERR_BAD_ALIGN_TYPE,
JERR_BAD_ALLOC_CHUNK,
JERR_BAD_BUFFER_MODE,
JERR_BAD_COMPONENT_ID,
JERR_BAD_DCT_COEF,
JERR_BAD_DCTSIZE,
JERR_BAD_HUFF_TABLE,
JERR_BAD_IN_COLORSPACE,
JERR_BAD_J_COLORSPACE,
JERR_BAD_LENGTH,
JERR_BAD_LIB_VERSION,
JERR_BAD_MCU_SIZE,
JERR_BAD_POOL_ID,
JERR_BAD_PRECISION,
JERR_BAD_PROGRESSION,
JERR_BAD_PROG_SCRIPT,
JERR_BAD_SAMPLING,
JERR_BAD_SCAN_SCRIPT,
JERR_BAD_STATE,
JERR_BAD_STRUCT_SIZE,
JERR_BAD_VIRTUAL_ACCESS,
JERR_BUFFER_SIZE,
JERR_CANT_SUSPEND,
JERR_CCIR601_NOTIMPL,
JERR_COMPONENT_COUNT,
JERR_CONVERSION_NOTIMPL,
JERR_DAC_INDEX,
JERR_DAC_VALUE,
JERR_DHT_COUNTS,
JERR_DHT_INDEX,
JERR_DQT_INDEX,
JERR_EMPTY_IMAGE,
JERR_EMS_READ,
JERR_EMS_WRITE,
JERR_EOI_EXPECTED,
JERR_FILE_READ,
JERR_FILE_WRITE,
JERR_FRACT_SAMPLE_NOTIMPL,
JERR_HUFF_CLEN_OVERFLOW,
JERR_HUFF_MISSING_CODE,
JERR_IMAGE_TOO_BIG,
JERR_INPUT_EMPTY,
JERR_INPUT_EOF,
JERR_MISMATCHED_QUANT_TABLE,
JERR_MISSING_DATA,
JERR_MODE_CHANGE,
JERR_NOTIMPL,
JERR_NOT_COMPILED,
JERR_NO_BACKING_STORE,
JERR_NO_HUFF_TABLE,
JERR_NO_IMAGE,
JERR_NO_QUANT_TABLE,
JERR_NO_SOI,
JERR_OUT_OF_MEMORY,
JERR_QUANT_COMPONENTS,
JERR_QUANT_FEW_COLORS,
JERR_QUANT_MANY_COLORS,
JERR_SOF_DUPLICATE,
JERR_SOF_NO_SOS,
JERR_SOF_UNSUPPORTED,
JERR_SOI_DUPLICATE,
JERR_SOS_NO_SOF,
JERR_TFILE_CREATE,
JERR_TFILE_READ,
JERR_TFILE_SEEK,
JERR_TFILE_WRITE,
JERR_TOO_LITTLE_DATA,
JERR_UNKNOWN_MARKER,
JERR_VIRTUAL_BUG,
JERR_WIDTH_OVERFLOW,
JERR_XMS_READ,
JERR_XMS_WRITE,
JMSG_COPYRIGHT,
JMSG_VERSION,
JTRC_16BIT_TABLES,
JTRC_ADOBE,
JTRC_APP0,
JTRC_APP14,
JTRC_DAC,
JTRC_DHT,
JTRC_DQT,
JTRC_DRI,
JTRC_EMS_CLOSE,
JTRC_EMS_OPEN,
JTRC_EOI,
JTRC_HUFFBITS,
JTRC_JFIF,
JTRC_JFIF_BADTHUMBNAILSIZE,
JTRC_JFIF_EXTENSION,
JTRC_JFIF_THUMBNAIL,
JTRC_MISC_MARKER,
JTRC_PARMLESS_MARKER,
JTRC_QUANTVALS,
JTRC_QUANT_3_NCOLORS,
JTRC_QUANT_NCOLORS,
JTRC_QUANT_SELECTED,
JTRC_RECOVERY_ACTION,
JTRC_RST,
JTRC_SMOOTH_NOTIMPL,
JTRC_SOF,
JTRC_SOF_COMPONENT,
JTRC_SOI,
JTRC_SOS,
JTRC_SOS_COMPONENT,
JTRC_SOS_PARAMS,
JTRC_TFILE_CLOSE,
JTRC_TFILE_OPEN,
JTRC_THUMB_JPEG,
JTRC_THUMB_PALETTE,
JTRC_THUMB_RGB,
JTRC_UNKNOWN_IDS,
JTRC_XMS_CLOSE,
JTRC_XMS_OPEN,
JWRN_ADOBE_XFORM,
JWRN_BOGUS_PROGRESSION,
JWRN_EXTRANEOUS_DATA,
JWRN_HIT_MARKER,
JWRN_HUFF_BAD_CODE,
JWRN_JFIF_MAJOR,
JWRN_JPEG_EOF,
JWRN_MUST_RESYNC,
JWRN_NOT_SEQUENTIAL,
JWRN_TOO_MUCH_DATA,
JMSG_FIRSTADDONCODE, { Must be first entry! }
{$ifdef BMP_SUPPORTED}
JERR_BMP_BADCMAP, { Unsupported BMP colormap format }
JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported }
JERR_BMP_BADHEADER, { Invalid BMP file: bad header length }
JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 }
JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB }
JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported }
JERR_BMP_NOT, { Not a BMP file - does not start with BM }
JTRC_BMP, { %dx%d 24-bit BMP image }
JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped BMP image }
JTRC_BMP_OS2, { %dx%d 24-bit OS2 BMP image }
JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image }
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
JERR_GIF_BUG, { GIF output got confused }
JERR_GIF_CODESIZE, { Bogus GIF codesize %d }
JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB }
JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file }
JERR_GIF_NOT, { Not a GIF file }
JTRC_GIF, { %dx%dx%d GIF image }
JTRC_GIF_BADVERSION,
{ Warning: unexpected GIF version number '%c%c%c' }
JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x }
JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input }
JWRN_GIF_BADDATA, { Corrupt data in GIF file }
JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring }
JWRN_GIF_ENDCODE, { Premature end of GIF image }
JWRN_GIF_NOMOREDATA, { Ran out of GIF bits }
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB }
JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file }
JERR_PPM_NOT, { Not a PPM file }
JTRC_PGM, { %dx%d PGM image }
JTRC_PGM_TEXT, { %dx%d text PGM image }
JTRC_PPM, { %dx%d PPM image }
JTRC_PPM_TEXT, { %dx%d text PPM image }
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
JERR_RLE_BADERROR, { Bogus error code from RLE library }
JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB }
JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE }
JERR_RLE_EMPTY, { Empty RLE file }
JERR_RLE_EOF, { Premature EOF in RLE header }
JERR_RLE_MEM, { Insufficient memory for RLE header }
JERR_RLE_NOT, { Not an RLE file }
JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE }
JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup }
JTRC_RLE, { %dx%d full-color RLE file }
JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d }
JTRC_RLE_GRAY, { %dx%d grayscale RLE file }
JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d }
JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d }
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
JERR_TGA_BADCMAP, { Unsupported Targa colormap format }
JERR_TGA_BADPARMS, { Invalid or unsupported Targa file }
JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB }
JTRC_TGA, { %dx%d RGB Targa image }
JTRC_TGA_GRAY, { %dx%d grayscale Targa image }
JTRC_TGA_MAPPED, { %dx%d colormapped Targa image }
{$else}
JERR_TGA_NOTCOMP, { Targa support was not compiled }
{$endif} { TARGA_SUPPORTED }
JERR_BAD_CMAP_FILE,
{ Color map file is invalid or of unsupported format }
JERR_TOO_MANY_COLORS,
{ Output file format cannot handle %d colormap entries }
JERR_UNGETC_FAILED, { ungetc failed }
{$ifdef TARGA_SUPPORTED}
JERR_UNKNOWN_FORMAT,
{ Unrecognized input file format --- perhaps you need -targa }
{$else}
JERR_UNKNOWN_FORMAT, { Unrecognized input file format }
{$endif}
JERR_UNSUPPORTED_FORMAT, { Unsupported output file format }
JMSG_LASTADDONCODE
);
const
JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE;
type
msg_table = Array[J_MESSAGE_CODE] of string[80];
const
jpeg_std_message_table : msg_table = (
{ JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! }
{ For maintenance convenience, list is alphabetical by message code name }
{ JERR_ARITH_NOTIMPL }
'Sorry, there are legal restrictions on arithmetic coding',
{ JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix',
{ JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK is wrong, please fix',
{ JERR_BAD_BUFFER_MODE } 'Bogus buffer control mode',
{ JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS',
{ JERR_BAD_DCT_COEF } 'DCT coefficient out of range',
{ JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported',
{ JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition',
{ JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace',
{ JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace',
{ JERR_BAD_LENGTH } 'Bogus marker length',
{ JERR_BAD_LIB_VERSION }
'Wrong JPEG library version: library is %d, caller expects %d',
{ JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan',
{ JERR_BAD_POOL_ID } 'Invalid memory pool code %d',
{ JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d',
{ JERR_BAD_PROGRESSION }
'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d',
{ JERR_BAD_PROG_SCRIPT }
'Invalid progressive parameters at scan script entry %d',
{ JERR_BAD_SAMPLING } 'Bogus sampling factors',
{ JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d',
{ JERR_BAD_STATE } 'Improper call to JPEG library in state %d',
{ JERR_BAD_STRUCT_SIZE }
'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d',
{ JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access',
{ JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small',
{ JERR_CANT_SUSPEND } 'Suspension not allowed here',
{ JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet',
{ JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d',
{ JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request',
{ JERR_DAC_INDEX } 'Bogus DAC index %d',
{ JERR_DAC_VALUE } 'Bogus DAC value $%x',
{ JERR_DHT_COUNTS } 'Bogus DHT counts',
{ JERR_DHT_INDEX } 'Bogus DHT index %d',
{ JERR_DQT_INDEX } 'Bogus DQT index %d',
{ JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)',
{ JERR_EMS_READ } 'Read from EMS failed',
{ JERR_EMS_WRITE } 'Write to EMS failed',
{ JERR_EOI_EXPECTED } 'Didn''t expect more than one scan',
{ JERR_FILE_READ } 'Input file read error',
{ JERR_FILE_WRITE } 'Output file write error --- out of disk space?',
{ JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet',
{ JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow',
{ JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry',
{ JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels',
{ JERR_INPUT_EMPTY } 'Empty input file',
{ JERR_INPUT_EOF } 'Premature end of input file',
{ JERR_MISMATCHED_QUANT_TABLE }
'Cannot transcode due to multiple use of quantization table %d',
{ JERR_MISSING_DATA } 'Scan script does not transmit all data',
{ JERR_MODE_CHANGE } 'Invalid color quantization mode change',
{ JERR_NOTIMPL } 'Not implemented yet',
{ JERR_NOT_COMPILED } 'Requested feature was omitted at compile time',
{ JERR_NO_BACKING_STORE } 'Backing store not supported',
{ JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined',
{ JERR_NO_IMAGE } 'JPEG datastream contains no image',
{ JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined',
{ JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x',
{ JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)',
{ JERR_QUANT_COMPONENTS }
'Cannot quantize more than %d color components',
{ JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors',
{ JERR_QUANT_MANY_COLORS } 'Cannot quantize to more than %d colors',
{ JERR_SOF_DUPLICATE } 'Invalid JPEG file structure: two SOF markers',
{ JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker',
{ JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x',
{ JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers',
{ JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF',
{ JERR_TFILE_CREATE } 'Failed to create temporary file %s',
{ JERR_TFILE_READ } 'Read failed on temporary file',
{ JERR_TFILE_SEEK } 'Seek failed on temporary file',
{ JERR_TFILE_WRITE }
'Write failed on temporary file --- out of disk space?',
{ JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines',
{ JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x',
{ JERR_VIRTUAL_BUG } 'Virtual array controller messed up',
{ JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation',
{ JERR_XMS_READ } 'Read from XMS failed',
{ JERR_XMS_WRITE } 'Write to XMS failed',
{ JMSG_COPYRIGHT } JCOPYRIGHT,
{ JMSG_VERSION } JVERSION,
{ JTRC_16BIT_TABLES }
'Caution: quantization tables are too coarse for baseline JPEG',
{ JTRC_ADOBE }
'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d',
{ JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d',
{ JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d',
{ JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x',
{ JTRC_DHT } 'Define Huffman Table $%02x',
{ JTRC_DQT } 'Define Quantization Table %d precision %d',
{ JTRC_DRI } 'Define Restart Interval %d',
{ JTRC_EMS_CLOSE } 'Freed EMS handle %d',
{ JTRC_EMS_OPEN } 'Obtained EMS handle %d',
{ JTRC_EOI } 'End Of Image',
{ JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d',
{ JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d',
{ JTRC_JFIF_BADTHUMBNAILSIZE }
'Warning: thumbnail image size does not match data length %d',
{ JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u',
{ JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image',
{ JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d',
{ JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x',
{ JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d',
{ JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors',
{ JTRC_QUANT_NCOLORS } 'Quantizing to %d colors',
{ JTRC_QUANT_SELECTED } 'Selected %d colors for quantization',
{ JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d',
{ JTRC_RST } 'RST%d',
{ JTRC_SMOOTH_NOTIMPL }
'Smoothing not supported with nonstandard sampling ratios',
{ JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d',
{ JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d',
{ JTRC_SOI } 'Start of Image',
{ JTRC_SOS } 'Start Of Scan: %d components',
{ JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d',
{ JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d',
{ JTRC_TFILE_CLOSE } 'Closed temporary file %s',
{ JTRC_TFILE_OPEN } 'Opened temporary file %s',
{ JTRC_THUMB_JPEG }
'JFIF extension marker: JPEG-compressed thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_PALETTE }
'JFIF extension marker: palette thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_RGB }
'JFIF extension marker: RGB thumbnail image, length %u',
{ JTRC_UNKNOWN_IDS }
'Unrecognized component IDs %d %d %d, assuming YCbCr',
{ JTRC_XMS_CLOSE } 'Freed XMS handle %d',
{ JTRC_XMS_OPEN } 'Obtained XMS handle %d',
{ JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d',
{ JWRN_BOGUS_PROGRESSION }
'Inconsistent progression sequence for component %d coefficient %d',
{ JWRN_EXTRANEOUS_DATA }
'Corrupt JPEG data: %d extraneous bytes before marker $%02x',
{ JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment',
{ JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code',
{ JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d',
{ JWRN_JPEG_EOF } 'Premature end of JPEG file',
{ JWRN_MUST_RESYNC }
'Corrupt JPEG data: found marker $%02x instead of RST%d',
{ JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG',
{ JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines',
{ JMSG_FIRSTADDONCODE } '', { Must be first entry! }
{$ifdef BMP_SUPPORTED}
{ JERR_BMP_BADCMAP } 'Unsupported BMP colormap format',
{ JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported',
{ JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length',
{ JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1',
{ JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB',
{ JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported',
{ JERR_BMP_NOT } 'Not a BMP file - does not start with BM',
{ JTRC_BMP } '%dx%d 24-bit BMP image',
{ JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped BMP image',
{ JTRC_BMP_OS2 } '%dx%d 24-bit OS2 BMP image',
{ JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image',
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
{ JERR_GIF_BUG } 'GIF output got confused',
{ JERR_GIF_CODESIZE } 'Bogus GIF codesize %d',
{ JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB',
{ JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file',
{ JERR_GIF_NOT } 'Not a GIF file',
{ JTRC_GIF } '%dx%dx%d GIF image',
{ JTRC_GIF_BADVERSION }
'Warning: unexpected GIF version number "%c%c%c"',
{ JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x',
{ JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input',
{ JWRN_GIF_BADDATA } 'Corrupt data in GIF file',
{ JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring',
{ JWRN_GIF_ENDCODE } 'Premature end of GIF image',
{ JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits',
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
{ JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB',
{ JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file',
{ JERR_PPM_NOT } 'Not a PPM file',
{ JTRC_PGM } '%dx%d PGM image',
{ JTRC_PGM_TEXT } '%dx%d text PGM image',
{ JTRC_PPM } '%dx%d PPM image',
{ JTRC_PPM_TEXT } '%dx%d text PPM image',
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
{ JERR_RLE_BADERROR } 'Bogus error code from RLE library',
{ JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB',
{ JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE',
{ JERR_RLE_EMPTY } 'Empty RLE file',
{ JERR_RLE_EOF } 'Premature EOF in RLE header',
{ JERR_RLE_MEM } 'Insufficient memory for RLE header',
{ JERR_RLE_NOT } 'Not an RLE file',
{ JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE',
{ JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup',
{ JTRC_RLE } '%dx%d full-color RLE file',
{ JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d',
{ JTRC_RLE_GRAY } '%dx%d grayscale RLE file',
{ JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d',
{ JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d',
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
{ JERR_TGA_BADCMAP } 'Unsupported Targa colormap format',
{ JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file',
{ JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB',
{ JTRC_TGA } '%dx%d RGB Targa image',
{ JTRC_TGA_GRAY } '%dx%d grayscale Targa image',
{ JTRC_TGA_MAPPED } '%dx%d colormapped Targa image',
{$else}
{ JERR_TGA_NOTCOMP } 'Targa support was not compiled',
{$endif} { TARGA_SUPPORTED }
{ JERR_BAD_CMAP_FILE }
'Color map file is invalid or of unsupported format',
{ JERR_TOO_MANY_COLORS }
'Output file format cannot handle %d colormap entries',
{ JERR_UNGETC_FAILED } 'ungetc failed',
{$ifdef TARGA_SUPPORTED}
{ JERR_UNKNOWN_FORMAT }
'Unrecognized input file format --- perhaps you need -targa',
{$else}
{ JERR_UNKNOWN_FORMAT } 'Unrecognized input file format',
{$endif}
{ JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format',
{ JMSG_LASTADDONCODE } '');
implementation
end.
unit imjdeferr;
{ This file defines the error and message codes for the cjpeg/djpeg
applications. These strings are not needed as part of the JPEG library
proper.
Edit this file to add new codes, or to translate the message strings to
some other language. }
{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ To define the enum list of message codes, include this file without
defining macro JMESSAGE. To create a message string table, include it
again with a suitable JMESSAGE definition (see jerror.c for an example). }
{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. }
{ This file contains software version identification. }
const
JVERSION = '6a 7-Feb-96';
JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane';
JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali';
{ Create the message string table.
We do this from the master message list in jerror.h by re-reading
jerror.h with a suitable definition for macro JMESSAGE.
The message table is made an external symbol just in case any applications
want to refer to it directly. }
type
J_MESSAGE_CODE =(
JMSG_NOMESSAGE,
JERR_ARITH_NOTIMPL,
JERR_BAD_ALIGN_TYPE,
JERR_BAD_ALLOC_CHUNK,
JERR_BAD_BUFFER_MODE,
JERR_BAD_COMPONENT_ID,
JERR_BAD_DCT_COEF,
JERR_BAD_DCTSIZE,
JERR_BAD_HUFF_TABLE,
JERR_BAD_IN_COLORSPACE,
JERR_BAD_J_COLORSPACE,
JERR_BAD_LENGTH,
JERR_BAD_LIB_VERSION,
JERR_BAD_MCU_SIZE,
JERR_BAD_POOL_ID,
JERR_BAD_PRECISION,
JERR_BAD_PROGRESSION,
JERR_BAD_PROG_SCRIPT,
JERR_BAD_SAMPLING,
JERR_BAD_SCAN_SCRIPT,
JERR_BAD_STATE,
JERR_BAD_STRUCT_SIZE,
JERR_BAD_VIRTUAL_ACCESS,
JERR_BUFFER_SIZE,
JERR_CANT_SUSPEND,
JERR_CCIR601_NOTIMPL,
JERR_COMPONENT_COUNT,
JERR_CONVERSION_NOTIMPL,
JERR_DAC_INDEX,
JERR_DAC_VALUE,
JERR_DHT_COUNTS,
JERR_DHT_INDEX,
JERR_DQT_INDEX,
JERR_EMPTY_IMAGE,
JERR_EMS_READ,
JERR_EMS_WRITE,
JERR_EOI_EXPECTED,
JERR_FILE_READ,
JERR_FILE_WRITE,
JERR_FRACT_SAMPLE_NOTIMPL,
JERR_HUFF_CLEN_OVERFLOW,
JERR_HUFF_MISSING_CODE,
JERR_IMAGE_TOO_BIG,
JERR_INPUT_EMPTY,
JERR_INPUT_EOF,
JERR_MISMATCHED_QUANT_TABLE,
JERR_MISSING_DATA,
JERR_MODE_CHANGE,
JERR_NOTIMPL,
JERR_NOT_COMPILED,
JERR_NO_BACKING_STORE,
JERR_NO_HUFF_TABLE,
JERR_NO_IMAGE,
JERR_NO_QUANT_TABLE,
JERR_NO_SOI,
JERR_OUT_OF_MEMORY,
JERR_QUANT_COMPONENTS,
JERR_QUANT_FEW_COLORS,
JERR_QUANT_MANY_COLORS,
JERR_SOF_DUPLICATE,
JERR_SOF_NO_SOS,
JERR_SOF_UNSUPPORTED,
JERR_SOI_DUPLICATE,
JERR_SOS_NO_SOF,
JERR_TFILE_CREATE,
JERR_TFILE_READ,
JERR_TFILE_SEEK,
JERR_TFILE_WRITE,
JERR_TOO_LITTLE_DATA,
JERR_UNKNOWN_MARKER,
JERR_VIRTUAL_BUG,
JERR_WIDTH_OVERFLOW,
JERR_XMS_READ,
JERR_XMS_WRITE,
JMSG_COPYRIGHT,
JMSG_VERSION,
JTRC_16BIT_TABLES,
JTRC_ADOBE,
JTRC_APP0,
JTRC_APP14,
JTRC_DAC,
JTRC_DHT,
JTRC_DQT,
JTRC_DRI,
JTRC_EMS_CLOSE,
JTRC_EMS_OPEN,
JTRC_EOI,
JTRC_HUFFBITS,
JTRC_JFIF,
JTRC_JFIF_BADTHUMBNAILSIZE,
JTRC_JFIF_EXTENSION,
JTRC_JFIF_THUMBNAIL,
JTRC_MISC_MARKER,
JTRC_PARMLESS_MARKER,
JTRC_QUANTVALS,
JTRC_QUANT_3_NCOLORS,
JTRC_QUANT_NCOLORS,
JTRC_QUANT_SELECTED,
JTRC_RECOVERY_ACTION,
JTRC_RST,
JTRC_SMOOTH_NOTIMPL,
JTRC_SOF,
JTRC_SOF_COMPONENT,
JTRC_SOI,
JTRC_SOS,
JTRC_SOS_COMPONENT,
JTRC_SOS_PARAMS,
JTRC_TFILE_CLOSE,
JTRC_TFILE_OPEN,
JTRC_THUMB_JPEG,
JTRC_THUMB_PALETTE,
JTRC_THUMB_RGB,
JTRC_UNKNOWN_IDS,
JTRC_XMS_CLOSE,
JTRC_XMS_OPEN,
JWRN_ADOBE_XFORM,
JWRN_BOGUS_PROGRESSION,
JWRN_EXTRANEOUS_DATA,
JWRN_HIT_MARKER,
JWRN_HUFF_BAD_CODE,
JWRN_JFIF_MAJOR,
JWRN_JPEG_EOF,
JWRN_MUST_RESYNC,
JWRN_NOT_SEQUENTIAL,
JWRN_TOO_MUCH_DATA,
JMSG_FIRSTADDONCODE, { Must be first entry! }
{$ifdef BMP_SUPPORTED}
JERR_BMP_BADCMAP, { Unsupported BMP colormap format }
JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported }
JERR_BMP_BADHEADER, { Invalid BMP file: bad header length }
JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 }
JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB }
JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported }
JERR_BMP_NOT, { Not a BMP file - does not start with BM }
JTRC_BMP, { %dx%d 24-bit BMP image }
JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped BMP image }
JTRC_BMP_OS2, { %dx%d 24-bit OS2 BMP image }
JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image }
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
JERR_GIF_BUG, { GIF output got confused }
JERR_GIF_CODESIZE, { Bogus GIF codesize %d }
JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB }
JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file }
JERR_GIF_NOT, { Not a GIF file }
JTRC_GIF, { %dx%dx%d GIF image }
JTRC_GIF_BADVERSION,
{ Warning: unexpected GIF version number '%c%c%c' }
JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x }
JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input }
JWRN_GIF_BADDATA, { Corrupt data in GIF file }
JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring }
JWRN_GIF_ENDCODE, { Premature end of GIF image }
JWRN_GIF_NOMOREDATA, { Ran out of GIF bits }
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB }
JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file }
JERR_PPM_NOT, { Not a PPM file }
JTRC_PGM, { %dx%d PGM image }
JTRC_PGM_TEXT, { %dx%d text PGM image }
JTRC_PPM, { %dx%d PPM image }
JTRC_PPM_TEXT, { %dx%d text PPM image }
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
JERR_RLE_BADERROR, { Bogus error code from RLE library }
JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB }
JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE }
JERR_RLE_EMPTY, { Empty RLE file }
JERR_RLE_EOF, { Premature EOF in RLE header }
JERR_RLE_MEM, { Insufficient memory for RLE header }
JERR_RLE_NOT, { Not an RLE file }
JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE }
JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup }
JTRC_RLE, { %dx%d full-color RLE file }
JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d }
JTRC_RLE_GRAY, { %dx%d grayscale RLE file }
JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d }
JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d }
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
JERR_TGA_BADCMAP, { Unsupported Targa colormap format }
JERR_TGA_BADPARMS, { Invalid or unsupported Targa file }
JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB }
JTRC_TGA, { %dx%d RGB Targa image }
JTRC_TGA_GRAY, { %dx%d grayscale Targa image }
JTRC_TGA_MAPPED, { %dx%d colormapped Targa image }
{$else}
JERR_TGA_NOTCOMP, { Targa support was not compiled }
{$endif} { TARGA_SUPPORTED }
JERR_BAD_CMAP_FILE,
{ Color map file is invalid or of unsupported format }
JERR_TOO_MANY_COLORS,
{ Output file format cannot handle %d colormap entries }
JERR_UNGETC_FAILED, { ungetc failed }
{$ifdef TARGA_SUPPORTED}
JERR_UNKNOWN_FORMAT,
{ Unrecognized input file format --- perhaps you need -targa }
{$else}
JERR_UNKNOWN_FORMAT, { Unrecognized input file format }
{$endif}
JERR_UNSUPPORTED_FORMAT, { Unsupported output file format }
JMSG_LASTADDONCODE
);
const
JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE;
type
msg_table = Array[J_MESSAGE_CODE] of string[80];
const
jpeg_std_message_table : msg_table = (
{ JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! }
{ For maintenance convenience, list is alphabetical by message code name }
{ JERR_ARITH_NOTIMPL }
'Sorry, there are legal restrictions on arithmetic coding',
{ JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix',
{ JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK is wrong, please fix',
{ JERR_BAD_BUFFER_MODE } 'Bogus buffer control mode',
{ JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS',
{ JERR_BAD_DCT_COEF } 'DCT coefficient out of range',
{ JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported',
{ JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition',
{ JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace',
{ JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace',
{ JERR_BAD_LENGTH } 'Bogus marker length',
{ JERR_BAD_LIB_VERSION }
'Wrong JPEG library version: library is %d, caller expects %d',
{ JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan',
{ JERR_BAD_POOL_ID } 'Invalid memory pool code %d',
{ JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d',
{ JERR_BAD_PROGRESSION }
'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d',
{ JERR_BAD_PROG_SCRIPT }
'Invalid progressive parameters at scan script entry %d',
{ JERR_BAD_SAMPLING } 'Bogus sampling factors',
{ JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d',
{ JERR_BAD_STATE } 'Improper call to JPEG library in state %d',
{ JERR_BAD_STRUCT_SIZE }
'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d',
{ JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access',
{ JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small',
{ JERR_CANT_SUSPEND } 'Suspension not allowed here',
{ JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet',
{ JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d',
{ JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request',
{ JERR_DAC_INDEX } 'Bogus DAC index %d',
{ JERR_DAC_VALUE } 'Bogus DAC value $%x',
{ JERR_DHT_COUNTS } 'Bogus DHT counts',
{ JERR_DHT_INDEX } 'Bogus DHT index %d',
{ JERR_DQT_INDEX } 'Bogus DQT index %d',
{ JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)',
{ JERR_EMS_READ } 'Read from EMS failed',
{ JERR_EMS_WRITE } 'Write to EMS failed',
{ JERR_EOI_EXPECTED } 'Didn''t expect more than one scan',
{ JERR_FILE_READ } 'Input file read error',
{ JERR_FILE_WRITE } 'Output file write error --- out of disk space?',
{ JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet',
{ JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow',
{ JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry',
{ JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels',
{ JERR_INPUT_EMPTY } 'Empty input file',
{ JERR_INPUT_EOF } 'Premature end of input file',
{ JERR_MISMATCHED_QUANT_TABLE }
'Cannot transcode due to multiple use of quantization table %d',
{ JERR_MISSING_DATA } 'Scan script does not transmit all data',
{ JERR_MODE_CHANGE } 'Invalid color quantization mode change',
{ JERR_NOTIMPL } 'Not implemented yet',
{ JERR_NOT_COMPILED } 'Requested feature was omitted at compile time',
{ JERR_NO_BACKING_STORE } 'Backing store not supported',
{ JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined',
{ JERR_NO_IMAGE } 'JPEG datastream contains no image',
{ JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined',
{ JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x',
{ JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)',
{ JERR_QUANT_COMPONENTS }
'Cannot quantize more than %d color components',
{ JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors',
{ JERR_QUANT_MANY_COLORS } 'Cannot quantize to more than %d colors',
{ JERR_SOF_DUPLICATE } 'Invalid JPEG file structure: two SOF markers',
{ JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker',
{ JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x',
{ JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers',
{ JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF',
{ JERR_TFILE_CREATE } 'Failed to create temporary file %s',
{ JERR_TFILE_READ } 'Read failed on temporary file',
{ JERR_TFILE_SEEK } 'Seek failed on temporary file',
{ JERR_TFILE_WRITE }
'Write failed on temporary file --- out of disk space?',
{ JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines',
{ JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x',
{ JERR_VIRTUAL_BUG } 'Virtual array controller messed up',
{ JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation',
{ JERR_XMS_READ } 'Read from XMS failed',
{ JERR_XMS_WRITE } 'Write to XMS failed',
{ JMSG_COPYRIGHT } JCOPYRIGHT,
{ JMSG_VERSION } JVERSION,
{ JTRC_16BIT_TABLES }
'Caution: quantization tables are too coarse for baseline JPEG',
{ JTRC_ADOBE }
'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d',
{ JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d',
{ JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d',
{ JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x',
{ JTRC_DHT } 'Define Huffman Table $%02x',
{ JTRC_DQT } 'Define Quantization Table %d precision %d',
{ JTRC_DRI } 'Define Restart Interval %d',
{ JTRC_EMS_CLOSE } 'Freed EMS handle %d',
{ JTRC_EMS_OPEN } 'Obtained EMS handle %d',
{ JTRC_EOI } 'End Of Image',
{ JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d',
{ JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d',
{ JTRC_JFIF_BADTHUMBNAILSIZE }
'Warning: thumbnail image size does not match data length %d',
{ JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u',
{ JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image',
{ JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d',
{ JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x',
{ JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d',
{ JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors',
{ JTRC_QUANT_NCOLORS } 'Quantizing to %d colors',
{ JTRC_QUANT_SELECTED } 'Selected %d colors for quantization',
{ JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d',
{ JTRC_RST } 'RST%d',
{ JTRC_SMOOTH_NOTIMPL }
'Smoothing not supported with nonstandard sampling ratios',
{ JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d',
{ JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d',
{ JTRC_SOI } 'Start of Image',
{ JTRC_SOS } 'Start Of Scan: %d components',
{ JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d',
{ JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d',
{ JTRC_TFILE_CLOSE } 'Closed temporary file %s',
{ JTRC_TFILE_OPEN } 'Opened temporary file %s',
{ JTRC_THUMB_JPEG }
'JFIF extension marker: JPEG-compressed thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_PALETTE }
'JFIF extension marker: palette thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_RGB }
'JFIF extension marker: RGB thumbnail image, length %u',
{ JTRC_UNKNOWN_IDS }
'Unrecognized component IDs %d %d %d, assuming YCbCr',
{ JTRC_XMS_CLOSE } 'Freed XMS handle %d',
{ JTRC_XMS_OPEN } 'Obtained XMS handle %d',
{ JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d',
{ JWRN_BOGUS_PROGRESSION }
'Inconsistent progression sequence for component %d coefficient %d',
{ JWRN_EXTRANEOUS_DATA }
'Corrupt JPEG data: %d extraneous bytes before marker $%02x',
{ JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment',
{ JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code',
{ JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d',
{ JWRN_JPEG_EOF } 'Premature end of JPEG file',
{ JWRN_MUST_RESYNC }
'Corrupt JPEG data: found marker $%02x instead of RST%d',
{ JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG',
{ JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines',
{ JMSG_FIRSTADDONCODE } '', { Must be first entry! }
{$ifdef BMP_SUPPORTED}
{ JERR_BMP_BADCMAP } 'Unsupported BMP colormap format',
{ JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported',
{ JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length',
{ JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1',
{ JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB',
{ JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported',
{ JERR_BMP_NOT } 'Not a BMP file - does not start with BM',
{ JTRC_BMP } '%dx%d 24-bit BMP image',
{ JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped BMP image',
{ JTRC_BMP_OS2 } '%dx%d 24-bit OS2 BMP image',
{ JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image',
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
{ JERR_GIF_BUG } 'GIF output got confused',
{ JERR_GIF_CODESIZE } 'Bogus GIF codesize %d',
{ JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB',
{ JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file',
{ JERR_GIF_NOT } 'Not a GIF file',
{ JTRC_GIF } '%dx%dx%d GIF image',
{ JTRC_GIF_BADVERSION }
'Warning: unexpected GIF version number "%c%c%c"',
{ JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x',
{ JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input',
{ JWRN_GIF_BADDATA } 'Corrupt data in GIF file',
{ JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring',
{ JWRN_GIF_ENDCODE } 'Premature end of GIF image',
{ JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits',
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
{ JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB',
{ JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file',
{ JERR_PPM_NOT } 'Not a PPM file',
{ JTRC_PGM } '%dx%d PGM image',
{ JTRC_PGM_TEXT } '%dx%d text PGM image',
{ JTRC_PPM } '%dx%d PPM image',
{ JTRC_PPM_TEXT } '%dx%d text PPM image',
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
{ JERR_RLE_BADERROR } 'Bogus error code from RLE library',
{ JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB',
{ JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE',
{ JERR_RLE_EMPTY } 'Empty RLE file',
{ JERR_RLE_EOF } 'Premature EOF in RLE header',
{ JERR_RLE_MEM } 'Insufficient memory for RLE header',
{ JERR_RLE_NOT } 'Not an RLE file',
{ JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE',
{ JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup',
{ JTRC_RLE } '%dx%d full-color RLE file',
{ JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d',
{ JTRC_RLE_GRAY } '%dx%d grayscale RLE file',
{ JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d',
{ JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d',
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
{ JERR_TGA_BADCMAP } 'Unsupported Targa colormap format',
{ JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file',
{ JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB',
{ JTRC_TGA } '%dx%d RGB Targa image',
{ JTRC_TGA_GRAY } '%dx%d grayscale Targa image',
{ JTRC_TGA_MAPPED } '%dx%d colormapped Targa image',
{$else}
{ JERR_TGA_NOTCOMP } 'Targa support was not compiled',
{$endif} { TARGA_SUPPORTED }
{ JERR_BAD_CMAP_FILE }
'Color map file is invalid or of unsupported format',
{ JERR_TOO_MANY_COLORS }
'Output file format cannot handle %d colormap entries',
{ JERR_UNGETC_FAILED } 'ungetc failed',
{$ifdef TARGA_SUPPORTED}
{ JERR_UNKNOWN_FORMAT }
'Unrecognized input file format --- perhaps you need -targa',
{$else}
{ JERR_UNKNOWN_FORMAT } 'Unrecognized input file format',
{$endif}
{ JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format',
{ JMSG_LASTADDONCODE } '');
implementation
end.

2408
Imaging/JpegLib/imjdhuff.pas
View File

File diff suppressed because it is too large Load Diff

832
Imaging/JpegLib/imjdinput.pas
View File

@ -1,416 +1,416 @@
unit imjdinput;
{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains input control logic for the JPEG decompressor.
These routines are concerned with controlling the decompressor's input
processing (marker reading and coefficient decoding). The actual input
reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude, imjutils;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
implementation
{ Private state }
type
my_inputctl_ptr = ^my_input_controller;
my_input_controller = record
pub : jpeg_input_controller; { public fields }
inheaders : boolean; { TRUE until first SOS is reached }
end; {my_input_controller;}
{ Forward declarations }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int; forward;
{ Routines to calculate various quantities related to the size of the image. }
{LOCAL}
procedure initial_setup (cinfo : j_decompress_ptr);
{ Called once, when first SOS marker is reached }
var
ci : int;
compptr : jpeg_component_info_ptr;
begin
{ Make sure image isn't bigger than I can handle }
if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or
(long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION));
{ For now, precision must match compiled-in value... }
if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision);
{ Check that number of components won't exceed internal array sizes }
if (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPONENTS);
{ Compute maximum sampling factors; check factor validity }
cinfo^.max_h_samp_factor := 1;
cinfo^.max_v_samp_factor := 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or
(compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING);
{cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor,
compptr^.h_samp_factor);
cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor,
compptr^.v_samp_factor);}
if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then
cinfo^.max_h_samp_factor := compptr^.h_samp_factor;
if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then
cinfo^.max_v_samp_factor := compptr^.v_samp_factor;
Inc(compptr);
end;
{ We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE.
In the full decompressor, this will be overridden by jdmaster.c;
but in the transcoder, jdmaster.c is not used, so we must do it here. }
cinfo^.min_DCT_scaled_size := DCTSIZE;
{ Compute dimensions of components }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
compptr^.DCT_scaled_size := DCTSIZE;
{ Size in DCT blocks }
compptr^.width_in_blocks := JDIMENSION(
jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor),
long(cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.height_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor * DCTSIZE)) );
{ downsampled_width and downsampled_height will also be overridden by
jdmaster.c if we are doing full decompression. The transcoder library
doesn't use these values, but the calling application might. }
{ Size in samples }
compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor),
long (cinfo^.max_h_samp_factor)) );
compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor)) );
{ Mark component needed, until color conversion says otherwise }
compptr^.component_needed := TRUE;
{ Mark no quantization table yet saved for component }
compptr^.quant_table := NIL;
Inc(compptr);
end;
{ Compute number of fully interleaved MCU rows. }
cinfo^.total_iMCU_rows := JDIMENSION(
jdiv_round_up(long(cinfo^.image_height),
long(cinfo^.max_v_samp_factor*DCTSIZE)) );
{ Decide whether file contains multiple scans }
if (cinfo^.comps_in_scan < cinfo^.num_components) or
(cinfo^.progressive_mode) then
cinfo^.inputctl^.has_multiple_scans := TRUE
else
cinfo^.inputctl^.has_multiple_scans := FALSE;
end;
{LOCAL}
procedure per_scan_setup (cinfo : j_decompress_ptr);
{ Do computations that are needed before processing a JPEG scan }
{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker }
var
ci, mcublks, tmp : int;
compptr : jpeg_component_info_ptr;
begin
if (cinfo^.comps_in_scan = 1) then
begin
{ Noninterleaved (single-component) scan }
compptr := cinfo^.cur_comp_info[0];
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := compptr^.width_in_blocks;
cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks;
{ For noninterleaved scan, always one block per MCU }
compptr^.MCU_width := 1;
compptr^.MCU_height := 1;
compptr^.MCU_blocks := 1;
compptr^.MCU_sample_width := compptr^.DCT_scaled_size;
compptr^.last_col_width := 1;
{ For noninterleaved scans, it is convenient to define last_row_height
as the number of block rows present in the last iMCU row. }
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor);
if (tmp = 0) then
tmp := compptr^.v_samp_factor;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
cinfo^.blocks_in_MCU := 1;
cinfo^.MCU_membership[0] := 0;
end
else
begin
{ Interleaved (multi-component) scan }
if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan,
MAX_COMPS_IN_SCAN);
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width),
long (cinfo^.max_h_samp_factor*DCTSIZE)) );
cinfo^.MCU_rows_in_scan := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) );
cinfo^.blocks_in_MCU := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Sampling factors give # of blocks of component in each MCU }
compptr^.MCU_width := compptr^.h_samp_factor;
compptr^.MCU_height := compptr^.v_samp_factor;
compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height;
compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size;
{ Figure number of non-dummy blocks in last MCU column & row }
tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width);
if (tmp = 0) then
tmp := compptr^.MCU_width;
compptr^.last_col_width := tmp;
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height);
if (tmp = 0) then
tmp := compptr^.MCU_height;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
mcublks := compptr^.MCU_blocks;
if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE);
while (mcublks > 0) do
begin
Dec(mcublks);
cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci;
Inc(cinfo^.blocks_in_MCU);
end;
end;
end;
end;
{ Save away a copy of the Q-table referenced by each component present
in the current scan, unless already saved during a prior scan.
In a multiple-scan JPEG file, the encoder could assign different components
the same Q-table slot number, but change table definitions between scans
so that each component uses a different Q-table. (The IJG encoder is not
currently capable of doing this, but other encoders might.) Since we want
to be able to dequantize all the components at the end of the file, this
means that we have to save away the table actually used for each component.
We do this by copying the table at the start of the first scan containing
the component.
The JPEG spec prohibits the encoder from changing the contents of a Q-table
slot between scans of a component using that slot. If the encoder does so
anyway, this decoder will simply use the Q-table values that were current
at the start of the first scan for the component.
The decompressor output side looks only at the saved quant tables,
not at the current Q-table slots. }
{LOCAL}
procedure latch_quant_tables (cinfo : j_decompress_ptr);
var
ci, qtblno : int;
compptr : jpeg_component_info_ptr;
qtbl : JQUANT_TBL_PTR;
begin
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ No work if we already saved Q-table for this component }
if (compptr^.quant_table <> NIL) then
continue;
{ Make sure specified quantization table is present }
qtblno := compptr^.quant_tbl_no;
if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or
(cinfo^.quant_tbl_ptrs[qtblno] = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno);
{ OK, save away the quantization table }
qtbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(JQUANT_TBL)) );
MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL));
compptr^.quant_table := qtbl;
end;
end;
{ Initialize the input modules to read a scan of compressed data.
The first call to this is done by jdmaster.c after initializing
the entire decompressor (during jpeg_start_decompress).
Subsequent calls come from consume_markers, below. }
{METHODDEF}
procedure start_input_pass (cinfo : j_decompress_ptr);
begin
per_scan_setup(cinfo);
latch_quant_tables(cinfo);
cinfo^.entropy^.start_pass (cinfo);
cinfo^.coef^.start_input_pass (cinfo);
cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data;
end;
{ Finish up after inputting a compressed-data scan.
This is called by the coefficient controller after it's read all
the expected data of the scan. }
{METHODDEF}
procedure finish_input_pass (cinfo : j_decompress_ptr);
begin
cinfo^.inputctl^.consume_input := consume_markers;
end;
{ Read JPEG markers before, between, or after compressed-data scans.
Change state as necessary when a new scan is reached.
Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI.
The consume_input method pointer points either here or to the
coefficient controller's consume_data routine, depending on whether
we are reading a compressed data segment or inter-segment markers. }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int;
var
val : int;
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further }
begin
consume_markers := JPEG_REACHED_EOI;
exit;
end;
val := cinfo^.marker^.read_markers (cinfo);
case (val) of
JPEG_REACHED_SOS: { Found SOS }
begin
if (inputctl^.inheaders) then
begin { 1st SOS }
initial_setup(cinfo);
inputctl^.inheaders := FALSE;
{ Note: start_input_pass must be called by jdmaster.c
before any more input can be consumed. jdapimin.c is
responsible for enforcing this sequencing. }
end
else
begin { 2nd or later SOS marker }
if (not inputctl^.pub.has_multiple_scans) then
ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! }
start_input_pass(cinfo);
end;
end;
JPEG_REACHED_EOI: { Found EOI }
begin
inputctl^.pub.eoi_reached := TRUE;
if (inputctl^.inheaders) then
begin { Tables-only datastream, apparently }
if (cinfo^.marker^.saw_SOF) then
ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS);
end
else
begin
{ Prevent infinite loop in coef ctlr's decompress_data routine
if user set output_scan_number larger than number of scans. }
if (cinfo^.output_scan_number > cinfo^.input_scan_number) then
cinfo^.output_scan_number := cinfo^.input_scan_number;
end;
end;
JPEG_SUSPENDED:;
end;
consume_markers := val;
end;
{ Reset state to begin a fresh datastream. }
{METHODDEF}
procedure reset_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
{ Reset other modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.marker^.reset_marker_reader (cinfo);
{ Reset progression state -- would be cleaner if entropy decoder did this }
cinfo^.coef_bits := NIL;
end;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
{ Create subobject in permanent pool }
inputctl := my_inputctl_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
SIZEOF(my_input_controller)) );
cinfo^.inputctl := jpeg_input_controller_ptr(inputctl);
{ Initialize method pointers }
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.reset_input_controller := reset_input_controller;
inputctl^.pub.start_input_pass := start_input_pass;
inputctl^.pub.finish_input_pass := finish_input_pass;
{ Initialize state: can't use reset_input_controller since we don't
want to try to reset other modules yet. }
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
end;
end.
unit imjdinput;
{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains input control logic for the JPEG decompressor.
These routines are concerned with controlling the decompressor's input
processing (marker reading and coefficient decoding). The actual input
reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude, imjutils;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
implementation
{ Private state }
type
my_inputctl_ptr = ^my_input_controller;
my_input_controller = record
pub : jpeg_input_controller; { public fields }
inheaders : boolean; { TRUE until first SOS is reached }
end; {my_input_controller;}
{ Forward declarations }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int; forward;
{ Routines to calculate various quantities related to the size of the image. }
{LOCAL}
procedure initial_setup (cinfo : j_decompress_ptr);
{ Called once, when first SOS marker is reached }
var
ci : int;
compptr : jpeg_component_info_ptr;
begin
{ Make sure image isn't bigger than I can handle }
if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or
(long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION));
{ For now, precision must match compiled-in value... }
if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision);
{ Check that number of components won't exceed internal array sizes }
if (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPONENTS);
{ Compute maximum sampling factors; check factor validity }
cinfo^.max_h_samp_factor := 1;
cinfo^.max_v_samp_factor := 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or
(compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING);
{cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor,
compptr^.h_samp_factor);
cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor,
compptr^.v_samp_factor);}
if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then
cinfo^.max_h_samp_factor := compptr^.h_samp_factor;
if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then
cinfo^.max_v_samp_factor := compptr^.v_samp_factor;
Inc(compptr);
end;
{ We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE.
In the full decompressor, this will be overridden by jdmaster.c;
but in the transcoder, jdmaster.c is not used, so we must do it here. }
cinfo^.min_DCT_scaled_size := DCTSIZE;
{ Compute dimensions of components }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
compptr^.DCT_scaled_size := DCTSIZE;
{ Size in DCT blocks }
compptr^.width_in_blocks := JDIMENSION(
jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor),
long(cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.height_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor * DCTSIZE)) );
{ downsampled_width and downsampled_height will also be overridden by
jdmaster.c if we are doing full decompression. The transcoder library
doesn't use these values, but the calling application might. }
{ Size in samples }
compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor),
long (cinfo^.max_h_samp_factor)) );
compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor)) );
{ Mark component needed, until color conversion says otherwise }
compptr^.component_needed := TRUE;
{ Mark no quantization table yet saved for component }
compptr^.quant_table := NIL;
Inc(compptr);
end;
{ Compute number of fully interleaved MCU rows. }
cinfo^.total_iMCU_rows := JDIMENSION(
jdiv_round_up(long(cinfo^.image_height),
long(cinfo^.max_v_samp_factor*DCTSIZE)) );
{ Decide whether file contains multiple scans }
if (cinfo^.comps_in_scan < cinfo^.num_components) or
(cinfo^.progressive_mode) then
cinfo^.inputctl^.has_multiple_scans := TRUE
else
cinfo^.inputctl^.has_multiple_scans := FALSE;
end;
{LOCAL}
procedure per_scan_setup (cinfo : j_decompress_ptr);
{ Do computations that are needed before processing a JPEG scan }
{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker }
var
ci, mcublks, tmp : int;
compptr : jpeg_component_info_ptr;
begin
if (cinfo^.comps_in_scan = 1) then
begin
{ Noninterleaved (single-component) scan }
compptr := cinfo^.cur_comp_info[0];
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := compptr^.width_in_blocks;
cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks;
{ For noninterleaved scan, always one block per MCU }
compptr^.MCU_width := 1;
compptr^.MCU_height := 1;
compptr^.MCU_blocks := 1;
compptr^.MCU_sample_width := compptr^.DCT_scaled_size;
compptr^.last_col_width := 1;
{ For noninterleaved scans, it is convenient to define last_row_height
as the number of block rows present in the last iMCU row. }
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor);
if (tmp = 0) then
tmp := compptr^.v_samp_factor;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
cinfo^.blocks_in_MCU := 1;
cinfo^.MCU_membership[0] := 0;
end
else
begin
{ Interleaved (multi-component) scan }
if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan,
MAX_COMPS_IN_SCAN);
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width),
long (cinfo^.max_h_samp_factor*DCTSIZE)) );
cinfo^.MCU_rows_in_scan := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) );
cinfo^.blocks_in_MCU := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Sampling factors give # of blocks of component in each MCU }
compptr^.MCU_width := compptr^.h_samp_factor;
compptr^.MCU_height := compptr^.v_samp_factor;
compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height;
compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size;
{ Figure number of non-dummy blocks in last MCU column & row }
tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width);
if (tmp = 0) then
tmp := compptr^.MCU_width;
compptr^.last_col_width := tmp;
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height);
if (tmp = 0) then
tmp := compptr^.MCU_height;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
mcublks := compptr^.MCU_blocks;
if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE);
while (mcublks > 0) do
begin
Dec(mcublks);
cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci;
Inc(cinfo^.blocks_in_MCU);
end;
end;
end;
end;
{ Save away a copy of the Q-table referenced by each component present
in the current scan, unless already saved during a prior scan.
In a multiple-scan JPEG file, the encoder could assign different components
the same Q-table slot number, but change table definitions between scans
so that each component uses a different Q-table. (The IJG encoder is not
currently capable of doing this, but other encoders might.) Since we want
to be able to dequantize all the components at the end of the file, this
means that we have to save away the table actually used for each component.
We do this by copying the table at the start of the first scan containing
the component.
The JPEG spec prohibits the encoder from changing the contents of a Q-table
slot between scans of a component using that slot. If the encoder does so
anyway, this decoder will simply use the Q-table values that were current
at the start of the first scan for the component.
The decompressor output side looks only at the saved quant tables,
not at the current Q-table slots. }
{LOCAL}
procedure latch_quant_tables (cinfo : j_decompress_ptr);
var
ci, qtblno : int;
compptr : jpeg_component_info_ptr;
qtbl : JQUANT_TBL_PTR;
begin
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ No work if we already saved Q-table for this component }
if (compptr^.quant_table <> NIL) then
continue;
{ Make sure specified quantization table is present }
qtblno := compptr^.quant_tbl_no;
if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or
(cinfo^.quant_tbl_ptrs[qtblno] = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno);
{ OK, save away the quantization table }
qtbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(JQUANT_TBL)) );
MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL));
compptr^.quant_table := qtbl;
end;
end;
{ Initialize the input modules to read a scan of compressed data.
The first call to this is done by jdmaster.c after initializing
the entire decompressor (during jpeg_start_decompress).
Subsequent calls come from consume_markers, below. }
{METHODDEF}
procedure start_input_pass (cinfo : j_decompress_ptr);
begin
per_scan_setup(cinfo);
latch_quant_tables(cinfo);
cinfo^.entropy^.start_pass (cinfo);
cinfo^.coef^.start_input_pass (cinfo);
cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data;
end;
{ Finish up after inputting a compressed-data scan.
This is called by the coefficient controller after it's read all
the expected data of the scan. }
{METHODDEF}
procedure finish_input_pass (cinfo : j_decompress_ptr);
begin
cinfo^.inputctl^.consume_input := consume_markers;
end;
{ Read JPEG markers before, between, or after compressed-data scans.
Change state as necessary when a new scan is reached.
Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI.
The consume_input method pointer points either here or to the
coefficient controller's consume_data routine, depending on whether
we are reading a compressed data segment or inter-segment markers. }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int;
var
val : int;
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further }
begin
consume_markers := JPEG_REACHED_EOI;
exit;
end;
val := cinfo^.marker^.read_markers (cinfo);
case (val) of
JPEG_REACHED_SOS: { Found SOS }
begin
if (inputctl^.inheaders) then
begin { 1st SOS }
initial_setup(cinfo);
inputctl^.inheaders := FALSE;
{ Note: start_input_pass must be called by jdmaster.c
before any more input can be consumed. jdapimin.c is
responsible for enforcing this sequencing. }
end
else
begin { 2nd or later SOS marker }
if (not inputctl^.pub.has_multiple_scans) then
ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! }
start_input_pass(cinfo);
end;
end;
JPEG_REACHED_EOI: { Found EOI }
begin
inputctl^.pub.eoi_reached := TRUE;
if (inputctl^.inheaders) then
begin { Tables-only datastream, apparently }
if (cinfo^.marker^.saw_SOF) then
ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS);
end
else
begin
{ Prevent infinite loop in coef ctlr's decompress_data routine
if user set output_scan_number larger than number of scans. }
if (cinfo^.output_scan_number > cinfo^.input_scan_number) then
cinfo^.output_scan_number := cinfo^.input_scan_number;
end;
end;
JPEG_SUSPENDED:;
end;
consume_markers := val;
end;
{ Reset state to begin a fresh datastream. }
{METHODDEF}
procedure reset_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
{ Reset other modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.marker^.reset_marker_reader (cinfo);
{ Reset progression state -- would be cleaner if entropy decoder did this }
cinfo^.coef_bits := NIL;
end;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
{ Create subobject in permanent pool }
inputctl := my_inputctl_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
SIZEOF(my_input_controller)) );
cinfo^.inputctl := jpeg_input_controller_ptr(inputctl);
{ Initialize method pointers }
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.reset_input_controller := reset_input_controller;
inputctl^.pub.start_input_pass := start_input_pass;
inputctl^.pub.finish_input_pass := finish_input_pass;
{ Initialize state: can't use reset_input_controller since we don't
want to try to reset other modules yet. }
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
end;
end.

1220
Imaging/JpegLib/imjdmainct.pas
View File

File diff suppressed because it is too large Load Diff

1358
Imaging/JpegLib/imjdmaster.pas
View File

File diff suppressed because it is too large Load Diff

1028
Imaging/JpegLib/imjdmerge.pas
View File

File diff suppressed because it is too large Load Diff

2122
Imaging/JpegLib/imjdphuff.pas
View File

File diff suppressed because it is too large Load Diff

682
Imaging/JpegLib/imjdpostct.pas
View File

@ -1,341 +1,341 @@
unit imjdpostct;
{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the decompression postprocessing controller.
This controller manages the upsampling, color conversion, and color
quantization/reduction steps; specifically, it controls the buffering
between upsample/color conversion and color quantization/reduction.
If no color quantization/reduction is required, then this module has no
work to do, and it just hands off to the upsample/color conversion code.
An integrated upsample/convert/quantize process would replace this module
entirely. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjutils,
imjpeglib;
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_post_ptr = ^my_post_controller;
my_post_controller = record
pub : jpeg_d_post_controller; { public fields }
{ Color quantization source buffer: this holds output data from
the upsample/color conversion step to be passed to the quantizer.
For two-pass color quantization, we need a full-image buffer;
for one-pass operation, a strip buffer is sufficient. }
whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass }
buffer : JSAMPARRAY; { strip buffer, or current strip of virtual }
strip_height : JDIMENSION; { buffer size in rows }
{ for two-pass mode only: }
starting_row : JDIMENSION; { row # of first row in current strip }
next_row : JDIMENSION; { index of next row to fill/empty in strip }
end;
{ Forward declarations }
{METHODDEF}
procedure post_process_1pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF}
procedure post_process_prepass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{METHODDEF}
procedure post_process_2pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_dpost (cinfo : j_decompress_ptr;
pass_mode : J_BUF_MODE);
var
post : my_post_ptr;
begin
post := my_post_ptr(cinfo^.post);
case (pass_mode) of
JBUF_PASS_THRU:
if (cinfo^.quantize_colors) then
begin
{ Single-pass processing with color quantization. }
post^.pub.post_process_data := post_process_1pass;
{ We could be doing buffered-image output before starting a 2-pass
color quantization; in that case, jinit_d_post_controller did not
allocate a strip buffer. Use the virtual-array buffer as workspace. }
if (post^.buffer = NIL) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
JDIMENSION(0), post^.strip_height, TRUE);
end;
end
else
begin
{ For single-pass processing without color quantization,
I have no work to do; just call the upsampler directly. }
post^.pub.post_process_data := cinfo^.upsample^.upsample;
end;
{$ifdef QUANT_2PASS_SUPPORTED}
JBUF_SAVE_AND_PASS:
begin
{ First pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_prepass;
end;
JBUF_CRANK_DEST:
begin
{ Second pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_2pass;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
post^.next_row := 0;
post^.starting_row := 0;
end;
{ Process some data in the one-pass (strip buffer) case.
This is used for color precision reduction as well as one-pass quantization. }
{METHODDEF}
procedure post_process_1pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr (cinfo^.post);
{ Fill the buffer, but not more than what we can dump out in one go. }
{ Note we rely on the upsampler to detect bottom of image. }
max_rows := out_rows_avail - out_row_ctr;
if (max_rows > post^.strip_height) then
max_rows := post^.strip_height;
num_rows := 0;
cinfo^.upsample^.upsample (cinfo,
input_buf,
in_row_group_ctr,
in_row_groups_avail,
post^.buffer,
num_rows, { var }
max_rows);
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
post^.buffer,
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{$ifdef QUANT_2PASS_SUPPORTED}
{ Process some data in the first pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_prepass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail:JDIMENSION);
var
post : my_post_ptr;
old_next_row, num_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, TRUE);
end;
{ Upsample some data (up to a strip height's worth). }
old_next_row := post^.next_row;
cinfo^.upsample^.upsample (cinfo,
input_buf, in_row_group_ctr, in_row_groups_avail,
post^.buffer, post^.next_row, post^.strip_height);
{ Allow quantizer to scan new data. No data is emitted, }
{ but we advance out_row_ctr so outer loop can tell when we're done. }
if (post^.next_row > old_next_row) then
begin
num_rows := post^.next_row - old_next_row;
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[old_next_row]),
JSAMPARRAY(NIL),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{ Advance if we filled the strip. }
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{ Process some data in the second pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_2pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, FALSE);
end;
{ Determine number of rows to emit. }
num_rows := post^.strip_height - post^.next_row; { available in strip }
max_rows := out_rows_avail - out_row_ctr; { available in output area }
if (num_rows > max_rows) then
num_rows := max_rows;
{ We have to check bottom of image here, can't depend on upsampler. }
max_rows := cinfo^.output_height - post^.starting_row;
if (num_rows > max_rows) then
num_rows := max_rows;
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[post^.next_row]),
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
{ Advance if we filled the strip. }
Inc(post^.next_row, num_rows);
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
var
post : my_post_ptr;
begin
post := my_post_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_post_controller)) );
cinfo^.post := jpeg_d_post_controller_ptr (post);
post^.pub.start_pass := start_pass_dpost;
post^.whole_image := NIL; { flag for no virtual arrays }
post^.buffer := NIL; { flag for no strip buffer }
{ Create the quantization buffer, if needed }
if (cinfo^.quantize_colors) then
begin
{ The buffer strip height is max_v_samp_factor, which is typically
an efficient number of rows for upsampling to return.
(In the presence of output rescaling, we might want to be smarter?) }
post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor);
if (need_full_buffer) then
begin
{ Two-pass color quantization: need full-image storage. }
{ We round up the number of rows to a multiple of the strip height. }
{$ifdef QUANT_2PASS_SUPPORTED}
post^.whole_image := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
JDIMENSION (jround_up( long(cinfo^.output_height),
long(post^.strip_height)) ),
post^.strip_height);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} { QUANT_2PASS_SUPPORTED }
end
else
begin
{ One-pass color quantization: just make a strip buffer. }
post^.buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr (cinfo), JPOOL_IMAGE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
post^.strip_height);
end;
end;
end;
end.
unit imjdpostct;
{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the decompression postprocessing controller.
This controller manages the upsampling, color conversion, and color
quantization/reduction steps; specifically, it controls the buffering
between upsample/color conversion and color quantization/reduction.
If no color quantization/reduction is required, then this module has no
work to do, and it just hands off to the upsample/color conversion code.
An integrated upsample/convert/quantize process would replace this module
entirely. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjutils,
imjpeglib;
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_post_ptr = ^my_post_controller;
my_post_controller = record
pub : jpeg_d_post_controller; { public fields }
{ Color quantization source buffer: this holds output data from
the upsample/color conversion step to be passed to the quantizer.
For two-pass color quantization, we need a full-image buffer;
for one-pass operation, a strip buffer is sufficient. }
whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass }
buffer : JSAMPARRAY; { strip buffer, or current strip of virtual }
strip_height : JDIMENSION; { buffer size in rows }
{ for two-pass mode only: }
starting_row : JDIMENSION; { row # of first row in current strip }
next_row : JDIMENSION; { index of next row to fill/empty in strip }
end;
{ Forward declarations }
{METHODDEF}
procedure post_process_1pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF}
procedure post_process_prepass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{METHODDEF}
procedure post_process_2pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_dpost (cinfo : j_decompress_ptr;
pass_mode : J_BUF_MODE);
var
post : my_post_ptr;
begin
post := my_post_ptr(cinfo^.post);
case (pass_mode) of
JBUF_PASS_THRU:
if (cinfo^.quantize_colors) then
begin
{ Single-pass processing with color quantization. }
post^.pub.post_process_data := post_process_1pass;
{ We could be doing buffered-image output before starting a 2-pass
color quantization; in that case, jinit_d_post_controller did not
allocate a strip buffer. Use the virtual-array buffer as workspace. }
if (post^.buffer = NIL) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
JDIMENSION(0), post^.strip_height, TRUE);
end;
end
else
begin
{ For single-pass processing without color quantization,
I have no work to do; just call the upsampler directly. }
post^.pub.post_process_data := cinfo^.upsample^.upsample;
end;
{$ifdef QUANT_2PASS_SUPPORTED}
JBUF_SAVE_AND_PASS:
begin
{ First pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_prepass;
end;
JBUF_CRANK_DEST:
begin
{ Second pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_2pass;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
post^.next_row := 0;
post^.starting_row := 0;
end;
{ Process some data in the one-pass (strip buffer) case.
This is used for color precision reduction as well as one-pass quantization. }
{METHODDEF}
procedure post_process_1pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr (cinfo^.post);
{ Fill the buffer, but not more than what we can dump out in one go. }
{ Note we rely on the upsampler to detect bottom of image. }
max_rows := out_rows_avail - out_row_ctr;
if (max_rows > post^.strip_height) then
max_rows := post^.strip_height;
num_rows := 0;
cinfo^.upsample^.upsample (cinfo,
input_buf,
in_row_group_ctr,
in_row_groups_avail,
post^.buffer,
num_rows, { var }
max_rows);
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
post^.buffer,
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{$ifdef QUANT_2PASS_SUPPORTED}
{ Process some data in the first pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_prepass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail:JDIMENSION);
var
post : my_post_ptr;
old_next_row, num_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, TRUE);
end;
{ Upsample some data (up to a strip height's worth). }
old_next_row := post^.next_row;
cinfo^.upsample^.upsample (cinfo,
input_buf, in_row_group_ctr, in_row_groups_avail,
post^.buffer, post^.next_row, post^.strip_height);
{ Allow quantizer to scan new data. No data is emitted, }
{ but we advance out_row_ctr so outer loop can tell when we're done. }
if (post^.next_row > old_next_row) then
begin
num_rows := post^.next_row - old_next_row;
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[old_next_row]),
JSAMPARRAY(NIL),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{ Advance if we filled the strip. }
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{ Process some data in the second pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_2pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, FALSE);
end;
{ Determine number of rows to emit. }
num_rows := post^.strip_height - post^.next_row; { available in strip }
max_rows := out_rows_avail - out_row_ctr; { available in output area }
if (num_rows > max_rows) then
num_rows := max_rows;
{ We have to check bottom of image here, can't depend on upsampler. }
max_rows := cinfo^.output_height - post^.starting_row;
if (num_rows > max_rows) then
num_rows := max_rows;
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[post^.next_row]),
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
{ Advance if we filled the strip. }
Inc(post^.next_row, num_rows);
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
var
post : my_post_ptr;
begin
post := my_post_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_post_controller)) );
cinfo^.post := jpeg_d_post_controller_ptr (post);
post^.pub.start_pass := start_pass_dpost;
post^.whole_image := NIL; { flag for no virtual arrays }
post^.buffer := NIL; { flag for no strip buffer }
{ Create the quantization buffer, if needed }
if (cinfo^.quantize_colors) then
begin
{ The buffer strip height is max_v_samp_factor, which is typically
an efficient number of rows for upsampling to return.
(In the presence of output rescaling, we might want to be smarter?) }
post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor);
if (need_full_buffer) then
begin
{ Two-pass color quantization: need full-image storage. }
{ We round up the number of rows to a multiple of the strip height. }
{$ifdef QUANT_2PASS_SUPPORTED}
post^.whole_image := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
JDIMENSION (jround_up( long(cinfo^.output_height),
long(post^.strip_height)) ),
post^.strip_height);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} { QUANT_2PASS_SUPPORTED }
end
else
begin
{ One-pass color quantization: just make a strip buffer. }
post^.buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr (cinfo), JPOOL_IMAGE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
post^.strip_height);
end;
end;
end;
end.

1184
Imaging/JpegLib/imjdsample.pas
View File

File diff suppressed because it is too large Load Diff

924
Imaging/JpegLib/imjerror.pas
View File

@ -1,462 +1,462 @@
unit imjerror;
{ This file contains simple error-reporting and trace-message routines.
These are suitable for Unix-like systems and others where writing to
stderr is the right thing to do. Many applications will want to replace
some or all of these routines.
These routines are used by both the compression and decompression code. }
{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. }
{ note: format_message still contains a hack }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjdeferr,
imjpeglib;
{
jversion;
}
const
EXIT_FAILURE = 1; { define halt() codes if not provided }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int);
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
implementation
{ How to format a message string, in format_message() ? }
{$IFDEF OS2}
{$DEFINE NO_FORMAT}
{$ENDIF}
{$IFDEF FPC}
{$DEFINE NO_FORMAT}
{$ENDIF}
uses
{$IFNDEF NO_FORMAT}
{$IFDEF VER70}
drivers, { Turbo Vision unit with FormatStr }
{$ELSE}
sysutils, { Delphi Unit with Format() }
{$ENDIF}
{$ENDIF}
imjcomapi;
{ Error exit handler: must not return to caller.
Applications may override this if they want to get control back after
an error. Typically one would longjmp somewhere instead of exiting.
The setjmp buffer can be made a private field within an expanded error
handler object. Note that the info needed to generate an error message
is stored in the error object, so you can generate the message now or
later, at your convenience.
You should make sure that the JPEG object is cleaned up (with jpeg_abort
or jpeg_destroy) at some point. }
{METHODDEF}
procedure error_exit (cinfo : j_common_ptr);
begin
{ Always display the message }
cinfo^.err^.output_message(cinfo);
{ Let the memory manager delete any temp files before we die }
jpeg_destroy(cinfo);
halt(EXIT_FAILURE);
end;
{ Actual output of an error or trace message.
Applications may override this method to send JPEG messages somewhere
other than stderr. }
{ Macros to simplify using the error and trace message stuff }
{ The first parameter is either type of cinfo pointer }
{ Fatal errors (print message and exit) }
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.error_exit(cinfo);
end;
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.msg_parm.i[3] := p4;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
cinfo^.err^.error_exit (cinfo);
end;
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, -1);
end;
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, -1);
end;
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, -1);
end;
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, lvl);
end;
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
var
_mp : ^int8array;
begin
_mp := @cinfo^.err^.msg_parm.i;
_mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3;
_mp^[3] := p4; _mp^[5] := p5;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
_mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
cinfo^.err^.emit_message (cinfo, lvl);
end;
{METHODDEF}
procedure output_message (cinfo : j_common_ptr);
var
buffer : string; {[JMSG_LENGTH_MAX];}
begin
{ Create the message }
cinfo^.err^.format_message (cinfo, buffer);
{ Send it to stderr, adding a newline }
WriteLn(output, buffer);
end;
{ Decide whether to emit a trace or warning message.
msg_level is one of:
-1: recoverable corrupt-data warning, may want to abort.
0: important advisory messages (always display to user).
1: first level of tracing detail.
2,3,...: successively more detailed tracing messages.
An application might override this method if it wanted to abort on warnings
or change the policy about which messages to display. }
{METHODDEF}
procedure emit_message (cinfo : j_common_ptr; msg_level : int);
var
err : jpeg_error_mgr_ptr;
begin
err := cinfo^.err;
if (msg_level < 0) then
begin
{ It's a warning message. Since corrupt files may generate many warnings,
the policy implemented here is to show only the first warning,
unless trace_level >= 3. }
if (err^.num_warnings = 0) or (err^.trace_level >= 3) then
err^.output_message(cinfo);
{ Always count warnings in num_warnings. }
Inc( err^.num_warnings );
end
else
begin
{ It's a trace message. Show it if trace_level >= msg_level. }
if (err^.trace_level >= msg_level) then
err^.output_message (cinfo);
end;
end;
{ Format a message string for the most recent JPEG error or message.
The message is stored into buffer, which should be at least JMSG_LENGTH_MAX
characters. Note that no '\n' character is added to the string.
Few applications should need to override this method. }
{METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string);
var
err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE;
msgtext : string;
isstring : boolean;
begin
err := cinfo^.err;
msg_code := J_MESSAGE_CODE(err^.msg_code);
msgtext := '';
{ Look up message string in proper table }
if (msg_code > JMSG_NOMESSAGE)
and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then
begin
msgtext := err^.jpeg_message_table^[msg_code];
end
else
if (err^.addon_message_table <> NIL) and
(msg_code >= err^.first_addon_message) and
(msg_code <= err^.last_addon_message) then
begin
msgtext := err^.addon_message_table^[J_MESSAGE_CODE
(ord(msg_code) - ord(err^.first_addon_message))];
end;
{ Defend against bogus message number }
if (msgtext = '') then
begin
err^.msg_parm.i[0] := int(msg_code);
msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE];
end;
{ Check for string parameter, as indicated by %s in the message text }
isstring := Pos('%s', msgtext) > 0;
{ Format the message into the passed buffer }
if (isstring) then
buffer := Concat(msgtext, err^.msg_parm.s)
else
begin
{$IFDEF VER70}
FormatStr(buffer, msgtext, err^.msg_parm.i);
{$ELSE}
{$IFDEF NO_FORMAT}
buffer := msgtext;
{$ELSE}
buffer := Format(msgtext, [
err^.msg_parm.i[0], err^.msg_parm.i[1],
err^.msg_parm.i[2], err^.msg_parm.i[3],
err^.msg_parm.i[4], err^.msg_parm.i[5],
err^.msg_parm.i[6], err^.msg_parm.i[7] ]);
{$ENDIF}
{$ENDIF}
end;
end;
{ Reset error state variables at start of a new image.
This is called during compression startup to reset trace/error
processing to default state, without losing any application-specific
method pointers. An application might possibly want to override
this method if it has additional error processing state. }
{METHODDEF}
procedure reset_error_mgr (cinfo : j_common_ptr);
begin
cinfo^.err^.num_warnings := 0;
{ trace_level is not reset since it is an application-supplied parameter }
cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" }
end;
{ Fill in the standard error-handling methods in a jpeg_error_mgr object.
Typical call is:
cinfo : jpeg_compress_struct;
err : jpeg_error_mgr;
cinfo.err := jpeg_std_error(@err);
after which the application may override some of the methods. }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
begin
err.error_exit := error_exit;
err.emit_message := emit_message;
err.output_message := output_message;
err.format_message := format_message;
err.reset_error_mgr := reset_error_mgr;
err.trace_level := 0; { default := no tracing }
err.num_warnings := 0; { no warnings emitted yet }
err.msg_code := 0; { may be useful as a flag for "no error" }
{ Initialize message table pointers }
err.jpeg_message_table := @jpeg_std_message_table;
err.last_jpeg_message := pred(JMSG_LASTMSGCODE);
err.addon_message_table := NIL;
err.first_addon_message := JMSG_NOMESSAGE; { for safety }
err.last_addon_message := JMSG_NOMESSAGE;
jpeg_std_error := @err;
end;
end.
unit imjerror;
{ This file contains simple error-reporting and trace-message routines.
These are suitable for Unix-like systems and others where writing to
stderr is the right thing to do. Many applications will want to replace
some or all of these routines.
These routines are used by both the compression and decompression code. }
{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. }
{ note: format_message still contains a hack }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjdeferr,
imjpeglib;
{
jversion;
}
const
EXIT_FAILURE = 1; { define halt() codes if not provided }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int);
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
implementation
{ How to format a message string, in format_message() ? }
{$IFDEF OS2}
{$DEFINE NO_FORMAT}
{$ENDIF}
{$IFDEF FPC}
{$DEFINE NO_FORMAT}
{$ENDIF}
uses
{$IFNDEF NO_FORMAT}
{$IFDEF VER70}
drivers, { Turbo Vision unit with FormatStr }
{$ELSE}
sysutils, { Delphi Unit with Format() }
{$ENDIF}
{$ENDIF}
imjcomapi;
{ Error exit handler: must not return to caller.
Applications may override this if they want to get control back after
an error. Typically one would longjmp somewhere instead of exiting.
The setjmp buffer can be made a private field within an expanded error
handler object. Note that the info needed to generate an error message
is stored in the error object, so you can generate the message now or
later, at your convenience.
You should make sure that the JPEG object is cleaned up (with jpeg_abort
or jpeg_destroy) at some point. }
{METHODDEF}
procedure error_exit (cinfo : j_common_ptr);
begin
{ Always display the message }
cinfo^.err^.output_message(cinfo);
{ Let the memory manager delete any temp files before we die }
jpeg_destroy(cinfo);
halt(EXIT_FAILURE);
end;
{ Actual output of an error or trace message.
Applications may override this method to send JPEG messages somewhere
other than stderr. }
{ Macros to simplify using the error and trace message stuff }
{ The first parameter is either type of cinfo pointer }
{ Fatal errors (print message and exit) }
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.error_exit(cinfo);
end;
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.msg_parm.i[3] := p4;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
cinfo^.err^.error_exit (cinfo);
end;
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, -1);
end;
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, -1);
end;
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, -1);
end;
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, lvl);
end;
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
var
_mp : ^int8array;
begin
_mp := @cinfo^.err^.msg_parm.i;
_mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3;
_mp^[3] := p4; _mp^[5] := p5;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
_mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
cinfo^.err^.emit_message (cinfo, lvl);
end;
{METHODDEF}
procedure output_message (cinfo : j_common_ptr);
var
buffer : string; {[JMSG_LENGTH_MAX];}
begin
{ Create the message }
cinfo^.err^.format_message (cinfo, buffer);
{ Send it to stderr, adding a newline }
WriteLn(output, buffer);
end;
{ Decide whether to emit a trace or warning message.
msg_level is one of:
-1: recoverable corrupt-data warning, may want to abort.
0: important advisory messages (always display to user).
1: first level of tracing detail.
2,3,...: successively more detailed tracing messages.
An application might override this method if it wanted to abort on warnings
or change the policy about which messages to display. }
{METHODDEF}
procedure emit_message (cinfo : j_common_ptr; msg_level : int);
var
err : jpeg_error_mgr_ptr;
begin
err := cinfo^.err;
if (msg_level < 0) then
begin
{ It's a warning message. Since corrupt files may generate many warnings,
the policy implemented here is to show only the first warning,
unless trace_level >= 3. }
if (err^.num_warnings = 0) or (err^.trace_level >= 3) then
err^.output_message(cinfo);
{ Always count warnings in num_warnings. }
Inc( err^.num_warnings );
end
else
begin
{ It's a trace message. Show it if trace_level >= msg_level. }
if (err^.trace_level >= msg_level) then
err^.output_message (cinfo);
end;
end;
{ Format a message string for the most recent JPEG error or message.
The message is stored into buffer, which should be at least JMSG_LENGTH_MAX
characters. Note that no '\n' character is added to the string.
Few applications should need to override this method. }
{METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string);
var
err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE;
msgtext : string;
isstring : boolean;
begin
err := cinfo^.err;
msg_code := J_MESSAGE_CODE(err^.msg_code);
msgtext := '';
{ Look up message string in proper table }
if (msg_code > JMSG_NOMESSAGE)
and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then
begin
msgtext := err^.jpeg_message_table^[msg_code];
end
else
if (err^.addon_message_table <> NIL) and
(msg_code >= err^.first_addon_message) and
(msg_code <= err^.last_addon_message) then
begin
msgtext := err^.addon_message_table^[J_MESSAGE_CODE
(ord(msg_code) - ord(err^.first_addon_message))];
end;
{ Defend against bogus message number }
if (msgtext = '') then
begin
err^.msg_parm.i[0] := int(msg_code);
msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE];
end;
{ Check for string parameter, as indicated by %s in the message text }
isstring := Pos('%s', msgtext) > 0;
{ Format the message into the passed buffer }
if (isstring) then
buffer := Concat(msgtext, err^.msg_parm.s)
else
begin
{$IFDEF VER70}
FormatStr(buffer, msgtext, err^.msg_parm.i);
{$ELSE}
{$IFDEF NO_FORMAT}
buffer := msgtext;
{$ELSE}
buffer := Format(msgtext, [
err^.msg_parm.i[0], err^.msg_parm.i[1],
err^.msg_parm.i[2], err^.msg_parm.i[3],
err^.msg_parm.i[4], err^.msg_parm.i[5],
err^.msg_parm.i[6], err^.msg_parm.i[7] ]);
{$ENDIF}
{$ENDIF}
end;
end;
{ Reset error state variables at start of a new image.
This is called during compression startup to reset trace/error
processing to default state, without losing any application-specific
method pointers. An application might possibly want to override
this method if it has additional error processing state. }
{METHODDEF}
procedure reset_error_mgr (cinfo : j_common_ptr);
begin
cinfo^.err^.num_warnings := 0;
{ trace_level is not reset since it is an application-supplied parameter }
cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" }
end;
{ Fill in the standard error-handling methods in a jpeg_error_mgr object.
Typical call is:
cinfo : jpeg_compress_struct;
err : jpeg_error_mgr;
cinfo.err := jpeg_std_error(@err);
after which the application may override some of the methods. }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
begin
err.error_exit := error_exit;
err.emit_message := emit_message;
err.output_message := output_message;
err.format_message := format_message;
err.reset_error_mgr := reset_error_mgr;
err.trace_level := 0; { default := no tracing }
err.num_warnings := 0; { no warnings emitted yet }
err.msg_code := 0; { may be useful as a flag for "no error" }
{ Initialize message table pointers }
err.jpeg_message_table := @jpeg_std_message_table;
err.last_jpeg_message := pred(JMSG_LASTMSGCODE);
err.addon_message_table := NIL;
err.first_addon_message := JMSG_NOMESSAGE; { for safety }
err.last_addon_message := JMSG_NOMESSAGE;
jpeg_std_error := @err;
end;
end.

352
Imaging/JpegLib/imjfdctflt.pas
View File

@ -1,176 +1,176 @@
unit imjfdctflt;
{$N+}
{ This file contains a floating-point implementation of the
forward DCT (Discrete Cosine Transform).
This implementation should be more accurate than either of the integer
DCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original : jfdctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z1, z2, z3, z4, z5, z11, z13 : FAST_FLOAT;
dataptr : PWorkspace;
ctr : int;
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * ({FAST_FLOAT}(0.707106781)); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * ( {FAST_FLOAT}(0.382683433)); { c6 }
z2 := {FAST_FLOAT}(0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT}(1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * {FAST_FLOAT} (0.707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * {FAST_FLOAT} (0.382683433); { c6 }
z2 := {FAST_FLOAT} (0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT} (1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr)); { advance pointer to next column }
end;
end;
end.
unit imjfdctflt;
{$N+}
{ This file contains a floating-point implementation of the
forward DCT (Discrete Cosine Transform).
This implementation should be more accurate than either of the integer
DCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original : jfdctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z1, z2, z3, z4, z5, z11, z13 : FAST_FLOAT;
dataptr : PWorkspace;
ctr : int;
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * ({FAST_FLOAT}(0.707106781)); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * ( {FAST_FLOAT}(0.382683433)); { c6 }
z2 := {FAST_FLOAT}(0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT}(1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * {FAST_FLOAT} (0.707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * {FAST_FLOAT} (0.382683433); { c6 }
z2 := {FAST_FLOAT} (0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT} (1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr)); { advance pointer to next column }
end;
end;
end.

474
Imaging/JpegLib/imjfdctfst.pas
View File

@ -1,237 +1,237 @@
unit imjfdctfst;
{ This file contains a fast, not so accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original: jfdctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jfdctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
Again to save a few shifts, the intermediate results between pass 1 and
pass 2 are not upscaled, but are represented only to integral precision.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
const
CONST_BITS = 8;
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_382683433 = INT32(Round(CONST_SCALE * 0.382683433)); {98}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {139}
FIX_0_707106781 = INT32(Round(CONST_SCALE * 0.707106781)); {181}
FIX_1_306562965 = INT32(Round(CONST_SCALE * 1.306562965)); {334}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
{$ifndef USE_ACCURATE_ROUNDING}
shift_temp := x;
{$else}
shift_temp := x + (INT32(1) shl (n-1));
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
function MULTIPLY(X : DCTELEM; Y: INT32): DCTELEM;
begin
Multiply := DeScale((X) * (Y), CONST_BITS);
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z1, z2, z3, z4, z5, z11, z13 : DCTELEM;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.
unit imjfdctfst;
{ This file contains a fast, not so accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original: jfdctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jfdctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
Again to save a few shifts, the intermediate results between pass 1 and
pass 2 are not upscaled, but are represented only to integral precision.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
const
CONST_BITS = 8;
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_382683433 = INT32(Round(CONST_SCALE * 0.382683433)); {98}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {139}
FIX_0_707106781 = INT32(Round(CONST_SCALE * 0.707106781)); {181}
FIX_1_306562965 = INT32(Round(CONST_SCALE * 1.306562965)); {334}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
{$ifndef USE_ACCURATE_ROUNDING}
shift_temp := x;
{$else}
shift_temp := x + (INT32(1) shl (n-1));
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
function MULTIPLY(X : DCTELEM; Y: INT32): DCTELEM;
begin
Multiply := DeScale((X) * (Y), CONST_BITS);
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z1, z2, z3, z4, z5, z11, z13 : DCTELEM;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.

594
Imaging/JpegLib/imjfdctint.pas
View File

@ -1,297 +1,297 @@
unit imjfdctint;
{ This file contains a slow-but-accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D DCT step produces outputs which are a factor of sqrt(N)
larger than the true DCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D DCT,
because the y0 and y4 outputs need not be divided by sqrt(N).
In the IJG code, this factor of 8 is removed by the quantization step
(in jcdctmgr.c), NOT in this module.
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (For 12-bit sample data, the intermediate
array is INT32 anyway.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: int): INT32;
begin
Multiply := int(X) * INT32(Y);
end;
{$else}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := X * Y;
end;
{$endif}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
{ Note results are scaled up by sqrt(8) compared to a true DCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS);
dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS);
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS-PASS1_BITS));
dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS-PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS));
dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, CONST_BITS-PASS1_BITS));
dataptr^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS));
dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS));
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns.
We remove the PASS1_BITS scaling, but leave the results scaled up
by an overall factor of 8. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS));
dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS));
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS+PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4,
CONST_BITS+PASS1_BITS));
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.
unit imjfdctint;
{ This file contains a slow-but-accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D DCT step produces outputs which are a factor of sqrt(N)
larger than the true DCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D DCT,
because the y0 and y4 outputs need not be divided by sqrt(N).
In the IJG code, this factor of 8 is removed by the quantization step
(in jcdctmgr.c), NOT in this module.
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (For 12-bit sample data, the intermediate
array is INT32 anyway.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: int): INT32;
begin
Multiply := int(X) * INT32(Y);
end;
{$else}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := X * Y;
end;
{$endif}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
{ Note results are scaled up by sqrt(8) compared to a true DCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS);
dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS);
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS-PASS1_BITS));
dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS-PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS));
dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, CONST_BITS-PASS1_BITS));
dataptr^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS));
dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS));
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns.
We remove the PASS1_BITS scaling, but leave the results scaled up
by an overall factor of 8. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS));
dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS));
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS+PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4,
CONST_BITS+PASS1_BITS));
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.

1586
Imaging/JpegLib/imjidctasm.pas
View File

File diff suppressed because it is too large Load Diff

572
Imaging/JpegLib/imjidctflt.pas
View File

@ -1,286 +1,286 @@
unit imjidctflt;
{$N+}
{ This file contains a floating-point implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
This implementation should be more accurate than either of the integer
IDCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a float result. }
function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT;
begin
Dequantize := ( (coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z5, z10, z11, z12, z13 : FAST_FLOAT;
inptr : JCOEFPTR;
quantptr : FLOAT_MULT_TYPE_FIELD_PTR;
wsptr : PWorkSpace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS}
var
dcval : FAST_FLOAT;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 }
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := tmp0 + tmp7;
wsptr^[DCTSIZE*7] := tmp0 - tmp7;
wsptr^[DCTSIZE*1] := tmp1 + tmp6;
wsptr^[DCTSIZE*6] := tmp1 - tmp6;
wsptr^[DCTSIZE*2] := tmp2 + tmp5;
wsptr^[DCTSIZE*5] := tmp2 - tmp5;
wsptr^[DCTSIZE*4] := tmp3 + tmp4;
wsptr^[DCTSIZE*3] := tmp3 - tmp4;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 = 2**3. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@(output_buf^[ctr]^[output_col]));
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
And testing floats for zero is relatively expensive, so we don't bother. }
{ Even part }
tmp10 := wsptr^[0] + wsptr^[4];
tmp11 := wsptr^[0] - wsptr^[4];
tmp13 := wsptr^[2] + wsptr^[6];
tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := wsptr^[5] + wsptr^[3];
z10 := wsptr^[5] - wsptr^[3];
z11 := wsptr^[1] + wsptr^[7];
z12 := wsptr^[1] - wsptr^[7];
tmp7 := z11 + z13;
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562));
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7;
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3))
and RANGE_MASK];
Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.
unit imjidctflt;
{$N+}
{ This file contains a floating-point implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
This implementation should be more accurate than either of the integer
IDCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a float result. }
function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT;
begin
Dequantize := ( (coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z5, z10, z11, z12, z13 : FAST_FLOAT;
inptr : JCOEFPTR;
quantptr : FLOAT_MULT_TYPE_FIELD_PTR;
wsptr : PWorkSpace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS}
var
dcval : FAST_FLOAT;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 }
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := tmp0 + tmp7;
wsptr^[DCTSIZE*7] := tmp0 - tmp7;
wsptr^[DCTSIZE*1] := tmp1 + tmp6;
wsptr^[DCTSIZE*6] := tmp1 - tmp6;
wsptr^[DCTSIZE*2] := tmp2 + tmp5;
wsptr^[DCTSIZE*5] := tmp2 - tmp5;
wsptr^[DCTSIZE*4] := tmp3 + tmp4;
wsptr^[DCTSIZE*3] := tmp3 - tmp4;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 = 2**3. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@(output_buf^[ctr]^[output_col]));
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
And testing floats for zero is relatively expensive, so we don't bother. }
{ Even part }
tmp10 := wsptr^[0] + wsptr^[4];
tmp11 := wsptr^[0] - wsptr^[4];
tmp13 := wsptr^[2] + wsptr^[6];
tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := wsptr^[5] + wsptr^[3];
z10 := wsptr^[5] - wsptr^[3];
z11 := wsptr^[1] + wsptr^[7];
z12 := wsptr^[1] - wsptr^[7];
tmp7 := z11 + z13;
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562));
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7;
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3))
and RANGE_MASK];
Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

820
Imaging/JpegLib/imjidctfst.pas
View File

@ -1,410 +1,410 @@
unit imjidctfst;
{ This file contains a fast, not so accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original : jidctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jidctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
The dequantized coefficients are not integers because the AA&N scaling
factors have been incorporated. We represent them scaled up by PASS1_BITS,
so that the first and second IDCT rounds have the same input scaling.
For 8-bit JSAMPLEs, we choose IFAST_SCALE_BITS = PASS1_BITS so as to
avoid a descaling shift; this compromises accuracy rather drastically
for small quantization table entries, but it saves a lot of shifts.
For 12-bit JSAMPLEs, there's no hope of using 16x16 multiplies anyway,
so we use a much larger scaling factor to preserve accuracy.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 8;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 8;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
FIX_1_082392200 = INT32(Round((INT32(1) shl CONST_BITS)*1.082392200)); {277}
FIX_1_414213562 = INT32(Round((INT32(1) shl CONST_BITS)*1.414213562)); {362}
FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS)*1.847759065)); {473}
FIX_2_613125930 = INT32(Round((INT32(1) shl CONST_BITS)*2.613125930)); {669}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef USE_ACCURATE_ROUNDING}
shift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
shift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
{(DCTELEM( DESCALE((var) * (const), CONST_BITS))}
function Multiply(Avar, Aconst: Integer): DCTELEM;
begin
Multiply := DCTELEM( Avar*INT32(Aconst) div (INT32(1) shl CONST_BITS));
end;
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a DCTELEM result. For 8-bit data a 16x16->16
multiplication will do. For 12-bit data, the multiplier table is
declared INT32, so a 32-bit multiply will be used. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( IFAST_MULT_TYPE(coef) * quantval);
end;
{$else}
function DEQUANTIZE(coef,quantval : INT32) : int;
begin
Dequantize := DESCALE((coef)*(quantval), IFAST_SCALE_BITS-PASS1_BITS);
end;
{$endif}
{ Like DESCALE, but applies to a DCTELEM and produces an int.
We assume that int right shift is unsigned if INT32 right shift is. }
function IDESCALE(x : DCTELEM; n : int) : int;
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
DCTELEMBITS = 16; { DCTELEM may be 16 or 32 bits }
{$else}
const
DCTELEMBITS = 32; { DCTELEM must be 32 bits }
{$endif}
var
ishift_temp : DCTELEM;
begin
{$ifndef USE_ACCURATE_ROUNDING}
ishift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
ishift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if ishift_temp < 0 then
IDescale := (ishift_temp shr n)
or ((not DCTELEM(0)) shl (DCTELEMBITS-n))
else
{$endif}
IDescale := (ishift_temp shr n);
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z5, z10, z11, z12, z13 : DCTELEM;
inptr : JCOEFPTR;
quantptr : IFAST_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS} { for DESCALE }
{ISHIFT_TEMPS} { for IDESCALE }
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := IFAST_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and
(inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
dcval := int(DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]));
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := MULTIPLY(tmp1 - tmp3, FIX_1_414213562) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := int (tmp0 + tmp7);
wsptr^[DCTSIZE*7] := int (tmp0 - tmp7);
wsptr^[DCTSIZE*1] := int (tmp1 + tmp6);
wsptr^[DCTSIZE*6] := int (tmp1 - tmp6);
wsptr^[DCTSIZE*2] := int (tmp2 + tmp5);
wsptr^[DCTSIZE*5] := int (tmp2 - tmp5);
wsptr^[DCTSIZE*4] := int (tmp3 + tmp4);
wsptr^[DCTSIZE*3] := int (tmp3 - tmp4);
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@output_buf^[ctr]^[output_col]);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) and
(wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then
begin
{ AC terms all zero }
dcval_ := range_limit^[IDESCALE(wsptr^[0], PASS1_BITS+3)
and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part }
tmp10 := (DCTELEM(wsptr^[0]) + DCTELEM(wsptr^[4]));
tmp11 := (DCTELEM(wsptr^[0]) - DCTELEM(wsptr^[4]));
tmp13 := (DCTELEM(wsptr^[2]) + DCTELEM(wsptr^[6]));
tmp12 := MULTIPLY(DCTELEM(wsptr^[2]) - DCTELEM(wsptr^[6]), FIX_1_414213562)
- tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := DCTELEM(wsptr^[5]) + DCTELEM(wsptr^[3]);
z10 := DCTELEM(wsptr^[5]) - DCTELEM(wsptr^[3]);
z11 := DCTELEM(wsptr^[1]) + DCTELEM(wsptr^[7]);
z12 := DCTELEM(wsptr^[1]) - DCTELEM(wsptr^[7]);
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[IDESCALE(tmp0 + tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[7] := range_limit^[IDESCALE(tmp0 - tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[1] := range_limit^[IDESCALE(tmp1 + tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[6] := range_limit^[IDESCALE(tmp1 - tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[2] := range_limit^[IDESCALE(tmp2 + tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[5] := range_limit^[IDESCALE(tmp2 - tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[4] := range_limit^[IDESCALE(tmp3 + tmp4, PASS1_BITS+3)
and RANGE_MASK];
outptr^[3] := range_limit^[IDESCALE(tmp3 - tmp4, PASS1_BITS+3)
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.
unit imjidctfst;
{ This file contains a fast, not so accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original : jidctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jidctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
The dequantized coefficients are not integers because the AA&N scaling
factors have been incorporated. We represent them scaled up by PASS1_BITS,
so that the first and second IDCT rounds have the same input scaling.
For 8-bit JSAMPLEs, we choose IFAST_SCALE_BITS = PASS1_BITS so as to
avoid a descaling shift; this compromises accuracy rather drastically
for small quantization table entries, but it saves a lot of shifts.
For 12-bit JSAMPLEs, there's no hope of using 16x16 multiplies anyway,
so we use a much larger scaling factor to preserve accuracy.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 8;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 8;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
FIX_1_082392200 = INT32(Round((INT32(1) shl CONST_BITS)*1.082392200)); {277}
FIX_1_414213562 = INT32(Round((INT32(1) shl CONST_BITS)*1.414213562)); {362}
FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS)*1.847759065)); {473}
FIX_2_613125930 = INT32(Round((INT32(1) shl CONST_BITS)*2.613125930)); {669}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef USE_ACCURATE_ROUNDING}
shift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
shift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
{(DCTELEM( DESCALE((var) * (const), CONST_BITS))}
function Multiply(Avar, Aconst: Integer): DCTELEM;
begin
Multiply := DCTELEM( Avar*INT32(Aconst) div (INT32(1) shl CONST_BITS));
end;
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a DCTELEM result. For 8-bit data a 16x16->16
multiplication will do. For 12-bit data, the multiplier table is
declared INT32, so a 32-bit multiply will be used. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( IFAST_MULT_TYPE(coef) * quantval);
end;
{$else}
function DEQUANTIZE(coef,quantval : INT32) : int;
begin
Dequantize := DESCALE((coef)*(quantval), IFAST_SCALE_BITS-PASS1_BITS);
end;
{$endif}
{ Like DESCALE, but applies to a DCTELEM and produces an int.
We assume that int right shift is unsigned if INT32 right shift is. }
function IDESCALE(x : DCTELEM; n : int) : int;
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
DCTELEMBITS = 16; { DCTELEM may be 16 or 32 bits }
{$else}
const
DCTELEMBITS = 32; { DCTELEM must be 32 bits }
{$endif}
var
ishift_temp : DCTELEM;
begin
{$ifndef USE_ACCURATE_ROUNDING}
ishift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
ishift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if ishift_temp < 0 then
IDescale := (ishift_temp shr n)
or ((not DCTELEM(0)) shl (DCTELEMBITS-n))
else
{$endif}
IDescale := (ishift_temp shr n);
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z5, z10, z11, z12, z13 : DCTELEM;
inptr : JCOEFPTR;
quantptr : IFAST_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS} { for DESCALE }
{ISHIFT_TEMPS} { for IDESCALE }
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := IFAST_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and
(inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
dcval := int(DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]));
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := MULTIPLY(tmp1 - tmp3, FIX_1_414213562) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := int (tmp0 + tmp7);
wsptr^[DCTSIZE*7] := int (tmp0 - tmp7);
wsptr^[DCTSIZE*1] := int (tmp1 + tmp6);
wsptr^[DCTSIZE*6] := int (tmp1 - tmp6);
wsptr^[DCTSIZE*2] := int (tmp2 + tmp5);
wsptr^[DCTSIZE*5] := int (tmp2 - tmp5);
wsptr^[DCTSIZE*4] := int (tmp3 + tmp4);
wsptr^[DCTSIZE*3] := int (tmp3 - tmp4);
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@output_buf^[ctr]^[output_col]);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) and
(wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then
begin
{ AC terms all zero }
dcval_ := range_limit^[IDESCALE(wsptr^[0], PASS1_BITS+3)
and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part }
tmp10 := (DCTELEM(wsptr^[0]) + DCTELEM(wsptr^[4]));
tmp11 := (DCTELEM(wsptr^[0]) - DCTELEM(wsptr^[4]));
tmp13 := (DCTELEM(wsptr^[2]) + DCTELEM(wsptr^[6]));
tmp12 := MULTIPLY(DCTELEM(wsptr^[2]) - DCTELEM(wsptr^[6]), FIX_1_414213562)
- tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := DCTELEM(wsptr^[5]) + DCTELEM(wsptr^[3]);
z10 := DCTELEM(wsptr^[5]) - DCTELEM(wsptr^[3]);
z11 := DCTELEM(wsptr^[1]) + DCTELEM(wsptr^[7]);
z12 := DCTELEM(wsptr^[1]) - DCTELEM(wsptr^[7]);
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[IDESCALE(tmp0 + tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[7] := range_limit^[IDESCALE(tmp0 - tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[1] := range_limit^[IDESCALE(tmp1 + tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[6] := range_limit^[IDESCALE(tmp1 - tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[2] := range_limit^[IDESCALE(tmp2 + tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[5] := range_limit^[IDESCALE(tmp2 - tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[4] := range_limit^[IDESCALE(tmp3 + tmp4, PASS1_BITS+3)
and RANGE_MASK];
outptr^[3] := range_limit^[IDESCALE(tmp3 - tmp4, PASS1_BITS+3)
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

880
Imaging/JpegLib/imjidctint.pas
View File

@ -1,440 +1,440 @@
unit imjidctint;
{$Q+}
{ This file contains a slow-but-accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D IDCT step produces outputs which are a factor of sqrt(N)
larger than the true IDCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D IDCT,
because the y0 and y4 inputs need not be divided by sqrt(N).
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (To scale up 12-bit sample data further, an
intermediate INT32 array would be needed.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{$IFDEF BASM16}
{$IFNDEF WIN32}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: Integer): integer; assembler;
asm
mov ax, X
imul Y
mov al, ah
mov ah, dl
end;
{$ENDIF}
{$ENDIF}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$else}
{#define MULTIPLY(var,const) ((var) * (const))}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce an int result. In this module, both inputs and result
are 16 bits or less, so either int or short multiply will work. }
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace;
{SHIFT_TEMPS}
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
{ Note results are scaled up by sqrt(8) compared to a true IDCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := PWorkspace(@workspace);
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0)) then
begin
{ AC terms all zero }
dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp0 := (z2 + z3) shl CONST_BITS;
tmp1 := (z2 - z3) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := output_buf^[ctr];
Inc(JSAMPLE_PTR(outptr), output_col);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0)
and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then
begin
{ AC terms all zero }
JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]),
PASS1_BITS+3)) and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := INT32 (wsptr^[2]);
z3 := INT32 (wsptr^[6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;
tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := INT32(wsptr^[7]);
tmp1 := INT32(wsptr^[5]);
tmp2 := INT32(wsptr^[3]);
tmp3 := INT32(wsptr^[1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.
unit imjidctint;
{$Q+}
{ This file contains a slow-but-accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D IDCT step produces outputs which are a factor of sqrt(N)
larger than the true IDCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D IDCT,
because the y0 and y4 inputs need not be divided by sqrt(N).
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (To scale up 12-bit sample data further, an
intermediate INT32 array would be needed.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{$IFDEF BASM16}
{$IFNDEF WIN32}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: Integer): integer; assembler;
asm
mov ax, X
imul Y
mov al, ah
mov ah, dl
end;
{$ENDIF}
{$ENDIF}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$else}
{#define MULTIPLY(var,const) ((var) * (const))}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce an int result. In this module, both inputs and result
are 16 bits or less, so either int or short multiply will work. }
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace;
{SHIFT_TEMPS}
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
{ Note results are scaled up by sqrt(8) compared to a true IDCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := PWorkspace(@workspace);
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0)) then
begin
{ AC terms all zero }
dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp0 := (z2 + z3) shl CONST_BITS;
tmp1 := (z2 - z3) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := output_buf^[ctr];
Inc(JSAMPLE_PTR(outptr), output_col);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0)
and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then
begin
{ AC terms all zero }
JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]),
PASS1_BITS+3)) and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := INT32 (wsptr^[2]);
z3 := INT32 (wsptr^[6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;
tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := INT32(wsptr^[7]);
tmp1 := INT32(wsptr^[5]);
tmp2 := INT32(wsptr^[3]);
tmp3 := INT32(wsptr^[1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

1050
Imaging/JpegLib/imjidctred.pas
View File

File diff suppressed because it is too large Load Diff

252
Imaging/JpegLib/imjinclude.pas
View File

@ -1,126 +1,126 @@
unit imjinclude;
{ This file exists to provide a single place to fix any problems with
including the wrong system include files. (Common problems are taken
care of by the standard jconfig symbols, but on really weird systems
you may have to edit this file.)
NOTE: this file is NOT intended to be included by applications using the
JPEG library. Most applications need only include jpeglib.h. }
{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Include auto-config file to find out which system include files we need. }
uses
{$ifdef Delphi_Stream}
classes,
{$endif}
imjmorecfg;
{ Nomssi:
To write a dest/source manager that handle streams rather than files,
you can edit the FILEptr definition and the JFREAD() and JFWRITE()
functions in this unit, you don't need to change the default managers
JDATASRC and JDATADST. }
{$ifdef Delphi_Stream}
type
FILEptr = ^TStream;
{$else}
{$ifdef Delphi_Jpeg}
type
FILEptr = TCustomMemoryStream;
{$else}
type
FILEptr = ^File;
{$endif}
{$endif}
{ We need the NULL macro and size_t typedef.
On an ANSI-conforming system it is sufficient to include <stddef.h>.
Otherwise, we get them from <stdlib.h> or <stdio.h>; we may have to
pull in <sys/types.h> as well.
Note that the core JPEG library does not require <stdio.h>;
only the default error handler and data source/destination modules do.
But we must pull it in because of the references to FILE in jpeglib.h.
You can remove those references if you want to compile without <stdio.h>.}
{ We need memory copying and zeroing functions, plus strncpy().
ANSI and System V implementations declare these in <string.h>.
BSD doesn't have the mem() functions, but it does have bcopy()/bzero().
Some systems may declare memset and memcpy in <memory.h>.
NOTE: we assume the size parameters to these functions are of type size_t.
Change the casts in these macros if not! }
procedure MEMZERO(target : pointer; size : size_t);
procedure MEMCOPY(dest, src : pointer; size : size_t);
{function SIZEOF(object) : size_t;}
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
implementation
procedure MEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure MEMCOPY(dest, src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{ In ANSI C, and indeed any rational implementation, size_t is also the
type returned by sizeof(). However, it seems there are some irrational
implementations out there, in which sizeof() returns an int even though
size_t is defined as long or unsigned long. To ensure consistent results
we always use this SIZEOF() macro in place of using sizeof() directly. }
{#define
SIZEOF(object) (size_t(sizeof(object))}
{ The modules that use fread() and fwrite() always invoke them through
these macros. On some systems you may need to twiddle the argument casts.
CAUTION: argument order is different from underlying functions! }
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Read(buf^, sizeofbuf);
{$else}
blockread(fp^, buf^, sizeofbuf, count);
{$endif}
JFREAD := size_t(count);
end;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Write(buf^, sizeofbuf);
{$else}
blockwrite(fp^, buf^, sizeofbuf, count);
{$endif}
JFWRITE := size_t(count);
end;
end.
unit imjinclude;
{ This file exists to provide a single place to fix any problems with
including the wrong system include files. (Common problems are taken
care of by the standard jconfig symbols, but on really weird systems
you may have to edit this file.)
NOTE: this file is NOT intended to be included by applications using the
JPEG library. Most applications need only include jpeglib.h. }
{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Include auto-config file to find out which system include files we need. }
uses
{$ifdef Delphi_Stream}
classes,
{$endif}
imjmorecfg;
{ Nomssi:
To write a dest/source manager that handle streams rather than files,
you can edit the FILEptr definition and the JFREAD() and JFWRITE()
functions in this unit, you don't need to change the default managers
JDATASRC and JDATADST. }
{$ifdef Delphi_Stream}
type
FILEptr = ^TStream;
{$else}
{$ifdef Delphi_Jpeg}
type
FILEptr = TCustomMemoryStream;
{$else}
type
FILEptr = ^File;
{$endif}
{$endif}
{ We need the NULL macro and size_t typedef.
On an ANSI-conforming system it is sufficient to include <stddef.h>.
Otherwise, we get them from <stdlib.h> or <stdio.h>; we may have to
pull in <sys/types.h> as well.
Note that the core JPEG library does not require <stdio.h>;
only the default error handler and data source/destination modules do.
But we must pull it in because of the references to FILE in jpeglib.h.
You can remove those references if you want to compile without <stdio.h>.}
{ We need memory copying and zeroing functions, plus strncpy().
ANSI and System V implementations declare these in <string.h>.
BSD doesn't have the mem() functions, but it does have bcopy()/bzero().
Some systems may declare memset and memcpy in <memory.h>.
NOTE: we assume the size parameters to these functions are of type size_t.
Change the casts in these macros if not! }
procedure MEMZERO(target : pointer; size : size_t);
procedure MEMCOPY(dest, src : pointer; size : size_t);
{function SIZEOF(object) : size_t;}
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
implementation
procedure MEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure MEMCOPY(dest, src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{ In ANSI C, and indeed any rational implementation, size_t is also the
type returned by sizeof(). However, it seems there are some irrational
implementations out there, in which sizeof() returns an int even though
size_t is defined as long or unsigned long. To ensure consistent results
we always use this SIZEOF() macro in place of using sizeof() directly. }
{#define
SIZEOF(object) (size_t(sizeof(object))}
{ The modules that use fread() and fwrite() always invoke them through
these macros. On some systems you may need to twiddle the argument casts.
CAUTION: argument order is different from underlying functions! }
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Read(buf^, sizeofbuf);
{$else}
blockread(fp^, buf^, sizeofbuf, count);
{$endif}
JFREAD := size_t(count);
end;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Write(buf^, sizeofbuf);
{$else}
blockwrite(fp^, buf^, sizeofbuf, count);
{$endif}
JFWRITE := size_t(count);
end;
end.

494
Imaging/JpegLib/imjmorecfg.pas
View File

@ -1,247 +1,247 @@
unit imjmorecfg;
{ This file contains additional configuration options that customize the
JPEG software for special applications or support machine-dependent
optimizations. Most users will not need to touch this file. }
{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{$IFDEF FPC} { Free Pascal Compiler }
type
int = longint;
uInt = Cardinal; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF WIN32}
{ Delphi 2.0 }
type
int = Integer;
uInt = Cardinal;
short = SmallInt;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF VIRTUALPASCAL}
type
int = longint;
uInt = longint; { unsigned int }
short = system.Integer;
ushort = system.Word;
long = longint;
{$ELSE}
type
int = Integer;
uInt = Word; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ENDIF}
{$ENDIF}
{$ENDIF}
type
voidp = pointer;
type
int_ptr = ^int;
size_t = int;
{ Define BITS_IN_JSAMPLE as either
8 for 8-bit sample values (the usual setting)
12 for 12-bit sample values
Only 8 and 12 are legal data precisions for lossy JPEG according to the
JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. }
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const
BITS_IN_JSAMPLE = 8;
{$else}
const
BITS_IN_JSAMPLE = 12;
{$endif}
{ Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn
few applications need more than 4 channels (maybe 5 for CMYK + alpha
mask). We recommend 10 as a reasonable compromise; use 4 if you are
really short on memory. (Each allowed component costs a hundred or so
bytes of storage, whether actually used in an image or not.) }
const
MAX_COMPONENTS = 10; { maximum number of image components }
{ Basic data types.
You may need to change these if you have a machine with unusual data
type sizes; for example, "char" not 8 bits, "short" not 16 bits,
or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits,
but it had better be at least 16. }
{ Representation of a single sample (pixel element value).
We frequently allocate large arrays of these, so it's important to keep
them small. But if you have memory to burn and access to char or short
arrays is very slow on your hardware, you might want to change these. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..255.
You can use a signed char by having GETJSAMPLE mask it with $FF. }
{ CHAR_IS_UNSIGNED }
type
JSAMPLE = byte; { Pascal unsigned char }
GETJSAMPLE = int;
const
MAXJSAMPLE = 255;
CENTERJSAMPLE = 128;
{$endif}
{$ifndef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..4095.
On nearly all machines "short" will do nicely. }
type
JSAMPLE = short;
GETJSAMPLE = int;
const
MAXJSAMPLE = 4095;
CENTERJSAMPLE = 2048;
{$endif} { BITS_IN_JSAMPLE = 12 }
{ Representation of a DCT frequency coefficient.
This should be a signed value of at least 16 bits; "short" is usually OK.
Again, we allocate large arrays of these, but you can change to int
if you have memory to burn and "short" is really slow. }
type
JCOEF = int;
JCOEF_PTR = ^JCOEF;
{ Compressed datastreams are represented as arrays of JOCTET.
These must be EXACTLY 8 bits wide, at least once they are written to
external storage. Note that when using the stdio data source/destination
managers, this is also the data type passed to fread/fwrite. }
type
JOCTET = Byte;
jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
JOCTET_FIELD = array[jTOctet] of JOCTET;
JOCTET_FIELD_PTR = ^JOCTET_FIELD;
JOCTETPTR = ^JOCTET;
GETJOCTET = JOCTET; { A work around }
{ These typedefs are used for various table entries and so forth.
They must be at least as wide as specified; but making them too big
won't cost a huge amount of memory, so we don't provide special
extraction code like we did for JSAMPLE. (In other words, these
typedefs live at a different point on the speed/space tradeoff curve.) }
{ UINT8 must hold at least the values 0..255. }
type
UINT8 = byte;
{ UINT16 must hold at least the values 0..65535. }
UINT16 = Word;
{ INT16 must hold at least the values -32768..32767. }
INT16 = int;
{ INT32 must hold at least signed 32-bit values. }
INT32 = longint;
type
INT32PTR = ^INT32;
{ Datatype used for image dimensions. The JPEG standard only supports
images up to 64K*64K due to 16-bit fields in SOF markers. Therefore
"unsigned int" is sufficient on all machines. However, if you need to
handle larger images and you don't mind deviating from the spec, you
can change this datatype. }
type
JDIMENSION = uInt;
const
JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows }
{ Ordering of RGB data in scanlines passed to or from the application.
If your application wants to deal with data in the order B,G,R, just
change these macros. You can also deal with formats such as R,G,B,X
(one extra byte per pixel) by changing RGB_PIXELSIZE. Note that changing
the offsets will also change the order in which colormap data is organized.
RESTRICTIONS:
1. The sample applications cjpeg,djpeg do NOT support modified RGB formats.
2. These macros only affect RGB<=>YCbCr color conversion, so they are not
useful if you are using JPEG color spaces other than YCbCr or grayscale.
3. The color quantizer modules will not behave desirably if RGB_PIXELSIZE
is not 3 (they don't understand about dummy color components!). So you
can't use color quantization if you change that value. }
{$ifdef RGB_RED_IS_0}
const
RGB_RED = 0; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 2; { Offset of Blue }
{$else}
const
RGB_RED = 2; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 0; { Offset of Blue }
{$endif}
{$ifdef RGB_PIXELSIZE_IS_3}
const
RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element }
{$else}
const
RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value }
{$endif}
{ Definitions for speed-related optimizations. }
{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying
two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER
as short on such a machine. MULTIPLIER must be at least 16 bits wide. }
type
MULTIPLIER = int; { type for fastest integer multiply }
{ FAST_FLOAT should be either float or double, whichever is done faster
by your compiler. (Note that this type is only used in the floating point
DCT routines, so it only matters if you've defined DCT_FLOAT_SUPPORTED.)
Typically, float is faster in ANSI C compilers, while double is faster in
pre-ANSI compilers (because they insist on converting to double anyway).
The code below therefore chooses float if we have ANSI-style prototypes. }
type
FAST_FLOAT = double; {float}
implementation
end.
unit imjmorecfg;
{ This file contains additional configuration options that customize the
JPEG software for special applications or support machine-dependent
optimizations. Most users will not need to touch this file. }
{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{$IFDEF FPC} { Free Pascal Compiler }
type
int = longint;
uInt = Cardinal; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF WIN32}
{ Delphi 2.0 }
type
int = Integer;
uInt = Cardinal;
short = SmallInt;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF VIRTUALPASCAL}
type
int = longint;
uInt = longint; { unsigned int }
short = system.Integer;
ushort = system.Word;
long = longint;
{$ELSE}
type
int = Integer;
uInt = Word; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ENDIF}
{$ENDIF}
{$ENDIF}
type
voidp = pointer;
type
int_ptr = ^int;
size_t = int;
{ Define BITS_IN_JSAMPLE as either
8 for 8-bit sample values (the usual setting)
12 for 12-bit sample values
Only 8 and 12 are legal data precisions for lossy JPEG according to the
JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. }
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const
BITS_IN_JSAMPLE = 8;
{$else}
const
BITS_IN_JSAMPLE = 12;
{$endif}
{ Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn
few applications need more than 4 channels (maybe 5 for CMYK + alpha
mask). We recommend 10 as a reasonable compromise; use 4 if you are
really short on memory. (Each allowed component costs a hundred or so
bytes of storage, whether actually used in an image or not.) }
const
MAX_COMPONENTS = 10; { maximum number of image components }
{ Basic data types.
You may need to change these if you have a machine with unusual data
type sizes; for example, "char" not 8 bits, "short" not 16 bits,
or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits,
but it had better be at least 16. }
{ Representation of a single sample (pixel element value).
We frequently allocate large arrays of these, so it's important to keep
them small. But if you have memory to burn and access to char or short
arrays is very slow on your hardware, you might want to change these. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..255.
You can use a signed char by having GETJSAMPLE mask it with $FF. }
{ CHAR_IS_UNSIGNED }
type
JSAMPLE = byte; { Pascal unsigned char }
GETJSAMPLE = int;
const
MAXJSAMPLE = 255;
CENTERJSAMPLE = 128;
{$endif}
{$ifndef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..4095.
On nearly all machines "short" will do nicely. }
type
JSAMPLE = short;
GETJSAMPLE = int;
const
MAXJSAMPLE = 4095;
CENTERJSAMPLE = 2048;
{$endif} { BITS_IN_JSAMPLE = 12 }
{ Representation of a DCT frequency coefficient.
This should be a signed value of at least 16 bits; "short" is usually OK.
Again, we allocate large arrays of these, but you can change to int
if you have memory to burn and "short" is really slow. }
type
JCOEF = int;
JCOEF_PTR = ^JCOEF;
{ Compressed datastreams are represented as arrays of JOCTET.
These must be EXACTLY 8 bits wide, at least once they are written to
external storage. Note that when using the stdio data source/destination
managers, this is also the data type passed to fread/fwrite. }
type
JOCTET = Byte;
jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
JOCTET_FIELD = array[jTOctet] of JOCTET;
JOCTET_FIELD_PTR = ^JOCTET_FIELD;
JOCTETPTR = ^JOCTET;
GETJOCTET = JOCTET; { A work around }
{ These typedefs are used for various table entries and so forth.
They must be at least as wide as specified; but making them too big
won't cost a huge amount of memory, so we don't provide special
extraction code like we did for JSAMPLE. (In other words, these
typedefs live at a different point on the speed/space tradeoff curve.) }
{ UINT8 must hold at least the values 0..255. }
type
UINT8 = byte;
{ UINT16 must hold at least the values 0..65535. }
UINT16 = Word;
{ INT16 must hold at least the values -32768..32767. }
INT16 = int;
{ INT32 must hold at least signed 32-bit values. }
INT32 = longint;
type
INT32PTR = ^INT32;
{ Datatype used for image dimensions. The JPEG standard only supports
images up to 64K*64K due to 16-bit fields in SOF markers. Therefore
"unsigned int" is sufficient on all machines. However, if you need to
handle larger images and you don't mind deviating from the spec, you
can change this datatype. }
type
JDIMENSION = uInt;
const
JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows }
{ Ordering of RGB data in scanlines passed to or from the application.
If your application wants to deal with data in the order B,G,R, just
change these macros. You can also deal with formats such as R,G,B,X
(one extra byte per pixel) by changing RGB_PIXELSIZE. Note that changing
the offsets will also change the order in which colormap data is organized.
RESTRICTIONS:
1. The sample applications cjpeg,djpeg do NOT support modified RGB formats.
2. These macros only affect RGB<=>YCbCr color conversion, so they are not
useful if you are using JPEG color spaces other than YCbCr or grayscale.
3. The color quantizer modules will not behave desirably if RGB_PIXELSIZE
is not 3 (they don't understand about dummy color components!). So you
can't use color quantization if you change that value. }
{$ifdef RGB_RED_IS_0}
const
RGB_RED = 0; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 2; { Offset of Blue }
{$else}
const
RGB_RED = 2; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 0; { Offset of Blue }
{$endif}
{$ifdef RGB_PIXELSIZE_IS_3}
const
RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element }
{$else}
const
RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value }
{$endif}
{ Definitions for speed-related optimizations. }
{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying
two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER
as short on such a machine. MULTIPLIER must be at least 16 bits wide. }
type
MULTIPLIER = int; { type for fastest integer multiply }
{ FAST_FLOAT should be either float or double, whichever is done faster
by your compiler. (Note that this type is only used in the floating point
DCT routines, so it only matters if you've defined DCT_FLOAT_SUPPORTED.)
Typically, float is faster in ANSI C compilers, while double is faster in
pre-ANSI compilers (because they insist on converting to double anyway).
The code below therefore chooses float if we have ANSI-style prototypes. }
type
FAST_FLOAT = double; {float}
implementation
end.

2600
Imaging/JpegLib/imjpeglib.pas
View File

File diff suppressed because it is too large Load Diff

2018
Imaging/JpegLib/imjquant1.pas
View File

File diff suppressed because it is too large Load Diff

3102
Imaging/JpegLib/imjquant2.pas
View File

File diff suppressed because it is too large Load Diff

464
Imaging/JpegLib/imjutils.pas
View File

@ -1,232 +1,232 @@
unit imjutils;
{ This file contains tables and miscellaneous utility routines needed
for both compression and decompression.
Note we prefix all global names with "j" to minimize conflicts with
a surrounding application. }
{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element
of a DCT block read in natural order (left to right, top to bottom). }
{$ifdef FALSE} { This table is not actually needed in v6a }
const
jpeg_zigzag_order : array[0..DCTSIZE2] of int =
(0, 1, 5, 6, 14, 15, 27, 28,
2, 4, 7, 13, 16, 26, 29, 42,
3, 8, 12, 17, 25, 30, 41, 43,
9, 11, 18, 24, 31, 40, 44, 53,
10, 19, 23, 32, 39, 45, 52, 54,
20, 22, 33, 38, 46, 51, 55, 60,
21, 34, 37, 47, 50, 56, 59, 61,
35, 36, 48, 49, 57, 58, 62, 63);
{$endif}
{ jpeg_natural_order[i] is the natural-order position of the i'th element
of zigzag order.
When reading corrupted data, the Huffman decoders could attempt
to reference an entry beyond the end of this array (if the decoded
zero run length reaches past the end of the block). To prevent
wild stores without adding an inner-loop test, we put some extra
"63"s after the real entries. This will cause the extra coefficient
to be stored in location 63 of the block, not somewhere random.
The worst case would be a run-length of 15, which means we need 16
fake entries. }
const
jpeg_natural_order : array[0..DCTSIZE2+16-1] of int =
(0, 1, 8, 16, 9, 2, 3, 10,
17, 24, 32, 25, 18, 11, 4, 5,
12, 19, 26, 33, 40, 48, 41, 34,
27, 20, 13, 6, 7, 14, 21, 28,
35, 42, 49, 56, 57, 50, 43, 36,
29, 22, 15, 23, 30, 37, 44, 51,
58, 59, 52, 45, 38, 31, 39, 46,
53, 60, 61, 54, 47, 55, 62, 63,
63, 63, 63, 63, 63, 63, 63, 63, { extra entries for safety in decoder }
63, 63, 63, 63, 63, 63, 63, 63);
{ Arithmetic utilities }
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY;
source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
procedure FMEMZERO(target : pointer; size : size_t);
procedure FMEMCOPY(dest,src : pointer; size : size_t);
implementation
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{ Compute a/b rounded up to next integer, ie, ceil(a/b) }
{ Assumes a >= 0, b > 0 }
begin
jdiv_round_up := (a + b - long(1)) div b;
end;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b }
{ Assumes a >= 0, b > 0 }
begin
Inc(a, b - long(1));
jround_up := a - (a mod b);
end;
{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays
and coefficient-block arrays. This won't work on 80x86 because the arrays
are FAR and we're assuming a small-pointer memory model. However, some
DOS compilers provide far-pointer versions of memcpy() and memset() even
in the small-model libraries. These will be used if USE_FMEM is defined.
Otherwise, the routines below do it the hard way. (The performance cost
is not all that great, because these routines aren't very heavily used.) }
{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros }
procedure FMEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure FMEMCOPY(dest,src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{$else} { 80x86 case, define if we can }
{$ifdef USE_FMEM}
FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size))
FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size))
{$endif}
{$endif}
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{ Copy some rows of samples from one place to another.
num_rows rows are copied from input_array[source_row++]
to output_array[dest_row++]; these areas may overlap for duplication.
The source and destination arrays must be at least as wide as num_cols. }
var
inptr, outptr : JSAMPLE_PTR; {register}
{$ifdef FMEMCOPY}
count : size_t; {register}
{$else}
count : JDIMENSION; {register}
{$endif}
row : int; {register}
begin
{$ifdef FMEMCOPY}
count := size_t(num_cols * SIZEOF(JSAMPLE));
{$endif}
Inc(JSAMPROW_PTR(input_array), source_row);
Inc(JSAMPROW_PTR(output_array), dest_row);
for row := pred(num_rows) downto 0 do
begin
inptr := JSAMPLE_PTR(input_array^[0]);
Inc(JSAMPROW_PTR(input_array));
outptr := JSAMPLE_PTR(output_array^[0]);
Inc(JSAMPROW_PTR(output_array));
{$ifdef FMEMCOPY}
FMEMCOPY(outptr, inptr, count);
{$else}
for count := pred(num_cols) downto 0 do
begin
outptr^ := inptr^; { needn't bother with GETJSAMPLE() here }
Inc(inptr);
Inc(outptr);
end;
{$endif}
end;
end;
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{ Copy a row of coefficient blocks from one place to another. }
{$ifdef FMEMCOPY}
begin
FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF)));
{$else}
var
inptr, outptr : JCOEFPTR; {register}
count : long; {register}
begin
inptr := JCOEFPTR (input_row);
outptr := JCOEFPTR (output_row);
for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do
begin
outptr^ := inptr^;
Inc(outptr);
Inc(inptr);
end;
{$endif}
end;
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
{ Zero out a chunk of FAR memory. }
{ This might be sample-array data, block-array data, or alloc_large data. }
{$ifdef FMEMZERO}
begin
FMEMZERO(target, bytestozero);
{$else}
var
ptr : byteptr;
count : size_t; {register}
begin
ptr := target;
for count := bytestozero-1 downto 0 do
begin
ptr^ := 0;
Inc(ptr);
end;
{$endif}
end;
end.
unit imjutils;
{ This file contains tables and miscellaneous utility routines needed
for both compression and decompression.
Note we prefix all global names with "j" to minimize conflicts with
a surrounding application. }
{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element
of a DCT block read in natural order (left to right, top to bottom). }
{$ifdef FALSE} { This table is not actually needed in v6a }
const
jpeg_zigzag_order : array[0..DCTSIZE2] of int =
(0, 1, 5, 6, 14, 15, 27, 28,
2, 4, 7, 13, 16, 26, 29, 42,
3, 8, 12, 17, 25, 30, 41, 43,
9, 11, 18, 24, 31, 40, 44, 53,
10, 19, 23, 32, 39, 45, 52, 54,
20, 22, 33, 38, 46, 51, 55, 60,
21, 34, 37, 47, 50, 56, 59, 61,
35, 36, 48, 49, 57, 58, 62, 63);
{$endif}
{ jpeg_natural_order[i] is the natural-order position of the i'th element
of zigzag order.
When reading corrupted data, the Huffman decoders could attempt
to reference an entry beyond the end of this array (if the decoded
zero run length reaches past the end of the block). To prevent
wild stores without adding an inner-loop test, we put some extra
"63"s after the real entries. This will cause the extra coefficient
to be stored in location 63 of the block, not somewhere random.
The worst case would be a run-length of 15, which means we need 16
fake entries. }
const
jpeg_natural_order : array[0..DCTSIZE2+16-1] of int =
(0, 1, 8, 16, 9, 2, 3, 10,
17, 24, 32, 25, 18, 11, 4, 5,
12, 19, 26, 33, 40, 48, 41, 34,
27, 20, 13, 6, 7, 14, 21, 28,
35, 42, 49, 56, 57, 50, 43, 36,
29, 22, 15, 23, 30, 37, 44, 51,
58, 59, 52, 45, 38, 31, 39, 46,
53, 60, 61, 54, 47, 55, 62, 63,
63, 63, 63, 63, 63, 63, 63, 63, { extra entries for safety in decoder }
63, 63, 63, 63, 63, 63, 63, 63);
{ Arithmetic utilities }
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY;
source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
procedure FMEMZERO(target : pointer; size : size_t);
procedure FMEMCOPY(dest,src : pointer; size : size_t);
implementation
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{ Compute a/b rounded up to next integer, ie, ceil(a/b) }
{ Assumes a >= 0, b > 0 }
begin
jdiv_round_up := (a + b - long(1)) div b;
end;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b }
{ Assumes a >= 0, b > 0 }
begin
Inc(a, b - long(1));
jround_up := a - (a mod b);
end;
{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays
and coefficient-block arrays. This won't work on 80x86 because the arrays
are FAR and we're assuming a small-pointer memory model. However, some
DOS compilers provide far-pointer versions of memcpy() and memset() even
in the small-model libraries. These will be used if USE_FMEM is defined.
Otherwise, the routines below do it the hard way. (The performance cost
is not all that great, because these routines aren't very heavily used.) }
{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros }
procedure FMEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure FMEMCOPY(dest,src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{$else} { 80x86 case, define if we can }
{$ifdef USE_FMEM}
FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size))
FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size))
{$endif}
{$endif}
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{ Copy some rows of samples from one place to another.
num_rows rows are copied from input_array[source_row++]
to output_array[dest_row++]; these areas may overlap for duplication.
The source and destination arrays must be at least as wide as num_cols. }
var
inptr, outptr : JSAMPLE_PTR; {register}
{$ifdef FMEMCOPY}
count : size_t; {register}
{$else}
count : JDIMENSION; {register}
{$endif}
row : int; {register}
begin
{$ifdef FMEMCOPY}
count := size_t(num_cols * SIZEOF(JSAMPLE));
{$endif}
Inc(JSAMPROW_PTR(input_array), source_row);
Inc(JSAMPROW_PTR(output_array), dest_row);
for row := pred(num_rows) downto 0 do
begin
inptr := JSAMPLE_PTR(input_array^[0]);
Inc(JSAMPROW_PTR(input_array));
outptr := JSAMPLE_PTR(output_array^[0]);
Inc(JSAMPROW_PTR(output_array));
{$ifdef FMEMCOPY}
FMEMCOPY(outptr, inptr, count);
{$else}
for count := pred(num_cols) downto 0 do
begin
outptr^ := inptr^; { needn't bother with GETJSAMPLE() here }
Inc(inptr);
Inc(outptr);
end;
{$endif}
end;
end;
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{ Copy a row of coefficient blocks from one place to another. }
{$ifdef FMEMCOPY}
begin
FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF)));
{$else}
var
inptr, outptr : JCOEFPTR; {register}
count : long; {register}
begin
inptr := JCOEFPTR (input_row);
outptr := JCOEFPTR (output_row);
for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do
begin
outptr^ := inptr^;
Inc(outptr);
Inc(inptr);
end;
{$endif}
end;
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
{ Zero out a chunk of FAR memory. }
{ This might be sample-array data, block-array data, or alloc_large data. }
{$ifdef FMEMZERO}
begin
FMEMZERO(target, bytestozero);
{$else}
var
ptr : byteptr;
count : size_t; {register}
begin
ptr := target;
for count := bytestozero-1 downto 0 do
begin
ptr^ := 0;
Inc(ptr);
end;
{$endif}
end;
end.

760
Imaging/JpegLib/readme.txt
View File

@ -1,381 +1,381 @@
_____________________________________________________________________________
PASJPEG 1.1 May 29th, 1999
Based on the Independent JPEG Group's JPEG software release 6b
Copyright (C) 1996,1998,1999 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Information in this file
========================
o Introduction
o Notes
o File list
o Translation
o Legal issues
o Archive Locations
Introduction
============
PASJPEG is a port of the sixth public release of the IJG C source (release
6b of 27-Mar-98) [3], that implements JPEG baseline, extended-sequential, and
progressive compression processes to Turbo Pascal 7.0 for DOS (TP). The code
has been tested under Delphi 3.0, it can be ported to other Pascal
environments, since many compilers try to be compatible to TP.
JPEG (pronounced "jay-peg") is a standardized familly of algorithms for
compression of continous tone still images. Most JPEG processes are lossy,
the output image is not exactly identical to the input image. However, on
typical photographic images, very good compression levels can be obtained
with no visible change, and remarkably high compression levels are possible
if you can tolerate a low-quality image [1],[2]. The Independent JPEG Group
(IJG) has created a free, portable C library for JPEG compression and
decompression of JPEG images.
The IJG documentation (system architecture, using the IJG JPEG library,
usage and file list) is a must read. The files DEMO.PAS, TEST.PAS, CJPEG.PAS,
DJPEG.PAS and EXAMPLE.PAS demonstrate the usage of the JPEG decompression
and compression library. The RDJPGCOM application shows how to parse a JFIF
file.
Notes:
======
* Please report any errors/problems you may find in code and in the
documentation (e.g. this README.TXT file).
* The sample applications (CJPEG, DJPEG) doesn't support all the options
of the original C code. WRJPGCOM is not ported.
* Environment variable JPEGMEM syntax changed;
* You can modify the jpeg.pas unit from the Delphi 3 distribution to
use PasJPEG.
Change log
==========
1. bugs fixed:
* in procedure read_gif_map(), unit RDCOLMAP.PAS (used by DJPEG sample
application). Davie Lee Reed <smatters@iquest.net>
* -dct int and -dct fast now bytewise equal to the IJG output.
* -dct float produced large files
2. Support for scripts
3. BASM version of JIDCTINT.PAS for Delphi 2 and 3.
4. images with integral sampling ratios were not decoded correctly.
Create a jpeg file with cjpeg and the option "-sample 4x1" and try to decode
it with any software that uses PasJpeg. Thanks to Jannie Gerber for reporting
this with a fix: In JDSAMPLE.PAS, procedure int_upsample(),
for h := pred(h_expand) downto 0 do
begin
outptr^ := invalue;
+=> inc(outptr); { this is the culprit that was left out!!! }
Dec(outcount);
end;
File list
=========
Here is a road map to the files in the PasJPEG distribution. The
distribution includes the JPEG library proper, plus two application
programs ("cjpeg" and "djpeg") which use the library to convert JPEG
files to and from some other popular image formats. A third application
"jpegtran" uses the library to do lossless conversion between different
variants of JPEG. There is also the stand-alone applications "rdjpgcom".
Documentation(see README for a guide to the documentation files):
readme.txt Introduction, Documentation
Additional files
demo.pas Demo program, uses example.pas
example.pas Sample code for calling JPEG library.
test.pas Sample application code for demo.pas
Configuration/installation files and programs (see install.doc for more info):
jconfig.inc Configuration declarations.
*.ijg script files
Pascal source code files:
jinclude.pas Central include file used by all IJG .c files to reference
system include files.
jpeglib.pas JPEG library's internal data structures, exported data
and function declarations.
jmorecfg.pas Additional configuration declarations; need not be changed
for a standard installation.
jdeferr.pas defines the error and message text.
jerror.pas Declares JPEG library's error and trace message codes.
jinclude.pas the place to specify system depedent input/output code.
jdct.pas Private declarations for forward & reverse DCT subsystems.
These files contain most of the functions intended to be called directly by
an application program:
jcapimin.pas Application program interface: core routines for compression.
jcapistd.pas Application program interface: standard compression.
jdapimin.pas Application program interface: core routines for decompression.
jdapistd.pas Application program interface: standard decompression.
jcomapi.pas Application program interface routines common to compression
and decompression.
jcparam.pas Compression parameter setting helper routines.
jctrans.pas API and library routines for transcoding compression.
jdtrans.pas API and library routines for transcoding decompression.
Compression side of the library:
jcinit.pas Initialization: determines which other modules to use.
jcmaster.pas Master control: setup and inter-pass sequencing logic.
jcmainct.pas Main buffer controller (preprocessor => JPEG compressor).
jcprepct.pas Preprocessor buffer controller.
jccoefct.pas Buffer controller for DCT coefficient buffer.
jccolor.pas Color space conversion.
jcsample.pas Downsampling.
jcdctmgr.pas DCT manager (DCT implementation selection & control).
jfdctint.pas Forward DCT using slow-but-accurate integer method.
jfdctfst.pas Forward DCT using faster, less accurate integer method.
jfdctflt.pas Forward DCT using floating-point arithmetic.
jchuff.pas Huffman entropy coding for sequential JPEG.
jcphuff.pas Huffman entropy coding for progressive JPEG.
jcmarker.pas JPEG marker writing.
jdatadst.pas Data destination manager for stdio output.
Decompression side of the library:
jdmaster.pas Master control: determines which other modules to use.
jdinput.pas Input controller: controls input processing modules.
jdmainct.pas Main buffer controller (JPEG decompressor => postprocessor).
jdcoefct.pas Buffer controller for DCT coefficient buffer.
jdpostct.pas Postprocessor buffer controller.
jdmarker.pas JPEG marker reading.
jdhuff.pas Huffman entropy decoding for sequential JPEG.
jdphuff.pas Huffman entropy decoding for progressive JPEG.
jddctmgr.pas IDCT manager (IDCT implementation selection & control).
jidctint.pas Inverse DCT using slow-but-accurate integer method.
jidctasm.pas BASM specific version of jidctint.pas for 32bit Delphi.
jidctfst.pas Inverse DCT using faster, less accurate integer method.
jidctflt.pas Inverse DCT using floating-point arithmetic.
jidctred.pas Inverse DCTs with reduced-size outputs.
jidct2d.pas How to for a direct 2D Inverse DCT - not used
jdsample.pas Upsampling.
jdcolor.pas Color space conversion.
jdmerge.pas Merged upsampling/color conversion (faster, lower quality).
jquant1.pas One-pass color quantization using a fixed-spacing colormap.
jquant2.pas Two-pass color quantization using a custom-generated colormap.
Also handles one-pass quantization to an externally given map.
jdatasrc.pas Data source manager for stdio input.
Support files for both compression and decompression:
jerror.pas Standard error handling routines (application replaceable).
jmemmgr.pas System-independent (more or less) memory management code.
jutils.pas Miscellaneous utility routines.
jmemmgr.pas relies on a system-dependent memory management module. The
PASJPEG distribution includes the following implementations of the system-
dependent module:
jmemnobs.pas "No backing store": assumes adequate virtual memory exists.
jmemdos.pas Custom implementation for MS-DOS (16-bit environment only):
can use extended and expanded memory as well as temporary
files.
jmemsys.pas A skeleton with all the declaration you need to create a
working system-dependent JPEG memory manager on unusual
systems.
Exactly one of the system-dependent units should be used in jmemmgr.pas.
jmemdosa.pas BASM 80x86 assembly code support for jmemdos.pas; used only
in MS-DOS-specific configurations of the JPEG library.
Applications using the library should use jmorecfg, jerror, jpeglib, and
include jconfig.inc.
CJPEG/DJPEG/JPEGTRAN
Pascal source code files:
cderror.pas Additional error and trace message codes for cjpeg/djpeg.
Not used, Those errors have been added to jdeferr.
cjpeg.pas Main program for cjpeg.
djpeg.pas Main program for djpeg.
jpegtran.pas Main program for jpegtran.
cdjpeg.pas Utility routines used by all three programs.
rdcolmap.pas Code to read a colormap file for djpeg's "-map" switch.
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
transupp.pas Support code for jpegtran: lossless image manipulations.
fcache.pas
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
Image file writer modules for djpeg:
wrbmp.pas BMP file output.
wrppm.pas PPM/PGM file output.
wrtarga.pas Targa file output.
Image file reader modules for cjpeg:
rdbmp.pas BMP file input.
rdppm.pas PPM/PGM file input.
rdtarga.pas Targa file input. - NOT READY YET
This program does not depend on the JPEG library
rdjpgcom.pas Stand-alone rdjpgcom application.
Translation
===========
TP is unit-centric, exported type definitions and routines are declared
in the "interface" part of the unit, "make" files are not needed.
Macros are not supported, they were either copied as needed or translated
to Pascal routines (procedure). The procedures will be replaced by code in
later releases.
Conditional defines that indicate whether to include various optional
functions are defined in the file JCONFIG.INC. This file is included first
in all source files.
The base type definitions are in the unit JMORECFG.PAS. The error handling
macros have been converted to procedures in JERROR.PAS. The error codes are
in JDEFERR.PAS. jpegint.h and jpeglib.h were merged into one large unit
JPEGLIB.PAS containing type definitions with global scope.
The translation of the header file is the most sophisticated work, a good
understanding of the syntax is required. Once the header files are done,
the translation turns into a lot of editing work. Each C source file was
converted to a unit by editing the syntax (separate variable definition
and usage, define labels, group variable definitions, expanding macros, etc).
The IJG source labels routines GLOBAL, METHODDEF and LOCAL. All globals
routines are in the interface section of the units. The "far" directive is
used for methods (METHODDEF).
Some C -> Pascal examples.
* "{" -> "begin" "->" -> "^." " = " -> " := " "<<" -> " shl "
"}" -> "end;" "!=" -> "<>" " == " -> " = " ">>" -> " shr "
"/*" -> "{" routine -> function "0x" -> "$"
"*/" -> "}" (void) procedure "NULL" -> "NIL"
* structs are records, Unions are variable records, pointers are always far,
the operators && and || (and/or) have not the same priority in both
languages, so parenthesis are important. The Pascal "case" doesn't have the
falltrough option of the C "switch" statement, my work around is to split
one "switch" statement into many case statements.
* The pointer type in C is not readily interchangeable. It is used to address
an array (Pascal pointer to an array) or in pointer arithmetic a pointer to
a single element. I've used the Inc() statement with type casting to
translate pointer arithmetic most of the time.
C example:
typedef JSAMPLE* JSAMPROW; /* ptr to one image row of pixel samples. */
Pascal
type
JSAMPLE_PTR = ^JSAMPLE; { ptr to a single pixel sample. }
jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1;
JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far}
JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. }
The following code
JSAMPROW buffer0, buffer1; /* ptr to a JSAMPLE buffer. */
...
buffer1 = buffer0 + i;
can be translated to
var
buffer0, buffer1 : JSAMPROW;
...
buffer1 := buffer0;
Inc(JSAMPLE_PTR(buffer1), i);
or
buffer1 := JSAMPROW(@ buffer0^[i]);
Declaring the variables as JSAMPLE_PTR may reduce type casting in some
places. I use help pointers to handle negative array offsets.
While translating the type of function parameter from C to Pascal, one can
often use "var", "const", or "array of" parameters instead of pointers.
While translating for(;;)-loops with more than one induction variable to
Pascal "for to/downto do"-loops, the extra induction variables have to be
manually updated at the end of the loop and before "continue"-statements.
Legal issues
============
Copyright (C) 1996,1998 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
[1] Thomas G. Lane, JPEG FAQ
in comp.graphics.misc and related newsgroups
[2] Wallace, Gregory K.: The JPEG Still Picture Compression Standard
ftp.uu.net, graphics/jpeg/wallace.ps.Z
[3] The Independent JPEG Group C library for JPEG encoding and decoding,
rev 6b.
ftp://ftp.uu.net/graphics/jpeg/
or SimTel in msdos/graphics/
[4] JPEG implementation, written by the PVRG group at Stanford,
ftp havefun.stanford.edu:/pub/jpeg/JPEGv1.2.tar.Z.
[5] PASJPEG.ZIP at NView ftp site
ftp://druckfix.physik.tu-chemnitz.de/pub/nv/
http://www.tu-chemnitz.de/~nomssi/pub/pasjpeg.zip
[6] The PasJPEG home page with links
http://www.tu-chemnitz.de/~nomssi/pasjpeg.html
_____________________________________________________________________________
PASJPEG 1.1 May 29th, 1999
Based on the Independent JPEG Group's JPEG software release 6b
Copyright (C) 1996,1998,1999 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Information in this file
========================
o Introduction
o Notes
o File list
o Translation
o Legal issues
o Archive Locations
Introduction
============
PASJPEG is a port of the sixth public release of the IJG C source (release
6b of 27-Mar-98) [3], that implements JPEG baseline, extended-sequential, and
progressive compression processes to Turbo Pascal 7.0 for DOS (TP). The code
has been tested under Delphi 3.0, it can be ported to other Pascal
environments, since many compilers try to be compatible to TP.
JPEG (pronounced "jay-peg") is a standardized familly of algorithms for
compression of continous tone still images. Most JPEG processes are lossy,
the output image is not exactly identical to the input image. However, on
typical photographic images, very good compression levels can be obtained
with no visible change, and remarkably high compression levels are possible
if you can tolerate a low-quality image [1],[2]. The Independent JPEG Group
(IJG) has created a free, portable C library for JPEG compression and
decompression of JPEG images.
The IJG documentation (system architecture, using the IJG JPEG library,
usage and file list) is a must read. The files DEMO.PAS, TEST.PAS, CJPEG.PAS,
DJPEG.PAS and EXAMPLE.PAS demonstrate the usage of the JPEG decompression
and compression library. The RDJPGCOM application shows how to parse a JFIF
file.
Notes:
======
* Please report any errors/problems you may find in code and in the
documentation (e.g. this README.TXT file).
* The sample applications (CJPEG, DJPEG) doesn't support all the options
of the original C code. WRJPGCOM is not ported.
* Environment variable JPEGMEM syntax changed;
* You can modify the jpeg.pas unit from the Delphi 3 distribution to
use PasJPEG.
Change log
==========
1. bugs fixed:
* in procedure read_gif_map(), unit RDCOLMAP.PAS (used by DJPEG sample
application). Davie Lee Reed <smatters@iquest.net>
* -dct int and -dct fast now bytewise equal to the IJG output.
* -dct float produced large files
2. Support for scripts
3. BASM version of JIDCTINT.PAS for Delphi 2 and 3.
4. images with integral sampling ratios were not decoded correctly.
Create a jpeg file with cjpeg and the option "-sample 4x1" and try to decode
it with any software that uses PasJpeg. Thanks to Jannie Gerber for reporting
this with a fix: In JDSAMPLE.PAS, procedure int_upsample(),
for h := pred(h_expand) downto 0 do
begin
outptr^ := invalue;
+=> inc(outptr); { this is the culprit that was left out!!! }
Dec(outcount);
end;
File list
=========
Here is a road map to the files in the PasJPEG distribution. The
distribution includes the JPEG library proper, plus two application
programs ("cjpeg" and "djpeg") which use the library to convert JPEG
files to and from some other popular image formats. A third application
"jpegtran" uses the library to do lossless conversion between different
variants of JPEG. There is also the stand-alone applications "rdjpgcom".
Documentation(see README for a guide to the documentation files):
readme.txt Introduction, Documentation
Additional files
demo.pas Demo program, uses example.pas
example.pas Sample code for calling JPEG library.
test.pas Sample application code for demo.pas
Configuration/installation files and programs (see install.doc for more info):
jconfig.inc Configuration declarations.
*.ijg script files
Pascal source code files:
jinclude.pas Central include file used by all IJG .c files to reference
system include files.
jpeglib.pas JPEG library's internal data structures, exported data
and function declarations.
jmorecfg.pas Additional configuration declarations; need not be changed
for a standard installation.
jdeferr.pas defines the error and message text.
jerror.pas Declares JPEG library's error and trace message codes.
jinclude.pas the place to specify system depedent input/output code.
jdct.pas Private declarations for forward & reverse DCT subsystems.
These files contain most of the functions intended to be called directly by
an application program:
jcapimin.pas Application program interface: core routines for compression.
jcapistd.pas Application program interface: standard compression.
jdapimin.pas Application program interface: core routines for decompression.
jdapistd.pas Application program interface: standard decompression.
jcomapi.pas Application program interface routines common to compression
and decompression.
jcparam.pas Compression parameter setting helper routines.
jctrans.pas API and library routines for transcoding compression.
jdtrans.pas API and library routines for transcoding decompression.
Compression side of the library:
jcinit.pas Initialization: determines which other modules to use.
jcmaster.pas Master control: setup and inter-pass sequencing logic.
jcmainct.pas Main buffer controller (preprocessor => JPEG compressor).
jcprepct.pas Preprocessor buffer controller.
jccoefct.pas Buffer controller for DCT coefficient buffer.
jccolor.pas Color space conversion.
jcsample.pas Downsampling.
jcdctmgr.pas DCT manager (DCT implementation selection & control).
jfdctint.pas Forward DCT using slow-but-accurate integer method.
jfdctfst.pas Forward DCT using faster, less accurate integer method.
jfdctflt.pas Forward DCT using floating-point arithmetic.
jchuff.pas Huffman entropy coding for sequential JPEG.
jcphuff.pas Huffman entropy coding for progressive JPEG.
jcmarker.pas JPEG marker writing.
jdatadst.pas Data destination manager for stdio output.
Decompression side of the library:
jdmaster.pas Master control: determines which other modules to use.
jdinput.pas Input controller: controls input processing modules.
jdmainct.pas Main buffer controller (JPEG decompressor => postprocessor).
jdcoefct.pas Buffer controller for DCT coefficient buffer.
jdpostct.pas Postprocessor buffer controller.
jdmarker.pas JPEG marker reading.
jdhuff.pas Huffman entropy decoding for sequential JPEG.
jdphuff.pas Huffman entropy decoding for progressive JPEG.
jddctmgr.pas IDCT manager (IDCT implementation selection & control).
jidctint.pas Inverse DCT using slow-but-accurate integer method.
jidctasm.pas BASM specific version of jidctint.pas for 32bit Delphi.
jidctfst.pas Inverse DCT using faster, less accurate integer method.
jidctflt.pas Inverse DCT using floating-point arithmetic.
jidctred.pas Inverse DCTs with reduced-size outputs.
jidct2d.pas How to for a direct 2D Inverse DCT - not used
jdsample.pas Upsampling.
jdcolor.pas Color space conversion.
jdmerge.pas Merged upsampling/color conversion (faster, lower quality).
jquant1.pas One-pass color quantization using a fixed-spacing colormap.
jquant2.pas Two-pass color quantization using a custom-generated colormap.
Also handles one-pass quantization to an externally given map.
jdatasrc.pas Data source manager for stdio input.
Support files for both compression and decompression:
jerror.pas Standard error handling routines (application replaceable).
jmemmgr.pas System-independent (more or less) memory management code.
jutils.pas Miscellaneous utility routines.
jmemmgr.pas relies on a system-dependent memory management module. The
PASJPEG distribution includes the following implementations of the system-
dependent module:
jmemnobs.pas "No backing store": assumes adequate virtual memory exists.
jmemdos.pas Custom implementation for MS-DOS (16-bit environment only):
can use extended and expanded memory as well as temporary
files.
jmemsys.pas A skeleton with all the declaration you need to create a
working system-dependent JPEG memory manager on unusual
systems.
Exactly one of the system-dependent units should be used in jmemmgr.pas.
jmemdosa.pas BASM 80x86 assembly code support for jmemdos.pas; used only
in MS-DOS-specific configurations of the JPEG library.
Applications using the library should use jmorecfg, jerror, jpeglib, and
include jconfig.inc.
CJPEG/DJPEG/JPEGTRAN
Pascal source code files:
cderror.pas Additional error and trace message codes for cjpeg/djpeg.
Not used, Those errors have been added to jdeferr.
cjpeg.pas Main program for cjpeg.
djpeg.pas Main program for djpeg.
jpegtran.pas Main program for jpegtran.
cdjpeg.pas Utility routines used by all three programs.
rdcolmap.pas Code to read a colormap file for djpeg's "-map" switch.
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
transupp.pas Support code for jpegtran: lossless image manipulations.
fcache.pas
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
Image file writer modules for djpeg:
wrbmp.pas BMP file output.
wrppm.pas PPM/PGM file output.
wrtarga.pas Targa file output.
Image file reader modules for cjpeg:
rdbmp.pas BMP file input.
rdppm.pas PPM/PGM file input.
rdtarga.pas Targa file input. - NOT READY YET
This program does not depend on the JPEG library
rdjpgcom.pas Stand-alone rdjpgcom application.
Translation
===========
TP is unit-centric, exported type definitions and routines are declared
in the "interface" part of the unit, "make" files are not needed.
Macros are not supported, they were either copied as needed or translated
to Pascal routines (procedure). The procedures will be replaced by code in
later releases.
Conditional defines that indicate whether to include various optional
functions are defined in the file JCONFIG.INC. This file is included first
in all source files.
The base type definitions are in the unit JMORECFG.PAS. The error handling
macros have been converted to procedures in JERROR.PAS. The error codes are
in JDEFERR.PAS. jpegint.h and jpeglib.h were merged into one large unit
JPEGLIB.PAS containing type definitions with global scope.
The translation of the header file is the most sophisticated work, a good
understanding of the syntax is required. Once the header files are done,
the translation turns into a lot of editing work. Each C source file was
converted to a unit by editing the syntax (separate variable definition
and usage, define labels, group variable definitions, expanding macros, etc).
The IJG source labels routines GLOBAL, METHODDEF and LOCAL. All globals
routines are in the interface section of the units. The "far" directive is
used for methods (METHODDEF).
Some C -> Pascal examples.
* "{" -> "begin" "->" -> "^." " = " -> " := " "<<" -> " shl "
"}" -> "end;" "!=" -> "<>" " == " -> " = " ">>" -> " shr "
"/*" -> "{" routine -> function "0x" -> "$"
"*/" -> "}" (void) procedure "NULL" -> "NIL"
* structs are records, Unions are variable records, pointers are always far,
the operators && and || (and/or) have not the same priority in both
languages, so parenthesis are important. The Pascal "case" doesn't have the
falltrough option of the C "switch" statement, my work around is to split
one "switch" statement into many case statements.
* The pointer type in C is not readily interchangeable. It is used to address
an array (Pascal pointer to an array) or in pointer arithmetic a pointer to
a single element. I've used the Inc() statement with type casting to
translate pointer arithmetic most of the time.
C example:
typedef JSAMPLE* JSAMPROW; /* ptr to one image row of pixel samples. */
Pascal
type
JSAMPLE_PTR = ^JSAMPLE; { ptr to a single pixel sample. }
jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1;
JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far}
JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. }
The following code
JSAMPROW buffer0, buffer1; /* ptr to a JSAMPLE buffer. */
...
buffer1 = buffer0 + i;
can be translated to
var
buffer0, buffer1 : JSAMPROW;
...
buffer1 := buffer0;
Inc(JSAMPLE_PTR(buffer1), i);
or
buffer1 := JSAMPROW(@ buffer0^[i]);
Declaring the variables as JSAMPLE_PTR may reduce type casting in some
places. I use help pointers to handle negative array offsets.
While translating the type of function parameter from C to Pascal, one can
often use "var", "const", or "array of" parameters instead of pointers.
While translating for(;;)-loops with more than one induction variable to
Pascal "for to/downto do"-loops, the extra induction variables have to be
manually updated at the end of the loop and before "continue"-statements.
Legal issues
============
Copyright (C) 1996,1998 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
[1] Thomas G. Lane, JPEG FAQ
in comp.graphics.misc and related newsgroups
[2] Wallace, Gregory K.: The JPEG Still Picture Compression Standard
ftp.uu.net, graphics/jpeg/wallace.ps.Z
[3] The Independent JPEG Group C library for JPEG encoding and decoding,
rev 6b.
ftp://ftp.uu.net/graphics/jpeg/
or SimTel in msdos/graphics/
[4] JPEG implementation, written by the PVRG group at Stanford,
ftp havefun.stanford.edu:/pub/jpeg/JPEGv1.2.tar.Z.
[5] PASJPEG.ZIP at NView ftp site
ftp://druckfix.physik.tu-chemnitz.de/pub/nv/
http://www.tu-chemnitz.de/~nomssi/pub/pasjpeg.zip
[6] The PasJPEG home page with links
http://www.tu-chemnitz.de/~nomssi/pasjpeg.html
_____________________________________________________________________________

228
Imaging/ZLib/imadler.pas
View File

@ -1,114 +1,114 @@
Unit imadler;
{
adler32.c -- compute the Adler-32 checksum of a data stream
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil;
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
return the updated checksum. If buf is NIL, this function returns
the required initial value for the checksum.
An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
much faster. Usage example:
var
adler : uLong;
begin
adler := adler32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do
adler := adler32(adler, buffer, length);
if (adler <> original_adler) then
error();
end;
}
implementation
const
BASE = uLong(65521); { largest prime smaller than 65536 }
{NMAX = 5552; original code with unsigned 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 }
NMAX = 3854; { code with signed 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 }
{ The penalty is the time loss in the extra MOD-calls. }
{ ========================================================================= }
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
var
s1, s2 : uLong;
k : int;
begin
s1 := adler and $ffff;
s2 := (adler shr 16) and $ffff;
if not Assigned(buf) then
begin
adler32 := uLong(1);
exit;
end;
while (len > 0) do
begin
if len < NMAX then
k := len
else
k := NMAX;
Dec(len, k);
{
while (k >= 16) do
begin
DO16(buf);
Inc(buf, 16);
Dec(k, 16);
end;
if (k <> 0) then
repeat
Inc(s1, buf^);
Inc(puf);
Inc(s2, s1);
Dec(k);
until (k = 0);
}
while (k > 0) do
begin
Inc(s1, buf^);
Inc(s2, s1);
Inc(buf);
Dec(k);
end;
s1 := s1 mod BASE;
s2 := s2 mod BASE;
end;
adler32 := (s2 shl 16) or s1;
end;
{
#define DO1(buf,i)
begin
Inc(s1, buf[i]);
Inc(s2, s1);
end;
#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
#define DO16(buf) DO8(buf,0); DO8(buf,8);
}
end.
Unit imadler;
{
adler32.c -- compute the Adler-32 checksum of a data stream
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil;
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
return the updated checksum. If buf is NIL, this function returns
the required initial value for the checksum.
An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
much faster. Usage example:
var
adler : uLong;
begin
adler := adler32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do
adler := adler32(adler, buffer, length);
if (adler <> original_adler) then
error();
end;
}
implementation
const
BASE = uLong(65521); { largest prime smaller than 65536 }
{NMAX = 5552; original code with unsigned 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 }
NMAX = 3854; { code with signed 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 }
{ The penalty is the time loss in the extra MOD-calls. }
{ ========================================================================= }
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
var
s1, s2 : uLong;
k : int;
begin
s1 := adler and $ffff;
s2 := (adler shr 16) and $ffff;
if not Assigned(buf) then
begin
adler32 := uLong(1);
exit;
end;
while (len > 0) do
begin
if len < NMAX then
k := len
else
k := NMAX;
Dec(len, k);
{
while (k >= 16) do
begin
DO16(buf);
Inc(buf, 16);
Dec(k, 16);
end;
if (k <> 0) then
repeat
Inc(s1, buf^);
Inc(puf);
Inc(s2, s1);
Dec(k);
until (k = 0);
}
while (k > 0) do
begin
Inc(s1, buf^);
Inc(s2, s1);
Inc(buf);
Dec(k);
end;
s1 := s1 mod BASE;
s2 := s2 mod BASE;
end;
adler32 := (s2 shl 16) or s1;
end;
{
#define DO1(buf,i)
begin
Inc(s1, buf[i]);
Inc(s2, s1);
end;
#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
#define DO16(buf) DO8(buf,0); DO8(buf,8);
}
end.

1902
Imaging/ZLib/iminfblock.pas
View File

File diff suppressed because it is too large Load Diff

1560
Imaging/ZLib/iminftrees.pas
View File

File diff suppressed because it is too large Load Diff

444
Imaging/ZLib/iminfutil.pas
View File

@ -1,222 +1,222 @@
Unit iminfutil;
{ types and macros common to blocks and codes
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil, impaszlib;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
{ And'ing with mask[n] masks the lower n bits }
const
inflate_mask : array[0..17-1] of uInt = (
$0000,
$0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
$01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);
{procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);}
implementation
{ macros for bit input with no checking and for returning unused bytes }
procedure GRABBITS(j : int);
begin
{while (k < j) do
begin
Dec(z^.avail_in);
Inc(z^.total_in);
b := b or (uLong(z^.next_in^) shl k);
Inc(z^.next_in);
Inc(k, 8);
end;}
end;
procedure DUMPBITS(j : int);
begin
{b := b shr j;
Dec(k, j);}
end;
procedure NEEDBITS(j : int);
begin
(*
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
*)
end;
procedure NEEDOUT;
begin
(*
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
*)
end;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
n : uInt;
p : pBytef;
q : pBytef;
begin
{ local copies of source and destination pointers }
p := z.next_out;
q := s.read;
{ compute number of bytes to copy as far as end of window }
if ptr2int(q) <= ptr2int(s.write) then
n := uInt(ptr2int(s.write) - ptr2int(q))
else
n := uInt(ptr2int(s.zend) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec(z.avail_out, n);
Inc(z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy as far as end of window }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
{ see if more to copy at beginning of window }
if (q = s.zend) then
begin
{ wrap pointers }
q := s.window;
if (s.write = s.zend) then
s.write := s.window;
{ compute bytes to copy }
n := uInt(ptr2int(s.write) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec( z.avail_out, n);
Inc( z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
end;
{ update pointers }
z.next_out := p;
s.read := q;
{ done }
inflate_flush := r;
end;
end.
Unit iminfutil;
{ types and macros common to blocks and codes
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil, impaszlib;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
{ And'ing with mask[n] masks the lower n bits }
const
inflate_mask : array[0..17-1] of uInt = (
$0000,
$0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
$01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);
{procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);}
implementation
{ macros for bit input with no checking and for returning unused bytes }
procedure GRABBITS(j : int);
begin
{while (k < j) do
begin
Dec(z^.avail_in);
Inc(z^.total_in);
b := b or (uLong(z^.next_in^) shl k);
Inc(z^.next_in);
Inc(k, 8);
end;}
end;
procedure DUMPBITS(j : int);
begin
{b := b shr j;
Dec(k, j);}
end;
procedure NEEDBITS(j : int);
begin
(*
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
*)
end;
procedure NEEDOUT;
begin
(*
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
*)
end;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
n : uInt;
p : pBytef;
q : pBytef;
begin
{ local copies of source and destination pointers }
p := z.next_out;
q := s.read;
{ compute number of bytes to copy as far as end of window }
if ptr2int(q) <= ptr2int(s.write) then
n := uInt(ptr2int(s.write) - ptr2int(q))
else
n := uInt(ptr2int(s.zend) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec(z.avail_out, n);
Inc(z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy as far as end of window }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
{ see if more to copy at beginning of window }
if (q = s.zend) then
begin
{ wrap pointers }
q := s.window;
if (s.write = s.zend) then
s.write := s.window;
{ compute bytes to copy }
n := uInt(ptr2int(s.write) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec( z.avail_out, n);
Inc( z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
end;
{ update pointers }
z.next_out := p;
s.read := q;
{ done }
inflate_flush := r;
end;
end.

50
Imaging/ZLib/imzconf.inc
View File

@ -1,25 +1,25 @@
{ -------------------------------------------------------------------- }
{$DEFINE MAX_MATCH_IS_258}
{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more
than 64k bytes at a time (needed on systems with 16-bit int). }
{$UNDEF MAXSEG_64K}
{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }
{$UNDEF DYNAMIC_CRC_TABLE}
{$UNDEF FASTEST}
{$DEFINE Use32}
{$DEFINE patch112} { apply patch from the zlib home page }
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$UNDEF DEBUG} // for Delphi 2007 in DEBUG mode
{$RANGECHECKS OFF}
{$OVERFLOWCHECKS OFF}
{ -------------------------------------------------------------------- }
{ -------------------------------------------------------------------- }
{$DEFINE MAX_MATCH_IS_258}
{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more
than 64k bytes at a time (needed on systems with 16-bit int). }
{$UNDEF MAXSEG_64K}
{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }
{$UNDEF DYNAMIC_CRC_TABLE}
{$UNDEF FASTEST}
{$DEFINE Use32}
{$DEFINE patch112} { apply patch from the zlib home page }
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$UNDEF DEBUG} // for Delphi 2007 in DEBUG mode
{$RANGECHECKS OFF}
{$OVERFLOWCHECKS OFF}
{ -------------------------------------------------------------------- }

382
Imaging/ZLib/imzutil.pas
View File

@ -1,191 +1,191 @@
Unit imzutil;
{
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
{ Type declarations }
type
{Byte = usigned char; 8 bits}
Bytef = byte;
charf = byte;
int = longint;
intf = int;
uInt = cardinal; { 16 bits or more }
uIntf = uInt;
Long = longint;
uLong = Cardinal;
uLongf = uLong;
voidp = pointer;
voidpf = voidp;
pBytef = ^Bytef;
pIntf = ^intf;
puIntf = ^uIntf;
puLong = ^uLongf;
ptr2int = uInt;
{ a pointer to integer casting is used to do pointer arithmetic.
ptr2int must be an integer type and sizeof(ptr2int) must be less
than sizeof(pointer) - Nomssi }
type
zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef;
pzByteArray = ^zByteArray;
type
zIntfArray = array[0..(MaxInt div SizeOf(Intf))-1] of Intf;
pzIntfArray = ^zIntfArray;
type
zuIntArray = array[0..(MaxInt div SizeOf(uInt))-1] of uInt;
PuIntArray = ^zuIntArray;
{ Type declarations - only for deflate }
type
uch = Byte;
uchf = uch; { FAR }
ush = Word;
ushf = ush;
ulg = LongInt;
unsigned = uInt;
pcharf = ^charf;
puchf = ^uchf;
pushf = ^ushf;
type
zuchfArray = zByteArray;
puchfArray = ^zuchfArray;
type
zushfArray = array[0..(MaxInt div SizeOf(ushf))-1] of ushf;
pushfArray = ^zushfArray;
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
procedure zmemzero(destp : pBytef; len : uInt);
procedure zcfree(opaque : voidpf; ptr : voidpf);
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
implementation
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
begin
Move(sourcep^, destp^, len);
end;
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
var
j : uInt;
source,
dest : pBytef;
begin
source := s1p;
dest := s2p;
for j := 0 to pred(len) do
begin
if (source^ <> dest^) then
begin
zmemcmp := 2*Ord(source^ > dest^)-1;
exit;
end;
Inc(source);
Inc(dest);
end;
zmemcmp := 0;
end;
procedure zmemzero(destp : pBytef; len : uInt);
begin
FillChar(destp^, len, 0);
end;
procedure zcfree(opaque : voidpf; ptr : voidpf);
{$ifdef Delphi16}
var
Handle : THandle;
{$endif}
{$IFDEF FPC}
var
memsize : uint;
{$ENDIF}
begin
(*
{$IFDEF DPMI}
{h :=} GlobalFreePtr(ptr);
{$ELSE}
{$IFDEF CALL_DOS}
dosFree(ptr);
{$ELSE}
{$ifdef HugeMem}
FreeMemHuge(ptr);
{$else}
{$ifdef Delphi16}
Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
GlobalUnLock(Handle);
GlobalFree(Handle);
{$else}
{$IFDEF FPC}
Dec(puIntf(ptr));
memsize := puIntf(ptr)^;
FreeMem(ptr, memsize+SizeOf(uInt));
{$ELSE}
FreeMem(ptr); { Delphi 2,3,4 }
{$ENDIF}
{$endif}
{$endif}
{$ENDIF}
{$ENDIF}
*)
FreeMem(ptr);
end;
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
var
p : voidpf;
memsize : uLong;
{$ifdef Delphi16}
handle : THandle;
{$endif}
begin
memsize := uLong(items) * size;
(*
{ $IFDEF DPMI}
p := GlobalAllocPtr(gmem_moveable, memsize);
{ $ELSE}
{ $IFDEF CALLDOS}
p := dosAlloc(memsize);
{ $ELSE}
{$ifdef HugeMem}
GetMemHuge(p, memsize);
{ $else}
{ $ifdef Delphi16}
Handle := GlobalAlloc(HeapAllocFlags, memsize);
p := GlobalLock(Handle);
{ $else}
{ $IFDEF FPC}
GetMem(p, memsize+SizeOf(uInt));
puIntf(p)^:= memsize;
Inc(puIntf(p));
{ $ELSE}
GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }
{ $ENDIF}
{ $endif}
{ $endif}
{ $ENDIF}
{ $ENDIF}
*)
GetMem(p, memsize);
zcalloc := p;
end;
end.
Unit imzutil;
{
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
{ Type declarations }
type
{Byte = usigned char; 8 bits}
Bytef = byte;
charf = byte;
int = longint;
intf = int;
uInt = cardinal; { 16 bits or more }
uIntf = uInt;
Long = longint;
uLong = Cardinal;
uLongf = uLong;
voidp = pointer;
voidpf = voidp;
pBytef = ^Bytef;
pIntf = ^intf;
puIntf = ^uIntf;
puLong = ^uLongf;
ptr2int = uInt;
{ a pointer to integer casting is used to do pointer arithmetic.
ptr2int must be an integer type and sizeof(ptr2int) must be less
than sizeof(pointer) - Nomssi }
type
zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef;
pzByteArray = ^zByteArray;
type
zIntfArray = array[0..(MaxInt div SizeOf(Intf))-1] of Intf;
pzIntfArray = ^zIntfArray;
type
zuIntArray = array[0..(MaxInt div SizeOf(uInt))-1] of uInt;
PuIntArray = ^zuIntArray;
{ Type declarations - only for deflate }
type
uch = Byte;
uchf = uch; { FAR }
ush = Word;
ushf = ush;
ulg = LongInt;
unsigned = uInt;
pcharf = ^charf;
puchf = ^uchf;
pushf = ^ushf;
type
zuchfArray = zByteArray;
puchfArray = ^zuchfArray;
type
zushfArray = array[0..(MaxInt div SizeOf(ushf))-1] of ushf;
pushfArray = ^zushfArray;
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
procedure zmemzero(destp : pBytef; len : uInt);
procedure zcfree(opaque : voidpf; ptr : voidpf);
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
implementation
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
begin
Move(sourcep^, destp^, len);
end;
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
var
j : uInt;
source,
dest : pBytef;
begin
source := s1p;
dest := s2p;
for j := 0 to pred(len) do
begin
if (source^ <> dest^) then
begin
zmemcmp := 2*Ord(source^ > dest^)-1;
exit;
end;
Inc(source);
Inc(dest);
end;
zmemcmp := 0;
end;
procedure zmemzero(destp : pBytef; len : uInt);
begin
FillChar(destp^, len, 0);
end;
procedure zcfree(opaque : voidpf; ptr : voidpf);
{$ifdef Delphi16}
var
Handle : THandle;
{$endif}
{$IFDEF FPC}
var
memsize : uint;
{$ENDIF}
begin
(*
{$IFDEF DPMI}
{h :=} GlobalFreePtr(ptr);
{$ELSE}
{$IFDEF CALL_DOS}
dosFree(ptr);
{$ELSE}
{$ifdef HugeMem}
FreeMemHuge(ptr);
{$else}
{$ifdef Delphi16}
Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
GlobalUnLock(Handle);
GlobalFree(Handle);
{$else}
{$IFDEF FPC}
Dec(puIntf(ptr));
memsize := puIntf(ptr)^;
FreeMem(ptr, memsize+SizeOf(uInt));
{$ELSE}
FreeMem(ptr); { Delphi 2,3,4 }
{$ENDIF}
{$endif}
{$endif}
{$ENDIF}
{$ENDIF}
*)
FreeMem(ptr);
end;
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
var
p : voidpf;
memsize : uLong;
{$ifdef Delphi16}
handle : THandle;
{$endif}
begin
memsize := uLong(items) * size;
(*
{ $IFDEF DPMI}
p := GlobalAllocPtr(gmem_moveable, memsize);
{ $ELSE}
{ $IFDEF CALLDOS}
p := dosAlloc(memsize);
{ $ELSE}
{$ifdef HugeMem}
GetMemHuge(p, memsize);
{ $else}
{ $ifdef Delphi16}
Handle := GlobalAlloc(HeapAllocFlags, memsize);
p := GlobalLock(Handle);
{ $else}
{ $IFDEF FPC}
GetMem(p, memsize+SizeOf(uInt));
puIntf(p)^:= memsize;
Inc(puIntf(p));
{ $ELSE}
GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }
{ $ENDIF}
{ $endif}
{ $endif}
{ $ENDIF}
{ $ENDIF}
*)
GetMem(p, memsize);
zcalloc := p;
end;
end.

256
Imaging/ZLib/readme.txt
View File

@ -1,129 +1,129 @@
_____________________________________________________________________________
PASZLIB 1.0 May 11th, 1998
Based on the zlib 1.1.2, a general purpose data compression library.
Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Introduction
============
The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The default memory requirements for deflate are 256K plus a few kilobytes
for small objects. The default memory requirements for inflate are 32K
plus a few kilobytes for small objects.
Change Log
==========
March 24th 2000 - minizip code by Gilles Vollant ported to Pascal.
z_stream.msg defined as string[255] to avoid problems
with Delphi 2+ dynamic string handling.
changes to silence Delphi 5 compiler warning. If you
have Delphi 5, defines Delphi5 in zconf.inc
May 7th 1999 - Some changes for FPC
deflateCopy() has new parameters
trees.pas - record constant definition
June 17th 1998 - Applied official 1.1.2 patch.
Memcheck turned off by default.
zutil.pas patch for Delphi 1 memory allocation corrected.
dzlib.txt file added.
compress2() is now exported
June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was
missing in line 574;
File list
=========
Here is a road map to the files in the Paszlib distribution.
readme.txt Introduction, Documentation
dzlib.txt Changes to Delphi sources for Paszlib stream classes
include file
zconf.inc Configuration declarations.
Pascal source code files:
adler.pas compute the Adler-32 checksum of a data stream
crc.pas compute the CRC-32 of a data stream
gzio.pas IO on .gz files
infblock.pas interpret and process block types to last block
infcodes.pas process literals and length/distance pairs
inffast.pas process literals and length/distance pairs fast
inftrees.pas generate Huffman trees for efficient decoding
infutil.pas types and macros common to blocks and codes
strutils.pas string utilities
trees.pas output deflated data using Huffman coding
zcompres.pas compress a memory buffer
zdeflate.pas compress data using the deflation algorithm
zinflate.pas zlib interface to inflate modules
zlib.pas zlib data structures. read the comments there!
zuncompr.pas decompress a memory buffer
zutil.pas
minizip/ziputils.pas data structure and IO on .zip file
minizip/unzip.pas
minizip/zip.pas
Test applications
example.pas usage example of the zlib compression library
minigzip.pas simulate gzip using the zlib compression library
minizip/miniunz.pas simulates unzip using the zlib compression library
minizip/minizip.pas simulates zip using the zlib compression library
Legal issues
============
Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
Check the Paszlib home page with links
http://www.tu-chemnitz.de/~nomssi/paszlib.html
The data format used by the zlib library is described by RFCs (Request for
Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt
(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
These documents are also available in other formats from
ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html.
____________________________________________________________________________
_____________________________________________________________________________
PASZLIB 1.0 May 11th, 1998
Based on the zlib 1.1.2, a general purpose data compression library.
Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Introduction
============
The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The default memory requirements for deflate are 256K plus a few kilobytes
for small objects. The default memory requirements for inflate are 32K
plus a few kilobytes for small objects.
Change Log
==========
March 24th 2000 - minizip code by Gilles Vollant ported to Pascal.
z_stream.msg defined as string[255] to avoid problems
with Delphi 2+ dynamic string handling.
changes to silence Delphi 5 compiler warning. If you
have Delphi 5, defines Delphi5 in zconf.inc
May 7th 1999 - Some changes for FPC
deflateCopy() has new parameters
trees.pas - record constant definition
June 17th 1998 - Applied official 1.1.2 patch.
Memcheck turned off by default.
zutil.pas patch for Delphi 1 memory allocation corrected.
dzlib.txt file added.
compress2() is now exported
June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was
missing in line 574;
File list
=========
Here is a road map to the files in the Paszlib distribution.
readme.txt Introduction, Documentation
dzlib.txt Changes to Delphi sources for Paszlib stream classes
include file
zconf.inc Configuration declarations.
Pascal source code files:
adler.pas compute the Adler-32 checksum of a data stream
crc.pas compute the CRC-32 of a data stream
gzio.pas IO on .gz files
infblock.pas interpret and process block types to last block
infcodes.pas process literals and length/distance pairs
inffast.pas process literals and length/distance pairs fast
inftrees.pas generate Huffman trees for efficient decoding
infutil.pas types and macros common to blocks and codes
strutils.pas string utilities
trees.pas output deflated data using Huffman coding
zcompres.pas compress a memory buffer
zdeflate.pas compress data using the deflation algorithm
zinflate.pas zlib interface to inflate modules
zlib.pas zlib data structures. read the comments there!
zuncompr.pas decompress a memory buffer
zutil.pas
minizip/ziputils.pas data structure and IO on .zip file
minizip/unzip.pas
minizip/zip.pas
Test applications
example.pas usage example of the zlib compression library
minigzip.pas simulate gzip using the zlib compression library
minizip/miniunz.pas simulates unzip using the zlib compression library
minizip/minizip.pas simulates zip using the zlib compression library
Legal issues
============
Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
Check the Paszlib home page with links
http://www.tu-chemnitz.de/~nomssi/paszlib.html
The data format used by the zlib library is described by RFCs (Request for
Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt
(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
These documents are also available in other formats from
ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html.
____________________________________________________________________________
Jacques Nomssi Nzali <mailto:nomssi@physik.tu-chemnitz.de> March 24th, 2000

78
Logging.pas
View File

@ -1,39 +1,39 @@
unit Logging;
{$mode objfpc}{$H+}
interface
uses
MultiLog{$IFNDEF NoLogging}, IPCChannel{$ENDIF};
const
lcAll = [0..31]; //all logging classes
lcDebug = 0;
lcError = 1;
lcInfo = 2;
lcWarning = 3;
lcEvents = 4;
lcServer = 10;
lcClient = 11;
lcLandscape = 12;
var
Logger: TLogger;
implementation
initialization
Logger := TLogger.Create;
{$IFNDEF NoLogging}
Logger.Channels.Add(TIPCChannel.Create);
Logger.ActiveClasses := lcAll;
{$ENDIF}
finalization
Logger.Free;
end.
unit Logging;
{$mode objfpc}{$H+}
interface
uses
MultiLog{$IFNDEF NoLogging}, IPCChannel{$ENDIF};
const
lcAll = [0..31]; //all logging classes
lcDebug = 0;
lcError = 1;
lcInfo = 2;
lcWarning = 3;
lcEvents = 4;
lcServer = 10;
lcClient = 11;
lcLandscape = 12;
var
Logger: TLogger;
implementation
initialization
Logger := TLogger.Create;
{$IFNDEF NoLogging}
Logger.Channels.Add(TIPCChannel.Create);
Logger.ActiveClasses := lcAll;
{$ENDIF}
finalization
Logger.Free;
end.

266
MulProvider/UAnimDataProvider.pas
View File

@ -1,133 +1,133 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UAnimDataProvider;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UMulProvider, UMulBlock, UAnimData;
type
TAnimDataArray = array of TAnimData;
{ TAnimDataProvider }
TAnimDataProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload;
override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload;
override;
destructor Destroy; override;
protected
FAnimData: TAnimDataArray;
FAnimCount: Cardinal;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TAnimData; override;
procedure InitArray;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
public
property AnimData: TAnimDataArray read FAnimData;
property AnimCount: Cardinal read FAnimCount;
function GetBlock(AID: Integer): TAnimData; override;
end;
implementation
uses
Logging;
{ TAnimDataProvider }
constructor TAnimDataProvider.Create(AData: TStream; AReadOnly: Boolean);
begin
inherited Create(AData, AReadOnly);
InitArray;
end;
constructor TAnimDataProvider.Create(AData: string; AReadOnly: Boolean);
begin
inherited Create(AData, AReadOnly);
InitArray;
end;
destructor TAnimDataProvider.Destroy;
var
i: Integer;
begin
for i := 0 to Length(FAnimData) - 1 do
FreeAndNil(FAnimData[i]);
inherited Destroy;
end;
function TAnimDataProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := GetAnimDataOffset(AID);
end;
function TAnimDataProvider.GetData(AID, AOffset: Integer): TAnimData;
begin
Result := FAnimData[AID];
end;
procedure TAnimDataProvider.InitArray;
var
i: Integer;
begin
FData.Position := 0;
FAnimCount := (FData.Size div AnimDataGroupSize) * 8;
Logger.Send([lcInfo], 'Loading $%x AnimData entries.', [FAnimCount]);
SetLength(FAnimData, FAnimCount);
for i := 0 to FAnimCount - 1 do
begin
if i mod 8 = 0 then
FData.Seek(4, soFromCurrent);
FAnimData[i] := TAnimData.Create(FData);
end;
end;
procedure TAnimDataProvider.SetData(AID, AOffset: Integer; ABlock: TMulBlock);
begin
FreeAndNil(FAnimData[AID]);
FAnimData[AID] := TAnimData(ABlock.Clone);
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
function TAnimDataProvider.GetBlock(AID: Integer): TAnimData;
begin
Result := FAnimData[AID].Clone;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UAnimDataProvider;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, UMulProvider, UMulBlock, UAnimData;
type
TAnimDataArray = array of TAnimData;
{ TAnimDataProvider }
TAnimDataProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload;
override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload;
override;
destructor Destroy; override;
protected
FAnimData: TAnimDataArray;
FAnimCount: Cardinal;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TAnimData; override;
procedure InitArray;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
public
property AnimData: TAnimDataArray read FAnimData;
property AnimCount: Cardinal read FAnimCount;
function GetBlock(AID: Integer): TAnimData; override;
end;
implementation
uses
Logging;
{ TAnimDataProvider }
constructor TAnimDataProvider.Create(AData: TStream; AReadOnly: Boolean);
begin
inherited Create(AData, AReadOnly);
InitArray;
end;
constructor TAnimDataProvider.Create(AData: string; AReadOnly: Boolean);
begin
inherited Create(AData, AReadOnly);
InitArray;
end;
destructor TAnimDataProvider.Destroy;
var
i: Integer;
begin
for i := 0 to Length(FAnimData) - 1 do
FreeAndNil(FAnimData[i]);
inherited Destroy;
end;
function TAnimDataProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := GetAnimDataOffset(AID);
end;
function TAnimDataProvider.GetData(AID, AOffset: Integer): TAnimData;
begin
Result := FAnimData[AID];
end;
procedure TAnimDataProvider.InitArray;
var
i: Integer;
begin
FData.Position := 0;
FAnimCount := (FData.Size div AnimDataGroupSize) * 8;
Logger.Send([lcInfo], 'Loading $%x AnimData entries.', [FAnimCount]);
SetLength(FAnimData, FAnimCount);
for i := 0 to FAnimCount - 1 do
begin
if i mod 8 = 0 then
FData.Seek(4, soFromCurrent);
FAnimData[i] := TAnimData.Create(FData);
end;
end;
procedure TAnimDataProvider.SetData(AID, AOffset: Integer; ABlock: TMulBlock);
begin
FreeAndNil(FAnimData[AID]);
FAnimData[AID] := TAnimData(ABlock.Clone);
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
function TAnimDataProvider.GetBlock(AID: Integer): TAnimData;
begin
Result := FAnimData[AID].Clone;
end;
end.

202
MulProvider/UArtProvider.pas
View File

@ -1,101 +1,101 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UArtProvider;
{$mode objfpc}{$H+}
interface
uses
Graphics, UMulProvider, UMulBlock, UGenericIndex, UArt, UHue;
type
TArtProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; override;
function GetArtData(AID: Integer; AIndex: TGenericIndex; AColor: Word;
AHue: THue; APartialHue: Boolean): TArt;
public
function GetArt(AID: Integer; AColor: Word; AHue: THue; APartialHue: Boolean): TArt;
function GetFlatLand(AID: Integer): TArt;
end;
implementation
{ TArtProvider }
function TArtProvider.GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock;
begin
Result := GetArtData(AID, AIndex, clBlack, nil, False);
end;
function TArtProvider.GetArtData(AID: Integer; AIndex: TGenericIndex;
AColor: Word; AHue: THue; APartialHue: Boolean): TArt;
begin
if (AIndex.Lookup > -1) and (AIndex.Size > 0) then
begin
if AID < $4000 then
Result := TArt.Create(FData, AIndex, atLand, AColor, AHue, APartialHue)
else
Result := TArt.Create(FData, AIndex, atStatic, AColor, AHue, APartialHue);
end
else
begin
if AID < $4000 then
Result := TArt.Create(nil, nil, atLand, AColor, AHue, APartialHue)
else
Result := TArt.Create(nil, nil, atStatic, AColor, AHue, APartialHue);
end;
Result.ID := AID;
end;
function TArtProvider.GetArt(AID: Integer; AColor: Word; AHue: THue;
APartialHue: Boolean): TArt;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := GetArtData(AID, genericIndex, AColor, AHue, APartialHue);
genericIndex.Free;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
function TArtProvider.GetFlatLand(AID: Integer): TArt;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := TArt.Create(FData, genericIndex, atLandFlat);
genericIndex.Free;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UArtProvider;
{$mode objfpc}{$H+}
interface
uses
Graphics, UMulProvider, UMulBlock, UGenericIndex, UArt, UHue;
type
TArtProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; override;
function GetArtData(AID: Integer; AIndex: TGenericIndex; AColor: Word;
AHue: THue; APartialHue: Boolean): TArt;
public
function GetArt(AID: Integer; AColor: Word; AHue: THue; APartialHue: Boolean): TArt;
function GetFlatLand(AID: Integer): TArt;
end;
implementation
{ TArtProvider }
function TArtProvider.GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock;
begin
Result := GetArtData(AID, AIndex, clBlack, nil, False);
end;
function TArtProvider.GetArtData(AID: Integer; AIndex: TGenericIndex;
AColor: Word; AHue: THue; APartialHue: Boolean): TArt;
begin
if (AIndex.Lookup > -1) and (AIndex.Size > 0) then
begin
if AID < $4000 then
Result := TArt.Create(FData, AIndex, atLand, AColor, AHue, APartialHue)
else
Result := TArt.Create(FData, AIndex, atStatic, AColor, AHue, APartialHue);
end
else
begin
if AID < $4000 then
Result := TArt.Create(nil, nil, atLand, AColor, AHue, APartialHue)
else
Result := TArt.Create(nil, nil, atStatic, AColor, AHue, APartialHue);
end;
Result.ID := AID;
end;
function TArtProvider.GetArt(AID: Integer; AColor: Word; AHue: THue;
APartialHue: Boolean): TArt;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := GetArtData(AID, genericIndex, AColor, AHue, APartialHue);
genericIndex.Free;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
function TArtProvider.GetFlatLand(AID: Integer): TArt;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := TArt.Create(FData, genericIndex, atLandFlat);
genericIndex.Free;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
end.

126
MulProvider/UGumpProvider.pas
View File

@ -1,63 +1,63 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGumpProvider;
{$mode objfpc}{$H+}
interface
uses
UMulProvider, UMulBlock, UGenericIndex, UGump;
type
TGumpProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; override;
function GetVarious(AID: Integer; ABlock: TMulBlock; ADefault: Integer): Integer; override;
end;
implementation
{ TGumpProvider }
function TGumpProvider.GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock;
begin
if AIndex.Lookup <> LongInt($FFFFFFFF) then
Result := TGump.Create(FData, TGumpIndex(AIndex))
else
Result := TGump.Create(0, 0);
Result.ID := AID;
end;
function TGumpProvider.GetVarious(AID: Integer; ABlock: TMulBlock;
ADefault: Integer): Integer;
begin
Result := TGump(ABlock).Graphic.Height or (TGump(ABlock).Graphic.Width shl 16);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGumpProvider;
{$mode objfpc}{$H+}
interface
uses
UMulProvider, UMulBlock, UGenericIndex, UGump;
type
TGumpProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; override;
function GetVarious(AID: Integer; ABlock: TMulBlock; ADefault: Integer): Integer; override;
end;
implementation
{ TGumpProvider }
function TGumpProvider.GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock;
begin
if AIndex.Lookup <> LongInt($FFFFFFFF) then
Result := TGump.Create(FData, TGumpIndex(AIndex))
else
Result := TGump.Create(0, 0);
Result.ID := AID;
end;
function TGumpProvider.GetVarious(AID: Integer; ABlock: TMulBlock;
ADefault: Integer): Integer;
begin
Result := TGump(ABlock).Graphic.Height or (TGump(ABlock).Graphic.Width shl 16);
end;
end.

306
MulProvider/UHueProvider.pas
View File

@ -1,153 +1,153 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UHueProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, Contnrs, UMulProvider, UMulBlock, UHue;
type
THueProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; override;
destructor Destroy; override;
protected
FHueGroups: TObjectList;
procedure InitList;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TMulBlock; override;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
function GetHue(AIndex: Integer): THue;
function GetCount: Integer;
public
function GetBlock(AID: Integer): TMulBlock; override;
property Hues[Index: Integer]: THue read GetHue;
property Count: Integer read GetCount;
end;
implementation
{ THueProvider }
function THueProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := (AID div 8) * 708 + (AID mod 8) * 88;
end;
constructor THueProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
inherited;
InitList;
end;
constructor THueProvider.Create(AData: string; AReadOnly: Boolean = False);
begin
inherited;
InitList;
end;
destructor THueProvider.Destroy;
begin
FHueGroups.Free;
inherited;
end;
function THueProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, 0);
end;
function THueProvider.GetCount: Integer;
begin
Result := FHueGroups.Count * 8;
end;
function THueProvider.GetData(AID, AOffset: Integer): TMulBlock;
var
group, entry: Integer;
begin
group := (AID div 8) mod FHueGroups.Count;
entry := AID mod 8;
Result := TMulBlock(THueGroup(FHueGroups.Items[group]).HueEntries[entry].Clone);
Result.ID := AID;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
function THueProvider.GetHue(AIndex: Integer): THue;
var
group, entry: Integer;
begin
group := (AIndex div 8) mod FHueGroups.Count;
entry := AIndex mod 8;
Result := THue(THueGroup(FHueGroups.Items[group]).HueEntries[entry]);
Result.ID := AIndex;
end;
procedure THueProvider.InitList;
var
i: Integer;
begin
FHueGroups := TObjectList.Create;
FHueGroups.Count := FData.Size div 708;
FData.Position := 0;
i := 0;
while FData.Position < FData.Size do
begin
FHueGroups.Items[i] := THueGroup.Create(FData);
Inc(i);
end;
end;
procedure THueProvider.SetData(AID, AOffset: Integer;
ABlock: TMulBlock);
var
group, entry: Integer;
begin
group := AID div 8;
entry := AID mod 8;
if (group >= FHueGroups.Count) or (group < 0) then
begin
group := FHueGroups.Count;
FHueGroups.Add(THueGroup.Create(nil));
entry := 0;
end;
THueGroup(FHueGroups.Items[group]).HueEntries[entry] := THue(ABlock.Clone);
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UHueProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, Contnrs, UMulProvider, UMulBlock, UHue;
type
THueProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; override;
destructor Destroy; override;
protected
FHueGroups: TObjectList;
procedure InitList;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TMulBlock; override;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
function GetHue(AIndex: Integer): THue;
function GetCount: Integer;
public
function GetBlock(AID: Integer): TMulBlock; override;
property Hues[Index: Integer]: THue read GetHue;
property Count: Integer read GetCount;
end;
implementation
{ THueProvider }
function THueProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := (AID div 8) * 708 + (AID mod 8) * 88;
end;
constructor THueProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
inherited;
InitList;
end;
constructor THueProvider.Create(AData: string; AReadOnly: Boolean = False);
begin
inherited;
InitList;
end;
destructor THueProvider.Destroy;
begin
FHueGroups.Free;
inherited;
end;
function THueProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, 0);
end;
function THueProvider.GetCount: Integer;
begin
Result := FHueGroups.Count * 8;
end;
function THueProvider.GetData(AID, AOffset: Integer): TMulBlock;
var
group, entry: Integer;
begin
group := (AID div 8) mod FHueGroups.Count;
entry := AID mod 8;
Result := TMulBlock(THueGroup(FHueGroups.Items[group]).HueEntries[entry].Clone);
Result.ID := AID;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
function THueProvider.GetHue(AIndex: Integer): THue;
var
group, entry: Integer;
begin
group := (AIndex div 8) mod FHueGroups.Count;
entry := AIndex mod 8;
Result := THue(THueGroup(FHueGroups.Items[group]).HueEntries[entry]);
Result.ID := AIndex;
end;
procedure THueProvider.InitList;
var
i: Integer;
begin
FHueGroups := TObjectList.Create;
FHueGroups.Count := FData.Size div 708;
FData.Position := 0;
i := 0;
while FData.Position < FData.Size do
begin
FHueGroups.Items[i] := THueGroup.Create(FData);
Inc(i);
end;
end;
procedure THueProvider.SetData(AID, AOffset: Integer;
ABlock: TMulBlock);
var
group, entry: Integer;
begin
group := AID div 8;
entry := AID mod 8;
if (group >= FHueGroups.Count) or (group < 0) then
begin
group := FHueGroups.Count;
FHueGroups.Add(THueGroup.Create(nil));
entry := 0;
end;
THueGroup(FHueGroups.Items[group]).HueEntries[entry] := THue(ABlock.Clone);
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
end.

124
MulProvider/ULightProvider.pas
View File

@ -1,62 +1,62 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit ULightProvider;
{$mode objfpc}{$H+}
interface
uses
UMulProvider, UGenericIndex, ULight;
type
{ TLightProvider }
TLightProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TLight; override;
public
function GetLight(AID: Integer): TLight;
end;
implementation
{ TLightProvider }
function TLightProvider.GetData(AID: Integer; AIndex: TGenericIndex): TLight;
begin
Result := TLight.Create(FData, AIndex);
Result.ID := AID;
end;
function TLightProvider.GetLight(AID: Integer): TLight;
begin
Result := TLight(GetBlock(AID));
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit ULightProvider;
{$mode objfpc}{$H+}
interface
uses
UMulProvider, UGenericIndex, ULight;
type
{ TLightProvider }
TLightProvider = class(TIndexedMulProvider)
protected
function GetData(AID: Integer; AIndex: TGenericIndex): TLight; override;
public
function GetLight(AID: Integer): TLight;
end;
implementation
{ TLightProvider }
function TLightProvider.GetData(AID: Integer; AIndex: TGenericIndex): TLight;
begin
Result := TLight.Create(FData, AIndex);
Result.ID := AID;
end;
function TLightProvider.GetLight(AID: Integer): TLight;
begin
Result := TLight(GetBlock(AID));
end;
end.

258
MulProvider/UMulManager.pas
View File

@ -1,129 +1,129 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UMulManager;
interface
uses
SysUtils, UTileDataProvider, UArtProvider, UGumpProvider, UTexmapProvider,
UHueProvider, URadarProvider, UAnimDataProvider;
type
{ TMulManager }
TMulManager = class
destructor Destroy; override;
protected
FArtProvider: TArtProvider;
FGumpProvider: TGumpProvider;
FTexmapProvider: TTexmapProvider;
FTileDataProvider: TTileDataProvider;
FAnimDataProvider: TAnimDataProvider;
FHueProvider: THueProvider;
FRadarProvider: TRadarProvider;
public
procedure RegisterArtProvider(AArtProvider: TArtProvider);
procedure RegisterGumpProvider(AGumpProvider: TGumpProvider);
procedure RegisterTexmapProvider(ATexmapProvider: TTexmapProvider);
procedure RegisterTileDataProvider(ATileDataProvider: TTileDataProvider);
procedure RegisterAnimDataProvider(AAnimDataProvider: TAnimDataProvider);
procedure RegisterHueProvider(AHueProvider: THueProvider);
procedure RegisterRadarProvider(ARadarProvider: TRadarProvider);
property ArtProvider: TArtProvider read FArtProvider;
property GumpProvider: TGumpProvider read FGumpProvider;
property TexmapProvider: TTexmapProvider read FTexmapProvider;
property TileDataProvider: TTileDataProvider read FTileDataProvider;
property AnimDataProvider: TAnimDataProvider read FAnimDataProvider;
property HueProvider: THueProvider read FHueProvider;
property RadarProvider: TRadarPRovider read FRadarProvider;
end;
implementation
{ TMulManager }
destructor TMulManager.Destroy;
begin
RegisterArtProvider(nil);
RegisterGumpProvider(nil);
RegisterTexmapProvider(nil);
RegisterTileDataProvider(nil);
RegisterHueProvider(nil);
RegisterRadarProvider(nil);
inherited Destroy;
end;
procedure TMulManager.RegisterArtProvider(
AArtProvider: TArtProvider);
begin
FreeAndNil(FArtProvider);
FArtProvider := AArtProvider;
end;
procedure TMulManager.RegisterGumpProvider(
AGumpProvider: TGumpProvider);
begin
FreeAndNil(FGumpProvider);
FGumpProvider := AGumpProvider;
end;
procedure TMulManager.RegisterHueProvider(
AHueProvider: THueProvider);
begin
FreeAndNil(FHueProvider);
FHueProvider := AHueProvider;
end;
procedure TMulManager.RegisterRadarProvider(
ARadarProvider: TRadarProvider);
begin
FreeAndNil(FRadarProvider);
FRadarProvider := ARadarProvider;
end;
procedure TMulManager.RegisterTexmapProvider(
ATexmapProvider: TTexmapProvider);
begin
FreeAndNil(FTexmapProvider);
FTexmapProvider := ATexmapProvider;
end;
procedure TMulManager.RegisterTileDataProvider(
ATileDataProvider: TTileDataProvider);
begin
FreeAndNil(FTileDataProvider);
FTileDataProvider := ATileDataProvider;
end;
procedure TMulManager.RegisterAnimDataProvider(
AAnimDataProvider: TAnimDataProvider);
begin
FreeAndNil(FAnimDataProvider);
FAnimDataProvider := AAnimDataProvider;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UMulManager;
interface
uses
SysUtils, UTileDataProvider, UArtProvider, UGumpProvider, UTexmapProvider,
UHueProvider, URadarProvider, UAnimDataProvider;
type
{ TMulManager }
TMulManager = class
destructor Destroy; override;
protected
FArtProvider: TArtProvider;
FGumpProvider: TGumpProvider;
FTexmapProvider: TTexmapProvider;
FTileDataProvider: TTileDataProvider;
FAnimDataProvider: TAnimDataProvider;
FHueProvider: THueProvider;
FRadarProvider: TRadarProvider;
public
procedure RegisterArtProvider(AArtProvider: TArtProvider);
procedure RegisterGumpProvider(AGumpProvider: TGumpProvider);
procedure RegisterTexmapProvider(ATexmapProvider: TTexmapProvider);
procedure RegisterTileDataProvider(ATileDataProvider: TTileDataProvider);
procedure RegisterAnimDataProvider(AAnimDataProvider: TAnimDataProvider);
procedure RegisterHueProvider(AHueProvider: THueProvider);
procedure RegisterRadarProvider(ARadarProvider: TRadarProvider);
property ArtProvider: TArtProvider read FArtProvider;
property GumpProvider: TGumpProvider read FGumpProvider;
property TexmapProvider: TTexmapProvider read FTexmapProvider;
property TileDataProvider: TTileDataProvider read FTileDataProvider;
property AnimDataProvider: TAnimDataProvider read FAnimDataProvider;
property HueProvider: THueProvider read FHueProvider;
property RadarProvider: TRadarPRovider read FRadarProvider;
end;
implementation
{ TMulManager }
destructor TMulManager.Destroy;
begin
RegisterArtProvider(nil);
RegisterGumpProvider(nil);
RegisterTexmapProvider(nil);
RegisterTileDataProvider(nil);
RegisterHueProvider(nil);
RegisterRadarProvider(nil);
inherited Destroy;
end;
procedure TMulManager.RegisterArtProvider(
AArtProvider: TArtProvider);
begin
FreeAndNil(FArtProvider);
FArtProvider := AArtProvider;
end;
procedure TMulManager.RegisterGumpProvider(
AGumpProvider: TGumpProvider);
begin
FreeAndNil(FGumpProvider);
FGumpProvider := AGumpProvider;
end;
procedure TMulManager.RegisterHueProvider(
AHueProvider: THueProvider);
begin
FreeAndNil(FHueProvider);
FHueProvider := AHueProvider;
end;
procedure TMulManager.RegisterRadarProvider(
ARadarProvider: TRadarProvider);
begin
FreeAndNil(FRadarProvider);
FRadarProvider := ARadarProvider;
end;
procedure TMulManager.RegisterTexmapProvider(
ATexmapProvider: TTexmapProvider);
begin
FreeAndNil(FTexmapProvider);
FTexmapProvider := ATexmapProvider;
end;
procedure TMulManager.RegisterTileDataProvider(
ATileDataProvider: TTileDataProvider);
begin
FreeAndNil(FTileDataProvider);
FTileDataProvider := ATileDataProvider;
end;
procedure TMulManager.RegisterAnimDataProvider(
AAnimDataProvider: TAnimDataProvider);
begin
FreeAndNil(FAnimDataProvider);
FAnimDataProvider := AAnimDataProvider;
end;
end.

782
MulProvider/UMulProvider.pas
View File

@ -1,391 +1,391 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UMulProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UBufferedStreams, UMulBlock, UGenericIndex;
type
TOnProgressEvent = procedure(Total, Current: Integer) of object;
{ TMulEventHandler }
TMulEventHandler = class
constructor Create;
destructor Destroy; override;
protected
FEvents: TList;
public
procedure RegisterEvent(AEvent: TMulBlockChanged);
procedure UnregisterEvent(AEvent: TMulBlockChanged);
procedure FireEvents(ABlock: TMulBlock);
end;
{ TMulProvider }
TMulProvider = class
constructor Create; overload; virtual;
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FData: TStream;
FOwnsData: Boolean;
FReadOnly: Boolean;
FChangeEvents: TMulEventHandler;
FFinishedEvents: TMulEventHandler;
function CalculateOffset(AID: Integer): Integer; virtual; abstract;
function GetData(AID, AOffset: Integer): TMulBlock; virtual; abstract;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); virtual;
procedure OnChanged(ABlock: TMulBlock);
procedure OnFinished(ABlock: TMulBlock);
public
function GetBlock(AID: Integer): TMulBlock; virtual;
procedure SetBlock(AID: Integer; ABlock: TMulBlock); virtual;
procedure RegisterOnChangeEvent(AEvent: TMulBlockChanged);
procedure UnregisterOnChangeEvent(AEvent: TMulBlockChanged);
procedure RegisterOnFinishedEvent(AEvent: TMulBlockChanged);
procedure UnregisterOnFinishedEvent(AEvent: TMulBlockChanged);
property Block[ID: Integer]: TMulBlock read GetBlock write SetBlock;
property Data: TStream read FData;
end;
{ TIndexedMulProvider }
TIndexedMulProvider = class(TMulProvider)
constructor Create(AData, AIndex: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData, AIndex: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FIndex: TBufferedReader;
FEntryCount: Cardinal;
function CalculateIndexOffset(AID: Integer): Integer; virtual;
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; reintroduce; virtual; abstract;
procedure SetData(AID: Integer; AIndex: TGenericIndex; ABlock: TMulBlock); reintroduce; virtual;
function GetVarious(AID: Integer; ABlock: TMulBlock; ADefault: Integer): Integer; virtual;
public
function GetBlock(AID: Integer): TMulBlock; override;
procedure GetBlockEx(AID: Integer; var ABlock: TMulBlock; var AIndex: TGenericIndex); virtual;
procedure SetBlock(AID: Integer; ABlock: TMulBlock); override;
function Exists(AID: Integer): Boolean; virtual;
procedure Defragment(ATempStream: TStream; AOnProgress: TOnProgressEvent = nil); virtual;
property Index: TBufferedReader read FIndex;
property EntryCount: Cardinal read FEntryCount;
end;
implementation
type
PMethod = ^TMethod;
{ TMulEventHandler }
constructor TMulEventHandler.Create;
begin
inherited;
FEvents := TList.Create;
end;
destructor TMulEventHandler.Destroy;
var
i: Integer;
begin
if Assigned(FEvents) then
begin
for i := 0 to FEvents.Count - 1 do
Dispose(PMethod(FEvents.Items[i]));
FreeAndNil(FEvents);
end;
inherited Destroy;
end;
procedure TMulEventHandler.FireEvents(ABlock: TMulBlock);
var
i: Integer;
begin
for i := 0 to FEvents.Count - 1 do
TMulBlockChanged(FEvents.Items[i]^)(ABlock);
end;
procedure TMulEventHandler.RegisterEvent(AEvent: TMulBlockChanged);
var
eventInfo: PMethod;
begin
UnregisterEvent(AEvent);
New(eventInfo);
eventInfo^.Code := TMethod(AEvent).Code;
eventInfo^.Data := TMethod(AEvent).Data;
FEvents.Add(eventInfo);
end;
procedure TMulEventHandler.UnregisterEvent(AEvent: TMulBlockChanged);
var
i: Integer;
function RemoveEntry: Boolean;
begin
Dispose(PMethod(FEvents.Items[i]));
FEvents.Delete(i);
Result := True;
end;
begin
i := 0;
while (i < FEvents.Count) and ((TMethod(AEvent).Code <> TMethod(FEvents.Items[i]^).Code) or (TMethod(AEvent).Data <> TMethod(FEvents.Items[i]^).Data) or not RemoveEntry) do
Inc(i);
end;
{ TMulProvider }
constructor TMulProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
Create;
FData := AData;
FOwnsData := False;
FReadOnly := AReadOnly;
end;
constructor TMulProvider.Create(AData: string; AReadOnly: Boolean = False);
var
mode: Word;
begin
Create;
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FData := TFileStream.Create(AData, mode);
FOwnsData := True;
FReadOnly := AReadOnly;
end;
constructor TMulProvider.Create;
begin
inherited;
FChangeEvents := TMulEventHandler.Create;
FFinishedEvents := TMulEventHandler.Create;
end;
destructor TMulProvider.Destroy;
begin
if FOwnsData and Assigned(FData) then FreeAndNil(FData);
if Assigned(FChangeEvents) then FreeAndNil(FChangeEvents);
if Assigned(FFinishedEvents) then FreeAndNil(FFinishedEvents);
inherited;
end;
function TMulProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, CalculateOffset(AID));
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
procedure TMulProvider.OnChanged(ABlock: TMulBlock);
begin
SetBlock(ABlock.ID, ABlock);
FChangeEvents.FireEvents(ABlock);
end;
procedure TMulProvider.OnFinished(ABlock: TMulBlock);
begin
FFinishedEvents.FireEvents(ABlock);
ABlock.Free;
end;
procedure TMulProvider.RegisterOnChangeEvent(AEvent: TMulBlockChanged);
begin
FChangeEvents.RegisterEvent(AEvent);
end;
procedure TMulProvider.RegisterOnFinishedEvent(AEvent: TMulBlockChanged);
begin
FFinishedEvents.RegisterEvent(AEvent);
end;
procedure TMulProvider.SetBlock(AID: Integer; ABlock: TMulBlock);
begin
if FReadOnly then Exit;
SetData(AID, CalculateOffset(AID), ABlock);
end;
procedure TMulProvider.SetData(AID, AOffset: Integer; ABlock: TMulBlock);
begin
if FReadOnly then Exit;
FData.Position := AOffset;
ABlock.Write(FData);
end;
procedure TMulProvider.UnregisterOnChangeEvent(AEvent: TMulBlockChanged);
begin
FChangeEvents.UnregisterEvent(AEvent);
end;
procedure TMulProvider.UnregisterOnFinishedEvent(AEvent: TMulBlockChanged);
begin
FFinishedEvents.UnregisterEvent(AEvent);
end;
{ TIndexedMulProvider }
function TIndexedMulProvider.CalculateIndexOffset(AID: Integer): Integer;
begin
Result := 12 * AID;
end;
constructor TIndexedMulProvider.Create(AData, AIndex: TStream; AReadOnly: Boolean = False);
begin
inherited Create(AData, AReadOnly);
FIndex := TBufferedReader.Create(AIndex);
FEntryCount := AIndex.Size div 12;
end;
constructor TIndexedMulProvider.Create(AData, AIndex: string; AReadOnly: Boolean = False);
var
mode: Word;
begin
inherited Create(AData, AReadOnly);
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FIndex := TBufferedReader.Create(TFileStream.Create(AIndex, mode), True);
FEntryCount := FIndex.Size div 12;
end;
procedure TIndexedMulProvider.Defragment(ATempStream: TStream; AOnProgress: TOnProgressEvent = nil);
var
genericIndex: TGenericIndex;
begin
if FReadOnly then Exit;
ATempStream.Size := FData.Size;
ATempStream.Position := 0;
FIndex.Position := 0;
while FIndex.Position < FIndex.Size do
begin
genericIndex := TGenericIndex.Create(FIndex);
if genericIndex.Lookup > -1 then
begin
FData.Position := genericIndex.Lookup;
genericIndex.Lookup := ATempStream.Position;
ATempStream.CopyFrom(FData, genericIndex.Size);
FIndex.Seek(-12, soFromCurrent);
genericIndex.Write(FIndex);
end;
genericIndex.Free;
if Assigned(AOnProgress) and (FIndex.Position mod 1200 = 0) then
AOnProgress(FIndex.Size, FIndex.Position);
end;
FData.Size := ATempStream.Position;
FData.Position := 0;
ATempStream.Position := 0;
FData.CopyFrom(ATempStream, FData.Size);
end;
destructor TIndexedMulProvider.Destroy;
begin
FreeAndNil(FIndex);
inherited Destroy;
end;
function TIndexedMulProvider.Exists(AID: Integer): Boolean;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := (genericIndex.Lookup > -1) and (genericIndex.Size > 0);
genericIndex.Free;
end;
function TIndexedMulProvider.GetBlock(AID: Integer): TMulBlock;
var
genericIndex: TGenericIndex;
begin
GetBlockEx(AID, Result, genericIndex);
genericIndex.Free;
end;
procedure TIndexedMulProvider.GetBlockEx(AID: Integer;
var ABlock: TMulBlock; var AIndex: TGenericIndex);
begin
FIndex.Position := CalculateIndexOffset(AID);
AIndex := TGenericIndex.Create(FIndex);
ABlock := GetData(AID, AIndex);
ABlock.OnChanged := @OnChanged;
ABlock.OnFinished := @OnFinished;
end;
function TIndexedMulProvider.GetVarious(AID: Integer; ABlock: TMulBlock;
ADefault: Integer): Integer;
begin
Result := ADefault;
end;
procedure TIndexedMulProvider.SetBlock(AID: Integer; ABlock: TMulBlock);
var
genericIndex: TGenericIndex;
begin
if FReadOnly then Exit;
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
SetData(AID, genericIndex, ABlock);
FIndex.Position := CalculateIndexOffset(AID);
genericIndex.Various := GetVarious(AID, ABlock, genericIndex.Various);
genericIndex.Write(FIndex);
genericIndex.Free;
end;
procedure TIndexedMulProvider.SetData(AID: Integer; AIndex: TGenericIndex;
ABlock: TMulBlock);
var
size: Integer;
begin
if FReadOnly then Exit;
size := ABlock.GetSize;
if size = 0 then
begin
AIndex.Lookup := -1;
AIndex.Various := -1;
end else if (size > AIndex.Size) or (AIndex.Lookup < 0) then
begin
FData.Position := FData.Size;
AIndex.Lookup := FData.Position;
ABlock.Write(FData);
end else
begin
FData.Position := AIndex.Lookup;
ABlock.Write(FData);
end;
AIndex.Size := size;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UMulProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UBufferedStreams, UMulBlock, UGenericIndex;
type
TOnProgressEvent = procedure(Total, Current: Integer) of object;
{ TMulEventHandler }
TMulEventHandler = class
constructor Create;
destructor Destroy; override;
protected
FEvents: TList;
public
procedure RegisterEvent(AEvent: TMulBlockChanged);
procedure UnregisterEvent(AEvent: TMulBlockChanged);
procedure FireEvents(ABlock: TMulBlock);
end;
{ TMulProvider }
TMulProvider = class
constructor Create; overload; virtual;
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FData: TStream;
FOwnsData: Boolean;
FReadOnly: Boolean;
FChangeEvents: TMulEventHandler;
FFinishedEvents: TMulEventHandler;
function CalculateOffset(AID: Integer): Integer; virtual; abstract;
function GetData(AID, AOffset: Integer): TMulBlock; virtual; abstract;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); virtual;
procedure OnChanged(ABlock: TMulBlock);
procedure OnFinished(ABlock: TMulBlock);
public
function GetBlock(AID: Integer): TMulBlock; virtual;
procedure SetBlock(AID: Integer; ABlock: TMulBlock); virtual;
procedure RegisterOnChangeEvent(AEvent: TMulBlockChanged);
procedure UnregisterOnChangeEvent(AEvent: TMulBlockChanged);
procedure RegisterOnFinishedEvent(AEvent: TMulBlockChanged);
procedure UnregisterOnFinishedEvent(AEvent: TMulBlockChanged);
property Block[ID: Integer]: TMulBlock read GetBlock write SetBlock;
property Data: TStream read FData;
end;
{ TIndexedMulProvider }
TIndexedMulProvider = class(TMulProvider)
constructor Create(AData, AIndex: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData, AIndex: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FIndex: TBufferedReader;
FEntryCount: Cardinal;
function CalculateIndexOffset(AID: Integer): Integer; virtual;
function GetData(AID: Integer; AIndex: TGenericIndex): TMulBlock; reintroduce; virtual; abstract;
procedure SetData(AID: Integer; AIndex: TGenericIndex; ABlock: TMulBlock); reintroduce; virtual;
function GetVarious(AID: Integer; ABlock: TMulBlock; ADefault: Integer): Integer; virtual;
public
function GetBlock(AID: Integer): TMulBlock; override;
procedure GetBlockEx(AID: Integer; var ABlock: TMulBlock; var AIndex: TGenericIndex); virtual;
procedure SetBlock(AID: Integer; ABlock: TMulBlock); override;
function Exists(AID: Integer): Boolean; virtual;
procedure Defragment(ATempStream: TStream; AOnProgress: TOnProgressEvent = nil); virtual;
property Index: TBufferedReader read FIndex;
property EntryCount: Cardinal read FEntryCount;
end;
implementation
type
PMethod = ^TMethod;
{ TMulEventHandler }
constructor TMulEventHandler.Create;
begin
inherited;
FEvents := TList.Create;
end;
destructor TMulEventHandler.Destroy;
var
i: Integer;
begin
if Assigned(FEvents) then
begin
for i := 0 to FEvents.Count - 1 do
Dispose(PMethod(FEvents.Items[i]));
FreeAndNil(FEvents);
end;
inherited Destroy;
end;
procedure TMulEventHandler.FireEvents(ABlock: TMulBlock);
var
i: Integer;
begin
for i := 0 to FEvents.Count - 1 do
TMulBlockChanged(FEvents.Items[i]^)(ABlock);
end;
procedure TMulEventHandler.RegisterEvent(AEvent: TMulBlockChanged);
var
eventInfo: PMethod;
begin
UnregisterEvent(AEvent);
New(eventInfo);
eventInfo^.Code := TMethod(AEvent).Code;
eventInfo^.Data := TMethod(AEvent).Data;
FEvents.Add(eventInfo);
end;
procedure TMulEventHandler.UnregisterEvent(AEvent: TMulBlockChanged);
var
i: Integer;
function RemoveEntry: Boolean;
begin
Dispose(PMethod(FEvents.Items[i]));
FEvents.Delete(i);
Result := True;
end;
begin
i := 0;
while (i < FEvents.Count) and ((TMethod(AEvent).Code <> TMethod(FEvents.Items[i]^).Code) or (TMethod(AEvent).Data <> TMethod(FEvents.Items[i]^).Data) or not RemoveEntry) do
Inc(i);
end;
{ TMulProvider }
constructor TMulProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
Create;
FData := AData;
FOwnsData := False;
FReadOnly := AReadOnly;
end;
constructor TMulProvider.Create(AData: string; AReadOnly: Boolean = False);
var
mode: Word;
begin
Create;
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FData := TFileStream.Create(AData, mode);
FOwnsData := True;
FReadOnly := AReadOnly;
end;
constructor TMulProvider.Create;
begin
inherited;
FChangeEvents := TMulEventHandler.Create;
FFinishedEvents := TMulEventHandler.Create;
end;
destructor TMulProvider.Destroy;
begin
if FOwnsData and Assigned(FData) then FreeAndNil(FData);
if Assigned(FChangeEvents) then FreeAndNil(FChangeEvents);
if Assigned(FFinishedEvents) then FreeAndNil(FFinishedEvents);
inherited;
end;
function TMulProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, CalculateOffset(AID));
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
procedure TMulProvider.OnChanged(ABlock: TMulBlock);
begin
SetBlock(ABlock.ID, ABlock);
FChangeEvents.FireEvents(ABlock);
end;
procedure TMulProvider.OnFinished(ABlock: TMulBlock);
begin
FFinishedEvents.FireEvents(ABlock);
ABlock.Free;
end;
procedure TMulProvider.RegisterOnChangeEvent(AEvent: TMulBlockChanged);
begin
FChangeEvents.RegisterEvent(AEvent);
end;
procedure TMulProvider.RegisterOnFinishedEvent(AEvent: TMulBlockChanged);
begin
FFinishedEvents.RegisterEvent(AEvent);
end;
procedure TMulProvider.SetBlock(AID: Integer; ABlock: TMulBlock);
begin
if FReadOnly then Exit;
SetData(AID, CalculateOffset(AID), ABlock);
end;
procedure TMulProvider.SetData(AID, AOffset: Integer; ABlock: TMulBlock);
begin
if FReadOnly then Exit;
FData.Position := AOffset;
ABlock.Write(FData);
end;
procedure TMulProvider.UnregisterOnChangeEvent(AEvent: TMulBlockChanged);
begin
FChangeEvents.UnregisterEvent(AEvent);
end;
procedure TMulProvider.UnregisterOnFinishedEvent(AEvent: TMulBlockChanged);
begin
FFinishedEvents.UnregisterEvent(AEvent);
end;
{ TIndexedMulProvider }
function TIndexedMulProvider.CalculateIndexOffset(AID: Integer): Integer;
begin
Result := 12 * AID;
end;
constructor TIndexedMulProvider.Create(AData, AIndex: TStream; AReadOnly: Boolean = False);
begin
inherited Create(AData, AReadOnly);
FIndex := TBufferedReader.Create(AIndex);
FEntryCount := AIndex.Size div 12;
end;
constructor TIndexedMulProvider.Create(AData, AIndex: string; AReadOnly: Boolean = False);
var
mode: Word;
begin
inherited Create(AData, AReadOnly);
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FIndex := TBufferedReader.Create(TFileStream.Create(AIndex, mode), True);
FEntryCount := FIndex.Size div 12;
end;
procedure TIndexedMulProvider.Defragment(ATempStream: TStream; AOnProgress: TOnProgressEvent = nil);
var
genericIndex: TGenericIndex;
begin
if FReadOnly then Exit;
ATempStream.Size := FData.Size;
ATempStream.Position := 0;
FIndex.Position := 0;
while FIndex.Position < FIndex.Size do
begin
genericIndex := TGenericIndex.Create(FIndex);
if genericIndex.Lookup > -1 then
begin
FData.Position := genericIndex.Lookup;
genericIndex.Lookup := ATempStream.Position;
ATempStream.CopyFrom(FData, genericIndex.Size);
FIndex.Seek(-12, soFromCurrent);
genericIndex.Write(FIndex);
end;
genericIndex.Free;
if Assigned(AOnProgress) and (FIndex.Position mod 1200 = 0) then
AOnProgress(FIndex.Size, FIndex.Position);
end;
FData.Size := ATempStream.Position;
FData.Position := 0;
ATempStream.Position := 0;
FData.CopyFrom(ATempStream, FData.Size);
end;
destructor TIndexedMulProvider.Destroy;
begin
FreeAndNil(FIndex);
inherited Destroy;
end;
function TIndexedMulProvider.Exists(AID: Integer): Boolean;
var
genericIndex: TGenericIndex;
begin
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
Result := (genericIndex.Lookup > -1) and (genericIndex.Size > 0);
genericIndex.Free;
end;
function TIndexedMulProvider.GetBlock(AID: Integer): TMulBlock;
var
genericIndex: TGenericIndex;
begin
GetBlockEx(AID, Result, genericIndex);
genericIndex.Free;
end;
procedure TIndexedMulProvider.GetBlockEx(AID: Integer;
var ABlock: TMulBlock; var AIndex: TGenericIndex);
begin
FIndex.Position := CalculateIndexOffset(AID);
AIndex := TGenericIndex.Create(FIndex);
ABlock := GetData(AID, AIndex);
ABlock.OnChanged := @OnChanged;
ABlock.OnFinished := @OnFinished;
end;
function TIndexedMulProvider.GetVarious(AID: Integer; ABlock: TMulBlock;
ADefault: Integer): Integer;
begin
Result := ADefault;
end;
procedure TIndexedMulProvider.SetBlock(AID: Integer; ABlock: TMulBlock);
var
genericIndex: TGenericIndex;
begin
if FReadOnly then Exit;
FIndex.Position := CalculateIndexOffset(AID);
genericIndex := TGenericIndex.Create(FIndex);
SetData(AID, genericIndex, ABlock);
FIndex.Position := CalculateIndexOffset(AID);
genericIndex.Various := GetVarious(AID, ABlock, genericIndex.Various);
genericIndex.Write(FIndex);
genericIndex.Free;
end;
procedure TIndexedMulProvider.SetData(AID: Integer; AIndex: TGenericIndex;
ABlock: TMulBlock);
var
size: Integer;
begin
if FReadOnly then Exit;
size := ABlock.GetSize;
if size = 0 then
begin
AIndex.Lookup := -1;
AIndex.Various := -1;
end else if (size > AIndex.Size) or (AIndex.Lookup < 0) then
begin
FData.Position := FData.Size;
AIndex.Lookup := FData.Position;
ABlock.Write(FData);
end else
begin
FData.Position := AIndex.Lookup;
ABlock.Write(FData);
end;
AIndex.Size := size;
end;
end.

212
MulProvider/URadarProvider.pas
View File

@ -1,106 +1,106 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit URadarProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UBufferedStreams;
type
{ TRadarProvider }
TRadarProvider = class
constructor Create; overload; virtual;
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FData: TBufferedReader;
FReadOnly: Boolean;
public
function GetColor(AID: Integer): Word;
procedure SetColor(AID: Integer; AColor: Word);
end;
implementation
{ TRaderProvider }
constructor TRadarProvider.Create;
begin
inherited Create;
end;
constructor TRadarProvider.Create(AData: TStream; AReadOnly: Boolean);
begin
Create;
FData := TBufferedReader.Create(AData, False);
FReadOnly := AReadOnly;
end;
constructor TRadarProvider.Create(AData: string; AReadOnly: Boolean);
var
mode: Word;
begin
Create;
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FData := TBufferedReader.Create(TFileStream.Create(AData, mode), True);
FReadOnly := AReadOnly;
end;
destructor TRadarProvider.Destroy;
begin
FreeAndNil(FData);
inherited Destroy;
end;
function TRadarProvider.GetColor(AID: Integer): Word;
begin
Result := 0;
if (AID >= 0) and (AID < $10000) then
begin
FData.Position := SizeOf(Word) * AID;
FData.Read(Result, SizeOf(Word));
end;
end;
procedure TRadarProvider.SetColor(AID: Integer; AColor: Word);
begin
if (not FReadOnly) and (AID >= 0) and (AID < $10000) then
begin
FData.Position := SizeOf(Word) * AID;
FData.Write(AColor, SizeOf(Word));
end;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit URadarProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UBufferedStreams;
type
{ TRadarProvider }
TRadarProvider = class
constructor Create; overload; virtual;
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; virtual;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; virtual;
destructor Destroy; override;
protected
FData: TBufferedReader;
FReadOnly: Boolean;
public
function GetColor(AID: Integer): Word;
procedure SetColor(AID: Integer; AColor: Word);
end;
implementation
{ TRaderProvider }
constructor TRadarProvider.Create;
begin
inherited Create;
end;
constructor TRadarProvider.Create(AData: TStream; AReadOnly: Boolean);
begin
Create;
FData := TBufferedReader.Create(AData, False);
FReadOnly := AReadOnly;
end;
constructor TRadarProvider.Create(AData: string; AReadOnly: Boolean);
var
mode: Word;
begin
Create;
if AReadOnly then
mode := fmOpenRead or fmShareDenyWrite
else
mode := fmOpenReadWrite or fmShareDenyWrite;
FData := TBufferedReader.Create(TFileStream.Create(AData, mode), True);
FReadOnly := AReadOnly;
end;
destructor TRadarProvider.Destroy;
begin
FreeAndNil(FData);
inherited Destroy;
end;
function TRadarProvider.GetColor(AID: Integer): Word;
begin
Result := 0;
if (AID >= 0) and (AID < $10000) then
begin
FData.Position := SizeOf(Word) * AID;
FData.Read(Result, SizeOf(Word));
end;
end;
procedure TRadarProvider.SetColor(AID: Integer; AColor: Word);
begin
if (not FReadOnly) and (AID >= 0) and (AID < $10000) then
begin
FData.Position := SizeOf(Word) * AID;
FData.Write(AColor, SizeOf(Word));
end;
end;
end.

342
MulProvider/UTileDataProvider.pas
View File

@ -1,171 +1,171 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UTileDataProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UMulProvider, UMulBlock, UTiledata;
type
TLandTileDataArray = array[$0..$3FFF] of TLandTileData;
TStaticTileDataArray = array of TStaticTileData;
{ TTiledataProvider }
TTiledataProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; override;
destructor Destroy; override;
protected
FLandTiles: TLandTileDataArray;
FStaticTiles: TStaticTileDataArray;
FStaticCount: Cardinal;
procedure InitArray;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TMulBlock; override;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
function GetTileData(AID: Integer): TTiledata;
public
function GetBlock(AID: Integer): TMulBlock; override;
property LandTiles: TLandTileDataArray read FLandTiles;
property StaticTiles: TStaticTileDataArray read FStaticTiles;
property TileData[AID: Integer]: TTiledata read GetTileData; //all tiles, no cloning
property StaticCount: Cardinal read FStaticCount;
end;
implementation
uses
Logging;
{ TTiledataProvider }
function TTiledataProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := GetTileDataOffset(AID);
end;
constructor TTiledataProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
inherited;
InitArray;
end;
constructor TTiledataProvider.Create(AData: string; AReadOnly: Boolean = False);
begin
inherited;
InitArray;
end;
destructor TTiledataProvider.Destroy;
var
i: Integer;
begin
for i := $0 to $3FFF do
FreeAndNil(FLandTiles[i]);
for i := 0 to FStaticCount - 1 do
FreeAndNil(FStaticTiles[i]);
inherited Destroy;
end;
function TTiledataProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, 0);
end;
function TTiledataProvider.GetData(AID, AOffset: Integer): TMulBlock;
begin
if AID < $4000 then
Result := TMulBlock(FLandTiles[AID].Clone)
else
Result := TMulBlock(FStaticTiles[AID - $4000].Clone);
Result.ID := AID;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
procedure TTiledataProvider.InitArray;
var
i: Integer;
begin
FData.Position := 0;
Logger.Send([lcInfo], 'Loading $4000 LandTiledata Entries');
for i := $0 to $3FFF do
begin
if i mod 32 = 0 then
FData.Seek(4, soFromCurrent);
FLandTiles[i] := TLandTileData.Create(FData);
end;
FStaticCount := ((FData.Size - FData.Position) div StaticTileGroupSize) * 32;
Logger.Send([lcInfo], 'Loading $%x StaticTiledata Entries', [FStaticCount]);
SetLength(FStaticTiles, FStaticCount);
for i := 0 to FStaticCount - 1 do
begin
if i mod 32 = 0 then
FData.Seek(4, soFromCurrent);
FStaticTiles[i] := TStaticTileData.Create(FData);
end;
end;
procedure TTiledataProvider.SetData(AID, AOffset: Integer;
ABlock: TMulBlock);
begin
if AID >= $4000 + FStaticCount then
Exit;
if AID < $4000 then
begin
FreeAndNil(FLandTiles[AID]);
FLandTiles[AID] := TLandTileData(ABlock.Clone);
end else
begin
FreeAndNil(FStaticTiles[AID - $4000]);
FStaticTiles[AID - $4000] := TStaticTileData(ABlock.Clone);
end;
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
function TTiledataProvider.GetTileData(AID: Integer): TTiledata;
begin
if AID < $4000 then
Result := FLandTiles[AID]
else
Result := FStaticTiles[AID - $4000];
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UTileDataProvider;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UMulProvider, UMulBlock, UTiledata;
type
TLandTileDataArray = array[$0..$3FFF] of TLandTileData;
TStaticTileDataArray = array of TStaticTileData;
{ TTiledataProvider }
TTiledataProvider = class(TMulProvider)
constructor Create(AData: TStream; AReadOnly: Boolean = False); overload; override;
constructor Create(AData: string; AReadOnly: Boolean = False); overload; override;
destructor Destroy; override;
protected
FLandTiles: TLandTileDataArray;
FStaticTiles: TStaticTileDataArray;
FStaticCount: Cardinal;
procedure InitArray;
function CalculateOffset(AID: Integer): Integer; override;
function GetData(AID, AOffset: Integer): TMulBlock; override;
procedure SetData(AID, AOffset: Integer; ABlock: TMulBlock); override;
function GetTileData(AID: Integer): TTiledata;
public
function GetBlock(AID: Integer): TMulBlock; override;
property LandTiles: TLandTileDataArray read FLandTiles;
property StaticTiles: TStaticTileDataArray read FStaticTiles;
property TileData[AID: Integer]: TTiledata read GetTileData; //all tiles, no cloning
property StaticCount: Cardinal read FStaticCount;
end;
implementation
uses
Logging;
{ TTiledataProvider }
function TTiledataProvider.CalculateOffset(AID: Integer): Integer;
begin
Result := GetTileDataOffset(AID);
end;
constructor TTiledataProvider.Create(AData: TStream; AReadOnly: Boolean = False);
begin
inherited;
InitArray;
end;
constructor TTiledataProvider.Create(AData: string; AReadOnly: Boolean = False);
begin
inherited;
InitArray;
end;
destructor TTiledataProvider.Destroy;
var
i: Integer;
begin
for i := $0 to $3FFF do
FreeAndNil(FLandTiles[i]);
for i := 0 to FStaticCount - 1 do
FreeAndNil(FStaticTiles[i]);
inherited Destroy;
end;
function TTiledataProvider.GetBlock(AID: Integer): TMulBlock;
begin
Result := GetData(AID, 0);
end;
function TTiledataProvider.GetData(AID, AOffset: Integer): TMulBlock;
begin
if AID < $4000 then
Result := TMulBlock(FLandTiles[AID].Clone)
else
Result := TMulBlock(FStaticTiles[AID - $4000].Clone);
Result.ID := AID;
Result.OnChanged := @OnChanged;
Result.OnFinished := @OnFinished;
end;
procedure TTiledataProvider.InitArray;
var
i: Integer;
begin
FData.Position := 0;
Logger.Send([lcInfo], 'Loading $4000 LandTiledata Entries');
for i := $0 to $3FFF do
begin
if i mod 32 = 0 then
FData.Seek(4, soFromCurrent);
FLandTiles[i] := TLandTileData.Create(FData);
end;
FStaticCount := ((FData.Size - FData.Position) div StaticTileGroupSize) * 32;
Logger.Send([lcInfo], 'Loading $%x StaticTiledata Entries', [FStaticCount]);
SetLength(FStaticTiles, FStaticCount);
for i := 0 to FStaticCount - 1 do
begin
if i mod 32 = 0 then
FData.Seek(4, soFromCurrent);
FStaticTiles[i] := TStaticTileData.Create(FData);
end;
end;
procedure TTiledataProvider.SetData(AID, AOffset: Integer;
ABlock: TMulBlock);
begin
if AID >= $4000 + FStaticCount then
Exit;
if AID < $4000 then
begin
FreeAndNil(FLandTiles[AID]);
FLandTiles[AID] := TLandTileData(ABlock.Clone);
end else
begin
FreeAndNil(FStaticTiles[AID - $4000]);
FStaticTiles[AID - $4000] := TStaticTileData(ABlock.Clone);
end;
if not FReadOnly then
begin
FData.Position := AOffset;
ABlock.Write(FData);
end;
end;
function TTiledataProvider.GetTileData(AID: Integer): TTiledata;
begin
if AID < $4000 then
Result := FLandTiles[AID]
else
Result := FStaticTiles[AID - $4000];
end;
end.

138
ResourceBuilder.pas
View File

@ -1,69 +1,69 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
program ResourceBuilder;
{$mode objfpc}{$H+}
uses
SysUtils, Classes;
var
fileList: TStringList;
infile, outfile: TFileStream;
i, count: Integer;
size: Cardinal;
lookupTable: array of Cardinal;
begin
if ParamCount <> 2 then
begin
writeln('Usage: ResourceBuilder <FileList> <ResourceFile>');
halt;
end;
fileList := TStringList.Create;
fileList.LoadFromFile(ParamStr(1));
outfile := TFileStream.Create(ParamStr(2), fmCreate);
count := fileList.Count;
outfile.Write(count, SizeOf(Integer));
SetLength(lookupTable, count);
outfile.Write(lookupTable[0], count * SizeOf(Cardinal));
for i := 0 to count - 1 do
begin
lookupTable[i] := outfile.Position;
writeln(i, ': ', fileList.Strings[i]);
infile := TFileStream.Create(fileList.Strings[i], fmOpenRead);
infile.Position := 0;
size := infile.Size;
outfile.Write(size, SizeOf(Cardinal));
outfile.CopyFrom(infile, infile.Size);
infile.Free;
end;
outfile.Position := SizeOf(Integer);
outfile.Write(lookupTable[0], count * SizeOf(Cardinal));
outfile.Free;
fileList.Free;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
program ResourceBuilder;
{$mode objfpc}{$H+}
uses
SysUtils, Classes;
var
fileList: TStringList;
infile, outfile: TFileStream;
i, count: Integer;
size: Cardinal;
lookupTable: array of Cardinal;
begin
if ParamCount <> 2 then
begin
writeln('Usage: ResourceBuilder <FileList> <ResourceFile>');
halt;
end;
fileList := TStringList.Create;
fileList.LoadFromFile(ParamStr(1));
outfile := TFileStream.Create(ParamStr(2), fmCreate);
count := fileList.Count;
outfile.Write(count, SizeOf(Integer));
SetLength(lookupTable, count);
outfile.Write(lookupTable[0], count * SizeOf(Cardinal));
for i := 0 to count - 1 do
begin
lookupTable[i] := outfile.Position;
writeln(i, ': ', fileList.Strings[i]);
infile := TFileStream.Create(fileList.Strings[i], fmOpenRead);
infile.Position := 0;
size := infile.Size;
outfile.Write(size, SizeOf(Cardinal));
outfile.CopyFrom(infile, infile.Size);
infile.Free;
end;
outfile.Position := SizeOf(Integer);
outfile.Write(lookupTable[0], count * SizeOf(Cardinal));
outfile.Free;
fileList.Free;
end.

178
Server/UNetState.pas
View File

@ -1,89 +1,89 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UNetState;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, lNet, UEnhancedMemoryStream, UAccount, ULinkedList;
type
{ TNetState }
TNetState = class(TObject)
constructor Create(ASocket: TLSocket);
destructor Destroy; override;
protected
FSocket: TLSocket;
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FAccount: TAccount;
FSubscriptions: TList;
FLastAction: TDateTime;
public
property Socket: TLSocket read FSocket;
property SendQueue: TEnhancedMemoryStream read FSendQueue;
property ReceiveQueue: TEnhancedMemoryStream read FReceiveQueue;
property Account: TAccount read FAccount write FAccount;
property Subscriptions: TList read FSubscriptions;
property LastAction: TDateTime read FLastAction write FLastAction;
end;
implementation
{ TNetState }
constructor TNetState.Create(ASocket: TLSocket);
begin
inherited Create;
FSocket := ASocket;
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
FAccount := nil;
FSubscriptions := TList.Create;
FLastAction := Now;
end;
destructor TNetState.Destroy;
var
i: Integer;
begin
if FSendQueue <> nil then FreeAndNil(FSendQueue);
if FReceiveQueue <> nil then FreeAndNil(FReceiveQueue);
if FSubscriptions <> nil then
begin
for i := 0 to FSubscriptions.Count - 1 do
TLinkedList(FSubscriptions.Items[i]).Delete(Self);
FreeAndNil(FSubscriptions);
end;
inherited Destroy;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UNetState;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, lNet, UEnhancedMemoryStream, UAccount, ULinkedList;
type
{ TNetState }
TNetState = class(TObject)
constructor Create(ASocket: TLSocket);
destructor Destroy; override;
protected
FSocket: TLSocket;
FSendQueue: TEnhancedMemoryStream;
FReceiveQueue: TEnhancedMemoryStream;
FAccount: TAccount;
FSubscriptions: TList;
FLastAction: TDateTime;
public
property Socket: TLSocket read FSocket;
property SendQueue: TEnhancedMemoryStream read FSendQueue;
property ReceiveQueue: TEnhancedMemoryStream read FReceiveQueue;
property Account: TAccount read FAccount write FAccount;
property Subscriptions: TList read FSubscriptions;
property LastAction: TDateTime read FLastAction write FLastAction;
end;
implementation
{ TNetState }
constructor TNetState.Create(ASocket: TLSocket);
begin
inherited Create;
FSocket := ASocket;
FSendQueue := TEnhancedMemoryStream.Create;
FReceiveQueue := TEnhancedMemoryStream.Create;
FAccount := nil;
FSubscriptions := TList.Create;
FLastAction := Now;
end;
destructor TNetState.Destroy;
var
i: Integer;
begin
if FSendQueue <> nil then FreeAndNil(FSendQueue);
if FReceiveQueue <> nil then FreeAndNil(FReceiveQueue);
if FSubscriptions <> nil then
begin
for i := 0 to FSubscriptions.Count - 1 do
TLinkedList(FSubscriptions.Items[i]).Delete(Self);
FreeAndNil(FSubscriptions);
end;
inherited Destroy;
end;
end.

436
Server/UPacketHandlers.pas
View File

@ -1,218 +1,218 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
Classes, SysUtils, dzlib, UConfig, UNetState, UEnhancedMemoryStream, UEnums,
ULinkedList, URegions;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream; ANetState: TNetState) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel): Boolean; overload;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel; AX, AY: Cardinal): Boolean; overload;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UCEDServer, UPackets, UConnectionHandling, UAdminHandling, UClientHandling;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel): Boolean;
begin
Result := (ANetState.Account <> nil) and (ANetState.Account.AccessLevel >= ALevel);
end;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel; AX, AY: Cardinal): Boolean;
var
i,j: Word;
region: TRegion;
rect: TRect;
begin
if not ValidateAccess(ANetState, ALevel) then Exit(False);
if (ANetState.Account.Regions.Count = 0) or
(ANetState.Account.AccessLevel >= alAdministrator) then Exit(True); //no restrictions
Result := False;
for i := 0 to ANetState.Account.Regions.Count - 1 do
begin
region := Config.Regions.Find(ANetState.Account.Regions[i]);
if region <> nil then
begin
for j := 0 to region.Areas.Count - 1 do
begin
rect := region.Areas.Rects[j];
if (AX >= rect.Left) and
(AX < rect.Right) and
(AY >= rect.Top) and
(AY < rect.Bottom) then
Exit(True);
end;
end;
end;
end;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
if Assigned(PacketHandlers[AID]) then FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer, ANetState)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer, ANetState);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
targetSize := ABuffer.ReadCardinal;
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream, ANetState);
uncompStream.Unlock;
end else
begin
Writeln(TimeStamp, 'Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.ReceiveQueue.Clear;
CEDServerInstance.Disconnect(ANetState.Socket);
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
procedure OnRequestBlocksPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
coords: TBlockCoordsArray;
begin
if not ValidateAccess(ANetState, alView) then Exit;
SetLength(coords, (ABuffer.Size - ABuffer.Position) div SizeOf(TBlockCoords));
ABuffer.Read(coords[0], Length(coords) * SizeOf(TBlockCoords));
CEDServerInstance.SendPacket(ANetState, TCompressedPacket.Create(TBlockPacket.Create(coords, ANetState)));
end;
procedure OnFreeBlockPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
x, y: Word;
blockSubscriptions: TLinkedList;
begin
if not ValidateAccess(ANetState, alView) then Exit;
x := ABuffer.ReadWord;
y := ABuffer.ReadWord;
blockSubscriptions := CEDServerInstance.Landscape.BlockSubscriptions[X, Y];
if blockSubscriptions <> nil then
begin
blockSubscriptions.Delete(ANetState);
ANetState.Subscriptions.Remove(blockSubscriptions);
end;
end;
procedure OnNoOpPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
begin
//no operation
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlerPacket);
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);
PacketHandlers[$04] := TPacketHandler.Create(0, @OnRequestBlocksPacket);
PacketHandlers[$05] := TPacketHandler.Create(5, @OnFreeBlockPacket);
//$06-$0B handled by landscape
PacketHandlers[$0C] := TPacketHandler.Create(0, @OnClientHandlerPacket);
//$0D handled by radarmap
//$0E handled by landscape
PacketHandlers[$FF] := TPacketHandler.Create(1, @OnNoOpPacket);
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPacketHandlers;
interface
uses
Classes, SysUtils, dzlib, UConfig, UNetState, UEnhancedMemoryStream, UEnums,
ULinkedList, URegions;
type
TPacketProcessor = procedure(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
TPacketProcessorMethod = procedure(ABuffer: TEnhancedMemoryStream; ANetState: TNetState) of object;
{ TPacketHandler }
TPacketHandler = class(TObject)
constructor Create(ALength: Cardinal; APacketProcessor: TPacketProcessor); overload;
constructor Create(ALength: Cardinal; APacketProcessorMethod: TPacketProcessorMethod); overload;
procedure Process(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
protected
FLength: Cardinal;
FPacketProcessor: TPacketProcessor;
FPacketProcessorMethod: TPacketProcessorMethod;
published
property PacketLength: Cardinal read FLength;
end;
var
PacketHandlers: array[0..$FF] of TPacketHandler;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel): Boolean; overload;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel; AX, AY: Cardinal): Boolean; overload;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
implementation
uses
UCEDServer, UPackets, UConnectionHandling, UAdminHandling, UClientHandling;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel): Boolean;
begin
Result := (ANetState.Account <> nil) and (ANetState.Account.AccessLevel >= ALevel);
end;
function ValidateAccess(ANetState: TNetState; ALevel: TAccessLevel; AX, AY: Cardinal): Boolean;
var
i,j: Word;
region: TRegion;
rect: TRect;
begin
if not ValidateAccess(ANetState, ALevel) then Exit(False);
if (ANetState.Account.Regions.Count = 0) or
(ANetState.Account.AccessLevel >= alAdministrator) then Exit(True); //no restrictions
Result := False;
for i := 0 to ANetState.Account.Regions.Count - 1 do
begin
region := Config.Regions.Find(ANetState.Account.Regions[i]);
if region <> nil then
begin
for j := 0 to region.Areas.Count - 1 do
begin
rect := region.Areas.Rects[j];
if (AX >= rect.Left) and
(AX < rect.Right) and
(AY >= rect.Top) and
(AY < rect.Bottom) then
Exit(True);
end;
end;
end;
end;
procedure RegisterPacketHandler(AID: Byte; APacketHandler: TPacketHandler);
begin
if Assigned(PacketHandlers[AID]) then FreeAndNil(PacketHandlers[AID]);
PacketHandlers[AID] := APacketHandler;
end;
{ TPacketHandler }
constructor TPacketHandler.Create(ALength: Cardinal; APacketProcessor: TPacketProcessor);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := APacketProcessor;
FPacketProcessorMethod := nil;
end;
constructor TPacketHandler.Create(ALength: Cardinal;
APacketProcessorMethod: TPacketProcessorMethod);
begin
inherited Create;
FLength := ALength;
FPacketProcessor := nil;
FPacketProcessorMethod := APacketProcessorMethod;
end;
procedure TPacketHandler.Process(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
begin
if Assigned(FPacketProcessor) then
FPacketProcessor(ABuffer, ANetState)
else if Assigned(FPacketProcessorMethod) then
FPacketProcessorMethod(ABuffer, ANetState);
end;
procedure OnCompressedPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
uncompStream: TEnhancedMemoryStream;
uncompBuffer: TDecompressionStream;
targetSize: Cardinal;
packetID: Byte;
begin
targetSize := ABuffer.ReadCardinal;
uncompBuffer := TDecompressionStream.Create(ABuffer);
uncompStream := TEnhancedMemoryStream.Create;
try
uncompStream.CopyFrom(uncompBuffer, targetSize);
uncompStream.Position := 0;
packetID := uncompStream.ReadByte;
if PacketHandlers[packetID] <> nil then
begin
if PacketHandlers[PacketID].PacketLength = 0 then
uncompStream.Position := uncompStream.Position + 4;
uncompStream.Lock(uncompStream.Position, uncompStream.Size - uncompStream.Position);
PacketHandlers[PacketID].Process(uncompStream, ANetState);
uncompStream.Unlock;
end else
begin
Writeln(TimeStamp, 'Dropping client due to unknown packet: ', ANetState.Socket.PeerAddress);
ANetState.ReceiveQueue.Clear;
CEDServerInstance.Disconnect(ANetState.Socket);
end;
finally
if uncompBuffer <> nil then uncompBuffer.Free;
if uncompStream <> nil then uncompStream.Free;
end;
end;
procedure OnRequestBlocksPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
coords: TBlockCoordsArray;
begin
if not ValidateAccess(ANetState, alView) then Exit;
SetLength(coords, (ABuffer.Size - ABuffer.Position) div SizeOf(TBlockCoords));
ABuffer.Read(coords[0], Length(coords) * SizeOf(TBlockCoords));
CEDServerInstance.SendPacket(ANetState, TCompressedPacket.Create(TBlockPacket.Create(coords, ANetState)));
end;
procedure OnFreeBlockPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
x, y: Word;
blockSubscriptions: TLinkedList;
begin
if not ValidateAccess(ANetState, alView) then Exit;
x := ABuffer.ReadWord;
y := ABuffer.ReadWord;
blockSubscriptions := CEDServerInstance.Landscape.BlockSubscriptions[X, Y];
if blockSubscriptions <> nil then
begin
blockSubscriptions.Delete(ANetState);
ANetState.Subscriptions.Remove(blockSubscriptions);
end;
end;
procedure OnNoOpPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
begin
//no operation
end;
{$WARNINGS OFF}
var
i: Integer;
initialization
for i := 0 to $FF do
PacketHandlers[i] := nil;
PacketHandlers[$01] := TPacketHandler.Create(0, @OnCompressedPacket);
PacketHandlers[$02] := TPacketHandler.Create(0, @OnConnectionHandlerPacket);
PacketHandlers[$03] := TPacketHandler.Create(0, @OnAdminHandlerPacket);
PacketHandlers[$04] := TPacketHandler.Create(0, @OnRequestBlocksPacket);
PacketHandlers[$05] := TPacketHandler.Create(5, @OnFreeBlockPacket);
//$06-$0B handled by landscape
PacketHandlers[$0C] := TPacketHandler.Create(0, @OnClientHandlerPacket);
//$0D handled by radarmap
//$0E handled by landscape
PacketHandlers[$FF] := TPacketHandler.Create(1, @OnNoOpPacket);
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
PacketHandlers[i].Free;
{$WARNINGS ON}
end.

452
Server/UPackets.pas
View File

@ -1,226 +1,226 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UMap, UStatics, ULinkedList,
UNetState;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TSendBlocksPacket }
TBlockPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray; ANetState: TNetState);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AMapCell: TMapCell);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
end;
implementation
uses
UCEDServer;
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TEnhancedMemoryStream;
begin
inherited Create($01, 0);
sourceStream := APacket.Stream;
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TBlockPacket }
constructor TBlockPacket.Create(ACoords: TBlockCoordsArray; ANetState: TNetState);
var
i: Integer;
mapBlock: TMapBlock;
staticsBlock: TStaticBlock;
subscriptions: TLinkedList;
begin
inherited Create($04, 0);
for i := Low(ACoords) to High(ACoords) do
begin
mapBlock := CEDServerInstance.Landscape.GetMapBlock(ACoords[i].X, ACoords[i].Y);
if mapBlock = nil then Continue;
mapBlock.GetSize;
staticsBlock := CEDServerInstance.Landscape.GetStaticBlock(ACoords[i].X, ACoords[i].Y);
if staticsBlock = nil then Continue;
staticsBlock.GetSize;
FStream.Write(ACoords[i], SizeOf(TBlockCoords));
mapBlock.Write(FStream);
FStream.WriteWord(staticsBlock.Items.Count);
staticsBlock.Write(FStream);
if ANetState <> nil then
begin
subscriptions := CEDServerInstance.Landscape.BlockSubscriptions[ACoords[i].X, ACoords[i].Y];
subscriptions.Delete(ANetState);
subscriptions.Add(Integer(ANetState), ANetState);
if ANetState.Subscriptions.IndexOf(subscriptions) = -1 then
ANetState.Subscriptions.Add(subscriptions);
end;
end;
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AMapCell: TMapCell);
begin
inherited Create($06, 8);
FStream.WriteWord(AMapCell.X);
FStream.WriteWord(AMapCell.Y);
FStream.WriteShortInt(AMapCell.Altitude);
FStream.WriteWord(AMapCell.TileID);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($07, 10);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteWord(ANewHue);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UPackets;
interface
uses
Classes, dzlib, UEnhancedMemoryStream, UPacket, UMap, UStatics, ULinkedList,
UNetState;
type
TBlockCoords = packed record
X: Word;
Y: Word;
end;
TBlockCoordsArray = array of TBlockCoords;
{ TCompressedPacket }
TCompressedPacket = class(TPacket)
constructor Create(APacket: TPacket);
end;
{ TSendBlocksPacket }
TBlockPacket = class(TPacket)
constructor Create(ACoords: TBlockCoordsArray; ANetState: TNetState);
end;
{ TDrawMapPacket }
TDrawMapPacket = class(TPacket)
constructor Create(AMapCell: TMapCell);
end;
{ TInsertStaticPacket }
TInsertStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TDeleteStaticPacket }
TDeleteStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem);
end;
{ TElevateStaticPacket }
TElevateStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
end;
{ TMoveStaticPacket }
TMoveStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewX, ANewY: Word);
end;
{ THueStaticPacket }
THueStaticPacket = class(TPacket)
constructor Create(AStaticItem: TStaticItem; ANewHue: Word);
end;
implementation
uses
UCEDServer;
{ TCompressedPacket }
constructor TCompressedPacket.Create(APacket: TPacket);
var
compBuffer: TEnhancedMemoryStream;
compStream: TCompressionStream;
sourceStream: TEnhancedMemoryStream;
begin
inherited Create($01, 0);
sourceStream := APacket.Stream;
compBuffer := TEnhancedMemoryStream.Create;
compStream := TCompressionStream.Create(clMax, compBuffer);
compStream.CopyFrom(sourceStream, 0);
compStream.Free;
FStream.WriteCardinal(sourceStream.Size);
FStream.CopyFrom(compBuffer, 0);
compBuffer.Free;
APacket.Free;
end;
{ TBlockPacket }
constructor TBlockPacket.Create(ACoords: TBlockCoordsArray; ANetState: TNetState);
var
i: Integer;
mapBlock: TMapBlock;
staticsBlock: TStaticBlock;
subscriptions: TLinkedList;
begin
inherited Create($04, 0);
for i := Low(ACoords) to High(ACoords) do
begin
mapBlock := CEDServerInstance.Landscape.GetMapBlock(ACoords[i].X, ACoords[i].Y);
if mapBlock = nil then Continue;
mapBlock.GetSize;
staticsBlock := CEDServerInstance.Landscape.GetStaticBlock(ACoords[i].X, ACoords[i].Y);
if staticsBlock = nil then Continue;
staticsBlock.GetSize;
FStream.Write(ACoords[i], SizeOf(TBlockCoords));
mapBlock.Write(FStream);
FStream.WriteWord(staticsBlock.Items.Count);
staticsBlock.Write(FStream);
if ANetState <> nil then
begin
subscriptions := CEDServerInstance.Landscape.BlockSubscriptions[ACoords[i].X, ACoords[i].Y];
subscriptions.Delete(ANetState);
subscriptions.Add(Integer(ANetState), ANetState);
if ANetState.Subscriptions.IndexOf(subscriptions) = -1 then
ANetState.Subscriptions.Add(subscriptions);
end;
end;
end;
{ TDrawMapPacket }
constructor TDrawMapPacket.Create(AMapCell: TMapCell);
begin
inherited Create($06, 8);
FStream.WriteWord(AMapCell.X);
FStream.WriteWord(AMapCell.Y);
FStream.WriteShortInt(AMapCell.Altitude);
FStream.WriteWord(AMapCell.TileID);
end;
{ TInsertStaticPacket }
constructor TInsertStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($07, 10);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TDeleteStaticPacket }
constructor TDeleteStaticPacket.Create(AStaticItem: TStaticItem);
begin
inherited Create($08, 10);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
end;
{ TElevateStaticPacket }
constructor TElevateStaticPacket.Create(AStaticItem: TStaticItem; ANewZ: ShortInt);
begin
inherited Create($09, 11);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteShortInt(ANewZ);
end;
{ TMoveStaticPacket }
constructor TMoveStaticPacket.Create(AStaticItem: TStaticItem; ANewX,
ANewY: Word);
begin
inherited Create($0A, 14);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteWord(ANewX);
FStream.WriteWord(ANewY);
end;
{ THueStaticPacket }
constructor THueStaticPacket.Create(AStaticItem: TStaticItem; ANewHue: Word);
begin
inherited Create($0B, 12);
FStream.WriteWord(AStaticItem.X);
FStream.WriteWord(AStaticItem.Y);
FStream.WriteShortInt(AStaticItem.Z);
FStream.WriteWord(AStaticItem.TileID);
FStream.WriteWord(AStaticItem.Hue);
FStream.WriteWord(ANewHue);
end;
end.

288
UBufferedStreams.pas
View File

@ -1,144 +1,144 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UBufferedStreams;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UEnhancedMemoryStream;
type
{ TBufferedStream }
TBufferedStream = class(TEnhancedMemoryStream)
constructor Create(ABaseStream: TStream; AOwnsBaseStream: Boolean = false); virtual;
destructor Destroy; override;
protected
FBaseStream: TStream;
FOwnsBaseStream: Boolean;
public
procedure Refresh; virtual;
procedure Flush; virtual;
function GetSize: Int64; override;
end;
TBufferedReader = class(TBufferedStream)
constructor Create(ABaseStream: TStream; AOwnsBaseStream: Boolean = false); override;
destructor Destroy; override;
protected
FReadBuffer: TEnhancedMemoryStream;
public
function Write(const Buffer; Count: Longint): Longint; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure Refresh; override;
end;
implementation
{ TBufferedStream }
constructor TBufferedStream.Create(ABaseStream: TStream;
AOwnsBaseStream: Boolean);
begin
inherited Create;
FBaseStream := ABaseStream;
FOwnsBaseStream := AOwnsBaseStream;
Refresh;
end;
destructor TBufferedStream.Destroy;
begin
if FOwnsBaseStream and Assigned(FBaseStream) then
FreeAndNil(FBaseStream);
inherited;
end;
procedure TBufferedStream.Flush;
begin
FBaseStream.Size := Size;
FBaseStream.Position := 0;
FBaseStream.CopyFrom(Self, 0);
end;
function TBufferedStream.GetSize: Int64;
begin
Result := FBaseStream.Size;
end;
procedure TBufferedStream.Refresh;
begin
Size := FBaseStream.Size;
Position := 0;
CopyFrom(FBaseStream, 0);
end;
{ TBufferedReader }
constructor TBufferedReader.Create(ABaseStream: TStream;
AOwnsBaseStream: Boolean);
begin
FReadBuffer := TEnhancedMemoryStream.Create;
inherited;
end;
destructor TBufferedReader.Destroy;
begin
if Assigned(FReadBuffer) then FreeAndNil(FReadBuffer);
inherited;
end;
function TBufferedReader.Read(var Buffer; Count: Integer): Longint;
begin
Result := FReadBuffer.Read(Buffer, Count);
end;
procedure TBufferedReader.Refresh;
begin
FReadBuffer.Size := FBaseStream.Size;
FReadBuffer.Position := 0;
FReadBuffer.CopyFrom(FBaseStream, 0);
FReadBuffer.Position := 0;
FBaseStream.Position := 0;
end;
function TBufferedReader.Seek(Offset: Integer; Origin: Word): Longint;
begin
FBaseStream.Seek(Offset, Origin);
Result := FReadBuffer.Seek(Offset, Origin);
end;
function TBufferedReader.Write(const Buffer; Count: Integer): Longint;
begin
FBaseStream.Position := FReadBuffer.Position;
FBaseStream.Write(Buffer, Count);
Result := FReadBuffer.Write(Buffer, Count);
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UBufferedStreams;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, UEnhancedMemoryStream;
type
{ TBufferedStream }
TBufferedStream = class(TEnhancedMemoryStream)
constructor Create(ABaseStream: TStream; AOwnsBaseStream: Boolean = false); virtual;
destructor Destroy; override;
protected
FBaseStream: TStream;
FOwnsBaseStream: Boolean;
public
procedure Refresh; virtual;
procedure Flush; virtual;
function GetSize: Int64; override;
end;
TBufferedReader = class(TBufferedStream)
constructor Create(ABaseStream: TStream; AOwnsBaseStream: Boolean = false); override;
destructor Destroy; override;
protected
FReadBuffer: TEnhancedMemoryStream;
public
function Write(const Buffer; Count: Longint): Longint; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure Refresh; override;
end;
implementation
{ TBufferedStream }
constructor TBufferedStream.Create(ABaseStream: TStream;
AOwnsBaseStream: Boolean);
begin
inherited Create;
FBaseStream := ABaseStream;
FOwnsBaseStream := AOwnsBaseStream;
Refresh;
end;
destructor TBufferedStream.Destroy;
begin
if FOwnsBaseStream and Assigned(FBaseStream) then
FreeAndNil(FBaseStream);
inherited;
end;
procedure TBufferedStream.Flush;
begin
FBaseStream.Size := Size;
FBaseStream.Position := 0;
FBaseStream.CopyFrom(Self, 0);
end;
function TBufferedStream.GetSize: Int64;
begin
Result := FBaseStream.Size;
end;
procedure TBufferedStream.Refresh;
begin
Size := FBaseStream.Size;
Position := 0;
CopyFrom(FBaseStream, 0);
end;
{ TBufferedReader }
constructor TBufferedReader.Create(ABaseStream: TStream;
AOwnsBaseStream: Boolean);
begin
FReadBuffer := TEnhancedMemoryStream.Create;
inherited;
end;
destructor TBufferedReader.Destroy;
begin
if Assigned(FReadBuffer) then FreeAndNil(FReadBuffer);
inherited;
end;
function TBufferedReader.Read(var Buffer; Count: Integer): Longint;
begin
Result := FReadBuffer.Read(Buffer, Count);
end;
procedure TBufferedReader.Refresh;
begin
FReadBuffer.Size := FBaseStream.Size;
FReadBuffer.Position := 0;
FReadBuffer.CopyFrom(FBaseStream, 0);
FReadBuffer.Position := 0;
FBaseStream.Position := 0;
end;
function TBufferedReader.Seek(Offset: Integer; Origin: Word): Longint;
begin
FBaseStream.Seek(Offset, Origin);
Result := FReadBuffer.Seek(Offset, Origin);
end;
function TBufferedReader.Write(const Buffer; Count: Integer): Longint;
begin
FBaseStream.Position := FReadBuffer.Position;
FBaseStream.Write(Buffer, Count);
Result := FReadBuffer.Write(Buffer, Count);
end;
end.

508
UEnhancedMemoryStream.pas
View File

@ -1,254 +1,254 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UEnhancedMemoryStream;
{$mode delphi}{$H+}
interface
uses
Classes, UStreamHelper;
type
{ TEnhancedMemoryStream }
TEnhancedMemoryStream = class(TFifoStream)
public
function ReadBoolean: Boolean;
function ReadByte: Byte;
function ReadCardinal: Cardinal;
function ReadInteger: Integer;
function ReadInt64: Int64;
function ReadShortInt: ShortInt;
function ReadSmallInt: SmallInt;
function ReadWord: Word;
function ReadStringNull: string;
function ReadStringFixed(ALength: Integer): string;
function ReadStringBigUniNull: WideString;
procedure WriteBoolean(AValue: Boolean);
procedure WriteByte(AValue: Byte);
procedure WriteCardinal(AValue: Cardinal);
procedure WriteInteger(AValue: Integer);
procedure WriteInt64(AValue: Int64);
procedure WriteShortInt(AValue: ShortInt);
procedure WriteSmallInt(AValue: SmallInt);
procedure WriteWord(AValue: Word);
procedure WriteStringNull(AValue: string);
procedure WriteStringFixed(AValue: string; ALength: Integer);
procedure WriteStringBigUniNull(AValue: WideString);
procedure WriteStringLittleUniNull(AValue: WideString);
end;
implementation
type
PByteArray = ^TByteArray;
TByteArray = array[0..MaxInt - 1] of Byte;
function SwapWideChar(Char: WideChar): WideChar;
begin
Result := WideChar((Word(Char) shl 8) or ((Word(Char) shr 8) and $FF));
end;
{ TEnhancedMemoryStream }
function TEnhancedMemoryStream.ReadBoolean: Boolean;
begin
Read(Result, SizeOf(Boolean));
end;
function TEnhancedMemoryStream.ReadByte: Byte;
begin
Read(Result, SizeOf(Byte));
end;
function TEnhancedMemoryStream.ReadCardinal: Cardinal;
begin
Read(Result, SizeOf(Cardinal));
end;
function TEnhancedMemoryStream.ReadInt64: Int64;
begin
Read(Result, SizeOf(Int64));
end;
function TEnhancedMemoryStream.ReadShortInt: ShortInt;
begin
Read(Result, SizeOf(ShortInt));
end;
function TEnhancedMemoryStream.ReadInteger: Integer;
begin
Read(Result, SizeOf(Integer));
end;
function TEnhancedMemoryStream.ReadSmallInt: SmallInt;
begin
Read(Result, SizeOf(SmallInt));
end;
function TEnhancedMemoryStream.ReadStringBigUniNull: WideString;
var
buffer: PWideChar;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(Memory) + Position);
length := 0;
while (buffer[length] <> #0) and (length < (Size - Position)) do
begin
if (SwapWideChar(buffer[length]) = #10) and (SwapWideChar(buffer[length - 1]) <> #13) then
Result := Result + #13;
Result := Result + SwapWideChar(buffer[length]);
if (SwapWideChar(buffer[length]) = #13) and (SwapWideChar(buffer[length + 1]) <> #10) then
Result := Result + #10;
inc(length);
end;
Position := Position + (Length + 1) * 2;
end;
function TEnhancedMemoryStream.ReadStringFixed(ALength: Integer): string;
var
buffer: PChar;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(FMemory) + FPosition);
length := 0;
while (length < ALength) and (length < (FSize - (FPosition - FLockOffset))) do
begin
if (buffer[length] = #10) and (buffer[length - 1] <> #13) then
Result := Result + #13;
Result := Result + buffer[length];
if (buffer[length] = #13) and (buffer[length + 1] <> #10) then
Result := Result + #10;
inc(length);
end;
FPosition := FPosition + length + 1;
end;
function TEnhancedMemoryStream.ReadStringNull: string;
var
buffer: PByteArray;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(FMemory) + FPosition);
length := 0;
while (buffer^[length] <> 0) and (length < (FSize - (FPosition - FLockOffset))) do
begin
if (buffer^[length] = 10) and (buffer^[length - 1] <> 13) then
Result := Result + #13;
Result := Result + Char(buffer^[length]);
if (buffer^[length] = 13) and (buffer^[length + 1] <> 10) then
Result := Result + #10;
inc(length);
end;
FPosition := FPosition + length + 1;
end;
function TEnhancedMemoryStream.ReadWord: Word;
begin
Read(Result, SizeOf(Word));
end;
procedure TEnhancedMemoryStream.WriteBoolean(AValue: Boolean);
begin
Write(AValue, SizeOf(Boolean));
end;
procedure TEnhancedMemoryStream.WriteByte(AValue: Byte);
begin
Write(AValue, SizeOf(Byte));
end;
procedure TEnhancedMemoryStream.WriteCardinal(AValue: Cardinal);
begin
Write(AValue, SizeOf(Cardinal));
end;
procedure TEnhancedMemoryStream.WriteInt64(AValue: Int64);
begin
Write(AValue, SizeOf(Int64));
end;
procedure TEnhancedMemoryStream.WriteShortInt(AValue: ShortInt);
begin
Write(AValue, SizeOf(ShortInt));
end;
procedure TEnhancedMemoryStream.WriteInteger(AValue: Integer);
begin
Write(AValue, SizeOf(Integer));
end;
procedure TEnhancedMemoryStream.WriteSmallInt(AValue: SmallInt);
begin
Write(AValue, SizeOf(SmallInt));
end;
procedure TEnhancedMemoryStream.WriteStringBigUniNull(AValue: WideString);
var
i: Integer;
begin
for i := 1 to Length(AValue) do
WriteWord(Word(SwapWideChar(AValue[i])));
WriteWord(0);
end;
procedure TEnhancedMemoryStream.WriteStringFixed(AValue: string;
ALength: Integer);
var
i: Integer;
begin
for i := Length(AValue) to ALength do
AValue := AValue + #0;
Write(PChar(AValue)^, ALength);
end;
procedure TEnhancedMemoryStream.WriteStringLittleUniNull(
AValue: WideString);
var
i: Integer;
begin
for i := 1 to Length(AValue) do
WriteWord(Word(AValue[i]));
WriteWord(0);
end;
procedure TEnhancedMemoryStream.WriteStringNull(AValue: string);
begin
write(PChar(AValue)^, Length(AValue) + 1);
end;
procedure TEnhancedMemoryStream.WriteWord(AValue: Word);
begin
Write(AValue, SizeOf(Word));
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UEnhancedMemoryStream;
{$mode delphi}{$H+}
interface
uses
Classes, UStreamHelper;
type
{ TEnhancedMemoryStream }
TEnhancedMemoryStream = class(TFifoStream)
public
function ReadBoolean: Boolean;
function ReadByte: Byte;
function ReadCardinal: Cardinal;
function ReadInteger: Integer;
function ReadInt64: Int64;
function ReadShortInt: ShortInt;
function ReadSmallInt: SmallInt;
function ReadWord: Word;
function ReadStringNull: string;
function ReadStringFixed(ALength: Integer): string;
function ReadStringBigUniNull: WideString;
procedure WriteBoolean(AValue: Boolean);
procedure WriteByte(AValue: Byte);
procedure WriteCardinal(AValue: Cardinal);
procedure WriteInteger(AValue: Integer);
procedure WriteInt64(AValue: Int64);
procedure WriteShortInt(AValue: ShortInt);
procedure WriteSmallInt(AValue: SmallInt);
procedure WriteWord(AValue: Word);
procedure WriteStringNull(AValue: string);
procedure WriteStringFixed(AValue: string; ALength: Integer);
procedure WriteStringBigUniNull(AValue: WideString);
procedure WriteStringLittleUniNull(AValue: WideString);
end;
implementation
type
PByteArray = ^TByteArray;
TByteArray = array[0..MaxInt - 1] of Byte;
function SwapWideChar(Char: WideChar): WideChar;
begin
Result := WideChar((Word(Char) shl 8) or ((Word(Char) shr 8) and $FF));
end;
{ TEnhancedMemoryStream }
function TEnhancedMemoryStream.ReadBoolean: Boolean;
begin
Read(Result, SizeOf(Boolean));
end;
function TEnhancedMemoryStream.ReadByte: Byte;
begin
Read(Result, SizeOf(Byte));
end;
function TEnhancedMemoryStream.ReadCardinal: Cardinal;
begin
Read(Result, SizeOf(Cardinal));
end;
function TEnhancedMemoryStream.ReadInt64: Int64;
begin
Read(Result, SizeOf(Int64));
end;
function TEnhancedMemoryStream.ReadShortInt: ShortInt;
begin
Read(Result, SizeOf(ShortInt));
end;
function TEnhancedMemoryStream.ReadInteger: Integer;
begin
Read(Result, SizeOf(Integer));
end;
function TEnhancedMemoryStream.ReadSmallInt: SmallInt;
begin
Read(Result, SizeOf(SmallInt));
end;
function TEnhancedMemoryStream.ReadStringBigUniNull: WideString;
var
buffer: PWideChar;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(Memory) + Position);
length := 0;
while (buffer[length] <> #0) and (length < (Size - Position)) do
begin
if (SwapWideChar(buffer[length]) = #10) and (SwapWideChar(buffer[length - 1]) <> #13) then
Result := Result + #13;
Result := Result + SwapWideChar(buffer[length]);
if (SwapWideChar(buffer[length]) = #13) and (SwapWideChar(buffer[length + 1]) <> #10) then
Result := Result + #10;
inc(length);
end;
Position := Position + (Length + 1) * 2;
end;
function TEnhancedMemoryStream.ReadStringFixed(ALength: Integer): string;
var
buffer: PChar;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(FMemory) + FPosition);
length := 0;
while (length < ALength) and (length < (FSize - (FPosition - FLockOffset))) do
begin
if (buffer[length] = #10) and (buffer[length - 1] <> #13) then
Result := Result + #13;
Result := Result + buffer[length];
if (buffer[length] = #13) and (buffer[length + 1] <> #10) then
Result := Result + #10;
inc(length);
end;
FPosition := FPosition + length + 1;
end;
function TEnhancedMemoryStream.ReadStringNull: string;
var
buffer: PByteArray;
length: Integer;
begin
Result := '';
buffer := Pointer(LongInt(FMemory) + FPosition);
length := 0;
while (buffer^[length] <> 0) and (length < (FSize - (FPosition - FLockOffset))) do
begin
if (buffer^[length] = 10) and (buffer^[length - 1] <> 13) then
Result := Result + #13;
Result := Result + Char(buffer^[length]);
if (buffer^[length] = 13) and (buffer^[length + 1] <> 10) then
Result := Result + #10;
inc(length);
end;
FPosition := FPosition + length + 1;
end;
function TEnhancedMemoryStream.ReadWord: Word;
begin
Read(Result, SizeOf(Word));
end;
procedure TEnhancedMemoryStream.WriteBoolean(AValue: Boolean);
begin
Write(AValue, SizeOf(Boolean));
end;
procedure TEnhancedMemoryStream.WriteByte(AValue: Byte);
begin
Write(AValue, SizeOf(Byte));
end;
procedure TEnhancedMemoryStream.WriteCardinal(AValue: Cardinal);
begin
Write(AValue, SizeOf(Cardinal));
end;
procedure TEnhancedMemoryStream.WriteInt64(AValue: Int64);
begin
Write(AValue, SizeOf(Int64));
end;
procedure TEnhancedMemoryStream.WriteShortInt(AValue: ShortInt);
begin
Write(AValue, SizeOf(ShortInt));
end;
procedure TEnhancedMemoryStream.WriteInteger(AValue: Integer);
begin
Write(AValue, SizeOf(Integer));
end;
procedure TEnhancedMemoryStream.WriteSmallInt(AValue: SmallInt);
begin
Write(AValue, SizeOf(SmallInt));
end;
procedure TEnhancedMemoryStream.WriteStringBigUniNull(AValue: WideString);
var
i: Integer;
begin
for i := 1 to Length(AValue) do
WriteWord(Word(SwapWideChar(AValue[i])));
WriteWord(0);
end;
procedure TEnhancedMemoryStream.WriteStringFixed(AValue: string;
ALength: Integer);
var
i: Integer;
begin
for i := Length(AValue) to ALength do
AValue := AValue + #0;
Write(PChar(AValue)^, ALength);
end;
procedure TEnhancedMemoryStream.WriteStringLittleUniNull(
AValue: WideString);
var
i: Integer;
begin
for i := 1 to Length(AValue) do
WriteWord(Word(AValue[i]));
WriteWord(0);
end;
procedure TEnhancedMemoryStream.WriteStringNull(AValue: string);
begin
write(PChar(AValue)^, Length(AValue) + 1);
end;
procedure TEnhancedMemoryStream.WriteWord(AValue: Word);
begin
Write(AValue, SizeOf(Word));
end;
end.

334
ULinkedList.pas
View File

@ -1,167 +1,167 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit ULinkedList;
interface
uses
SysUtils;
type
PLinkedItem = ^TLinkedItem;
TLinkedItem = record
ID: Integer;
Data: Pointer;
Next: PLinkedItem;
end;
TLinkedList = class(TObject)
constructor Create; virtual;
destructor Destroy; override;
protected
FFirst: PLinkedItem;
FLast: PLinkedItem;
public
procedure Clear; virtual;
function Iterate(var ALinkedItem: PLinkedItem): Boolean; virtual;
function Add(AID: Integer; AData: Pointer): PLinkedItem; virtual;
procedure Delete(AData: Pointer); overload; virtual;
procedure Delete(AID: Integer); overload; virtual;
function Get(AID: Integer): Pointer; virtual;
property Last: PLinkedItem read FLast;
end;
implementation
{ TBlockList }
function TLinkedList.Add(AID: Integer; AData: Pointer): PLinkedItem;
var
current: PLinkedItem;
begin
New(current);
current^.ID := AID;
current^.Data := AData;
current^.Next := nil;
if FFirst = nil then FFirst := current;
if FLast <> nil then FLast^.Next := current;
FLast := current;
Result := current;
end;
procedure TLinkedList.Clear;
var
current, next: PLinkedItem;
begin
current := FFirst;
while current <> nil do
begin
next := current^.Next;
Dispose(current);
current := next;
end;
FFirst := nil;
FLast := nil;
end;
constructor TLinkedList.Create;
begin
inherited Create;
FFirst := nil;
FLast := nil;
end;
procedure TLinkedList.Delete(AData: Pointer);
var
currentItem, lastItem, nextItem: PLinkedItem;
begin
lastItem := nil;
currentItem := FFirst;
while currentItem <> nil do
begin
if currentItem^.Data = AData then
begin
if FFirst = currentItem then FFirst := currentItem^.Next;
if FLast = currentItem then FLast := lastItem;
if lastItem <> nil then lastItem^.Next := currentItem^.Next;
Dispose(currentItem);
nextItem := nil;
end else
nextItem := currentItem^.Next;
lastItem := currentItem;
currentItem := nextItem;
end;
end;
procedure TLinkedList.Delete(AID: Integer);
var
currentItem, lastItem, nextItem: PLinkedItem;
begin
lastItem := nil;
currentItem := FFirst;
while currentItem <> nil do
begin
if currentItem^.ID = AID then
begin
if FFirst = currentItem then FFirst := currentItem^.Next;
if FLast = currentItem then FLast := lastItem;
if lastItem <> nil then lastItem^.Next := currentItem^.Next;
Dispose(currentItem);
nextItem := nil;
end else
nextItem := currentItem^.Next;
lastItem := currentItem;
currentItem := nextItem;
end;
end;
destructor TLinkedList.Destroy;
begin
Clear;
inherited Destroy;
end;
function TLinkedList.Get(AID: Integer): Pointer;
var
item: PLinkedItem;
begin
Result := nil;
item := nil;
while Iterate(item) and (Result = nil) do
if item^.ID = AID then
Result := item^.Data;
end;
function TLinkedList.Iterate(var ALinkedItem: PLinkedItem): Boolean;
begin
if ALinkedItem = nil then
ALinkedItem := FFirst
else
ALinkedItem := ALinkedItem^.Next;
Result := ALinkedItem <> nil;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit ULinkedList;
interface
uses
SysUtils;
type
PLinkedItem = ^TLinkedItem;
TLinkedItem = record
ID: Integer;
Data: Pointer;
Next: PLinkedItem;
end;
TLinkedList = class(TObject)
constructor Create; virtual;
destructor Destroy; override;
protected
FFirst: PLinkedItem;
FLast: PLinkedItem;
public
procedure Clear; virtual;
function Iterate(var ALinkedItem: PLinkedItem): Boolean; virtual;
function Add(AID: Integer; AData: Pointer): PLinkedItem; virtual;
procedure Delete(AData: Pointer); overload; virtual;
procedure Delete(AID: Integer); overload; virtual;
function Get(AID: Integer): Pointer; virtual;
property Last: PLinkedItem read FLast;
end;
implementation
{ TBlockList }
function TLinkedList.Add(AID: Integer; AData: Pointer): PLinkedItem;
var
current: PLinkedItem;
begin
New(current);
current^.ID := AID;
current^.Data := AData;
current^.Next := nil;
if FFirst = nil then FFirst := current;
if FLast <> nil then FLast^.Next := current;
FLast := current;
Result := current;
end;
procedure TLinkedList.Clear;
var
current, next: PLinkedItem;
begin
current := FFirst;
while current <> nil do
begin
next := current^.Next;
Dispose(current);
current := next;
end;
FFirst := nil;
FLast := nil;
end;
constructor TLinkedList.Create;
begin
inherited Create;
FFirst := nil;
FLast := nil;
end;
procedure TLinkedList.Delete(AData: Pointer);
var
currentItem, lastItem, nextItem: PLinkedItem;
begin
lastItem := nil;
currentItem := FFirst;
while currentItem <> nil do
begin
if currentItem^.Data = AData then
begin
if FFirst = currentItem then FFirst := currentItem^.Next;
if FLast = currentItem then FLast := lastItem;
if lastItem <> nil then lastItem^.Next := currentItem^.Next;
Dispose(currentItem);
nextItem := nil;
end else
nextItem := currentItem^.Next;
lastItem := currentItem;
currentItem := nextItem;
end;
end;
procedure TLinkedList.Delete(AID: Integer);
var
currentItem, lastItem, nextItem: PLinkedItem;
begin
lastItem := nil;
currentItem := FFirst;
while currentItem <> nil do
begin
if currentItem^.ID = AID then
begin
if FFirst = currentItem then FFirst := currentItem^.Next;
if FLast = currentItem then FLast := lastItem;
if lastItem <> nil then lastItem^.Next := currentItem^.Next;
Dispose(currentItem);
nextItem := nil;
end else
nextItem := currentItem^.Next;
lastItem := currentItem;
currentItem := nextItem;
end;
end;
destructor TLinkedList.Destroy;
begin
Clear;
inherited Destroy;
end;
function TLinkedList.Get(AID: Integer): Pointer;
var
item: PLinkedItem;
begin
Result := nil;
item := nil;
while Iterate(item) and (Result = nil) do
if item^.ID = AID then
Result := item^.Data;
end;
function TLinkedList.Iterate(var ALinkedItem: PLinkedItem): Boolean;
begin
if ALinkedItem = nil then
ALinkedItem := FFirst
else
ALinkedItem := ALinkedItem^.Next;
Result := ALinkedItem <> nil;
end;
end.

650
UOLib/UArt.pas
View File

@ -1,325 +1,325 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UArt;
{$mode objfpc}{$H+}
interface
uses
Classes, Imaging, ImagingTypes, ImagingCanvases, ImagingClasses,
UMulBlock, UGenericIndex, UHue;
type
TArtType = (atLand, atStatic, atLandFlat);
TArt = class(TMulBlock)
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType); overload;
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AHue: THue; APartialHue: Boolean); overload;
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AArtColor: Word; AHue: THue; APartialHue: Boolean); overload;
destructor Destroy; override;
function Clone: TArt; override;
function GetSize: Integer; override;
procedure Write(AData: TStream); override;
procedure RefreshBuffer;
protected
FArtType: TArtType;
FHeader: LongInt;
FGraphic: TSingleImage;
FBuffer: TStream;
public
property ArtType: TArtType read FArtType write FArtType;
property Header: LongInt read FHeader write FHeader;
property Graphic: TSingleImage read FGraphic;
property Buffer: TStream read FBuffer;
end;
implementation
type
PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType);
begin
Create(AData, AIndex, AArtType, 0, nil, False);
end;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AHue: THue; APartialHue: Boolean);
begin
Create(AData, AIndex, AArtType, 0, AHue, APartialHue);
end;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AArtColor: Word; AHue: THue; APartialHue: Boolean);
var
i, x, y, start: Integer;
iCurrentHeight, iCurrentWidth: Integer;
width, height: SmallInt;
lookup: array of integer;
color, run, offset: Word;
block: TMemoryStream;
P: PWordArray;
r, g, b: Byte;
begin
FBuffer := TMemoryStream.Create;
FArtType := AArtType;
AArtColor := AArtColor or $8000; //set alpha bit on background
if Assigned(AData) and (AIndex.Lookup > -1) then
begin
AData.Position := AIndex.Lookup;
block := TMemoryStream.Create;
block.CopyFrom(AData, AIndex.Size);
block.Position := 0;
if AArtType = atLand then
begin
FGraphic:= TSingleImage.CreateFromParams(44, 44, ifA1R5G5B5);
FillWord(FGraphic.Bits^, 44 * 44, AArtColor);
for y := 0 to 21 do
begin
P := FGraphic.Bits + y * 44 * 2;
block.Read(P^[22 - (y + 1)], (y + 1) * 4);
end;
for y := 0 to 21 do
begin
P := FGraphic.Bits + (22 + y) * 44 * 2;
block.Read(P^[y], (22 - y) * 4);
end;
for i := 0 to 44 * 44 - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else if AArtType = atLandFlat then
begin
FGraphic:= TSingleImage.CreateFromParams(44, 44, ifA1R5G5B5);
for i := 1 to 22 do
begin
for x := 0 to i * 2 - 1 do
begin
y := i * 2 - x - 1;
block.Read(color, SizeOf(Word));
PWordArray(FGraphic.Bits + y * 44 * 2)^[x] := color;
if y > 0 then
PWordArray(FGraphic.Bits + (y - 1) * 44 * 2)^[x] := color;
end;
end;
for i := 22 to 43 do
begin
for y := 0 to (44 - i) * 2 - 1 do
begin
x := 42 - (43 - i) * 2 + y;
block.Read(color, SizeOf(Word));
PWordArray(FGraphic.Bits + (43 - y) * 44 * 2)^[x] := color;
if y > 0 then
PWordArray(FGraphic.Bits + (44 - y) * 44 * 2)^[x] := color;
end;
end;
for i := 0 to 44 * 44 - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else if AArtType = atStatic then
begin
block.Read(FHeader, SizeOf(LongInt));
block.Read(width, SizeOf(SmallInt));
block.Read(height, SizeOf(SmallInt));
FGraphic:= TSingleImage.CreateFromParams(width, height, ifA1R5G5B5);
FillWord(FGraphic.Bits^, width * height, AArtColor);
SetLength(lookup, height);
start := block.Position + (height * 2);
for i := 0 to height - 1 do
begin
block.Read(offset, SizeOf(Word));
lookup[i] := start + (offset * 2);
end;
for iCurrentHeight := 0 to height - 1 do
begin
block.Position := lookup[iCurrentHeight];
iCurrentWidth := 0;
P := FGraphic.Bits + iCurrentHeight * width * 2;
while (block.Read(offset, SizeOf(Word)) = SizeOf(Word)) and
(block.Read(run, SizeOf(Word)) = SizeOf(Word)) and
(offset + run <> 0) do
begin
inc(iCurrentWidth, offset);
for i := 0 to run - 1 do
begin
block.Read(color, SizeOf(Word));
P^[iCurrentWidth + i] := color;
end;
inc(iCurrentWidth, run);
end;
end;
if AHue <> nil then
begin
for i := 0 to width * height - 1 do
begin
color := PWordArray(FGraphic.Bits)^[i];
if color <> AArtColor then
begin
r := (color and $7C00) shr 10;
if APartialHue then
begin
g := (color and $3E0) shr 5;
b := color and $1F;
if (r = g) and (g = b) then
color := AHue.ColorTable[r];
end else
color := AHue.ColorTable[r];
end;
PWordArray(FGraphic.Bits)^[i] := color;
end;
end;
for i := 0 to width * height - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else
FGraphic:= TSingleImage.Create;
if Assigned(block) then block.Free;
end else
begin
FHeader := 1;
FGraphic := TSingleImage.Create;
end;
FGraphic.Format := ifA8R8G8B8;
end;
destructor TArt.Destroy;
begin
if assigned(FGraphic) then FGraphic.Free;
if assigned(FBuffer) then FBuffer.Free;
inherited;
end;
function TArt.Clone: TArt;
begin
Result := TArt.Create(nil, nil, FArtType);
Result.FHeader := FHeader;
Result.FGraphic.Assign(FGraphic);
end;
procedure TArt.Write(AData: TStream);
begin
FBuffer.Position := 0;
AData.CopyFrom(FBuffer, FBuffer.Size);
end;
function TArt.GetSize: Integer;
begin
RefreshBuffer;
Result := FBuffer.Size
end;
procedure TArt.RefreshBuffer;
var
argbGraphic: TSingleImage;
i, x, y, lineWidth, start: Integer;
iCurrentHeight, iCurrentWidth: Integer;
width, height: SmallInt;
color, run, offset: Word;
lookup: array of SmallInt;
begin
argbGraphic := TSingleImage.CreateFromImage(FGraphic);
argbGraphic.Format := ifA1R5G5B5;
for i := 0 to argbGraphic.Width * argbGraphic.Height - 1 do
PWordArray(argbGraphic.Bits)^[i] := PWordArray(argbGraphic.Bits)^[i] xor $8000; //invert alpha bit
FBuffer.Size := 0;
if FArtType = atLand then
begin
if (argbGraphic.Height <> 44) or (argbGraphic.Width <> 44) then Exit;
x := 21;
y := 0;
lineWidth := 2;
for i := 1 to 22 do
begin
Dec(x);
FBuffer.Write(PWordArray(argbGraphic.Bits + y * 44 * 2)^[x + i], lineWidth);
Inc(y);
Inc(lineWidth, 2);
end;
for i := 1 to 22 do
begin
Dec(lineWidth, 2);
FBuffer.Write(PWordArray(argbGraphic.Bits + y * 44 * 2)^[x + i], lineWidth);
Inc(x);
Inc(y);
end;
end else if FArtType = atStatic then
begin
if (argbGraphic.Height = 0) or (argbGraphic.Width = 0) then Exit;
width := argbGraphic.Width;
height := argbGraphic.Height;
FBuffer.Write(FHeader, SizeOf(LongInt));
FBuffer.Write(width, SizeOf(SmallInt));
FBuffer.Write(height, SizeOf(SmallInt));
SetLength(lookup, height);
for i := 0 to height - 1 do
FBuffer.Write(lookup[i], SizeOf(SmallInt)); //placeholders for the lookup table
start := FBuffer.Position;
for iCurrentHeight := 0 to height - 1 do
begin
lookup[iCurrentHeight] := SmallInt((FBuffer.Position - start) div 2); //remember the lookup offset for the current line
offset := 0;
run := 0;
for iCurrentWidth := 0 to width - 1 do //process every pixel on the current line
begin
color := PWordArray(FGraphic.Bits + iCurrentHeight * width * 2)^[iCurrentWidth];
if (color and $8000 = 0) and (run = 0) then //new visible pixel found
begin
FBuffer.Write(offset, SizeOf(Word));
FBuffer.Write(offset, SizeOf(Word)); //just a placeholder for the "run length"
run := 1;
FBuffer.Write(color, SizeOf(Word));
end else if (color and $8000 = 0) and (run > 0) then //another visible pixel found
begin
inc(run);
FBuffer.Write(color, SizeOf(Word));
end else if (color and $8000 = $8000) and (run > 0) then //after some visible pixels this one is invisible, so stop the current run
begin
FBuffer.Seek(Integer(-((run + 1) * 2)), soFromCurrent); //jump back ...
FBuffer.Write(run, SizeOf(Word)); //... to write the actual "run length" ...
FBuffer.Seek(Integer(run * 2), soFromCurrent); //... and jump forth again to proceed
run := 0;
offset := 1;
end else
inc(offset);
end;
if run > 0 then //no more pixels but the "run" didn't end yet ;-)
begin
FBuffer.Seek(Integer(-((run + 1) * 2)), soFromCurrent);
FBuffer.Write(run, SizeOf(Word));
FBuffer.Seek(Integer(run * 2), soFromCurrent);
run := 0;
end;
FBuffer.Write(run, SizeOf(Word)); //just write "0"
FBuffer.Write(run, SizeOf(Word)); //... two times, to indicate the end of that line
end;
FBuffer.Position := start - (height * 2); //now update the lookup table with our new values
for i := 0 to height - 1 do
FBuffer.Write(lookup[i], SizeOf(SmallInt));
end;
argbGraphic.Free;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UArt;
{$mode objfpc}{$H+}
interface
uses
Classes, Imaging, ImagingTypes, ImagingCanvases, ImagingClasses,
UMulBlock, UGenericIndex, UHue;
type
TArtType = (atLand, atStatic, atLandFlat);
TArt = class(TMulBlock)
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType); overload;
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AHue: THue; APartialHue: Boolean); overload;
constructor Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AArtColor: Word; AHue: THue; APartialHue: Boolean); overload;
destructor Destroy; override;
function Clone: TArt; override;
function GetSize: Integer; override;
procedure Write(AData: TStream); override;
procedure RefreshBuffer;
protected
FArtType: TArtType;
FHeader: LongInt;
FGraphic: TSingleImage;
FBuffer: TStream;
public
property ArtType: TArtType read FArtType write FArtType;
property Header: LongInt read FHeader write FHeader;
property Graphic: TSingleImage read FGraphic;
property Buffer: TStream read FBuffer;
end;
implementation
type
PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType);
begin
Create(AData, AIndex, AArtType, 0, nil, False);
end;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AHue: THue; APartialHue: Boolean);
begin
Create(AData, AIndex, AArtType, 0, AHue, APartialHue);
end;
constructor TArt.Create(AData: TStream; AIndex: TGenericIndex; AArtType: TArtType; AArtColor: Word; AHue: THue; APartialHue: Boolean);
var
i, x, y, start: Integer;
iCurrentHeight, iCurrentWidth: Integer;
width, height: SmallInt;
lookup: array of integer;
color, run, offset: Word;
block: TMemoryStream;
P: PWordArray;
r, g, b: Byte;
begin
FBuffer := TMemoryStream.Create;
FArtType := AArtType;
AArtColor := AArtColor or $8000; //set alpha bit on background
if Assigned(AData) and (AIndex.Lookup > -1) then
begin
AData.Position := AIndex.Lookup;
block := TMemoryStream.Create;
block.CopyFrom(AData, AIndex.Size);
block.Position := 0;
if AArtType = atLand then
begin
FGraphic:= TSingleImage.CreateFromParams(44, 44, ifA1R5G5B5);
FillWord(FGraphic.Bits^, 44 * 44, AArtColor);
for y := 0 to 21 do
begin
P := FGraphic.Bits + y * 44 * 2;
block.Read(P^[22 - (y + 1)], (y + 1) * 4);
end;
for y := 0 to 21 do
begin
P := FGraphic.Bits + (22 + y) * 44 * 2;
block.Read(P^[y], (22 - y) * 4);
end;
for i := 0 to 44 * 44 - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else if AArtType = atLandFlat then
begin
FGraphic:= TSingleImage.CreateFromParams(44, 44, ifA1R5G5B5);
for i := 1 to 22 do
begin
for x := 0 to i * 2 - 1 do
begin
y := i * 2 - x - 1;
block.Read(color, SizeOf(Word));
PWordArray(FGraphic.Bits + y * 44 * 2)^[x] := color;
if y > 0 then
PWordArray(FGraphic.Bits + (y - 1) * 44 * 2)^[x] := color;
end;
end;
for i := 22 to 43 do
begin
for y := 0 to (44 - i) * 2 - 1 do
begin
x := 42 - (43 - i) * 2 + y;
block.Read(color, SizeOf(Word));
PWordArray(FGraphic.Bits + (43 - y) * 44 * 2)^[x] := color;
if y > 0 then
PWordArray(FGraphic.Bits + (44 - y) * 44 * 2)^[x] := color;
end;
end;
for i := 0 to 44 * 44 - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else if AArtType = atStatic then
begin
block.Read(FHeader, SizeOf(LongInt));
block.Read(width, SizeOf(SmallInt));
block.Read(height, SizeOf(SmallInt));
FGraphic:= TSingleImage.CreateFromParams(width, height, ifA1R5G5B5);
FillWord(FGraphic.Bits^, width * height, AArtColor);
SetLength(lookup, height);
start := block.Position + (height * 2);
for i := 0 to height - 1 do
begin
block.Read(offset, SizeOf(Word));
lookup[i] := start + (offset * 2);
end;
for iCurrentHeight := 0 to height - 1 do
begin
block.Position := lookup[iCurrentHeight];
iCurrentWidth := 0;
P := FGraphic.Bits + iCurrentHeight * width * 2;
while (block.Read(offset, SizeOf(Word)) = SizeOf(Word)) and
(block.Read(run, SizeOf(Word)) = SizeOf(Word)) and
(offset + run <> 0) do
begin
inc(iCurrentWidth, offset);
for i := 0 to run - 1 do
begin
block.Read(color, SizeOf(Word));
P^[iCurrentWidth + i] := color;
end;
inc(iCurrentWidth, run);
end;
end;
if AHue <> nil then
begin
for i := 0 to width * height - 1 do
begin
color := PWordArray(FGraphic.Bits)^[i];
if color <> AArtColor then
begin
r := (color and $7C00) shr 10;
if APartialHue then
begin
g := (color and $3E0) shr 5;
b := color and $1F;
if (r = g) and (g = b) then
color := AHue.ColorTable[r];
end else
color := AHue.ColorTable[r];
end;
PWordArray(FGraphic.Bits)^[i] := color;
end;
end;
for i := 0 to width * height - 1 do
PWordArray(FGraphic.Bits)^[i] := PWordArray(FGraphic.Bits)^[i] xor $8000; //invert alpha bit
end else
FGraphic:= TSingleImage.Create;
if Assigned(block) then block.Free;
end else
begin
FHeader := 1;
FGraphic := TSingleImage.Create;
end;
FGraphic.Format := ifA8R8G8B8;
end;
destructor TArt.Destroy;
begin
if assigned(FGraphic) then FGraphic.Free;
if assigned(FBuffer) then FBuffer.Free;
inherited;
end;
function TArt.Clone: TArt;
begin
Result := TArt.Create(nil, nil, FArtType);
Result.FHeader := FHeader;
Result.FGraphic.Assign(FGraphic);
end;
procedure TArt.Write(AData: TStream);
begin
FBuffer.Position := 0;
AData.CopyFrom(FBuffer, FBuffer.Size);
end;
function TArt.GetSize: Integer;
begin
RefreshBuffer;
Result := FBuffer.Size
end;
procedure TArt.RefreshBuffer;
var
argbGraphic: TSingleImage;
i, x, y, lineWidth, start: Integer;
iCurrentHeight, iCurrentWidth: Integer;
width, height: SmallInt;
color, run, offset: Word;
lookup: array of SmallInt;
begin
argbGraphic := TSingleImage.CreateFromImage(FGraphic);
argbGraphic.Format := ifA1R5G5B5;
for i := 0 to argbGraphic.Width * argbGraphic.Height - 1 do
PWordArray(argbGraphic.Bits)^[i] := PWordArray(argbGraphic.Bits)^[i] xor $8000; //invert alpha bit
FBuffer.Size := 0;
if FArtType = atLand then
begin
if (argbGraphic.Height <> 44) or (argbGraphic.Width <> 44) then Exit;
x := 21;
y := 0;
lineWidth := 2;
for i := 1 to 22 do
begin
Dec(x);
FBuffer.Write(PWordArray(argbGraphic.Bits + y * 44 * 2)^[x + i], lineWidth);
Inc(y);
Inc(lineWidth, 2);
end;
for i := 1 to 22 do
begin
Dec(lineWidth, 2);
FBuffer.Write(PWordArray(argbGraphic.Bits + y * 44 * 2)^[x + i], lineWidth);
Inc(x);
Inc(y);
end;
end else if FArtType = atStatic then
begin
if (argbGraphic.Height = 0) or (argbGraphic.Width = 0) then Exit;
width := argbGraphic.Width;
height := argbGraphic.Height;
FBuffer.Write(FHeader, SizeOf(LongInt));
FBuffer.Write(width, SizeOf(SmallInt));
FBuffer.Write(height, SizeOf(SmallInt));
SetLength(lookup, height);
for i := 0 to height - 1 do
FBuffer.Write(lookup[i], SizeOf(SmallInt)); //placeholders for the lookup table
start := FBuffer.Position;
for iCurrentHeight := 0 to height - 1 do
begin
lookup[iCurrentHeight] := SmallInt((FBuffer.Position - start) div 2); //remember the lookup offset for the current line
offset := 0;
run := 0;
for iCurrentWidth := 0 to width - 1 do //process every pixel on the current line
begin
color := PWordArray(FGraphic.Bits + iCurrentHeight * width * 2)^[iCurrentWidth];
if (color and $8000 = 0) and (run = 0) then //new visible pixel found
begin
FBuffer.Write(offset, SizeOf(Word));
FBuffer.Write(offset, SizeOf(Word)); //just a placeholder for the "run length"
run := 1;
FBuffer.Write(color, SizeOf(Word));
end else if (color and $8000 = 0) and (run > 0) then //another visible pixel found
begin
inc(run);
FBuffer.Write(color, SizeOf(Word));
end else if (color and $8000 = $8000) and (run > 0) then //after some visible pixels this one is invisible, so stop the current run
begin
FBuffer.Seek(Integer(-((run + 1) * 2)), soFromCurrent); //jump back ...
FBuffer.Write(run, SizeOf(Word)); //... to write the actual "run length" ...
FBuffer.Seek(Integer(run * 2), soFromCurrent); //... and jump forth again to proceed
run := 0;
offset := 1;
end else
inc(offset);
end;
if run > 0 then //no more pixels but the "run" didn't end yet ;-)
begin
FBuffer.Seek(Integer(-((run + 1) * 2)), soFromCurrent);
FBuffer.Write(run, SizeOf(Word));
FBuffer.Seek(Integer(run * 2), soFromCurrent);
run := 0;
end;
FBuffer.Write(run, SizeOf(Word)); //just write "0"
FBuffer.Write(run, SizeOf(Word)); //... two times, to indicate the end of that line
end;
FBuffer.Position := start - (height * 2); //now update the lookup table with our new values
for i := 0 to height - 1 do
FBuffer.Write(lookup[i], SizeOf(SmallInt));
end;
argbGraphic.Free;
end;
end.

166
UOLib/UGenericIndex.pas
View File

@ -1,83 +1,83 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGenericIndex;
{$mode objfpc}{$H+}
interface
uses
Classes, UMulBlock;
type
TGenericIndex = class(TMulBlock)
constructor Create(Data: TStream);
function Clone: TGenericIndex; override;
function GetSize: Integer; override;
procedure Write(Data: TStream); override;
protected
FLookup: LongInt;
FSize: LongInt;
FVarious: LongInt;
published
property Lookup: LongInt read FLookup write FLookup;
property Size: LongInt read FSize write FSize;
property Various: LongInt read FVarious write FVarious;
end;
implementation
constructor TGenericIndex.Create(Data: TStream);
begin
if assigned(Data) then
begin
Data.Read(FLookup, SizeOf(LongInt));
Data.Read(FSize, SizeOf(LongInt));
Data.Read(FVarious, SizeOf(LongInt));
end;
end;
function TGenericIndex.Clone: TGenericIndex;
begin
Result := TGenericIndex.Create(nil);
Result.FLookup := FLookup;
Result.FSize := FSize;
Result.FVarious := FVarious;
end;
procedure TGenericIndex.Write(Data: TStream);
begin
Data.Write(FLookup, SizeOf(LongInt));
Data.Write(FSize, SizeOf(LongInt));
Data.Write(FVarious, SizeOf(LongInt));
end;
function TGenericIndex.GetSize: Integer;
begin
Result := 12;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGenericIndex;
{$mode objfpc}{$H+}
interface
uses
Classes, UMulBlock;
type
TGenericIndex = class(TMulBlock)
constructor Create(Data: TStream);
function Clone: TGenericIndex; override;
function GetSize: Integer; override;
procedure Write(Data: TStream); override;
protected
FLookup: LongInt;
FSize: LongInt;
FVarious: LongInt;
published
property Lookup: LongInt read FLookup write FLookup;
property Size: LongInt read FSize write FSize;
property Various: LongInt read FVarious write FVarious;
end;
implementation
constructor TGenericIndex.Create(Data: TStream);
begin
if assigned(Data) then
begin
Data.Read(FLookup, SizeOf(LongInt));
Data.Read(FSize, SizeOf(LongInt));
Data.Read(FVarious, SizeOf(LongInt));
end;
end;
function TGenericIndex.Clone: TGenericIndex;
begin
Result := TGenericIndex.Create(nil);
Result.FLookup := FLookup;
Result.FSize := FSize;
Result.FVarious := FVarious;
end;
procedure TGenericIndex.Write(Data: TStream);
begin
Data.Write(FLookup, SizeOf(LongInt));
Data.Write(FSize, SizeOf(LongInt));
Data.Write(FVarious, SizeOf(LongInt));
end;
function TGenericIndex.GetSize: Integer;
begin
Result := 12;
end;
end.

170
UOLib/UGraphicHelper.pas
View File

@ -1,85 +1,85 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGraphicHelper;
{$mode objfpc}{$H+}
interface
function ARGB2RGB(Value: Word): Integer;
function RGB2ARGB(Value: Integer): Word;
//New functions for Vampyre Imaging Lib
function DecodeUOColor(Value: Word): Integer;
function EncodeUOColor(Value: Integer): Word;
implementation
function ARGB2RGB(Value: Word): Integer;
var
R, G, B: Byte;
begin
R := ((Value shr 10) and $1F) * 8;
G := ((Value shr 5) and $1F) * 8;
B := (Value and $1F) * 8;
Result := R + G shl 8 + B shl 16;
end;
function RGB2ARGB(Value: Integer): Word;
var
R, G, B: Byte;
begin
R := (Value and $FF) div 8;
G := ((Value shr 8) and $FF) div 8;
B := ((Value shr 16) and $FF) div 8;
Result := (R shl 10) + (G shl 5) + B;
end;
function DecodeUOColor(Value: Word): Integer;
var
R, G, B: Byte;
begin
R := ((Value shr 10) and $1F) * 8;
G := ((Value shr 5) and $1F) * 8;
B := (Value and $1F) * 8;
Result := B + G shl 8 + R shl 16;
end;
function EncodeUOColor(Value: Integer): Word;
var
R, G, B: Byte;
begin
B := (Value and $FF) div 8;
G := ((Value shr 8) and $FF) div 8;
R := ((Value shr 16) and $FF) div 8;
Result := (R shl 10) + (G shl 5) + B;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGraphicHelper;
{$mode objfpc}{$H+}
interface
function ARGB2RGB(Value: Word): Integer;
function RGB2ARGB(Value: Integer): Word;
//New functions for Vampyre Imaging Lib
function DecodeUOColor(Value: Word): Integer;
function EncodeUOColor(Value: Integer): Word;
implementation
function ARGB2RGB(Value: Word): Integer;
var
R, G, B: Byte;
begin
R := ((Value shr 10) and $1F) * 8;
G := ((Value shr 5) and $1F) * 8;
B := (Value and $1F) * 8;
Result := R + G shl 8 + B shl 16;
end;
function RGB2ARGB(Value: Integer): Word;
var
R, G, B: Byte;
begin
R := (Value and $FF) div 8;
G := ((Value shr 8) and $FF) div 8;
B := ((Value shr 16) and $FF) div 8;
Result := (R shl 10) + (G shl 5) + B;
end;
function DecodeUOColor(Value: Word): Integer;
var
R, G, B: Byte;
begin
R := ((Value shr 10) and $1F) * 8;
G := ((Value shr 5) and $1F) * 8;
B := (Value and $1F) * 8;
Result := B + G shl 8 + R shl 16;
end;
function EncodeUOColor(Value: Integer): Word;
var
R, G, B: Byte;
begin
B := (Value and $FF) div 8;
G := ((Value shr 8) and $FF) div 8;
R := ((Value shr 16) and $FF) div 8;
Result := (R shl 10) + (G shl 5) + B;
end;
end.

466
UOLib/UGump.pas
View File

@ -1,233 +1,233 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGump;
{$mode objfpc}{$H+}
interface
uses
Classes, Imaging, ImagingTypes, ImagingClasses, UMulBlock, UGenericIndex;
type
TGumpIndex = class(TGenericIndex)
protected
function GetWidth: SmallInt;
function GetHeight: SmallInt;
procedure SetWidth(AValue: SmallInt);
procedure SetHeight(AValue: SmallInt);
published
property Width: SmallInt read GetWidth write SetWidth;
property Height: SmallInt read GetHeight write SetHeight;
end;
TGump = class(TMulBlock)
constructor Create(AData: TStream; AIndex: TGumpIndex); overload;
constructor Create(AWidth, AHeight: Integer); overload;
destructor Destroy; override;
function Clone: TGump; override;
function GetSize: Integer; override;
procedure Write(AData: TStream); override;
procedure RefreshBuffer;
protected
FGraphic: TSingleImage;
FBuffer: TStream;
published
property Graphic: TSingleImage read FGraphic;
end;
implementation
type
PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word;
{ TGumpIndex }
function TGumpIndex.GetHeight: SmallInt;
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
Result := sizeInfoW[0];
end;
function TGumpIndex.GetWidth: SmallInt;
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
Result := sizeInfoW[1];
end;
procedure TGumpIndex.SetHeight(AValue: SmallInt);
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
sizeInfoW[0] := AValue;
FVarious := sizeInfo;
end;
procedure TGumpIndex.SetWidth(AValue: SmallInt);
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
sizeInfoW[1] := AValue;
FVarious := sizeInfo;
end;
{ TGump }
constructor TGump.Create(AData: TStream; AIndex: TGumpIndex);
var
iCurrentHeight, iCurrentWidth, i: Integer;
RowLookup: array of integer;
Offset: Integer;
Value, Run: Word;
block: TMemoryStream;
begin
inherited Create;
FGraphic := TSingleImage.CreateFromParams(AIndex.Width, AIndex.Height, ifA1R5G5B5);
FBuffer := TMemoryStream.Create;
SetLength(RowLookup, AIndex.Height);
if assigned(AData) then
begin
AData.Position := AIndex.Lookup;
block := TMemoryStream.Create;
block.CopyFrom(AData, AIndex.Size);
block.Position := 0;
for i := 0 to AIndex.Height - 1 do
begin
block.Read(Offset, SizeOf(Integer));
RowLookup[i] := Offset * 4;
end;
for iCurrentHeight := 0 to AIndex.Height - 1 do
begin
block.Position := RowLookup[iCurrentHeight];
iCurrentWidth := 0;
while iCurrentWidth < AIndex.Width do
begin
block.Read(Value, SizeOf(Word));
block.Read(Run, SizeOf(Word));
if Value > 0 then Value := Value or $8000; //Set alpha bit of non-black colors
for i := 0 to Run - 1 do
PWordArray(FGraphic.Bits + iCurrentHeight * AIndex.Width * 2)^[iCurrentWidth + i] := Value;
inc(iCurrentWidth, Run);
end;
end;
block.Free;
end;
FGraphic.Format := ifA8R8G8B8;
end;
constructor TGump.Create(AWidth, AHeight: Integer);
begin
{TODO : WARNING! Width and Height got switched since MulEditor!}
inherited Create;
FGraphic := TSingleImage.CreateFromParams(AWidth, AHeight, ifA8R8G8B8);
FBuffer := TMemoryStream.Create;
end;
destructor TGump.Destroy;
begin
if assigned(FGraphic) then FGraphic.Free;
if assigned(FBuffer) then FBuffer.Free;
inherited Destroy;
end;
function TGump.Clone: TGump;
begin
Result := TGump.Create(FGraphic.Width, FGraphic.Height);
Result.FGraphic.Assign(FGraphic);
end;
procedure TGump.Write(AData: TStream);
begin
FBuffer.Position := 0;
AData.CopyFrom(FBuffer, FBuffer.Size);
end;
function TGump.GetSize: Integer;
begin
RefreshBuffer;
Result := FBuffer.Size;
end;
procedure TGump.RefreshBuffer;
var
argbGraphic: TSingleImage;
colorBuffer: PWordArray;
runBuffer: array of Word;
offsetBuffer: array of Integer;
currentColor, currentRun: Integer;
iCurrentHeight, i: Integer;
begin
argbGraphic := TSingleImage.CreateFromImage(FGraphic);
argbGraphic.Format := ifA1R5G5B5;
SetLength(runBuffer, argbGraphic.Width);
SetLength(offsetBuffer, argbGraphic.Height);
FBuffer.Size := argbGraphic.Height * SizeOf(Integer);
FBuffer.Position := FBuffer.Size;
for iCurrentHeight := 0 to argbGraphic.Height - 1 do
begin
colorBuffer := argbGraphic.Bits + iCurrentHeight * argbGraphic.Width * 2;
for i := 0 to argbGraphic.Width - 1 do
begin
runBuffer[i] := 1;
colorBuffer^[i] := colorBuffer^[i] and not $8000; //eleminate alpha bit
end;
currentRun := 0;
currentColor := colorBuffer^[0];
for i := 1 to argbGraphic.Width - 1 do
begin
if colorBuffer^[i] = currentColor then
Inc(runBuffer[currentRun])
else
Inc(currentRun);
currentColor := colorBuffer^[i];
end;
offsetBuffer[iCurrentHeight] := FBuffer.Position div 4;
currentColor := 0;
for i := 0 to currentRun do
begin
FBuffer.Write(colorBuffer^[currentColor], SizeOf(Word));
FBuffer.Write(runBuffer[i], SizeOf(Word));
Inc(currentColor, runBuffer[i]);
end;
end;
FBuffer.Position := 0;
for i := 0 to argbGraphic.Height - 1 do FBuffer.Write(offsetBuffer[i], SizeOf(Integer));
argbGraphic.Free;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UGump;
{$mode objfpc}{$H+}
interface
uses
Classes, Imaging, ImagingTypes, ImagingClasses, UMulBlock, UGenericIndex;
type
TGumpIndex = class(TGenericIndex)
protected
function GetWidth: SmallInt;
function GetHeight: SmallInt;
procedure SetWidth(AValue: SmallInt);
procedure SetHeight(AValue: SmallInt);
published
property Width: SmallInt read GetWidth write SetWidth;
property Height: SmallInt read GetHeight write SetHeight;
end;
TGump = class(TMulBlock)
constructor Create(AData: TStream; AIndex: TGumpIndex); overload;
constructor Create(AWidth, AHeight: Integer); overload;
destructor Destroy; override;
function Clone: TGump; override;
function GetSize: Integer; override;
procedure Write(AData: TStream); override;
procedure RefreshBuffer;
protected
FGraphic: TSingleImage;
FBuffer: TStream;
published
property Graphic: TSingleImage read FGraphic;
end;
implementation
type
PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word;
{ TGumpIndex }
function TGumpIndex.GetHeight: SmallInt;
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
Result := sizeInfoW[0];
end;
function TGumpIndex.GetWidth: SmallInt;
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
Result := sizeInfoW[1];
end;
procedure TGumpIndex.SetHeight(AValue: SmallInt);
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
sizeInfoW[0] := AValue;
FVarious := sizeInfo;
end;
procedure TGumpIndex.SetWidth(AValue: SmallInt);
var
sizeInfo: LongInt;
sizeInfoW: array[0..1] of SmallInt absolute sizeInfo;
begin
sizeInfo := FVarious;
sizeInfoW[1] := AValue;
FVarious := sizeInfo;
end;
{ TGump }
constructor TGump.Create(AData: TStream; AIndex: TGumpIndex);
var
iCurrentHeight, iCurrentWidth, i: Integer;
RowLookup: array of integer;
Offset: Integer;
Value, Run: Word;
block: TMemoryStream;
begin
inherited Create;
FGraphic := TSingleImage.CreateFromParams(AIndex.Width, AIndex.Height, ifA1R5G5B5);
FBuffer := TMemoryStream.Create;
SetLength(RowLookup, AIndex.Height);
if assigned(AData) then
begin
AData.Position := AIndex.Lookup;
block := TMemoryStream.Create;
block.CopyFrom(AData, AIndex.Size);
block.Position := 0;
for i := 0 to AIndex.Height - 1 do
begin
block.Read(Offset, SizeOf(Integer));
RowLookup[i] := Offset * 4;
end;
for iCurrentHeight := 0 to AIndex.Height - 1 do
begin
block.Position := RowLookup[iCurrentHeight];
iCurrentWidth := 0;
while iCurrentWidth < AIndex.Width do
begin
block.Read(Value, SizeOf(Word));
block.Read(Run, SizeOf(Word));
if Value > 0 then Value := Value or $8000; //Set alpha bit of non-black colors
for i := 0 to Run - 1 do
PWordArray(FGraphic.Bits + iCurrentHeight * AIndex.Width * 2)^[iCurrentWidth + i] := Value;
inc(iCurrentWidth, Run);
end;
end;
block.Free;
end;
FGraphic.Format := ifA8R8G8B8;
end;
constructor TGump.Create(AWidth, AHeight: Integer);
begin
{TODO : WARNING! Width and Height got switched since MulEditor!}
inherited Create;
FGraphic := TSingleImage.CreateFromParams(AWidth, AHeight, ifA8R8G8B8);
FBuffer := TMemoryStream.Create;
end;
destructor TGump.Destroy;
begin
if assigned(FGraphic) then FGraphic.Free;
if assigned(FBuffer) then FBuffer.Free;
inherited Destroy;
end;
function TGump.Clone: TGump;
begin
Result := TGump.Create(FGraphic.Width, FGraphic.Height);
Result.FGraphic.Assign(FGraphic);
end;
procedure TGump.Write(AData: TStream);
begin
FBuffer.Position := 0;
AData.CopyFrom(FBuffer, FBuffer.Size);
end;
function TGump.GetSize: Integer;
begin
RefreshBuffer;
Result := FBuffer.Size;
end;
procedure TGump.RefreshBuffer;
var
argbGraphic: TSingleImage;
colorBuffer: PWordArray;
runBuffer: array of Word;
offsetBuffer: array of Integer;
currentColor, currentRun: Integer;
iCurrentHeight, i: Integer;
begin
argbGraphic := TSingleImage.CreateFromImage(FGraphic);
argbGraphic.Format := ifA1R5G5B5;
SetLength(runBuffer, argbGraphic.Width);
SetLength(offsetBuffer, argbGraphic.Height);
FBuffer.Size := argbGraphic.Height * SizeOf(Integer);
FBuffer.Position := FBuffer.Size;
for iCurrentHeight := 0 to argbGraphic.Height - 1 do
begin
colorBuffer := argbGraphic.Bits + iCurrentHeight * argbGraphic.Width * 2;
for i := 0 to argbGraphic.Width - 1 do
begin
runBuffer[i] := 1;
colorBuffer^[i] := colorBuffer^[i] and not $8000; //eleminate alpha bit
end;
currentRun := 0;
currentColor := colorBuffer^[0];
for i := 1 to argbGraphic.Width - 1 do
begin
if colorBuffer^[i] = currentColor then
Inc(runBuffer[currentRun])
else
Inc(currentRun);
currentColor := colorBuffer^[i];
end;
offsetBuffer[iCurrentHeight] := FBuffer.Position div 4;
currentColor := 0;
for i := 0 to currentRun do
begin
FBuffer.Write(colorBuffer^[currentColor], SizeOf(Word));
FBuffer.Write(runBuffer[i], SizeOf(Word));
Inc(currentColor, runBuffer[i]);
end;
end;
FBuffer.Position := 0;
for i := 0 to argbGraphic.Height - 1 do FBuffer.Write(offsetBuffer[i], SizeOf(Integer));
argbGraphic.Free;
end;
end.

Some files were not shown because too many files have changed in this diff Show More