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

* Unified line-endings (using hgeol)

This commit is contained in:
Andreas Schneider 2015-05-01 12:14:15 +02:00
parent 03b9097465
commit 2e62fd570a
113 changed files with 40648 additions and 40648 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
.hgeol Normal file
View File

104
Client/CentrED.lpr
View File

@ -1,52 +1,52 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2009 Andreas Schneider * Portions Copyright 2009 Andreas Schneider
*) *)
program CentrED; program CentrED;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
uses uses
{$IFDEF UNIX}{$IFDEF UseCThreads} {$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads, cthreads,
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
SysUtils, SysUtils,
Interfaces, // this includes the LCL widgetset Interfaces, // this includes the LCL widgetset
Forms, LResources, UdmNetwork; Forms, LResources, UdmNetwork;
{$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF} {$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF}
function GetApplicationName: String; function GetApplicationName: String;
begin begin
Result := 'CentrED'; Result := 'CentrED';
end; end;
begin begin
{$I CentrED.lrs} {$I CentrED.lrs}
OnGetApplicationName := @GetApplicationName; OnGetApplicationName := @GetApplicationName;
Application.Initialize; Application.Initialize;
Application.CreateForm(TdmNetwork, dmNetwork); Application.CreateForm(TdmNetwork, dmNetwork);
Application.Run; Application.Run;
end. end.

74
Client/Tools/UfrmConfirmation.lfm
View File

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

114
Client/Tools/UfrmConfirmation.pas
View File

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

246
Client/Tools/UfrmDrawSettings.lfm
View File

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

258
Client/Tools/UfrmDrawSettings.pas
View File

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

634
Client/Tools/UfrmFilter.lfm
View File

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

706
Client/Tools/UfrmFilter.pas
View File

@ -1,353 +1,353 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2009 Andreas Schneider * Portions Copyright 2009 Andreas Schneider
*) *)
unit UfrmFilter; unit UfrmFilter;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, VirtualTrees, LCLIntf, LMessages, Buttons, UPlatformTypes, UStatics, ExtCtrls, VirtualTrees, LCLIntf, LMessages, Buttons, UPlatformTypes, UStatics,
Menus; Menus;
type type
{ TfrmFilter } { TfrmFilter }
TfrmFilter = class(TForm) TfrmFilter = class(TForm)
btnClear: TSpeedButton; btnClear: TSpeedButton;
btnDelete: TSpeedButton; btnDelete: TSpeedButton;
btnRandomPresetDelete: TSpeedButton; btnRandomPresetDelete: TSpeedButton;
btnRandomPresetSave: TSpeedButton; btnRandomPresetSave: TSpeedButton;
cbRandomPreset: TComboBox; cbRandomPreset: TComboBox;
cbTileFilter: TCheckBox; cbTileFilter: TCheckBox;
cbHueFilter: TCheckBox; cbHueFilter: TCheckBox;
GroupBox1: TGroupBox; GroupBox1: TGroupBox;
GroupBox2: TGroupBox; GroupBox2: TGroupBox;
Label1: TLabel; Label1: TLabel;
mnuUncheckHues: TMenuItem; mnuUncheckHues: TMenuItem;
mnuCheckHues: TMenuItem; mnuCheckHues: TMenuItem;
pnlRandomPreset: TPanel; pnlRandomPreset: TPanel;
pmHues: TPopupMenu; pmHues: TPopupMenu;
rgFilterType: TRadioGroup; rgFilterType: TRadioGroup;
Splitter1: TSplitter; Splitter1: TSplitter;
vdtFilter: TVirtualDrawTree; vdtFilter: TVirtualDrawTree;
vdtHues: TVirtualDrawTree; vdtHues: TVirtualDrawTree;
procedure btnClearClick(Sender: TObject); procedure btnClearClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject); procedure btnDeleteClick(Sender: TObject);
procedure cbHueFilterChange(Sender: TObject); procedure cbHueFilterChange(Sender: TObject);
procedure cbTileFilterChange(Sender: TObject); procedure cbTileFilterChange(Sender: TObject);
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject); procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject); procedure FormShow(Sender: TObject);
procedure mnuUncheckHuesClick(Sender: TObject); procedure mnuUncheckHuesClick(Sender: TObject);
procedure mnuCheckHuesClick(Sender: TObject); procedure mnuCheckHuesClick(Sender: TObject);
procedure rgFilterTypeClick(Sender: TObject); procedure rgFilterTypeClick(Sender: TObject);
procedure vdtFilterDragDrop(Sender: TBaseVirtualTree; Source: TObject; procedure vdtFilterDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode); Pt: TPoint; var Effect: Integer; Mode: TDropMode);
procedure vdtFilterDragOver(Sender: TBaseVirtualTree; Source: TObject; procedure vdtFilterDragOver(Sender: TBaseVirtualTree; Source: TObject;
Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;
var Effect: Integer; var Accept: Boolean); var Effect: Integer; var Accept: Boolean);
procedure vdtFilterDrawNode(Sender: TBaseVirtualTree; procedure vdtFilterDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
procedure vdtHuesChecked(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure vdtHuesChecked(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure vdtHuesDrawNode(Sender: TBaseVirtualTree; procedure vdtHuesDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
protected protected
FLocked: Boolean; FLocked: Boolean;
FCheckedHues: TBits; FCheckedHues: TBits;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave; procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public public
property Locked: Boolean read FLocked write FLocked; property Locked: Boolean read FLocked write FLocked;
function Filter(AStatic: TStaticItem): Boolean; function Filter(AStatic: TStaticItem): Boolean;
procedure JumpToHue(AHueID: Word); procedure JumpToHue(AHueID: Word);
end; end;
var var
frmFilter: TfrmFilter; frmFilter: TfrmFilter;
implementation implementation
uses uses
UfrmMain, UGameResources, UHue, UGraphicHelper, UGUIPlatformUtils; UfrmMain, UGameResources, UHue, UGraphicHelper, UGUIPlatformUtils;
type type
PTileInfo = ^TTileInfo; PTileInfo = ^TTileInfo;
TTileInfo = record TTileInfo = record
ID: Word; ID: Word;
end; end;
PHueInfo = ^THueInfo; PHueInfo = ^THueInfo;
THueInfo = record THueInfo = record
ID: Word; ID: Word;
Hue: THue; Hue: THue;
end; end;
{ TfrmFilter } { TfrmFilter }
procedure TfrmFilter.FormShow(Sender: TObject); procedure TfrmFilter.FormShow(Sender: TObject);
var var
upperLeft, lowerLeft: TPoint; upperLeft, lowerLeft: TPoint;
begin begin
upperLeft := frmMain.pcLeft.ClientToScreen(Point(frmMain.pcLeft.Width, 0)); upperLeft := frmMain.pcLeft.ClientToScreen(Point(frmMain.pcLeft.Width, 0));
lowerLeft := frmMain.pcLeft.ClientToScreen(Point(frmMain.pcLeft.Width, lowerLeft := frmMain.pcLeft.ClientToScreen(Point(frmMain.pcLeft.Width,
frmMain.pcLeft.Height)); frmMain.pcLeft.Height));
Left := upperLeft.x - 8; Left := upperLeft.x - 8;
Top := upperLeft.y - 8; Top := upperLeft.y - 8;
Height := lowerLeft.y - upperLeft.y; Height := lowerLeft.y - upperLeft.y;
SetWindowParent(Handle, frmMain.Handle); SetWindowParent(Handle, frmMain.Handle);
end; end;
procedure TfrmFilter.mnuUncheckHuesClick(Sender: TObject); procedure TfrmFilter.mnuUncheckHuesClick(Sender: TObject);
begin begin
vdtHues.ClearChecked; vdtHues.ClearChecked;
end; end;
procedure TfrmFilter.mnuCheckHuesClick(Sender: TObject); procedure TfrmFilter.mnuCheckHuesClick(Sender: TObject);
var var
node: PVirtualNode; node: PVirtualNode;
begin begin
node := vdtHues.GetFirst; node := vdtHues.GetFirst;
while node <> nil do while node <> nil do
begin begin
vdtHues.CheckState[node] := csCheckedNormal; vdtHues.CheckState[node] := csCheckedNormal;
node := vdtHues.GetNext(node); node := vdtHues.GetNext(node);
end; end;
end; end;
procedure TfrmFilter.rgFilterTypeClick(Sender: TObject); procedure TfrmFilter.rgFilterTypeClick(Sender: TObject);
begin begin
frmMain.InvalidateFilter; frmMain.InvalidateFilter;
end; end;
procedure TfrmFilter.vdtFilterDragDrop(Sender: TBaseVirtualTree; procedure TfrmFilter.vdtFilterDragDrop(Sender: TBaseVirtualTree;
Source: TObject; DataObject: IDataObject; Formats: TFormatArray; Source: TObject; DataObject: IDataObject; Formats: TFormatArray;
Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode); Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);
var var
sourceTree: TVirtualDrawTree; sourceTree: TVirtualDrawTree;
selected, node: PVirtualNode; selected, node: PVirtualNode;
sourceTileInfo, targetTileInfo: PTileInfo; sourceTileInfo, targetTileInfo: PTileInfo;
begin begin
sourceTree := Source as TVirtualDrawTree; sourceTree := Source as TVirtualDrawTree;
if (sourceTree <> Sender) and (sourceTree <> nil) and if (sourceTree <> Sender) and (sourceTree <> nil) and
(sourceTree.Tag = 1) then (sourceTree.Tag = 1) then
begin begin
Sender.BeginUpdate; Sender.BeginUpdate;
selected := sourceTree.GetFirstSelected; selected := sourceTree.GetFirstSelected;
while selected <> nil do while selected <> nil do
begin begin
sourceTileInfo := sourceTree.GetNodeData(selected); sourceTileInfo := sourceTree.GetNodeData(selected);
if sourceTileInfo^.ID > $3FFF then if sourceTileInfo^.ID > $3FFF then
begin begin
node := Sender.AddChild(nil); node := Sender.AddChild(nil);
targetTileInfo := Sender.GetNodeData(node); targetTileInfo := Sender.GetNodeData(node);
targetTileInfo^.ID := sourceTileInfo^.ID; targetTileInfo^.ID := sourceTileInfo^.ID;
cbTileFilter.Checked := True; cbTileFilter.Checked := True;
frmMain.InvalidateFilter; frmMain.InvalidateFilter;
end; end;
selected := sourceTree.GetNextSelected(selected); selected := sourceTree.GetNextSelected(selected);
end; end;
Sender.EndUpdate; Sender.EndUpdate;
end; end;
end; end;
procedure TfrmFilter.vdtFilterDragOver(Sender: TBaseVirtualTree; procedure TfrmFilter.vdtFilterDragOver(Sender: TBaseVirtualTree;
Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint;
Mode: TDropMode; var Effect: Integer; var Accept: Boolean); Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
begin begin
if (Source <> Sender) and (Source is TVirtualDrawTree) and if (Source <> Sender) and (Source is TVirtualDrawTree) and
(TVirtualDrawTree(Source).Tag = 1) then (TVirtualDrawTree(Source).Tag = 1) then
begin begin
Accept := True; Accept := True;
end; end;
end; end;
procedure TfrmFilter.vdtFilterDrawNode(Sender: TBaseVirtualTree; procedure TfrmFilter.vdtFilterDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
begin begin
frmMain.vdtTilesDrawNode(Sender, PaintInfo); frmMain.vdtTilesDrawNode(Sender, PaintInfo);
end; end;
procedure TfrmFilter.vdtHuesChecked(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure TfrmFilter.vdtHuesChecked(Sender: TBaseVirtualTree; Node: PVirtualNode);
var var
hueInfo: PHueInfo; hueInfo: PHueInfo;
begin begin
hueInfo := Sender.GetNodeData(Node); hueInfo := Sender.GetNodeData(Node);
FCheckedHues.Bits[hueInfo^.ID] := (Sender.CheckState[node] = csCheckedNormal); FCheckedHues.Bits[hueInfo^.ID] := (Sender.CheckState[node] = csCheckedNormal);
cbHueFilter.Checked := True; cbHueFilter.Checked := True;
frmMain.InvalidateFilter; frmMain.InvalidateFilter;
end; end;
procedure TfrmFilter.vdtHuesDrawNode(Sender: TBaseVirtualTree; procedure TfrmFilter.vdtHuesDrawNode(Sender: TBaseVirtualTree;
const PaintInfo: TVTPaintInfo); const PaintInfo: TVTPaintInfo);
var var
hueInfo: PHueInfo; hueInfo: PHueInfo;
hueColor: TColor; hueColor: TColor;
i: Integer; i: Integer;
textStyle: TTextStyle; textStyle: TTextStyle;
begin begin
hueInfo := Sender.GetNodeData(PaintInfo.Node); hueInfo := Sender.GetNodeData(PaintInfo.Node);
textStyle := PaintInfo.Canvas.TextStyle; textStyle := PaintInfo.Canvas.TextStyle;
textStyle.Alignment := taLeftJustify; textStyle.Alignment := taLeftJustify;
textStyle.Layout := tlCenter; textStyle.Layout := tlCenter;
textStyle.Wordbreak := True; textStyle.Wordbreak := True;
case PaintInfo.Column of case PaintInfo.Column of
1: 1:
begin begin
for i := 0 to 31 do for i := 0 to 31 do
begin begin
hueColor := ARGB2RGB(hueInfo^.Hue.ColorTable[i]); hueColor := ARGB2RGB(hueInfo^.Hue.ColorTable[i]);
PaintInfo.Canvas.Pen.Color := hueColor; PaintInfo.Canvas.Pen.Color := hueColor;
PaintInfo.Canvas.MoveTo(PaintInfo.CellRect.Left + 2 + i, PaintInfo.CellRect.Top + 1); PaintInfo.Canvas.MoveTo(PaintInfo.CellRect.Left + 2 + i, PaintInfo.CellRect.Top + 1);
PaintInfo.Canvas.LineTo(PaintInfo.CellRect.Left + 2 + i, PaintInfo.CellRect.Bottom - 1); PaintInfo.Canvas.LineTo(PaintInfo.CellRect.Left + 2 + i, PaintInfo.CellRect.Bottom - 1);
end; end;
end; end;
2: 2:
begin begin
PaintInfo.Canvas.TextRect(PaintInfo.CellRect, PaintInfo.CellRect.Left, PaintInfo.CellRect.Top, Format('$%x (%s)', [hueInfo^.ID, hueInfo^.Hue.Name]), textStyle); PaintInfo.Canvas.TextRect(PaintInfo.CellRect, PaintInfo.CellRect.Left, PaintInfo.CellRect.Top, Format('$%x (%s)', [hueInfo^.ID, hueInfo^.Hue.Name]), textStyle);
end; end;
end; end;
end; end;
procedure TfrmFilter.MouseLeave(var msg: TLMessage); procedure TfrmFilter.MouseLeave(var msg: TLMessage);
begin begin
{if Active and (not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos))) then {if Active and (not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos))) then
Close;} Close;}
end; end;
function TfrmFilter.Filter(AStatic: TStaticItem): Boolean; function TfrmFilter.Filter(AStatic: TStaticItem): Boolean;
var var
found: Boolean; found: Boolean;
tileInfo: PTileInfo; tileInfo: PTileInfo;
node: PVirtualNode; node: PVirtualNode;
id: Word; id: Word;
begin begin
if cbTileFilter.Checked then if cbTileFilter.Checked then
begin begin
id := AStatic.TileID + $4000; id := AStatic.TileID + $4000;
found := False; found := False;
node := vdtFilter.GetFirst; node := vdtFilter.GetFirst;
while (node <> nil) and (not found) do while (node <> nil) and (not found) do
begin begin
tileInfo := vdtFilter.GetNodeData(node); tileInfo := vdtFilter.GetNodeData(node);
if tileInfo^.ID = id then if tileInfo^.ID = id then
found := True found := True
else else
node := vdtFilter.GetNext(node); node := vdtFilter.GetNext(node);
end; end;
Result := ((rgFilterType.ItemIndex = 0) and (not found)) or Result := ((rgFilterType.ItemIndex = 0) and (not found)) or
((rgFilterType.ItemIndex = 1) and found); ((rgFilterType.ItemIndex = 1) and found);
end else end else
Result := True; Result := True;
if cbHueFilter.Checked then if cbHueFilter.Checked then
begin begin
Result := Result and ( Result := Result and (
((rgFilterType.ItemIndex = 0) and (not FCheckedHues.Bits[AStatic.Hue])) or ((rgFilterType.ItemIndex = 0) and (not FCheckedHues.Bits[AStatic.Hue])) or
((rgFilterType.ItemIndex = 1) and (FCheckedHues.Bits[AStatic.Hue])) ((rgFilterType.ItemIndex = 1) and (FCheckedHues.Bits[AStatic.Hue]))
); );
end; end;
end; end;
procedure TfrmFilter.JumpToHue(AHueID: Word); procedure TfrmFilter.JumpToHue(AHueID: Word);
var var
hueInfo: PHueInfo; hueInfo: PHueInfo;
node: PVirtualNode; node: PVirtualNode;
begin begin
node := vdtHues.GetFirst; node := vdtHues.GetFirst;
while node <> nil do while node <> nil do
begin begin
hueInfo := vdtHues.GetNodeData(node); hueInfo := vdtHues.GetNodeData(node);
if hueInfo^.ID = AHueID then if hueInfo^.ID = AHueID then
begin begin
vdtHues.ClearSelection; vdtHues.ClearSelection;
vdtHues.Selected[node] := True; vdtHues.Selected[node] := True;
vdtHues.FocusedNode := node; vdtHues.FocusedNode := node;
node := nil; node := nil;
end else end else
node := vdtHues.GetNext(node); node := vdtHues.GetNext(node);
end; end;
end; end;
procedure TfrmFilter.FormCreate(Sender: TObject); procedure TfrmFilter.FormCreate(Sender: TObject);
var var
i: Integer; i: Integer;
hueInfo: PHueInfo; hueInfo: PHueInfo;
node: PVirtualNode; node: PVirtualNode;
begin begin
FLocked := False; FLocked := False;
vdtFilter.NodeDataSize := SizeOf(TTileInfo); vdtFilter.NodeDataSize := SizeOf(TTileInfo);
vdtHues.NodeDataSize := SizeOf(THueInfo); vdtHues.NodeDataSize := SizeOf(THueInfo);
vdtHues.BeginUpdate; vdtHues.BeginUpdate;
vdtHues.Clear; vdtHues.Clear;
for i := 0 to ResMan.Hue.Count - 1 do for i := 0 to ResMan.Hue.Count - 1 do
begin begin
node := vdtHues.AddChild(nil); node := vdtHues.AddChild(nil);
hueInfo := vdtHues.GetNodeData(node); hueInfo := vdtHues.GetNodeData(node);
hueInfo^.ID := i + 1; hueInfo^.ID := i + 1;
hueInfo^.Hue := ResMan.Hue.Hues[i]; hueInfo^.Hue := ResMan.Hue.Hues[i];
vdtHues.CheckType[node] := ctCheckBox; vdtHues.CheckType[node] := ctCheckBox;
end; end;
vdtHues.EndUpdate; vdtHues.EndUpdate;
FCheckedHues := TBits.Create(ResMan.Hue.Count + 1); FCheckedHues := TBits.Create(ResMan.Hue.Count + 1);
//FCheckedHues.Bits[0] := True; //FCheckedHues.Bits[0] := True;
end; end;
procedure TfrmFilter.FormDestroy(Sender: TObject); procedure TfrmFilter.FormDestroy(Sender: TObject);
begin begin
if FCheckedHues <> nil then FreeAndNil(FCheckedHues); if FCheckedHues <> nil then FreeAndNil(FCheckedHues);
end; end;
procedure TfrmFilter.btnDeleteClick(Sender: TObject); procedure TfrmFilter.btnDeleteClick(Sender: TObject);
begin begin
vdtFilter.DeleteSelectedNodes; vdtFilter.DeleteSelectedNodes;
end; end;
procedure TfrmFilter.cbHueFilterChange(Sender: TObject); procedure TfrmFilter.cbHueFilterChange(Sender: TObject);
begin begin
frmMain.InvalidateFilter; frmMain.InvalidateFilter;
end; end;
procedure TfrmFilter.cbTileFilterChange(Sender: TObject); procedure TfrmFilter.cbTileFilterChange(Sender: TObject);
begin begin
frmMain.InvalidateFilter; frmMain.InvalidateFilter;
end; end;
procedure TfrmFilter.btnClearClick(Sender: TObject); procedure TfrmFilter.btnClearClick(Sender: TObject);
begin begin
vdtFilter.Clear; vdtFilter.Clear;
end; end;
initialization initialization
{$I UfrmFilter.lrs} {$I UfrmFilter.lrs}
end. end.

44
Client/Tools/UfrmLightlevel.lfm
View File

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

208
Client/Tools/UfrmToolWindow.pas
View File

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

250
Client/UGameResources.pas
View File

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

510
Client/UOverlayUI.pas
View File

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

300
Client/UPacketHandlers.pas
View File

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

746
Client/UPackets.pas
View File

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

82
Client/UPlatformTypes.pas
View File

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

210
Client/UResourceManager.pas
View File

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

742
Client/UdmNetwork.pas
View File

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

762
Client/UfrmAccountControl.lfm
View File

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

822
Client/UfrmAccountControl.pas
View File

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

334
Client/UfrmEditAccount.lfm
View File

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

80
Client/UfrmInitialize.lfm
View File

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

192
Client/UfrmInitialize.pas
View File

@ -1,96 +1,96 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2007 Andreas Schneider * Portions Copyright 2007 Andreas Schneider
*) *)
unit UfrmInitialize; unit UfrmInitialize;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls, LCLIntf, LCLType, WSForms; StdCtrls, LCLIntf, LCLType, WSForms;
type type
{ TfrmInitialize } { TfrmInitialize }
TfrmInitialize = class(TForm) TfrmInitialize = class(TForm)
lblStatus: TLabel; lblStatus: TLabel;
pnlMain: TPanel; pnlMain: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
protected protected
FActiveWindow: HWND; FActiveWindow: HWND;
FModal: Boolean; FModal: Boolean;
public public
procedure SetModal; procedure SetModal;
procedure UnsetModal; procedure UnsetModal;
end; end;
var var
frmInitialize: TfrmInitialize; frmInitialize: TfrmInitialize;
implementation implementation
{ TfrmInitialize } { TfrmInitialize }
procedure TfrmInitialize.FormClose(Sender: TObject; procedure TfrmInitialize.FormClose(Sender: TObject;
var CloseAction: TCloseAction); var CloseAction: TCloseAction);
begin begin
CloseAction := caNone; CloseAction := caNone;
end; end;
procedure TfrmInitialize.FormCreate(Sender: TObject); procedure TfrmInitialize.FormCreate(Sender: TObject);
begin begin
FModal := False; FModal := False;
end; end;
procedure TfrmInitialize.SetModal; procedure TfrmInitialize.SetModal;
begin begin
if FModal then Exit; if FModal then Exit;
FActiveWindow := GetActiveWindow; FActiveWindow := GetActiveWindow;
TWSCustomFormClass(WidgetSetClass).ShowModal(Self); TWSCustomFormClass(WidgetSetClass).ShowModal(Self);
{FormStyle := fsStayOnTop; {FormStyle := fsStayOnTop;
Screen.MoveFormToFocusFront(Self); Screen.MoveFormToFocusFront(Self);
Screen.MoveFormToZFront(Self);} Screen.MoveFormToZFront(Self);}
FModal := True; FModal := True;
end; end;
procedure TfrmInitialize.UnsetModal; procedure TfrmInitialize.UnsetModal;
begin begin
if not FModal then Exit; if not FModal then Exit;
TWSCustomFormClass(WidgetSetClass).CloseModal(Self); TWSCustomFormClass(WidgetSetClass).CloseModal(Self);
if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow); if FActiveWindow <> 0 then SetActiveWindow(FActiveWindow);
FActiveWindow := 0; FActiveWindow := 0;
//FormStyle := fsNormal; //FormStyle := fsNormal;
FModal := False; FModal := False;
end; end;
initialization initialization
{$I UfrmInitialize.lrs} {$I UfrmInitialize.lrs}
end. 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 * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2009 Andreas Schneider * Portions Copyright 2009 Andreas Schneider
*) *)
unit UfrmLogin; unit UfrmLogin;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, EditBtn, Buttons, IniFiles; ExtCtrls, Spin, EditBtn, Buttons, IniFiles;
type type
{ TfrmLogin } { TfrmLogin }
TfrmLogin = class(TForm) TfrmLogin = class(TForm)
btnOK: TButton; btnOK: TButton;
btnCancel: TButton; btnCancel: TButton;
cbProfile: TComboBox; cbProfile: TComboBox;
edData: TDirectoryEdit; edData: TDirectoryEdit;
edHost: TEdit; edHost: TEdit;
edUsername: TEdit; edUsername: TEdit;
edPassword: TEdit; edPassword: TEdit;
gbConnection: TGroupBox; gbConnection: TGroupBox;
gbData: TGroupBox; gbData: TGroupBox;
gbActions: TGroupBox; gbActions: TGroupBox;
gbProfiles: TGroupBox; gbProfiles: TGroupBox;
imgHost: TImage; imgHost: TImage;
imgUsername: TImage; imgUsername: TImage;
imgPassword: TImage; imgPassword: TImage;
lblCopyright: TLabel; lblCopyright: TLabel;
lblHost: TLabel; lblHost: TLabel;
lblUsername: TLabel; lblUsername: TLabel;
lblPassword: TLabel; lblPassword: TLabel;
edPort: TSpinEdit; edPort: TSpinEdit;
lblData: TLabel; lblData: TLabel;
btnSaveProfile: TSpeedButton; btnSaveProfile: TSpeedButton;
btnDeleteProfile: TSpeedButton; btnDeleteProfile: TSpeedButton;
procedure btnCancelClick(Sender: TObject); procedure btnCancelClick(Sender: TObject);
procedure btnDeleteProfileClick(Sender: TObject); procedure btnDeleteProfileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject); procedure btnOKClick(Sender: TObject);
procedure btnSaveProfileClick(Sender: TObject); procedure btnSaveProfileClick(Sender: TObject);
procedure cbProfileChange(Sender: TObject); procedure cbProfileChange(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
protected protected
FProfilePath: string; FProfilePath: string;
public public
{ public declarations } { public declarations }
end; end;
var var
frmLogin: TfrmLogin; frmLogin: TfrmLogin;
implementation implementation
uses uses
UdmNetwork; UdmNetwork;
{$I version.inc} {$I version.inc}
{ TfrmLogin } { TfrmLogin }
procedure TfrmLogin.btnCancelClick(Sender: TObject); procedure TfrmLogin.btnCancelClick(Sender: TObject);
begin begin
Close; Close;
end; end;
procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject); procedure TfrmLogin.btnDeleteProfileClick(Sender: TObject);
begin begin
if cbProfile.ItemIndex > -1 then if cbProfile.ItemIndex > -1 then
begin begin
DeleteFile(FProfilePath + cbProfile.Text + '.ini'); DeleteFile(FProfilePath + cbProfile.Text + '.ini');
cbProfile.Items.Delete(cbProfile.ItemIndex); cbProfile.Items.Delete(cbProfile.ItemIndex);
end; end;
end; end;
procedure TfrmLogin.btnOKClick(Sender: TObject); procedure TfrmLogin.btnOKClick(Sender: TObject);
var var
path: string; path: string;
begin begin
path := IncludeTrailingPathDelimiter(edData.Text); path := IncludeTrailingPathDelimiter(edData.Text);
if (not FileExists(path + 'art.mul')) or if (not FileExists(path + 'art.mul')) or
(not FileExists(path + 'artidx.mul')) or (not FileExists(path + 'artidx.mul')) or
(not FileExists(path + 'hues.mul')) or (not FileExists(path + 'hues.mul')) or
(not FileExists(path + 'tiledata.mul')) or (not FileExists(path + 'tiledata.mul')) or
(not FileExists(path + 'animdata.mul')) or (not FileExists(path + 'animdata.mul')) or
(not FileExists(path + 'texmaps.mul')) or (not FileExists(path + 'texmaps.mul')) or
(not FileExists(path + 'texidx.mul')) or (not FileExists(path + 'texidx.mul')) or
(not FileExists(path + 'light.mul')) or (not FileExists(path + 'light.mul')) or
(not FileExists(path + 'lightidx.mul')) then (not FileExists(path + 'lightidx.mul')) then
begin begin
MessageDlg('Incorrect directory', 'The data path you specified does not ' MessageDlg('Incorrect directory', 'The data path you specified does not '
+ 'seem to be correct.', mtWarning, [mbOK], 0); + 'seem to be correct.', mtWarning, [mbOK], 0);
edData.SetFocus; edData.SetFocus;
end else end else
ModalResult := mrOK; ModalResult := mrOK;
end; end;
procedure TfrmLogin.btnSaveProfileClick(Sender: TObject); procedure TfrmLogin.btnSaveProfileClick(Sender: TObject);
var var
profileName: string; profileName: string;
profile: TIniFile; profile: TIniFile;
begin begin
profileName := cbProfile.Text; profileName := cbProfile.Text;
if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then if InputQuery('Save profile', 'Enter the name of the profile:', profileName) then
begin begin
profile := TIniFile.Create(FProfilePath + profileName + '.ini'); profile := TIniFile.Create(FProfilePath + profileName + '.ini');
profile.WriteString('Connection', 'Host', edHost.Text); profile.WriteString('Connection', 'Host', edHost.Text);
profile.WriteInteger('Connection', 'Port', edPort.Value); profile.WriteInteger('Connection', 'Port', edPort.Value);
profile.WriteString('Connection', 'Username', edUsername.Text); profile.WriteString('Connection', 'Username', edUsername.Text);
profile.WriteString('Data', 'Path', edData.Text); profile.WriteString('Data', 'Path', edData.Text);
profile.Free; profile.Free;
cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName); cbProfile.ItemIndex := cbProfile.Items.IndexOf(profileName);
if cbProfile.ItemIndex = -1 then if cbProfile.ItemIndex = -1 then
begin begin
cbProfile.Items.Add(profileName); cbProfile.Items.Add(profileName);
cbProfile.ItemIndex := cbProfile.Items.Count - 1; cbProfile.ItemIndex := cbProfile.Items.Count - 1;
end; end;
end; end;
end; end;
procedure TfrmLogin.cbProfileChange(Sender: TObject); procedure TfrmLogin.cbProfileChange(Sender: TObject);
var var
profile: TIniFile; profile: TIniFile;
begin begin
if cbProfile.ItemIndex > -1 then if cbProfile.ItemIndex > -1 then
begin begin
profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini'); profile := TIniFile.Create(FProfilePath + cbProfile.Text + '.ini');
edHost.Text := profile.ReadString('Connection', 'Host', ''); edHost.Text := profile.ReadString('Connection', 'Host', '');
edPort.Value := profile.ReadInteger('Connection', 'Port', 2597); edPort.Value := profile.ReadInteger('Connection', 'Port', 2597);
edUsername.Text := profile.ReadString('Connection', 'Username', ''); edUsername.Text := profile.ReadString('Connection', 'Username', '');
edPassword.Text := ''; edPassword.Text := '';
edData.Text := profile.ReadString('Data', 'Path', ''); edData.Text := profile.ReadString('Data', 'Path', '');
edPassword.SetFocus; edPassword.SetFocus;
profile.Free; profile.Free;
end; end;
end; end;
procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction); procedure TfrmLogin.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin begin
if ModalResult <> mrOK then if ModalResult <> mrOK then
dmNetwork.CheckClose(Self); dmNetwork.CheckClose(Self);
end; end;
procedure TfrmLogin.FormCreate(Sender: TObject); procedure TfrmLogin.FormCreate(Sender: TObject);
var var
searchRec: TSearchRec; searchRec: TSearchRec;
begin begin
lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s', lblCopyright.Caption := Format('UO CentrED Client Version %s (c) %s',
[ProductVersion, Copyright]); [ProductVersion, Copyright]);
FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim; FProfilePath := GetAppConfigDir(False) + 'Profiles' + PathDelim;
ForceDirectories(FProfilePath); ForceDirectories(FProfilePath);
if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then if FindFirst(FProfilePath + '*.ini', faAnyFile, searchRec) = 0 then
begin begin
repeat repeat
cbProfile.Items.Add(ChangeFileExt(searchRec.Name, '')); cbProfile.Items.Add(ChangeFileExt(searchRec.Name, ''));
until FindNext(searchRec) <> 0; until FindNext(searchRec) <> 0;
end; end;
FindClose(searchRec); FindClose(searchRec);
end; end;
initialization initialization
{$I UfrmLogin.lrs} {$I UfrmLogin.lrs}
end. 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; unit imjcapimin;
{$N+} {$N+}
{ This file contains application interface code for the compression half { This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be 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 needed in either the normal full-compression case or the transcoding-only
case. case.
Most of the routines intended to be called directly by an application 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 are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. } compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. } { jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjpeglib, imjpeglib,
imjcomapi, imjcomapi,
imjmemmgr, imjmemmgr,
imjcmarker; imjcmarker;
{ Initialization of JPEG compression objects. { Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code. Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking. passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. } NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr); procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object. { Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). } The error manager must already be set up (in case memory manager fails). }
{GLOBAL} {GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr; procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int; version : int;
structsize : size_t); structsize : size_t);
{ Destruction of a JPEG compression object } { Destruction of a JPEG compression object }
{GLOBAL} {GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr); procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation, { Abort processing of a JPEG compression operation,
but don't destroy the object itself. } but don't destroy the object itself. }
{GLOBAL} {GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr); procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables. { Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress) Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call. by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise 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. } jcparam.o would be linked whether the application used it or not. }
{GLOBAL} {GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr; procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean); suppress : boolean);
{ Finish JPEG compression. { Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. } work including most of the actual output. }
{GLOBAL} {GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr); procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker. { Write a special marker.
This is only recommended for writing COM or APPn markers. This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL} {GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr; procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int; marker : int;
dataptr : JOCTETptr; dataptr : JOCTETptr;
datalen : uInt); datalen : uInt);
{GLOBAL} {GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr; procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int; marker : int;
datalen : uint); datalen : uint);
{GLOBAL} {GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file. { Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up. Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows: image data, one would proceed as follows:
initialize JPEG object initialize JPEG object
set JPEG parameters set JPEG parameters
set destination to table file set destination to table file
jpeg_write_tables(cinfo); jpeg_write_tables(cinfo);
set destination to image file set destination to image file
jpeg_start_compress(cinfo, FALSE); jpeg_start_compress(cinfo, FALSE);
write data... write data...
jpeg_finish_compress(cinfo); jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress (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. } will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL} {GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr); procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr); procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION, jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct))); size_t(sizeof(jpeg_compress_struct)));
end; end;
{ Initialization of a JPEG compression object. { Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). } The error manager must already be set up (in case memory manager fails). }
{GLOBAL} {GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr; procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int; version : int;
structsize : size_t); structsize : size_t);
var var
i : int; i : int;
var var
err : jpeg_error_mgr_ptr; err : jpeg_error_mgr_ptr;
client_data : voidp; client_data : voidp;
begin begin
{ Guard against version mismatches between library and caller. } { Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called } cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version); ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE, ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize)); int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure. { For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields. client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may Note: if application hasn't set client_data, tools like Purify may
complain here. } complain here. }
err := cinfo^.err; err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here } client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct)); MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err; cinfo^.err := err;
cinfo^.is_decompressor := FALSE; cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object } { Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo)); jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. } { Zero out pointers to permanent structures. }
cinfo^.progress := NIL; cinfo^.progress := NIL;
cinfo^.dest := NIL; cinfo^.dest := NIL;
cinfo^.comp_info := NIL; cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL; cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do for i := 0 to pred(NUM_HUFF_TBLS) do
begin begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL; cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL; cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end; end;
cinfo^.script_space := NIL; cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets } cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready } { OK, I'm ready }
cinfo^.global_state := CSTATE_START; cinfo^.global_state := CSTATE_START;
end; end;
{ Destruction of a JPEG compression object } { Destruction of a JPEG compression object }
{GLOBAL} {GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr); procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine } jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end; end;
{ Abort processing of a JPEG compression operation, { Abort processing of a JPEG compression operation,
but don't destroy the object itself. } but don't destroy the object itself. }
{GLOBAL} {GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr); procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine } jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end; end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables. { Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress) Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call. by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise 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. } jcparam.o would be linked whether the application used it or not. }
{GLOBAL} {GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr; procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean); suppress : boolean);
var var
i : int; i : int;
qtbl : JQUANT_TBL_PTR; qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR; htbl : JHUFF_TBL_PTR;
begin begin
for i := 0 to pred(NUM_QUANT_TBLS) do for i := 0 to pred(NUM_QUANT_TBLS) do
begin begin
qtbl := cinfo^.quant_tbl_ptrs[i]; qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then if (qtbl <> NIL) then
qtbl^.sent_table := suppress; qtbl^.sent_table := suppress;
end; end;
for i := 0 to pred(NUM_HUFF_TBLS) do for i := 0 to pred(NUM_HUFF_TBLS) do
begin begin
htbl := cinfo^.dc_huff_tbl_ptrs[i]; htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then if (htbl <> NIL) then
htbl^.sent_table := suppress; htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i]; htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then if (htbl <> NIL) then
htbl^.sent_table := suppress; htbl^.sent_table := suppress;
end; end;
end; end;
{ Finish JPEG compression. { Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. } work including most of the actual output. }
{GLOBAL} {GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr); procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var var
iMCU_row : JDIMENSION; iMCU_row : JDIMENSION;
begin begin
if (cinfo^.global_state = CSTATE_SCANNING) or if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then (cinfo^.global_state = CSTATE_RAW_OK) then
begin begin
{ Terminate first pass } { Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA); ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo); cinfo^.master^.finish_pass (cinfo);
end end
else else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes } { Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do while (not cinfo^.master^.is_last_pass) do
begin begin
cinfo^.master^.prepare_for_pass (cinfo); cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin begin
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long (iMCU_row); cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows); cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ We bypass the main controller and invoke coef controller directly; { We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. } all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end; end;
cinfo^.master^.finish_pass (cinfo); cinfo^.master^.finish_pass (cinfo);
end; end;
{ Write EOI, do final cleanup } { Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo); cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo); cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state } { We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo)); jpeg_abort(j_common_ptr(cinfo));
end; end;
{ Write a special marker. { Write a special marker.
This is only recommended for writing COM or APPn markers. This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL} {GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr; procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int; marker : int;
dataptr : JOCTETptr; dataptr : JOCTETptr;
datalen : uInt); datalen : uInt);
var var
write_marker_byte : procedure(info : j_compress_ptr; val : int); write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin begin
if (cinfo^.next_scanline <> 0) or if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and ((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and (cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then (cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen); cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed } write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do while (datalen <> 0) do
begin begin
Dec(datalen); Dec(datalen);
write_marker_byte (cinfo, dataptr^); write_marker_byte (cinfo, dataptr^);
Inc(dataptr); Inc(dataptr);
end; end;
end; end;
{ Same, but piecemeal. } { Same, but piecemeal. }
{GLOBAL} {GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr; procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int; marker : int;
datalen : uint); datalen : uint);
begin begin
if (cinfo^.next_scanline <> 0) or if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and ((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and (cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then (cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen); cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end; end;
{GLOBAL} {GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin begin
cinfo^.marker^.write_marker_byte (cinfo, val); cinfo^.marker^.write_marker_byte (cinfo, val);
end; end;
{ Alternate compression function: just write an abbreviated table file. { Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up. Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows: image data, one would proceed as follows:
initialize JPEG object initialize JPEG object
set JPEG parameters set JPEG parameters
set destination to table file set destination to table file
jpeg_write_tables(cinfo); jpeg_write_tables(cinfo);
set destination to image file set destination to image file
jpeg_start_compress(cinfo, FALSE); jpeg_start_compress(cinfo, FALSE);
write data... write data...
jpeg_finish_compress(cinfo); jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress (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. } will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL} {GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr); procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin begin
if (cinfo^.global_state <> CSTATE_START) then if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules } { (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo); cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. } { Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo); jinit_marker_writer(cinfo);
{ Write them tables! } { Write them tables! }
cinfo^.marker^.write_tables_only (cinfo); cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. } { And clean up. }
cinfo^.dest^.term_destination (cinfo); cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free { In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space 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 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 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 memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case. 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 An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). } each call to jpeg_write_tables(). }
end; end;
end. end.

444
Imaging/JpegLib/imjcapistd.pas
View File

@ -1,222 +1,222 @@
unit imjcapistd; unit imjcapistd;
{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software. { This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file. For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the compression half This file contains application interface code for the compression half
of the JPEG library. These are the "standard" API routines that are 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 used in the normal full-compression case. They are not used by a
transcoding-only application. Note that if an application links in transcoding-only application. Note that if an application links in
jpeg_start_compress, it will end up linking in the entire compressor. 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 We thus must separate this file from jcapimin.c to avoid linking the
whole compression library into a transcoder. } whole compression library into a transcoder. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjpeglib, imjpeglib,
imjcapimin, imjcinit; imjcapimin, imjcinit;
{ Compression initialization. { Compression initialization.
Before calling this, all parameters and a data destination must be set up. 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 We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run 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 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: 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 programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. } wrong thing. }
{GLOBAL} {GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr; procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean); write_all_tables : boolean);
{ Write some scanlines of data to the JPEG compressor. { Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written. The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor, the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in. or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However, this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored, excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. } when using a multiple-scanline buffer. }
{GLOBAL} {GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr; function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY; scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION; num_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to write raw data. { Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. } Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL} {GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr; function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE; data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION; num_lines : JDIMENSION) : JDIMENSION;
implementation implementation
{ Compression initialization. { Compression initialization.
Before calling this, all parameters and a data destination must be set up. 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 We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run 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 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: 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 programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. } wrong thing. }
{GLOBAL} {GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr; procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean); write_all_tables : boolean);
begin begin
if (cinfo^.global_state <> CSTATE_START) then if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (write_all_tables) then if (write_all_tables) then
jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written } jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written }
{ (Re)initialize error mgr and destination modules } { (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo); cinfo^.dest^.init_destination (cinfo);
{ Perform master selection of active modules } { Perform master selection of active modules }
jinit_compress_master(cinfo); jinit_compress_master(cinfo);
{ Set up for the first pass } { Set up for the first pass }
cinfo^.master^.prepare_for_pass (cinfo); cinfo^.master^.prepare_for_pass (cinfo);
{ Ready for application to drive first pass through jpeg_write_scanlines { Ready for application to drive first pass through jpeg_write_scanlines
or jpeg_write_raw_data. } or jpeg_write_raw_data. }
cinfo^.next_scanline := 0; cinfo^.next_scanline := 0;
if cinfo^.raw_data_in then if cinfo^.raw_data_in then
cinfo^.global_state := CSTATE_RAW_OK cinfo^.global_state := CSTATE_RAW_OK
else else
cinfo^.global_state := CSTATE_SCANNING; cinfo^.global_state := CSTATE_SCANNING;
end; end;
{ Write some scanlines of data to the JPEG compressor. { Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written. The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor, the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in. or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However, this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored, excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. } when using a multiple-scanline buffer. }
{GLOBAL} {GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr; function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY; scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION; num_lines : JDIMENSION) : JDIMENSION;
var var
row_ctr, rows_left : JDIMENSION; row_ctr, rows_left : JDIMENSION;
begin begin
if (cinfo^.global_state <> CSTATE_SCANNING) then if (cinfo^.global_state <> CSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then if (cinfo^.next_scanline >= cinfo^.image_height) then
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long (cinfo^.next_scanline); cinfo^.progress^.pass_counter := long (cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.image_height); cinfo^.progress^.pass_limit := long (cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ Give master control module another chance if this is first call to { Give master control module another chance if this is first call to
jpeg_write_scanlines. This lets output of the frame/scan headers be jpeg_write_scanlines. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_scanlines. } jpeg_start_compress and jpeg_write_scanlines. }
if (cinfo^.master^.call_pass_startup) then if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo); cinfo^.master^.pass_startup (cinfo);
{ Ignore any extra scanlines at bottom of image. } { Ignore any extra scanlines at bottom of image. }
rows_left := cinfo^.image_height - cinfo^.next_scanline; rows_left := cinfo^.image_height - cinfo^.next_scanline;
if (num_lines > rows_left) then if (num_lines > rows_left) then
num_lines := rows_left; num_lines := rows_left;
row_ctr := 0; row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines); cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines);
Inc(cinfo^.next_scanline, row_ctr); Inc(cinfo^.next_scanline, row_ctr);
jpeg_write_scanlines := row_ctr; jpeg_write_scanlines := row_ctr;
end; end;
{ Alternate entry point to write raw data. { Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. } Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL} {GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr; function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE; data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION; num_lines : JDIMENSION) : JDIMENSION;
var var
lines_per_iMCU_row : JDIMENSION; lines_per_iMCU_row : JDIMENSION;
begin begin
if (cinfo^.global_state <> CSTATE_RAW_OK) then if (cinfo^.global_state <> CSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then if (cinfo^.next_scanline >= cinfo^.image_height) then
begin begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_write_raw_data := 0; jpeg_write_raw_data := 0;
exit; exit;
end; end;
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long(cinfo^.next_scanline); cinfo^.progress^.pass_counter := long(cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long(cinfo^.image_height); cinfo^.progress^.pass_limit := long(cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ Give master control module another chance if this is first call to { 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 jpeg_write_raw_data. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_raw_data. } jpeg_start_compress and jpeg_write_raw_data. }
if (cinfo^.master^.call_pass_startup) then if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo); cinfo^.master^.pass_startup (cinfo);
{ Verify that at least one iMCU row has been passed. } { Verify that at least one iMCU row has been passed. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE; lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE;
if (num_lines < lines_per_iMCU_row) then if (num_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Directly compress the row. } { Directly compress the row. }
if (not cinfo^.coef^.compress_data (cinfo, data)) then if (not cinfo^.coef^.compress_data (cinfo, data)) then
begin begin
{ If compressor did not consume the whole row, suspend processing. } { If compressor did not consume the whole row, suspend processing. }
jpeg_write_raw_data := 0; jpeg_write_raw_data := 0;
exit; exit;
end; end;
{ OK, we processed one iMCU row. } { OK, we processed one iMCU row. }
Inc(cinfo^.next_scanline, lines_per_iMCU_row); Inc(cinfo^.next_scanline, lines_per_iMCU_row);
jpeg_write_raw_data := lines_per_iMCU_row; jpeg_write_raw_data := lines_per_iMCU_row;
end; end;
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; unit imjcinit;
{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. } { Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file contains initialization logic for the JPEG compressor. { This file contains initialization logic for the JPEG compressor.
This routine is in charge of selecting the modules to be executed and This routine is in charge of selecting the modules to be executed and
making an initialization call to each one. making an initialization call to each one.
Logically, this code belongs in jcmaster.c. It's split out because Logically, this code belongs in jcmaster.c. It's split out because
linking this routine implies linking the entire compression library. linking this routine implies linking the entire compression library.
For a transcoding-only application, we want to be able to use jcmaster.c For a transcoding-only application, we want to be able to use jcmaster.c
without linking in the whole library. } without linking in the whole library. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjpeglib, imjpeglib,
{$ifdef C_PROGRESSIVE_SUPPORTED} {$ifdef C_PROGRESSIVE_SUPPORTED}
imjcphuff, imjcphuff,
{$endif} {$endif}
imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct, imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct,
imjcdctmgr, imjccoefct, imjcmainct, imjcmarker; imjcdctmgr, imjccoefct, imjcmainct, imjcmarker;
{ Master selection of compression modules. { Master selection of compression modules.
This is done once at the start of processing an image. We determine This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. } which modules will be used and give them appropriate initialization calls. }
{GLOBAL} {GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr); procedure jinit_compress_master (cinfo : j_compress_ptr);
implementation implementation
{ Master selection of compression modules. { Master selection of compression modules.
This is done once at the start of processing an image. We determine This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. } which modules will be used and give them appropriate initialization calls. }
{GLOBAL} {GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr); procedure jinit_compress_master (cinfo : j_compress_ptr);
begin begin
{ Initialize master control (includes parameter checking/processing) } { Initialize master control (includes parameter checking/processing) }
jinit_c_master_control(cinfo, FALSE { full compression }); jinit_c_master_control(cinfo, FALSE { full compression });
{ Preprocessing } { Preprocessing }
if (not cinfo^.raw_data_in) then if (not cinfo^.raw_data_in) then
begin begin
jinit_color_converter(cinfo); jinit_color_converter(cinfo);
jinit_downsampler(cinfo); jinit_downsampler(cinfo);
jinit_c_prep_controller(cinfo, FALSE { never need full buffer here }); jinit_c_prep_controller(cinfo, FALSE { never need full buffer here });
end; end;
{ Forward DCT } { Forward DCT }
jinit_forward_dct(cinfo); jinit_forward_dct(cinfo);
{ Entropy encoding: either Huffman or arithmetic coding. } { Entropy encoding: either Huffman or arithmetic coding. }
if (cinfo^.arith_code) then if (cinfo^.arith_code) then
begin begin
ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL); ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL);
end end
else else
begin begin
if (cinfo^.progressive_mode) then if (cinfo^.progressive_mode) then
begin begin
{$ifdef C_PROGRESSIVE_SUPPORTED} {$ifdef C_PROGRESSIVE_SUPPORTED}
jinit_phuff_encoder(cinfo); jinit_phuff_encoder(cinfo);
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} {$endif}
end end
else else
jinit_huff_encoder(cinfo); jinit_huff_encoder(cinfo);
end; end;
{ Need a full-image coefficient buffer in any multi-pass mode. } { Need a full-image coefficient buffer in any multi-pass mode. }
jinit_c_coef_controller(cinfo, jinit_c_coef_controller(cinfo,
(cinfo^.num_scans > 1) or (cinfo^.optimize_coding)); (cinfo^.num_scans > 1) or (cinfo^.optimize_coding));
jinit_c_main_controller(cinfo, FALSE { never need full buffer here }); jinit_c_main_controller(cinfo, FALSE { never need full buffer here });
jinit_marker_writer(cinfo); jinit_marker_writer(cinfo);
{ We can now tell the memory manager to allocate virtual arrays. } { We can now tell the memory manager to allocate virtual arrays. }
cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo)); cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo));
{ Write the datastream header (SOI) immediately. { Write the datastream header (SOI) immediately.
Frame and scan headers are postponed till later. Frame and scan headers are postponed till later.
This lets application insert special markers after the SOI. } This lets application insert special markers after the SOI. }
cinfo^.marker^.write_file_header (cinfo); cinfo^.marker^.write_file_header (cinfo);
end; end;
end. end.

686
Imaging/JpegLib/imjcmainct.pas
View File

@ -1,343 +1,343 @@
unit imjcmainct; unit imjcmainct;
{ This file contains the main buffer controller for compression. { This file contains the main buffer controller for compression.
The main buffer lies between the pre-processor and the JPEG The main buffer lies between the pre-processor and the JPEG
compressor proper; it holds downsampled data in the JPEG colorspace. } compressor proper; it holds downsampled data in the JPEG colorspace. }
{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
{ Note: currently, there is no operating mode in which a full-image buffer { 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 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, "raw data" input, since this module is bypassed in that case. However,
we've left the code here for possible use in special applications. } we've left the code here for possible use in special applications. }
{$undef FULL_MAIN_BUFFER_SUPPORTED} {$undef FULL_MAIN_BUFFER_SUPPORTED}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
imjutils, imjutils,
{$endif} {$endif}
imjpeglib; imjpeglib;
{ Initialize main buffer controller. } { Initialize main buffer controller. }
{GLOBAL} {GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr; procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
implementation implementation
{ Private buffer controller object } { Private buffer controller object }
type type
my_main_ptr = ^my_main_controller; my_main_ptr = ^my_main_controller;
my_main_controller = record my_main_controller = record
pub : jpeg_c_main_controller; { public fields } pub : jpeg_c_main_controller; { public fields }
cur_iMCU_row : JDIMENSION; { number of current iMCU row } cur_iMCU_row : JDIMENSION; { number of current iMCU row }
rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row } rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row }
suspended : boolean; { remember if we suspended output } suspended : boolean; { remember if we suspended output }
pass_mode : J_BUF_MODE; { current operating mode } pass_mode : J_BUF_MODE; { current operating mode }
{ If using just a strip buffer, this points to the entire set of buffers { 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 (we allocate one for each component). In the full-image case, this
points to the currently accessible strips of the virtual arrays. } points to the currently accessible strips of the virtual arrays. }
buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ If using full-image storage, this array holds pointers to virtual-array { If using full-image storage, this array holds pointers to virtual-array
control blocks for each component. Unused if not full-image storage. } control blocks for each component. Unused if not full-image storage. }
whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr; whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr;
{$endif} {$endif}
end; {my_main_controller} end; {my_main_controller}
{ Forward declarations } { Forward declarations }
{METHODDEF} {METHODDEF}
procedure process_data_simple_main(cinfo : j_compress_ptr; procedure process_data_simple_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr: JDIMENSION; var in_row_ctr: JDIMENSION;
in_rows_avail : JDIMENSION); forward; in_rows_avail : JDIMENSION); forward;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{METHODDEF} {METHODDEF}
procedure process_data_buffer_main(cinfo : j_compress_ptr; procedure process_data_buffer_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION; var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); forward; in_rows_avail : JDIMENSION); forward;
{$endif} {$endif}
{ Initialize for a processing pass. } { Initialize for a processing pass. }
{METHODDEF} {METHODDEF}
procedure start_pass_main (cinfo : j_compress_ptr; procedure start_pass_main (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE); pass_mode : J_BUF_MODE);
var var
main : my_main_ptr; main : my_main_ptr;
begin begin
main := my_main_ptr (cinfo^.main); main := my_main_ptr (cinfo^.main);
{ Do nothing in raw-data mode. } { Do nothing in raw-data mode. }
if (cinfo^.raw_data_in) then if (cinfo^.raw_data_in) then
exit; exit;
main^.cur_iMCU_row := 0; { initialize counters } main^.cur_iMCU_row := 0; { initialize counters }
main^.rowgroup_ctr := 0; main^.rowgroup_ctr := 0;
main^.suspended := FALSE; main^.suspended := FALSE;
main^.pass_mode := pass_mode; { save mode for use by process_data } main^.pass_mode := pass_mode; { save mode for use by process_data }
case (pass_mode) of case (pass_mode) of
JBUF_PASS_THRU: JBUF_PASS_THRU:
begin begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
if (main^.whole_image[0] <> NIL) then if (main^.whole_image[0] <> NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} {$endif}
main^.pub.process_data := process_data_simple_main; main^.pub.process_data := process_data_simple_main;
end; end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
JBUF_SAVE_SOURCE, JBUF_SAVE_SOURCE,
JBUF_CRANK_DEST, JBUF_CRANK_DEST,
JBUF_SAVE_AND_PASS: JBUF_SAVE_AND_PASS:
begin begin
if (main^.whole_image[0] = NIL) then if (main^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
main^.pub.process_data := process_data_buffer_main; main^.pub.process_data := process_data_buffer_main;
end; end;
{$endif} {$endif}
else else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end; end;
end; end;
{ Process some data. { Process some data.
This routine handles the simple pass-through mode, This routine handles the simple pass-through mode,
where we have only a strip buffer. } where we have only a strip buffer. }
{METHODDEF} {METHODDEF}
procedure process_data_simple_main (cinfo : j_compress_ptr; procedure process_data_simple_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION; var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); in_rows_avail : JDIMENSION);
var var
main : my_main_ptr; main : my_main_ptr;
begin begin
main := my_main_ptr (cinfo^.main); main := my_main_ptr (cinfo^.main);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin begin
{ Read input data if we haven't filled the main buffer yet } { Read input data if we haven't filled the main buffer yet }
if (main^.rowgroup_ctr < DCTSIZE) then if (main^.rowgroup_ctr < DCTSIZE) then
cinfo^.prep^.pre_process_data (cinfo, cinfo^.prep^.pre_process_data (cinfo,
input_buf, input_buf,
in_row_ctr, in_row_ctr,
in_rows_avail, in_rows_avail,
JSAMPIMAGE(@main^.buffer), JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr, main^.rowgroup_ctr,
JDIMENSION(DCTSIZE)); JDIMENSION(DCTSIZE));
{ If we don't have a full iMCU row buffered, return to application for { 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 more data. Note that preprocessor will always pad to fill the iMCU row
at the bottom of the image. } at the bottom of the image. }
if (main^.rowgroup_ctr <> DCTSIZE) then if (main^.rowgroup_ctr <> DCTSIZE) then
exit; exit;
{ Send the completed row to the compressor } { Send the completed row to the compressor }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then
begin begin
{ If compressor did not consume the whole row, then we must need to { If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if 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 it happened to be the last row of the image, the application would
think we were done. } think we were done. }
if (not main^.suspended) then if (not main^.suspended) then
begin begin
Dec(in_row_ctr); Dec(in_row_ctr);
main^.suspended := TRUE; main^.suspended := TRUE;
end; end;
exit; exit;
end; end;
{ We did finish the row. Undo our little suspension hack if a previous { We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. } call suspended; then mark the main buffer empty. }
if (main^.suspended) then if (main^.suspended) then
begin begin
Inc(in_row_ctr); Inc(in_row_ctr);
main^.suspended := FALSE; main^.suspended := FALSE;
end; end;
main^.rowgroup_ctr := 0; main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row); Inc(main^.cur_iMCU_row);
end; end;
end; end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Process some data. { Process some data.
This routine handles all of the modes that use a full-size buffer. } This routine handles all of the modes that use a full-size buffer. }
{METHODDEF} {METHODDEF}
procedure process_data_buffer_main (cinfo : j_compress_ptr; procedure process_data_buffer_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION; var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); in_rows_avail : JDIMENSION);
var var
main : my_main_ptr; main : my_main_ptr;
ci : int; ci : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
writing : boolean; writing : boolean;
begin begin
main := my_main_ptr (cinfo^.main); main := my_main_ptr (cinfo^.main);
writing := (main^.pass_mode <> JBUF_CRANK_DEST); writing := (main^.pass_mode <> JBUF_CRANK_DEST);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin begin
{ Realign the virtual buffers if at the start of an iMCU row. } { Realign the virtual buffers if at the start of an iMCU row. }
if (main^.rowgroup_ctr = 0) then if (main^.rowgroup_ctr = 0) then
begin begin
compptr := cinfo^.comp_info; compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
main^.buffer[ci] := cinfo^.mem^.access_virt_sarray main^.buffer[ci] := cinfo^.mem^.access_virt_sarray
(j_common_ptr (cinfo), main^.whole_image[ci], (j_common_ptr (cinfo), main^.whole_image[ci],
main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE), main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing); JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing);
Inc(compptr); Inc(compptr);
end; end;
{ In a read pass, pretend we just read some source data. } { In a read pass, pretend we just read some source data. }
if (not writing) then if (not writing) then
begin begin
Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE); Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE);
main^.rowgroup_ctr := DCTSIZE; main^.rowgroup_ctr := DCTSIZE;
end; end;
end; end;
{ If a write pass, read input data until the current iMCU row is full. } { 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. } { Note: preprocessor will pad if necessary to fill the last iMCU row. }
if (writing) then if (writing) then
begin begin
cinfo^.prep^.pre_process_data (cinfo, cinfo^.prep^.pre_process_data (cinfo,
input_buf, in_row_ctr, in_rows_avail, input_buf, in_row_ctr, in_rows_avail,
JSAMPIMAGE(@main^.buffer), JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr, main^.rowgroup_ctr,
JDIMENSION (DCTSIZE)); JDIMENSION (DCTSIZE));
{ Return to application if we need more data to fill the iMCU row. } { Return to application if we need more data to fill the iMCU row. }
if (main^.rowgroup_ctr < DCTSIZE) then if (main^.rowgroup_ctr < DCTSIZE) then
exit; exit;
end; end;
{ Emit data, unless this is a sink-only pass. } { Emit data, unless this is a sink-only pass. }
if (main^.pass_mode <> JBUF_SAVE_SOURCE) then if (main^.pass_mode <> JBUF_SAVE_SOURCE) then
begin begin
if (not cinfo^.coef^.compress_data (cinfo, if (not cinfo^.coef^.compress_data (cinfo,
JSAMPIMAGE(@main^.buffer))) then JSAMPIMAGE(@main^.buffer))) then
begin begin
{ If compressor did not consume the whole row, then we must need to { If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if 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 it happened to be the last row of the image, the application would
think we were done. } think we were done. }
if (not main^.suspended) then if (not main^.suspended) then
begin begin
Dec(in_row_ctr); Dec(in_row_ctr);
main^.suspended := TRUE; main^.suspended := TRUE;
end; end;
exit; exit;
end; end;
{ We did finish the row. Undo our little suspension hack if a previous { We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. } call suspended; then mark the main buffer empty. }
if (main^.suspended) then if (main^.suspended) then
begin begin
Inc(in_row_ctr); Inc(in_row_ctr);
main^.suspended := FALSE; main^.suspended := FALSE;
end; end;
end; end;
{ If get here, we are done with this iMCU row. Mark buffer empty. } { If get here, we are done with this iMCU row. Mark buffer empty. }
main^.rowgroup_ctr := 0; main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row); Inc(main^.cur_iMCU_row);
end; end;
end; end;
{$endif} { FULL_MAIN_BUFFER_SUPPORTED } {$endif} { FULL_MAIN_BUFFER_SUPPORTED }
{ Initialize main buffer controller. } { Initialize main buffer controller. }
{GLOBAL} {GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr; procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
var var
main : my_main_ptr; main : my_main_ptr;
ci : int; ci : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
begin begin
main := my_main_ptr( main := my_main_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_main_controller)) ); SIZEOF(my_main_controller)) );
cinfo^.main := jpeg_c_main_controller_ptr(main); cinfo^.main := jpeg_c_main_controller_ptr(main);
main^.pub.start_pass := start_pass_main; main^.pub.start_pass := start_pass_main;
{ We don't need to create a buffer in raw-data mode. } { We don't need to create a buffer in raw-data mode. }
if (cinfo^.raw_data_in) then if (cinfo^.raw_data_in) then
exit; exit;
{ Create the buffer. It holds downsampled data, so each component { Create the buffer. It holds downsampled data, so each component
may be of a different size. } may be of a different size. }
if (need_full_buffer) then if (need_full_buffer) then
begin begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Allocate a full-image virtual array for each component } { Allocate a full-image virtual array for each component }
{ Note we pad the bottom to a multiple of the iMCU height } { Note we pad the bottom to a multiple of the iMCU height }
compptr := cinfo^.comp_info; compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
compptr^.width_in_blocks * DCTSIZE, compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (jround_up( long (compptr^.height_in_blocks), JDIMENSION (jround_up( long (compptr^.height_in_blocks),
long (compptr^.v_samp_factor)) * DCTSIZE), long (compptr^.v_samp_factor)) * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr); Inc(compptr);
end; end;
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} {$endif}
end end
else else
begin begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED} {$ifdef FULL_MAIN_BUFFER_SUPPORTED}
main^.whole_image[0] := NIL; { flag for no virtual arrays } main^.whole_image[0] := NIL; { flag for no virtual arrays }
{$endif} {$endif}
{ Allocate a strip buffer for each component } { Allocate a strip buffer for each component }
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
main^.buffer[ci] := cinfo^.mem^.alloc_sarray main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, (j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * DCTSIZE, compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr); Inc(compptr);
end; end;
end; end;
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; unit imjcomapi;
{ This file contains application interface routines that are used for both { This file contains application interface routines that are used for both
compression and decompression. } compression and decompression. }
{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. } { Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjpeglib; imjpeglib;
{ Abort processing of a JPEG compression or decompression operation, { Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself. } but don't destroy the object itself. }
{GLOBAL} {GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr); procedure jpeg_abort (cinfo : j_common_ptr);
{ Destruction of a JPEG object. } { Destruction of a JPEG object. }
{GLOBAL} {GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr); procedure jpeg_destroy (cinfo : j_common_ptr);
{GLOBAL} {GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
{GLOBAL} {GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
implementation implementation
{ Abort processing of a JPEG compression or decompression operation, { Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself. but don't destroy the object itself.
For this, we merely clean up all the nonpermanent memory pools. For this, we merely clean up all the nonpermanent memory pools.
Note that temp files (virtual arrays) are not allowed to belong to 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. 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 Closing a data source or destination, if necessary, is the application's
responsibility. } responsibility. }
{GLOBAL} {GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr); procedure jpeg_abort (cinfo : j_common_ptr);
var var
pool : int; pool : int;
begin begin
{ Do nothing if called on a not-initialized or destroyed JPEG object. } { Do nothing if called on a not-initialized or destroyed JPEG object. }
if (cinfo^.mem = NIL) then if (cinfo^.mem = NIL) then
exit; exit;
{ Releasing pools in reverse order might help avoid fragmentation { Releasing pools in reverse order might help avoid fragmentation
with some (brain-damaged) malloc libraries. } with some (brain-damaged) malloc libraries. }
for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do
begin begin
cinfo^.mem^.free_pool (cinfo, pool); cinfo^.mem^.free_pool (cinfo, pool);
end; end;
{ Reset overall state for possible reuse of object } { Reset overall state for possible reuse of object }
if (cinfo^.is_decompressor) then if (cinfo^.is_decompressor) then
begin begin
cinfo^.global_state := DSTATE_START; cinfo^.global_state := DSTATE_START;
{ Try to keep application from accessing now-deleted marker list. { Try to keep application from accessing now-deleted marker list.
A bit kludgy to do it here, but this is the most central place. } A bit kludgy to do it here, but this is the most central place. }
j_decompress_ptr(cinfo)^.marker_list := NIL; j_decompress_ptr(cinfo)^.marker_list := NIL;
end end
else else
begin begin
cinfo^.global_state := CSTATE_START; cinfo^.global_state := CSTATE_START;
end; end;
end; end;
{ Destruction of a JPEG object. { Destruction of a JPEG object.
Everything gets deallocated except the master jpeg_compress_struct itself Everything gets deallocated except the master jpeg_compress_struct itself
and the error manager struct. Both of these are supplied by the application 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 and must be freed, if necessary, by the application. (Often they are on
the stack and so don't need to be freed anyway.) the stack and so don't need to be freed anyway.)
Closing a data source or destination, if necessary, is the application's Closing a data source or destination, if necessary, is the application's
responsibility. } responsibility. }
{GLOBAL} {GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr); procedure jpeg_destroy (cinfo : j_common_ptr);
begin begin
{ We need only tell the memory manager to release everything. } { We need only tell the memory manager to release everything. }
{ NB: mem pointer is NIL if memory mgr failed to initialize. } { NB: mem pointer is NIL if memory mgr failed to initialize. }
if (cinfo^.mem <> NIL) then if (cinfo^.mem <> NIL) then
cinfo^.mem^.self_destruct (cinfo); cinfo^.mem^.self_destruct (cinfo);
cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice } cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice }
cinfo^.global_state := 0; { mark it destroyed } cinfo^.global_state := 0; { mark it destroyed }
end; end;
{ Convenience routines for allocating quantization and Huffman tables. { Convenience routines for allocating quantization and Huffman tables.
(Would jutils.c be a more reasonable place to put these?) } (Would jutils.c be a more reasonable place to put these?) }
{GLOBAL} {GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
var var
tbl : JQUANT_TBL_PTR; tbl : JQUANT_TBL_PTR;
begin begin
tbl := JQUANT_TBL_PTR( tbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL)) cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL))
); );
tbl^.sent_table := FALSE; { make sure this is false in any new table } tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_quant_table := tbl; jpeg_alloc_quant_table := tbl;
end; end;
{GLOBAL} {GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
var var
tbl : JHUFF_TBL_PTR; tbl : JHUFF_TBL_PTR;
begin begin
tbl := JHUFF_TBL_PTR( tbl := JHUFF_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL)) cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL))
); );
tbl^.sent_table := FALSE; { make sure this is false in any new table } tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_huff_table := tbl; jpeg_alloc_huff_table := tbl;
end; end;
end. end.

248
Imaging/JpegLib/imjconfig.inc
View File

@ -1,124 +1,124 @@
{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- } { ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- }
{ These defines indicate whether to include various optional functions. { These defines indicate whether to include various optional functions.
Undefining some of these symbols will produce a smaller but less capable Undefining some of these symbols will produce a smaller but less capable
library. Note that you can leave certain source files out of the library. Note that you can leave certain source files out of the
compilation/linking process if you've #undef'd the corresponding symbols. 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.)} (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. } { Arithmetic coding is unsupported for legal reasons. Complaints to IBM. }
{ Capability options common to encoder and decoder: } { Capability options common to encoder and decoder: }
{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm } {$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm }
{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method } {$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method }
{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW } {$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW }
{ Encoder capability options: } { Encoder capability options: }
{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } {$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } {$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} {$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? } {$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? }
{ Note: if you selected 12-bit data precision, it is dangerous to turn off { 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 ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit
precision, so jchuff.c normally uses entropy optimization to compute precision, so jchuff.c normally uses entropy optimization to compute
usable tables for higher precision. If you don't want to do optimization, usable tables for higher precision. If you don't want to do optimization,
you'll have to supply different default Huffman tables. you'll have to supply different default Huffman tables.
The exact same statements apply for progressive JPEG: the default tables The exact same statements apply for progressive JPEG: the default tables
don't work for progressive mode. (This may get fixed, however.) } don't work for progressive mode. (This may get fixed, however.) }
{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? } {$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? }
{ Decoder capability options: } { Decoder capability options: }
{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } {$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } {$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} {$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? } {$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? }
{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) } {$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) }
{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? } {$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? }
{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? } {$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? }
{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? } {$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? }
{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? } {$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? }
{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? } {$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? }
{ If you happen not to want the image transform support, disable it here } { If you happen not to want the image transform support, disable it here }
{$define TRANSFORMS_SUPPORTED} {$define TRANSFORMS_SUPPORTED}
{ more capability options later, no doubt } { more capability options later, no doubt }
{$ifopt I+} {$define IOcheck} {$endif} {$ifopt I+} {$define IOcheck} {$endif}
{ ------------------------------------------------------------------------ } { ------------------------------------------------------------------------ }
{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() } {$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() }
{$define FMEMCOPY} {$define FMEMCOPY}
{$define FMEMZERO} {$define FMEMZERO}
{$define DCTSIZE_IS_8} { e.g. unroll the inner loop } {$define DCTSIZE_IS_8} { e.g. unroll the inner loop }
{$define RIGHT_SHIFT_IS_UNSIGNED} {$define RIGHT_SHIFT_IS_UNSIGNED}
{$undef AVOID_TABLES} {$undef AVOID_TABLES}
{$undef FAST_DIVIDE} {$undef FAST_DIVIDE}
{$define BITS_IN_JSAMPLE_IS_8} {$define BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------} {----------------------------------------------------------------}
{ for test of 12 bit JPEG code only. !! } { for test of 12 bit JPEG code only. !! }
{-- $undef BITS_IN_JSAMPLE_IS_8} {-- $undef BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------} {----------------------------------------------------------------}
//{$define RGB_RED_IS_0} //{$define RGB_RED_IS_0}
{ !CHANGE: This must be defined for Delphi/Kylix/FPC } { !CHANGE: This must be defined for Delphi/Kylix/FPC }
{$define RGB_RED_IS_2} { RGB byte order } {$define RGB_RED_IS_2} { RGB byte order }
{$define RGB_PIXELSIZE_IS_3} {$define RGB_PIXELSIZE_IS_3}
{$define SLOW_SHIFT_32} {$define SLOW_SHIFT_32}
{$undef NO_ZERO_ROW_TEST} {$undef NO_ZERO_ROW_TEST}
{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c } {$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c }
{$define XMS_SUPPORTED} {$define XMS_SUPPORTED}
{$define EMS_SUPPORTED} {$define EMS_SUPPORTED}
{$undef MEM_STATS} { Write out memory usage } {$undef MEM_STATS} { Write out memory usage }
{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs } {$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs }
{$undef FULL_MAIN_BUFFER_SUPPORTED} {$undef FULL_MAIN_BUFFER_SUPPORTED}
{$define PROGRESS_REPORT} {$define PROGRESS_REPORT}
{$define TWO_FILE_COMMANDLINE} {$define TWO_FILE_COMMANDLINE}
{$undef BMP_SUPPORTED} {$undef BMP_SUPPORTED}
{$undef PPM_SUPPORTED} {$undef PPM_SUPPORTED}
{$undef GIF_SUPPORTED} {$undef GIF_SUPPORTED}
{$undef RLE_SUPPORTED} {$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED} {$undef TARGA_SUPPORTED}
{$define EXT_SWITCH} {$define EXT_SWITCH}
{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples } {$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples }
{$undef BMP_SUPPORTED} {$undef BMP_SUPPORTED}
{$undef RLE_SUPPORTED} {$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED} {$undef TARGA_SUPPORTED}
{$endif} {$endif}
{!CHANGE: Allowed only for Delphi} {!CHANGE: Allowed only for Delphi}
{$undef BASM16} { for TP7 - use BASM for fast multiply } {$undef BASM16} { for TP7 - use BASM for fast multiply }
{$ifdef Win32} {$ifdef Win32}
{$ifndef FPC} {$ifndef FPC}
{$define BASM} { jidctint with BASM for Delphi 2/3 } {$define BASM} { jidctint with BASM for Delphi 2/3 }
{$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 } {$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 }
{$endif} {$endif}
{$endif} {$endif}
{$ifdef FPC} {$ifdef FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$endif} {$endif}
{!CHANGE: Added this} {!CHANGE: Added this}
{$define Delphi_Stream} {$define Delphi_Stream}
{$Q-} {$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; unit imjcprepct;
{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the compression preprocessing controller. { This file contains the compression preprocessing controller.
This controller manages the color conversion, downsampling, This controller manages the color conversion, downsampling,
and edge expansion steps. and edge expansion steps.
Most of the complexity here is associated with buffering input rows Most of the complexity here is associated with buffering input rows
as required by the downsampler. See the comments at the head of as required by the downsampler. See the comments at the head of
jcsample.c for the downsampler's needs. } jcsample.c for the downsampler's needs. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjpeglib, imjpeglib,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjinclude, imjinclude,
imjutils; imjutils;
{GLOBAL} {GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr; procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
implementation implementation
{ At present, jcsample.c can request context rows only for smoothing. { At present, jcsample.c can request context rows only for smoothing.
In the future, we might also need context rows for CCIR601 sampling In the future, we might also need context rows for CCIR601 sampling
or other more-complex downsampling procedures. The code to support or other more-complex downsampling procedures. The code to support
context rows should be compiled only if needed. } context rows should be compiled only if needed. }
{$ifdef INPUT_SMOOTHING_SUPPORTED} {$ifdef INPUT_SMOOTHING_SUPPORTED}
{$define CONTEXT_ROWS_SUPPORTED} {$define CONTEXT_ROWS_SUPPORTED}
{$endif} {$endif}
{ For the simple (no-context-row) case, we just need to buffer one { 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 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 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 The downsampler's last output row is then replicated if needed to pad
out to a full iMCU row. out to a full iMCU row.
When providing context rows, we must buffer three row groups' worth of When providing context rows, we must buffer three row groups' worth of
pixels. Three row groups are physically allocated, but the row pointer pixels. Three row groups are physically allocated, but the row pointer
arrays are made five row groups high, with the extra pointers above and 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. below "wrapping around" to point to the last and first real row groups.
This allows the downsampler to access the proper context rows. This allows the downsampler to access the proper context rows.
At the top and bottom of the image, we create dummy context rows by 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 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 by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the
trouble on the compression side. } trouble on the compression side. }
{ Private buffer controller object } { Private buffer controller object }
type type
my_prep_ptr = ^my_prep_controller; my_prep_ptr = ^my_prep_controller;
my_prep_controller = record my_prep_controller = record
pub : jpeg_c_prep_controller; { public fields } pub : jpeg_c_prep_controller; { public fields }
{ Downsampling input buffer. This buffer holds color-converted data { Downsampling input buffer. This buffer holds color-converted data
until we have enough to do a downsample step. } until we have enough to do a downsample step. }
color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
rows_to_go : JDIMENSION; { counts rows remaining in source image } rows_to_go : JDIMENSION; { counts rows remaining in source image }
next_buf_row : int; { index of next row to store in color_buf } next_buf_row : int; { index of next row to store in color_buf }
{$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case } {$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case }
this_row_group : int; { starting row index of group to process } this_row_group : int; { starting row index of group to process }
next_buf_stop : int; { downsample when we reach this index } next_buf_stop : int; { downsample when we reach this index }
{$endif} {$endif}
end; {my_prep_controller;} end; {my_prep_controller;}
{ Initialize for a processing pass. } { Initialize for a processing pass. }
{METHODDEF} {METHODDEF}
procedure start_pass_prep (cinfo : j_compress_ptr; procedure start_pass_prep (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE ); pass_mode : J_BUF_MODE );
var var
prep : my_prep_ptr; prep : my_prep_ptr;
begin begin
prep := my_prep_ptr (cinfo^.prep); prep := my_prep_ptr (cinfo^.prep);
if (pass_mode <> JBUF_PASS_THRU) then if (pass_mode <> JBUF_PASS_THRU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{ Initialize total-height counter for detecting bottom of image } { Initialize total-height counter for detecting bottom of image }
prep^.rows_to_go := cinfo^.image_height; prep^.rows_to_go := cinfo^.image_height;
{ Mark the conversion buffer empty } { Mark the conversion buffer empty }
prep^.next_buf_row := 0; prep^.next_buf_row := 0;
{$ifdef CONTEXT_ROWS_SUPPORTED} {$ifdef CONTEXT_ROWS_SUPPORTED}
{ Preset additional state variables for context mode. { Preset additional state variables for context mode.
These aren't used in non-context mode, so we needn't test which mode. } These aren't used in non-context mode, so we needn't test which mode. }
prep^.this_row_group := 0; prep^.this_row_group := 0;
{ Set next_buf_stop to stop after two row groups have been read in. } { Set next_buf_stop to stop after two row groups have been read in. }
prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor; prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor;
{$endif} {$endif}
end; end;
{ Expand an image vertically from height input_rows to height output_rows, { Expand an image vertically from height input_rows to height output_rows,
by duplicating the bottom row. } by duplicating the bottom row. }
{LOCAL} {LOCAL}
procedure expand_bottom_edge (image_data : JSAMPARRAY; procedure expand_bottom_edge (image_data : JSAMPARRAY;
num_cols : JDIMENSION; num_cols : JDIMENSION;
input_rows : int; input_rows : int;
output_rows : int); output_rows : int);
var var
{register} row : int; {register} row : int;
begin begin
for row := input_rows to pred(output_rows) do for row := input_rows to pred(output_rows) do
begin begin
jcopy_sample_rows(image_data, input_rows-1, image_data, row, jcopy_sample_rows(image_data, input_rows-1, image_data, row,
1, num_cols); 1, num_cols);
end; end;
end; end;
{ Process some data in the simple no-context case. { Process some data in the simple no-context case.
Preprocessor output data is counted in "row groups". A row group Preprocessor output data is counted in "row groups". A row group
is defined to be v_samp_factor sample rows of each component. is defined to be v_samp_factor sample rows of each component.
Downsampling will produce this much data from each max_v_samp_factor Downsampling will produce this much data from each max_v_samp_factor
input rows. } input rows. }
{METHODDEF} {METHODDEF}
procedure pre_process_data (cinfo : j_compress_ptr; procedure pre_process_data (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION; var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION; in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE; output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION; var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION); out_row_groups_avail : JDIMENSION);
var var
prep : my_prep_ptr; prep : my_prep_ptr;
numrows, ci : int; numrows, ci : int;
inrows : JDIMENSION; inrows : JDIMENSION;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
var var
local_input_buf : JSAMPARRAY; local_input_buf : JSAMPARRAY;
begin begin
prep := my_prep_ptr (cinfo^.prep); prep := my_prep_ptr (cinfo^.prep);
while (in_row_ctr < in_rows_avail) and while (in_row_ctr < in_rows_avail) and
(out_row_group_ctr < out_row_groups_avail) do (out_row_group_ctr < out_row_groups_avail) do
begin begin
{ Do color conversion to fill the conversion buffer. } { Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr; inrows := in_rows_avail - in_row_ctr;
numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row; numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row;
{numrows := int( MIN(JDIMENSION(numrows), inrows) );} {numrows := int( MIN(JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then if inrows < JDIMENSION(numrows) then
numrows := int(inrows); numrows := int(inrows);
local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr])); local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr]));
cinfo^.cconvert^.color_convert (cinfo, local_input_buf, cinfo^.cconvert^.color_convert (cinfo, local_input_buf,
JSAMPIMAGE(@prep^.color_buf), JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.next_buf_row), JDIMENSION(prep^.next_buf_row),
numrows); numrows);
Inc(in_row_ctr, numrows); Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows); Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows); Dec(prep^.rows_to_go, numrows);
{ If at bottom of image, pad to fill the conversion buffer. } { If at bottom of image, pad to fill the conversion buffer. }
if (prep^.rows_to_go = 0) and if (prep^.rows_to_go = 0) and
(prep^.next_buf_row < cinfo^.max_v_samp_factor) then (prep^.next_buf_row < cinfo^.max_v_samp_factor) then
begin begin
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, cinfo^.max_v_samp_factor); prep^.next_buf_row, cinfo^.max_v_samp_factor);
end; end;
prep^.next_buf_row := cinfo^.max_v_samp_factor; prep^.next_buf_row := cinfo^.max_v_samp_factor;
end; end;
{ If we've filled the conversion buffer, empty it. } { If we've filled the conversion buffer, empty it. }
if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then
begin begin
cinfo^.downsample^.downsample (cinfo, cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf), JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (0), JDIMENSION (0),
output_buf, output_buf,
out_row_group_ctr); out_row_group_ctr);
prep^.next_buf_row := 0; prep^.next_buf_row := 0;
Inc(out_row_group_ctr);; Inc(out_row_group_ctr);;
end; end;
{ If at bottom of image, pad the output to a full iMCU height. { 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! } Note we assume the caller is providing a one-iMCU-height output buffer! }
if (prep^.rows_to_go = 0) and if (prep^.rows_to_go = 0) and
(out_row_group_ctr < out_row_groups_avail) then (out_row_group_ctr < out_row_groups_avail) then
begin begin
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
expand_bottom_edge(output_buf^[ci], expand_bottom_edge(output_buf^[ci],
compptr^.width_in_blocks * DCTSIZE, compptr^.width_in_blocks * DCTSIZE,
int (out_row_group_ctr) * compptr^.v_samp_factor, int (out_row_group_ctr) * compptr^.v_samp_factor,
int (out_row_groups_avail) * compptr^.v_samp_factor); int (out_row_groups_avail) * compptr^.v_samp_factor);
Inc(compptr); Inc(compptr);
end; end;
out_row_group_ctr := out_row_groups_avail; out_row_group_ctr := out_row_groups_avail;
break; { can exit outer loop without test } break; { can exit outer loop without test }
end; end;
end; end;
end; end;
{$ifdef CONTEXT_ROWS_SUPPORTED} {$ifdef CONTEXT_ROWS_SUPPORTED}
{ Process some data in the context case. } { Process some data in the context case. }
{METHODDEF} {METHODDEF}
procedure pre_process_context (cinfo : j_compress_ptr; procedure pre_process_context (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY; input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION; var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION; in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE; output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION; var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION); out_row_groups_avail : JDIMENSION);
var var
prep : my_prep_ptr; prep : my_prep_ptr;
numrows, ci : int; numrows, ci : int;
buf_height : int; buf_height : int;
inrows : JDIMENSION; inrows : JDIMENSION;
var var
row : int; row : int;
begin begin
prep := my_prep_ptr (cinfo^.prep); prep := my_prep_ptr (cinfo^.prep);
buf_height := cinfo^.max_v_samp_factor * 3; buf_height := cinfo^.max_v_samp_factor * 3;
while (out_row_group_ctr < out_row_groups_avail) do while (out_row_group_ctr < out_row_groups_avail) do
begin begin
if (in_row_ctr < in_rows_avail) then if (in_row_ctr < in_rows_avail) then
begin begin
{ Do color conversion to fill the conversion buffer. } { Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr; inrows := in_rows_avail - in_row_ctr;
numrows := prep^.next_buf_stop - prep^.next_buf_row; numrows := prep^.next_buf_stop - prep^.next_buf_row;
{numrows := int ( MIN( JDIMENSION(numrows), inrows) );} {numrows := int ( MIN( JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then if inrows < JDIMENSION(numrows) then
numrows := int(inrows); numrows := int(inrows);
cinfo^.cconvert^.color_convert (cinfo, cinfo^.cconvert^.color_convert (cinfo,
JSAMPARRAY(@input_buf^[in_row_ctr]), JSAMPARRAY(@input_buf^[in_row_ctr]),
JSAMPIMAGE(@prep^.color_buf), JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (prep^.next_buf_row), JDIMENSION (prep^.next_buf_row),
numrows); numrows);
{ Pad at top of image, if first time through } { Pad at top of image, if first time through }
if (prep^.rows_to_go = cinfo^.image_height) then if (prep^.rows_to_go = cinfo^.image_height) then
begin begin
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
for row := 1 to cinfo^.max_v_samp_factor do for row := 1 to cinfo^.max_v_samp_factor do
begin begin
jcopy_sample_rows(prep^.color_buf[ci], 0, jcopy_sample_rows(prep^.color_buf[ci], 0,
prep^.color_buf[ci], -row, prep^.color_buf[ci], -row,
1, cinfo^.image_width); 1, cinfo^.image_width);
end; end;
end; end;
end; end;
Inc(in_row_ctr, numrows); Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows); Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows); Dec(prep^.rows_to_go, numrows);
end end
else else
begin begin
{ Return for more data, unless we are at the bottom of the image. } { Return for more data, unless we are at the bottom of the image. }
if (prep^.rows_to_go <> 0) then if (prep^.rows_to_go <> 0) then
break; break;
{ When at bottom of image, pad to fill the conversion buffer. } { When at bottom of image, pad to fill the conversion buffer. }
if (prep^.next_buf_row < prep^.next_buf_stop) then if (prep^.next_buf_row < prep^.next_buf_stop) then
begin begin
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, prep^.next_buf_stop); prep^.next_buf_row, prep^.next_buf_stop);
end; end;
prep^.next_buf_row := prep^.next_buf_stop; prep^.next_buf_row := prep^.next_buf_stop;
end; end;
end; end;
{ If we've gotten enough data, downsample a row group. } { If we've gotten enough data, downsample a row group. }
if (prep^.next_buf_row = prep^.next_buf_stop) then if (prep^.next_buf_row = prep^.next_buf_stop) then
begin begin
cinfo^.downsample^.downsample (cinfo, cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf), JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.this_row_group), JDIMENSION(prep^.this_row_group),
output_buf, output_buf,
out_row_group_ctr); out_row_group_ctr);
Inc(out_row_group_ctr); Inc(out_row_group_ctr);
{ Advance pointers with wraparound as necessary. } { Advance pointers with wraparound as necessary. }
Inc(prep^.this_row_group, cinfo^.max_v_samp_factor); Inc(prep^.this_row_group, cinfo^.max_v_samp_factor);
if (prep^.this_row_group >= buf_height) then if (prep^.this_row_group >= buf_height) then
prep^.this_row_group := 0; prep^.this_row_group := 0;
if (prep^.next_buf_row >= buf_height) then if (prep^.next_buf_row >= buf_height) then
prep^.next_buf_row := 0; prep^.next_buf_row := 0;
prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor; prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor;
end; end;
end; end;
end; end;
{ Create the wrapped-around downsampling input buffer needed for context mode. } { Create the wrapped-around downsampling input buffer needed for context mode. }
{LOCAL} {LOCAL}
procedure create_context_buffer (cinfo : j_compress_ptr); procedure create_context_buffer (cinfo : j_compress_ptr);
var var
prep : my_prep_ptr; prep : my_prep_ptr;
rgroup_height : int; rgroup_height : int;
ci, i : int; ci, i : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
true_buffer, fake_buffer : JSAMPARRAY; true_buffer, fake_buffer : JSAMPARRAY;
begin begin
prep := my_prep_ptr (cinfo^.prep); prep := my_prep_ptr (cinfo^.prep);
rgroup_height := cinfo^.max_v_samp_factor; rgroup_height := cinfo^.max_v_samp_factor;
{ Grab enough space for fake row pointers for all the components; { Grab enough space for fake row pointers for all the components;
we need five row groups' worth of pointers for each component. } we need five row groups' worth of pointers for each component. }
fake_buffer := JSAMPARRAY( fake_buffer := JSAMPARRAY(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(cinfo^.num_components * 5 * rgroup_height) * (cinfo^.num_components * 5 * rgroup_height) *
SIZEOF(JSAMPROW)) ); SIZEOF(JSAMPROW)) );
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
{ Allocate the actual buffer space (3 row groups) for this component. { Allocate the actual buffer space (3 row groups) for this component.
We make the buffer wide enough to allow the downsampler to edge-expand We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. } horizontally within the buffer, if it so chooses. }
true_buffer := cinfo^.mem^.alloc_sarray true_buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, (j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION (3 * rgroup_height)); JDIMENSION (3 * rgroup_height));
{ Copy true buffer row pointers into the middle of the fake row array } { Copy true buffer row pointers into the middle of the fake row array }
MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer, MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer,
3 * rgroup_height * SIZEOF(JSAMPROW)); 3 * rgroup_height * SIZEOF(JSAMPROW));
{ Fill in the above and below wraparound pointers } { Fill in the above and below wraparound pointers }
for i := 0 to pred(rgroup_height) do for i := 0 to pred(rgroup_height) do
begin begin
fake_buffer^[i] := true_buffer^[2 * rgroup_height + i]; fake_buffer^[i] := true_buffer^[2 * rgroup_height + i];
fake_buffer^[4 * rgroup_height + i] := true_buffer^[i]; fake_buffer^[4 * rgroup_height + i] := true_buffer^[i];
end; end;
prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]); prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]);
Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component } Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component }
Inc(compptr); Inc(compptr);
end; end;
end; end;
{$endif} { CONTEXT_ROWS_SUPPORTED } {$endif} { CONTEXT_ROWS_SUPPORTED }
{ Initialize preprocessing controller. } { Initialize preprocessing controller. }
{GLOBAL} {GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr; procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
var var
prep : my_prep_ptr; prep : my_prep_ptr;
ci : int; ci : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
begin begin
if (need_full_buffer) then { safety check } if (need_full_buffer) then { safety check }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
prep := my_prep_ptr( prep := my_prep_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_prep_controller)) ); SIZEOF(my_prep_controller)) );
cinfo^.prep := jpeg_c_prep_controller_ptr(prep); cinfo^.prep := jpeg_c_prep_controller_ptr(prep);
prep^.pub.start_pass := start_pass_prep; prep^.pub.start_pass := start_pass_prep;
{ Allocate the color conversion buffer. { Allocate the color conversion buffer.
We make the buffer wide enough to allow the downsampler to edge-expand We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. } horizontally within the buffer, if it so chooses. }
if (cinfo^.downsample^.need_context_rows) then if (cinfo^.downsample^.need_context_rows) then
begin begin
{ Set up to provide context rows } { Set up to provide context rows }
{$ifdef CONTEXT_ROWS_SUPPORTED} {$ifdef CONTEXT_ROWS_SUPPORTED}
prep^.pub.pre_process_data := pre_process_context; prep^.pub.pre_process_data := pre_process_context;
create_context_buffer(cinfo); create_context_buffer(cinfo);
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} {$endif}
end end
else else
begin begin
{ No context, just make it tall enough for one row group } { No context, just make it tall enough for one row group }
prep^.pub.pre_process_data := pre_process_data; prep^.pub.pre_process_data := pre_process_data;
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, (j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION(cinfo^.max_v_samp_factor) ); JDIMENSION(cinfo^.max_v_samp_factor) );
Inc(compptr); Inc(compptr);
end; end;
end; end;
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; unit imjdapistd;
{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software. { This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file. For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the decompression half This file contains application interface code for the decompression half
of the JPEG library. These are the "standard" API routines that are 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 used in the normal full-decompression case. They are not used by a
transcoding-only application. Note that if an application links in transcoding-only application. Note that if an application links in
jpeg_start_decompress, it will end up linking in the entire decompressor. 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 We thus must separate this file from jdapimin.c to avoid linking the
whole decompression library into a transcoder. } whole decompression library into a transcoder. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjpeglib, imjpeglib,
imjdmaster; imjdmaster;
{ Read some scanlines of data from the JPEG decompressor. { Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read. The return value will be the number of lines actually read.
This may be less than the number requested in several cases, This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time. modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However, this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. } an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL} {GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr; function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY; scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION; max_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to read raw data. { Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. } Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL} {GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr; function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE; data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION; max_lines : JDIMENSION) : JDIMENSION;
{$ifdef D_MULTISCAN_FILES_SUPPORTED} {$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. } { Initialize for an output pass in buffered-image mode. }
{GLOBAL} {GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr; function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean; scan_number : int) : boolean;
{ Finish up after an output pass in buffered-image mode. { Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. } a suspending data source is used. }
{GLOBAL} {GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
{$endif} { D_MULTISCAN_FILES_SUPPORTED } {$endif} { D_MULTISCAN_FILES_SUPPORTED }
{ Decompression initialization. { Decompression initialization.
jpeg_read_header must be completed before calling this. jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time. last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. } a suspending data source is used. }
{GLOBAL} {GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
implementation implementation
{ Forward declarations } { Forward declarations }
{LOCAL} {LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward; function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward;
{ Decompression initialization. { Decompression initialization.
jpeg_read_header must be completed before calling this. jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time. last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. } a suspending data source is used. }
{GLOBAL} {GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
var var
retcode : int; retcode : int;
begin begin
if (cinfo^.global_state = DSTATE_READY) then if (cinfo^.global_state = DSTATE_READY) then
begin begin
{ First call: initialize master control, select active modules } { First call: initialize master control, select active modules }
jinit_master_decompress(cinfo); jinit_master_decompress(cinfo);
if (cinfo^.buffered_image) then if (cinfo^.buffered_image) then
begin begin
{ No more work here; expecting jpeg_start_output next } { No more work here; expecting jpeg_start_output next }
cinfo^.global_state := DSTATE_BUFIMAGE; cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_start_decompress := TRUE; jpeg_start_decompress := TRUE;
exit; exit;
end; end;
cinfo^.global_state := DSTATE_PRELOAD; cinfo^.global_state := DSTATE_PRELOAD;
end; end;
if (cinfo^.global_state = DSTATE_PRELOAD) then if (cinfo^.global_state = DSTATE_PRELOAD) then
begin begin
{ If file has multiple scans, absorb them all into the coef buffer } { If file has multiple scans, absorb them all into the coef buffer }
if (cinfo^.inputctl^.has_multiple_scans) then if (cinfo^.inputctl^.has_multiple_scans) then
begin begin
{$ifdef D_MULTISCAN_FILES_SUPPORTED} {$ifdef D_MULTISCAN_FILES_SUPPORTED}
while TRUE do while TRUE do
begin begin
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
{ Absorb some more input } { Absorb some more input }
retcode := cinfo^.inputctl^.consume_input (cinfo); retcode := cinfo^.inputctl^.consume_input (cinfo);
if (retcode = JPEG_SUSPENDED) then if (retcode = JPEG_SUSPENDED) then
begin begin
jpeg_start_decompress := FALSE; jpeg_start_decompress := FALSE;
exit; exit;
end; end;
if (retcode = JPEG_REACHED_EOI) then if (retcode = JPEG_REACHED_EOI) then
break; break;
{ Advance progress counter if appropriate } { Advance progress counter if appropriate }
if (cinfo^.progress <> NIL) and if (cinfo^.progress <> NIL) and
((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then ((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then
begin begin
Inc(cinfo^.progress^.pass_counter); Inc(cinfo^.progress^.pass_counter);
if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then
begin begin
{ jdmaster underestimated number of scans; ratchet up one scan } { jdmaster underestimated number of scans; ratchet up one scan }
Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows)); Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows));
end; end;
end; end;
end; end;
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { D_MULTISCAN_FILES_SUPPORTED } {$endif} { D_MULTISCAN_FILES_SUPPORTED }
end; end;
cinfo^.output_scan_number := cinfo^.input_scan_number; cinfo^.output_scan_number := cinfo^.input_scan_number;
end end
else else
if (cinfo^.global_state <> DSTATE_PRESCAN) then if (cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any dummy output passes, and set up for the final pass } { Perform any dummy output passes, and set up for the final pass }
jpeg_start_decompress := output_pass_setup(cinfo); jpeg_start_decompress := output_pass_setup(cinfo);
end; end;
{ Set up for an output pass, and perform any dummy pass(es) needed. { Set up for an output pass, and perform any dummy pass(es) needed.
Common subroutine for jpeg_start_decompress and jpeg_start_output. Common subroutine for jpeg_start_decompress and jpeg_start_output.
Entry: global_state := DSTATE_PRESCAN only if previously suspended. Entry: global_state := DSTATE_PRESCAN only if previously suspended.
Exit: If done, returns TRUE and sets global_state for proper output mode. Exit: If done, returns TRUE and sets global_state for proper output mode.
If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. } If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. }
{LOCAL} {LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean; function output_pass_setup (cinfo : j_decompress_ptr) : boolean;
var var
last_scanline : JDIMENSION; last_scanline : JDIMENSION;
begin begin
if (cinfo^.global_state <> DSTATE_PRESCAN) then if (cinfo^.global_state <> DSTATE_PRESCAN) then
begin begin
{ First call: do pass setup } { First call: do pass setup }
cinfo^.master^.prepare_for_output_pass (cinfo); cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0; cinfo^.output_scanline := 0;
cinfo^.global_state := DSTATE_PRESCAN; cinfo^.global_state := DSTATE_PRESCAN;
end; end;
{ Loop over any required dummy passes } { Loop over any required dummy passes }
while (cinfo^.master^.is_dummy_pass) do while (cinfo^.master^.is_dummy_pass) do
begin begin
{$ifdef QUANT_2PASS_SUPPORTED} {$ifdef QUANT_2PASS_SUPPORTED}
{ Crank through the dummy pass } { Crank through the dummy pass }
while (cinfo^.output_scanline < cinfo^.output_height) do while (cinfo^.output_scanline < cinfo^.output_height) do
begin begin
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height); cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ Process some data } { Process some data }
last_scanline := cinfo^.output_scanline; last_scanline := cinfo^.output_scanline;
cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL), cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL),
cinfo^.output_scanline, {var} cinfo^.output_scanline, {var}
JDIMENSION(0)); JDIMENSION(0));
if (cinfo^.output_scanline = last_scanline) then if (cinfo^.output_scanline = last_scanline) then
begin begin
output_pass_setup := FALSE; { No progress made, must suspend } output_pass_setup := FALSE; { No progress made, must suspend }
exit; exit;
end; end;
end; end;
{ Finish up dummy pass, and set up for another one } { Finish up dummy pass, and set up for another one }
cinfo^.master^.finish_output_pass (cinfo); cinfo^.master^.finish_output_pass (cinfo);
cinfo^.master^.prepare_for_output_pass (cinfo); cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0; cinfo^.output_scanline := 0;
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { QUANT_2PASS_SUPPORTED } {$endif} { QUANT_2PASS_SUPPORTED }
end; end;
{ Ready for application to drive output pass through { Ready for application to drive output pass through
jpeg_read_scanlines or jpeg_read_raw_data. } jpeg_read_scanlines or jpeg_read_raw_data. }
if cinfo^.raw_data_out then if cinfo^.raw_data_out then
cinfo^.global_state := DSTATE_RAW_OK cinfo^.global_state := DSTATE_RAW_OK
else else
cinfo^.global_state := DSTATE_SCANNING; cinfo^.global_state := DSTATE_SCANNING;
output_pass_setup := TRUE; output_pass_setup := TRUE;
end; end;
{ Read some scanlines of data from the JPEG decompressor. { Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read. The return value will be the number of lines actually read.
This may be less than the number requested in several cases, This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time. modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However, this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. } an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL} {GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr; function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY; scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION; max_lines : JDIMENSION) : JDIMENSION;
var var
row_ctr : JDIMENSION; row_ctr : JDIMENSION;
begin begin
if (cinfo^.global_state <> DSTATE_SCANNING) then if (cinfo^.global_state <> DSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then if (cinfo^.output_scanline >= cinfo^.output_height) then
begin begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_scanlines := 0; jpeg_read_scanlines := 0;
exit; exit;
end; end;
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height); cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ Process some data } { Process some data }
row_ctr := 0; row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines); cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines);
Inc(cinfo^.output_scanline, row_ctr); Inc(cinfo^.output_scanline, row_ctr);
jpeg_read_scanlines := row_ctr; jpeg_read_scanlines := row_ctr;
end; end;
{ Alternate entry point to read raw data. { Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. } Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL} {GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr; function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE; data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION; max_lines : JDIMENSION) : JDIMENSION;
var var
lines_per_iMCU_row : JDIMENSION; lines_per_iMCU_row : JDIMENSION;
begin begin
if (cinfo^.global_state <> DSTATE_RAW_OK) then if (cinfo^.global_state <> DSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then if (cinfo^.output_scanline >= cinfo^.output_height) then
begin begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_raw_data := 0; jpeg_read_raw_data := 0;
exit; exit;
end; end;
{ Call progress monitor hook if present } { Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then if (cinfo^.progress <> NIL) then
begin begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height); cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end; end;
{ Verify that at least one iMCU row can be returned. } { Verify that at least one iMCU row can be returned. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size; lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size;
if (max_lines < lines_per_iMCU_row) then if (max_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Decompress directly into user's buffer. } { Decompress directly into user's buffer. }
if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then
begin begin
jpeg_read_raw_data := 0; { suspension forced, can do nothing more } jpeg_read_raw_data := 0; { suspension forced, can do nothing more }
exit; exit;
end; end;
{ OK, we processed one iMCU row. } { OK, we processed one iMCU row. }
Inc(cinfo^.output_scanline, lines_per_iMCU_row); Inc(cinfo^.output_scanline, lines_per_iMCU_row);
jpeg_read_raw_data := lines_per_iMCU_row; jpeg_read_raw_data := lines_per_iMCU_row;
end; end;
{ Additional entry points for buffered-image mode. } { Additional entry points for buffered-image mode. }
{$ifdef D_MULTISCAN_FILES_SUPPORTED} {$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. } { Initialize for an output pass in buffered-image mode. }
{GLOBAL} {GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr; function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean; scan_number : int) : boolean;
begin begin
if (cinfo^.global_state <> DSTATE_BUFIMAGE) and if (cinfo^.global_state <> DSTATE_BUFIMAGE) and
(cinfo^.global_state <> DSTATE_PRESCAN) then (cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Limit scan number to valid range } { Limit scan number to valid range }
if (scan_number <= 0) then if (scan_number <= 0) then
scan_number := 1; scan_number := 1;
if (cinfo^.inputctl^.eoi_reached) and if (cinfo^.inputctl^.eoi_reached) and
(scan_number > cinfo^.input_scan_number) then (scan_number > cinfo^.input_scan_number) then
scan_number := cinfo^.input_scan_number; scan_number := cinfo^.input_scan_number;
cinfo^.output_scan_number := scan_number; cinfo^.output_scan_number := scan_number;
{ Perform any dummy output passes, and set up for the real pass } { Perform any dummy output passes, and set up for the real pass }
jpeg_start_output := output_pass_setup(cinfo); jpeg_start_output := output_pass_setup(cinfo);
end; end;
{ Finish up after an output pass in buffered-image mode. { Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. } a suspending data source is used. }
{GLOBAL} {GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
begin begin
if ((cinfo^.global_state = DSTATE_SCANNING) or if ((cinfo^.global_state = DSTATE_SCANNING) or
(cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then (cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then
begin begin
{ Terminate this pass. } { Terminate this pass. }
{ We do not require the whole pass to have been completed. } { We do not require the whole pass to have been completed. }
cinfo^.master^.finish_output_pass (cinfo); cinfo^.master^.finish_output_pass (cinfo);
cinfo^.global_state := DSTATE_BUFPOST; cinfo^.global_state := DSTATE_BUFPOST;
end end
else else
if (cinfo^.global_state <> DSTATE_BUFPOST) then if (cinfo^.global_state <> DSTATE_BUFPOST) then
begin begin
{ BUFPOST := repeat call after a suspension, anything else is error } { BUFPOST := repeat call after a suspension, anything else is error }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end; end;
{ Read markers looking for SOS or EOI } { Read markers looking for SOS or EOI }
while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and
(not cinfo^.inputctl^.eoi_reached) do (not cinfo^.inputctl^.eoi_reached) do
begin begin
if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then
begin begin
jpeg_finish_output := FALSE; { Suspend, come back later } jpeg_finish_output := FALSE; { Suspend, come back later }
exit; exit;
end; end;
end; end;
cinfo^.global_state := DSTATE_BUFIMAGE; cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_finish_output := TRUE; jpeg_finish_output := TRUE;
end; end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED } {$endif} { D_MULTISCAN_FILES_SUPPORTED }
end. 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; unit imjdct;
{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. } { Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This include file contains common declarations for the forward and { This include file contains common declarations for the forward and
inverse DCT modules. These declarations are private to the DCT managers inverse DCT modules. These declarations are private to the DCT managers
(jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms. (jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms.
The individual DCT algorithms are kept in separate files to ease The individual DCT algorithms are kept in separate files to ease
machine-dependent tuning (e.g., assembly coding). } machine-dependent tuning (e.g., assembly coding). }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg; imjmorecfg;
{ A forward DCT routine is given a pointer to a work area of type DCTELEM[]; { 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 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 for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT
implementations use an array of type FAST_FLOAT, instead.) implementations use an array of type FAST_FLOAT, instead.)
The DCT inputs are expected to be signed (range +-CENTERJSAMPLE). The DCT inputs are expected to be signed (range +-CENTERJSAMPLE).
The DCT outputs are returned scaled up by a factor of 8; they therefore 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 have a range of +-8K for 8-bit data, +-128K for 12-bit data. This
convention improves accuracy in integer implementations and saves some convention improves accuracy in integer implementations and saves some
work in floating-point ones. work in floating-point ones.
Quantization of the output coefficients is done by jcdctmgr.c. } Quantization of the output coefficients is done by jcdctmgr.c. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
type type
DCTELEM = int; { 16 or 32 bits is fine } DCTELEM = int; { 16 or 32 bits is fine }
{$else} {$else}
type { must have 32 bits } type { must have 32 bits }
DCTELEM = INT32; DCTELEM = INT32;
{$endif} {$endif}
type type
jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1; jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1;
DCTELEM_FIELD = array[jTDctElem] of DCTELEM; DCTELEM_FIELD = array[jTDctElem] of DCTELEM;
DCTELEM_FIELD_PTR = ^DCTELEM_FIELD; DCTELEM_FIELD_PTR = ^DCTELEM_FIELD;
DCTELEMPTR = ^DCTELEM; DCTELEMPTR = ^DCTELEM;
type type
forward_DCT_method_ptr = procedure(var data : array of DCTELEM); forward_DCT_method_ptr = procedure(var data : array of DCTELEM);
float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT); 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 { 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 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 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 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 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.) 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 Note that the number of samples emitted by the IDCT routine is
DCT_scaled_size * DCT_scaled_size. } DCT_scaled_size * DCT_scaled_size. }
{ typedef inverse_DCT_method_ptr is declared in jpegint.h } { typedef inverse_DCT_method_ptr is declared in jpegint.h }
{ Each IDCT routine has its own ideas about the best dct_table element type. } { Each IDCT routine has its own ideas about the best dct_table element type. }
type type
ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster } ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
type type
IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster } IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster }
const const
IFAST_SCALE_BITS = 2; { fractional bits in scale factors } IFAST_SCALE_BITS = 2; { fractional bits in scale factors }
{$else} {$else}
type type
IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers } IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers }
const const
IFAST_SCALE_BITS = 13; { fractional bits in scale factors } IFAST_SCALE_BITS = 13; { fractional bits in scale factors }
{$endif} {$endif}
type type
FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type } FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type }
const const
RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples } RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples }
type type
jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1; jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1;
ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE; ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE;
ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD; ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD;
ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE; ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE;
jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1; jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1;
FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE; FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE;
FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD; FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD;
FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE; FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE;
jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1; jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1;
IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE; IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE;
IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD; IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD;
IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE; IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE;
type type
jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1; jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1;
FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT; FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT;
FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD; FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD;
FAST_FLOAT_PTR = ^FAST_FLOAT; FAST_FLOAT_PTR = ^FAST_FLOAT;
implementation implementation
end. end.

660
Imaging/JpegLib/imjddctmgr.pas
View File

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

994
Imaging/JpegLib/imjdeferr.pas
View File

@ -1,497 +1,497 @@
unit imjdeferr; unit imjdeferr;
{ This file defines the error and message codes for the cjpeg/djpeg { This file defines the error and message codes for the cjpeg/djpeg
applications. These strings are not needed as part of the JPEG library applications. These strings are not needed as part of the JPEG library
proper. proper.
Edit this file to add new codes, or to translate the message strings to Edit this file to add new codes, or to translate the message strings to
some other language. } some other language. }
{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. } { Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
{ To define the enum list of message codes, include this file without { To define the enum list of message codes, include this file without
defining macro JMESSAGE. To create a message string table, include it defining macro JMESSAGE. To create a message string table, include it
again with a suitable JMESSAGE definition (see jerror.c for an example). } again with a suitable JMESSAGE definition (see jerror.c for an example). }
{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. } { Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. }
{ This file contains software version identification. } { This file contains software version identification. }
const const
JVERSION = '6a 7-Feb-96'; JVERSION = '6a 7-Feb-96';
JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane'; JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane';
JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali'; JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali';
{ Create the message string table. { Create the message string table.
We do this from the master message list in jerror.h by re-reading We do this from the master message list in jerror.h by re-reading
jerror.h with a suitable definition for macro JMESSAGE. jerror.h with a suitable definition for macro JMESSAGE.
The message table is made an external symbol just in case any applications The message table is made an external symbol just in case any applications
want to refer to it directly. } want to refer to it directly. }
type type
J_MESSAGE_CODE =( J_MESSAGE_CODE =(
JMSG_NOMESSAGE, JMSG_NOMESSAGE,
JERR_ARITH_NOTIMPL, JERR_ARITH_NOTIMPL,
JERR_BAD_ALIGN_TYPE, JERR_BAD_ALIGN_TYPE,
JERR_BAD_ALLOC_CHUNK, JERR_BAD_ALLOC_CHUNK,
JERR_BAD_BUFFER_MODE, JERR_BAD_BUFFER_MODE,
JERR_BAD_COMPONENT_ID, JERR_BAD_COMPONENT_ID,
JERR_BAD_DCT_COEF, JERR_BAD_DCT_COEF,
JERR_BAD_DCTSIZE, JERR_BAD_DCTSIZE,
JERR_BAD_HUFF_TABLE, JERR_BAD_HUFF_TABLE,
JERR_BAD_IN_COLORSPACE, JERR_BAD_IN_COLORSPACE,
JERR_BAD_J_COLORSPACE, JERR_BAD_J_COLORSPACE,
JERR_BAD_LENGTH, JERR_BAD_LENGTH,
JERR_BAD_LIB_VERSION, JERR_BAD_LIB_VERSION,
JERR_BAD_MCU_SIZE, JERR_BAD_MCU_SIZE,
JERR_BAD_POOL_ID, JERR_BAD_POOL_ID,
JERR_BAD_PRECISION, JERR_BAD_PRECISION,
JERR_BAD_PROGRESSION, JERR_BAD_PROGRESSION,
JERR_BAD_PROG_SCRIPT, JERR_BAD_PROG_SCRIPT,
JERR_BAD_SAMPLING, JERR_BAD_SAMPLING,
JERR_BAD_SCAN_SCRIPT, JERR_BAD_SCAN_SCRIPT,
JERR_BAD_STATE, JERR_BAD_STATE,
JERR_BAD_STRUCT_SIZE, JERR_BAD_STRUCT_SIZE,
JERR_BAD_VIRTUAL_ACCESS, JERR_BAD_VIRTUAL_ACCESS,
JERR_BUFFER_SIZE, JERR_BUFFER_SIZE,
JERR_CANT_SUSPEND, JERR_CANT_SUSPEND,
JERR_CCIR601_NOTIMPL, JERR_CCIR601_NOTIMPL,
JERR_COMPONENT_COUNT, JERR_COMPONENT_COUNT,
JERR_CONVERSION_NOTIMPL, JERR_CONVERSION_NOTIMPL,
JERR_DAC_INDEX, JERR_DAC_INDEX,
JERR_DAC_VALUE, JERR_DAC_VALUE,
JERR_DHT_COUNTS, JERR_DHT_COUNTS,
JERR_DHT_INDEX, JERR_DHT_INDEX,
JERR_DQT_INDEX, JERR_DQT_INDEX,
JERR_EMPTY_IMAGE, JERR_EMPTY_IMAGE,
JERR_EMS_READ, JERR_EMS_READ,
JERR_EMS_WRITE, JERR_EMS_WRITE,
JERR_EOI_EXPECTED, JERR_EOI_EXPECTED,
JERR_FILE_READ, JERR_FILE_READ,
JERR_FILE_WRITE, JERR_FILE_WRITE,
JERR_FRACT_SAMPLE_NOTIMPL, JERR_FRACT_SAMPLE_NOTIMPL,
JERR_HUFF_CLEN_OVERFLOW, JERR_HUFF_CLEN_OVERFLOW,
JERR_HUFF_MISSING_CODE, JERR_HUFF_MISSING_CODE,
JERR_IMAGE_TOO_BIG, JERR_IMAGE_TOO_BIG,
JERR_INPUT_EMPTY, JERR_INPUT_EMPTY,
JERR_INPUT_EOF, JERR_INPUT_EOF,
JERR_MISMATCHED_QUANT_TABLE, JERR_MISMATCHED_QUANT_TABLE,
JERR_MISSING_DATA, JERR_MISSING_DATA,
JERR_MODE_CHANGE, JERR_MODE_CHANGE,
JERR_NOTIMPL, JERR_NOTIMPL,
JERR_NOT_COMPILED, JERR_NOT_COMPILED,
JERR_NO_BACKING_STORE, JERR_NO_BACKING_STORE,
JERR_NO_HUFF_TABLE, JERR_NO_HUFF_TABLE,
JERR_NO_IMAGE, JERR_NO_IMAGE,
JERR_NO_QUANT_TABLE, JERR_NO_QUANT_TABLE,
JERR_NO_SOI, JERR_NO_SOI,
JERR_OUT_OF_MEMORY, JERR_OUT_OF_MEMORY,
JERR_QUANT_COMPONENTS, JERR_QUANT_COMPONENTS,
JERR_QUANT_FEW_COLORS, JERR_QUANT_FEW_COLORS,
JERR_QUANT_MANY_COLORS, JERR_QUANT_MANY_COLORS,
JERR_SOF_DUPLICATE, JERR_SOF_DUPLICATE,
JERR_SOF_NO_SOS, JERR_SOF_NO_SOS,
JERR_SOF_UNSUPPORTED, JERR_SOF_UNSUPPORTED,
JERR_SOI_DUPLICATE, JERR_SOI_DUPLICATE,
JERR_SOS_NO_SOF, JERR_SOS_NO_SOF,
JERR_TFILE_CREATE, JERR_TFILE_CREATE,
JERR_TFILE_READ, JERR_TFILE_READ,
JERR_TFILE_SEEK, JERR_TFILE_SEEK,
JERR_TFILE_WRITE, JERR_TFILE_WRITE,
JERR_TOO_LITTLE_DATA, JERR_TOO_LITTLE_DATA,
JERR_UNKNOWN_MARKER, JERR_UNKNOWN_MARKER,
JERR_VIRTUAL_BUG, JERR_VIRTUAL_BUG,
JERR_WIDTH_OVERFLOW, JERR_WIDTH_OVERFLOW,
JERR_XMS_READ, JERR_XMS_READ,
JERR_XMS_WRITE, JERR_XMS_WRITE,
JMSG_COPYRIGHT, JMSG_COPYRIGHT,
JMSG_VERSION, JMSG_VERSION,
JTRC_16BIT_TABLES, JTRC_16BIT_TABLES,
JTRC_ADOBE, JTRC_ADOBE,
JTRC_APP0, JTRC_APP0,
JTRC_APP14, JTRC_APP14,
JTRC_DAC, JTRC_DAC,
JTRC_DHT, JTRC_DHT,
JTRC_DQT, JTRC_DQT,
JTRC_DRI, JTRC_DRI,
JTRC_EMS_CLOSE, JTRC_EMS_CLOSE,
JTRC_EMS_OPEN, JTRC_EMS_OPEN,
JTRC_EOI, JTRC_EOI,
JTRC_HUFFBITS, JTRC_HUFFBITS,
JTRC_JFIF, JTRC_JFIF,
JTRC_JFIF_BADTHUMBNAILSIZE, JTRC_JFIF_BADTHUMBNAILSIZE,
JTRC_JFIF_EXTENSION, JTRC_JFIF_EXTENSION,
JTRC_JFIF_THUMBNAIL, JTRC_JFIF_THUMBNAIL,
JTRC_MISC_MARKER, JTRC_MISC_MARKER,
JTRC_PARMLESS_MARKER, JTRC_PARMLESS_MARKER,
JTRC_QUANTVALS, JTRC_QUANTVALS,
JTRC_QUANT_3_NCOLORS, JTRC_QUANT_3_NCOLORS,
JTRC_QUANT_NCOLORS, JTRC_QUANT_NCOLORS,
JTRC_QUANT_SELECTED, JTRC_QUANT_SELECTED,
JTRC_RECOVERY_ACTION, JTRC_RECOVERY_ACTION,
JTRC_RST, JTRC_RST,
JTRC_SMOOTH_NOTIMPL, JTRC_SMOOTH_NOTIMPL,
JTRC_SOF, JTRC_SOF,
JTRC_SOF_COMPONENT, JTRC_SOF_COMPONENT,
JTRC_SOI, JTRC_SOI,
JTRC_SOS, JTRC_SOS,
JTRC_SOS_COMPONENT, JTRC_SOS_COMPONENT,
JTRC_SOS_PARAMS, JTRC_SOS_PARAMS,
JTRC_TFILE_CLOSE, JTRC_TFILE_CLOSE,
JTRC_TFILE_OPEN, JTRC_TFILE_OPEN,
JTRC_THUMB_JPEG, JTRC_THUMB_JPEG,
JTRC_THUMB_PALETTE, JTRC_THUMB_PALETTE,
JTRC_THUMB_RGB, JTRC_THUMB_RGB,
JTRC_UNKNOWN_IDS, JTRC_UNKNOWN_IDS,
JTRC_XMS_CLOSE, JTRC_XMS_CLOSE,
JTRC_XMS_OPEN, JTRC_XMS_OPEN,
JWRN_ADOBE_XFORM, JWRN_ADOBE_XFORM,
JWRN_BOGUS_PROGRESSION, JWRN_BOGUS_PROGRESSION,
JWRN_EXTRANEOUS_DATA, JWRN_EXTRANEOUS_DATA,
JWRN_HIT_MARKER, JWRN_HIT_MARKER,
JWRN_HUFF_BAD_CODE, JWRN_HUFF_BAD_CODE,
JWRN_JFIF_MAJOR, JWRN_JFIF_MAJOR,
JWRN_JPEG_EOF, JWRN_JPEG_EOF,
JWRN_MUST_RESYNC, JWRN_MUST_RESYNC,
JWRN_NOT_SEQUENTIAL, JWRN_NOT_SEQUENTIAL,
JWRN_TOO_MUCH_DATA, JWRN_TOO_MUCH_DATA,
JMSG_FIRSTADDONCODE, { Must be first entry! } JMSG_FIRSTADDONCODE, { Must be first entry! }
{$ifdef BMP_SUPPORTED} {$ifdef BMP_SUPPORTED}
JERR_BMP_BADCMAP, { Unsupported BMP colormap format } JERR_BMP_BADCMAP, { Unsupported BMP colormap format }
JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported } JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported }
JERR_BMP_BADHEADER, { Invalid BMP file: bad header length } JERR_BMP_BADHEADER, { Invalid BMP file: bad header length }
JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 } JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 }
JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB } JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB }
JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported } JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported }
JERR_BMP_NOT, { Not a BMP file - does not start with BM } JERR_BMP_NOT, { Not a BMP file - does not start with BM }
JTRC_BMP, { %dx%d 24-bit BMP image } JTRC_BMP, { %dx%d 24-bit BMP image }
JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped 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, { %dx%d 24-bit OS2 BMP image }
JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image } JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image }
{$endif} { BMP_SUPPORTED } {$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED} {$ifdef GIF_SUPPORTED}
JERR_GIF_BUG, { GIF output got confused } JERR_GIF_BUG, { GIF output got confused }
JERR_GIF_CODESIZE, { Bogus GIF codesize %d } JERR_GIF_CODESIZE, { Bogus GIF codesize %d }
JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB } JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB }
JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file } JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file }
JERR_GIF_NOT, { Not a GIF file } JERR_GIF_NOT, { Not a GIF file }
JTRC_GIF, { %dx%dx%d GIF image } JTRC_GIF, { %dx%dx%d GIF image }
JTRC_GIF_BADVERSION, JTRC_GIF_BADVERSION,
{ Warning: unexpected GIF version number '%c%c%c' } { Warning: unexpected GIF version number '%c%c%c' }
JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x } JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x }
JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input } JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input }
JWRN_GIF_BADDATA, { Corrupt data in GIF file } JWRN_GIF_BADDATA, { Corrupt data in GIF file }
JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring } JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring }
JWRN_GIF_ENDCODE, { Premature end of GIF image } JWRN_GIF_ENDCODE, { Premature end of GIF image }
JWRN_GIF_NOMOREDATA, { Ran out of GIF bits } JWRN_GIF_NOMOREDATA, { Ran out of GIF bits }
{$endif} { GIF_SUPPORTED } {$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED} {$ifdef PPM_SUPPORTED}
JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB } JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB }
JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file } JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file }
JERR_PPM_NOT, { Not a PPM file } JERR_PPM_NOT, { Not a PPM file }
JTRC_PGM, { %dx%d PGM image } JTRC_PGM, { %dx%d PGM image }
JTRC_PGM_TEXT, { %dx%d text PGM image } JTRC_PGM_TEXT, { %dx%d text PGM image }
JTRC_PPM, { %dx%d PPM image } JTRC_PPM, { %dx%d PPM image }
JTRC_PPM_TEXT, { %dx%d text PPM image } JTRC_PPM_TEXT, { %dx%d text PPM image }
{$endif} { PPM_SUPPORTED } {$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED} {$ifdef RLE_SUPPORTED}
JERR_RLE_BADERROR, { Bogus error code from RLE library } JERR_RLE_BADERROR, { Bogus error code from RLE library }
JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB } JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB }
JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE } JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE }
JERR_RLE_EMPTY, { Empty RLE file } JERR_RLE_EMPTY, { Empty RLE file }
JERR_RLE_EOF, { Premature EOF in RLE header } JERR_RLE_EOF, { Premature EOF in RLE header }
JERR_RLE_MEM, { Insufficient memory for RLE header } JERR_RLE_MEM, { Insufficient memory for RLE header }
JERR_RLE_NOT, { Not an RLE file } JERR_RLE_NOT, { Not an RLE file }
JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE } JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE }
JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup } JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup }
JTRC_RLE, { %dx%d full-color RLE file } JTRC_RLE, { %dx%d full-color RLE file }
JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d } JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d }
JTRC_RLE_GRAY, { %dx%d grayscale RLE file } JTRC_RLE_GRAY, { %dx%d grayscale RLE file }
JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d } 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 } JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d }
{$endif} { RLE_SUPPORTED } {$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED} {$ifdef TARGA_SUPPORTED}
JERR_TGA_BADCMAP, { Unsupported Targa colormap format } JERR_TGA_BADCMAP, { Unsupported Targa colormap format }
JERR_TGA_BADPARMS, { Invalid or unsupported Targa file } JERR_TGA_BADPARMS, { Invalid or unsupported Targa file }
JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB } JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB }
JTRC_TGA, { %dx%d RGB Targa image } JTRC_TGA, { %dx%d RGB Targa image }
JTRC_TGA_GRAY, { %dx%d grayscale Targa image } JTRC_TGA_GRAY, { %dx%d grayscale Targa image }
JTRC_TGA_MAPPED, { %dx%d colormapped Targa image } JTRC_TGA_MAPPED, { %dx%d colormapped Targa image }
{$else} {$else}
JERR_TGA_NOTCOMP, { Targa support was not compiled } JERR_TGA_NOTCOMP, { Targa support was not compiled }
{$endif} { TARGA_SUPPORTED } {$endif} { TARGA_SUPPORTED }
JERR_BAD_CMAP_FILE, JERR_BAD_CMAP_FILE,
{ Color map file is invalid or of unsupported format } { Color map file is invalid or of unsupported format }
JERR_TOO_MANY_COLORS, JERR_TOO_MANY_COLORS,
{ Output file format cannot handle %d colormap entries } { Output file format cannot handle %d colormap entries }
JERR_UNGETC_FAILED, { ungetc failed } JERR_UNGETC_FAILED, { ungetc failed }
{$ifdef TARGA_SUPPORTED} {$ifdef TARGA_SUPPORTED}
JERR_UNKNOWN_FORMAT, JERR_UNKNOWN_FORMAT,
{ Unrecognized input file format --- perhaps you need -targa } { Unrecognized input file format --- perhaps you need -targa }
{$else} {$else}
JERR_UNKNOWN_FORMAT, { Unrecognized input file format } JERR_UNKNOWN_FORMAT, { Unrecognized input file format }
{$endif} {$endif}
JERR_UNSUPPORTED_FORMAT, { Unsupported output file format } JERR_UNSUPPORTED_FORMAT, { Unsupported output file format }
JMSG_LASTADDONCODE JMSG_LASTADDONCODE
); );
const const
JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE; JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE;
type type
msg_table = Array[J_MESSAGE_CODE] of string[80]; msg_table = Array[J_MESSAGE_CODE] of string[80];
const const
jpeg_std_message_table : msg_table = ( jpeg_std_message_table : msg_table = (
{ JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! } { JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! }
{ For maintenance convenience, list is alphabetical by message code name } { For maintenance convenience, list is alphabetical by message code name }
{ JERR_ARITH_NOTIMPL } { JERR_ARITH_NOTIMPL }
'Sorry, there are legal restrictions on arithmetic coding', 'Sorry, there are legal restrictions on arithmetic coding',
{ JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix', { JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix',
{ JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK 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_BUFFER_MODE } 'Bogus buffer control mode',
{ JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS', { JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS',
{ JERR_BAD_DCT_COEF } 'DCT coefficient out of range', { JERR_BAD_DCT_COEF } 'DCT coefficient out of range',
{ JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported', { JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported',
{ JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition', { JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition',
{ JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace', { JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace',
{ JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace', { JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace',
{ JERR_BAD_LENGTH } 'Bogus marker length', { JERR_BAD_LENGTH } 'Bogus marker length',
{ JERR_BAD_LIB_VERSION } { JERR_BAD_LIB_VERSION }
'Wrong JPEG library version: library is %d, caller expects %d', 'Wrong JPEG library version: library is %d, caller expects %d',
{ JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan', { JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan',
{ JERR_BAD_POOL_ID } 'Invalid memory pool code %d', { JERR_BAD_POOL_ID } 'Invalid memory pool code %d',
{ JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d', { JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d',
{ JERR_BAD_PROGRESSION } { JERR_BAD_PROGRESSION }
'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d', 'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d',
{ JERR_BAD_PROG_SCRIPT } { JERR_BAD_PROG_SCRIPT }
'Invalid progressive parameters at scan script entry %d', 'Invalid progressive parameters at scan script entry %d',
{ JERR_BAD_SAMPLING } 'Bogus sampling factors', { JERR_BAD_SAMPLING } 'Bogus sampling factors',
{ JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d', { JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d',
{ JERR_BAD_STATE } 'Improper call to JPEG library in state %d', { JERR_BAD_STATE } 'Improper call to JPEG library in state %d',
{ JERR_BAD_STRUCT_SIZE } { JERR_BAD_STRUCT_SIZE }
'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d', 'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d',
{ JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access', { JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access',
{ JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small', { JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small',
{ JERR_CANT_SUSPEND } 'Suspension not allowed here', { JERR_CANT_SUSPEND } 'Suspension not allowed here',
{ JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet', { JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet',
{ JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d', { JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d',
{ JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request', { JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request',
{ JERR_DAC_INDEX } 'Bogus DAC index %d', { JERR_DAC_INDEX } 'Bogus DAC index %d',
{ JERR_DAC_VALUE } 'Bogus DAC value $%x', { JERR_DAC_VALUE } 'Bogus DAC value $%x',
{ JERR_DHT_COUNTS } 'Bogus DHT counts', { JERR_DHT_COUNTS } 'Bogus DHT counts',
{ JERR_DHT_INDEX } 'Bogus DHT index %d', { JERR_DHT_INDEX } 'Bogus DHT index %d',
{ JERR_DQT_INDEX } 'Bogus DQT index %d', { JERR_DQT_INDEX } 'Bogus DQT index %d',
{ JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)', { JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)',
{ JERR_EMS_READ } 'Read from EMS failed', { JERR_EMS_READ } 'Read from EMS failed',
{ JERR_EMS_WRITE } 'Write to EMS failed', { JERR_EMS_WRITE } 'Write to EMS failed',
{ JERR_EOI_EXPECTED } 'Didn''t expect more than one scan', { JERR_EOI_EXPECTED } 'Didn''t expect more than one scan',
{ JERR_FILE_READ } 'Input file read error', { JERR_FILE_READ } 'Input file read error',
{ JERR_FILE_WRITE } 'Output file write error --- out of disk space?', { JERR_FILE_WRITE } 'Output file write error --- out of disk space?',
{ JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet', { JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet',
{ JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow', { JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow',
{ JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry', { JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry',
{ JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels', { JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels',
{ JERR_INPUT_EMPTY } 'Empty input file', { JERR_INPUT_EMPTY } 'Empty input file',
{ JERR_INPUT_EOF } 'Premature end of input file', { JERR_INPUT_EOF } 'Premature end of input file',
{ JERR_MISMATCHED_QUANT_TABLE } { JERR_MISMATCHED_QUANT_TABLE }
'Cannot transcode due to multiple use of quantization table %d', 'Cannot transcode due to multiple use of quantization table %d',
{ JERR_MISSING_DATA } 'Scan script does not transmit all data', { JERR_MISSING_DATA } 'Scan script does not transmit all data',
{ JERR_MODE_CHANGE } 'Invalid color quantization mode change', { JERR_MODE_CHANGE } 'Invalid color quantization mode change',
{ JERR_NOTIMPL } 'Not implemented yet', { JERR_NOTIMPL } 'Not implemented yet',
{ JERR_NOT_COMPILED } 'Requested feature was omitted at compile time', { JERR_NOT_COMPILED } 'Requested feature was omitted at compile time',
{ JERR_NO_BACKING_STORE } 'Backing store not supported', { JERR_NO_BACKING_STORE } 'Backing store not supported',
{ JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined', { JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined',
{ JERR_NO_IMAGE } 'JPEG datastream contains no image', { JERR_NO_IMAGE } 'JPEG datastream contains no image',
{ JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined', { JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined',
{ JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x', { JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x',
{ JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)', { JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)',
{ JERR_QUANT_COMPONENTS } { JERR_QUANT_COMPONENTS }
'Cannot quantize more than %d color components', 'Cannot quantize more than %d color components',
{ JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors', { JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors',
{ JERR_QUANT_MANY_COLORS } 'Cannot quantize to more 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_DUPLICATE } 'Invalid JPEG file structure: two SOF markers',
{ JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker', { JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker',
{ JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x', { JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x',
{ JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers', { JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers',
{ JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF', { JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF',
{ JERR_TFILE_CREATE } 'Failed to create temporary file %s', { JERR_TFILE_CREATE } 'Failed to create temporary file %s',
{ JERR_TFILE_READ } 'Read failed on temporary file', { JERR_TFILE_READ } 'Read failed on temporary file',
{ JERR_TFILE_SEEK } 'Seek failed on temporary file', { JERR_TFILE_SEEK } 'Seek failed on temporary file',
{ JERR_TFILE_WRITE } { JERR_TFILE_WRITE }
'Write failed on temporary file --- out of disk space?', 'Write failed on temporary file --- out of disk space?',
{ JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines', { JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines',
{ JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x', { JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x',
{ JERR_VIRTUAL_BUG } 'Virtual array controller messed up', { JERR_VIRTUAL_BUG } 'Virtual array controller messed up',
{ JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation', { JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation',
{ JERR_XMS_READ } 'Read from XMS failed', { JERR_XMS_READ } 'Read from XMS failed',
{ JERR_XMS_WRITE } 'Write to XMS failed', { JERR_XMS_WRITE } 'Write to XMS failed',
{ JMSG_COPYRIGHT } JCOPYRIGHT, { JMSG_COPYRIGHT } JCOPYRIGHT,
{ JMSG_VERSION } JVERSION, { JMSG_VERSION } JVERSION,
{ JTRC_16BIT_TABLES } { JTRC_16BIT_TABLES }
'Caution: quantization tables are too coarse for baseline JPEG', 'Caution: quantization tables are too coarse for baseline JPEG',
{ JTRC_ADOBE } { JTRC_ADOBE }
'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d', 'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d',
{ JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d', { JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d',
{ JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d', { JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d',
{ JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x', { JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x',
{ JTRC_DHT } 'Define Huffman Table $%02x', { JTRC_DHT } 'Define Huffman Table $%02x',
{ JTRC_DQT } 'Define Quantization Table %d precision %d', { JTRC_DQT } 'Define Quantization Table %d precision %d',
{ JTRC_DRI } 'Define Restart Interval %d', { JTRC_DRI } 'Define Restart Interval %d',
{ JTRC_EMS_CLOSE } 'Freed EMS handle %d', { JTRC_EMS_CLOSE } 'Freed EMS handle %d',
{ JTRC_EMS_OPEN } 'Obtained EMS handle %d', { JTRC_EMS_OPEN } 'Obtained EMS handle %d',
{ JTRC_EOI } 'End Of Image', { JTRC_EOI } 'End Of Image',
{ JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d', { JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d',
{ JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d', { JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d',
{ JTRC_JFIF_BADTHUMBNAILSIZE } { JTRC_JFIF_BADTHUMBNAILSIZE }
'Warning: thumbnail image size does not match data length %d', 'Warning: thumbnail image size does not match data length %d',
{ JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u', { JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u',
{ JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image', { JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image',
{ JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d', { JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d',
{ JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x', { JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x',
{ JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d', { JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d',
{ JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors', { JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors',
{ JTRC_QUANT_NCOLORS } 'Quantizing to %d colors', { JTRC_QUANT_NCOLORS } 'Quantizing to %d colors',
{ JTRC_QUANT_SELECTED } 'Selected %d colors for quantization', { JTRC_QUANT_SELECTED } 'Selected %d colors for quantization',
{ JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d', { JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d',
{ JTRC_RST } 'RST%d', { JTRC_RST } 'RST%d',
{ JTRC_SMOOTH_NOTIMPL } { JTRC_SMOOTH_NOTIMPL }
'Smoothing not supported with nonstandard sampling ratios', 'Smoothing not supported with nonstandard sampling ratios',
{ JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d', { JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d',
{ JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d', { JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d',
{ JTRC_SOI } 'Start of Image', { JTRC_SOI } 'Start of Image',
{ JTRC_SOS } 'Start Of Scan: %d components', { JTRC_SOS } 'Start Of Scan: %d components',
{ JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d', { JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d',
{ JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d', { JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d',
{ JTRC_TFILE_CLOSE } 'Closed temporary file %s', { JTRC_TFILE_CLOSE } 'Closed temporary file %s',
{ JTRC_TFILE_OPEN } 'Opened temporary file %s', { JTRC_TFILE_OPEN } 'Opened temporary file %s',
{ JTRC_THUMB_JPEG } { JTRC_THUMB_JPEG }
'JFIF extension marker: JPEG-compressed thumbnail image, length %u', 'JFIF extension marker: JPEG-compressed thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_PALETTE } { JMESSAGE(JTRC_THUMB_PALETTE }
'JFIF extension marker: palette thumbnail image, length %u', 'JFIF extension marker: palette thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_RGB } { JMESSAGE(JTRC_THUMB_RGB }
'JFIF extension marker: RGB thumbnail image, length %u', 'JFIF extension marker: RGB thumbnail image, length %u',
{ JTRC_UNKNOWN_IDS } { JTRC_UNKNOWN_IDS }
'Unrecognized component IDs %d %d %d, assuming YCbCr', 'Unrecognized component IDs %d %d %d, assuming YCbCr',
{ JTRC_XMS_CLOSE } 'Freed XMS handle %d', { JTRC_XMS_CLOSE } 'Freed XMS handle %d',
{ JTRC_XMS_OPEN } 'Obtained XMS handle %d', { JTRC_XMS_OPEN } 'Obtained XMS handle %d',
{ JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d', { JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d',
{ JWRN_BOGUS_PROGRESSION } { JWRN_BOGUS_PROGRESSION }
'Inconsistent progression sequence for component %d coefficient %d', 'Inconsistent progression sequence for component %d coefficient %d',
{ JWRN_EXTRANEOUS_DATA } { JWRN_EXTRANEOUS_DATA }
'Corrupt JPEG data: %d extraneous bytes before marker $%02x', 'Corrupt JPEG data: %d extraneous bytes before marker $%02x',
{ JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment', { JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment',
{ JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code', { JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code',
{ JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d', { JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d',
{ JWRN_JPEG_EOF } 'Premature end of JPEG file', { JWRN_JPEG_EOF } 'Premature end of JPEG file',
{ JWRN_MUST_RESYNC } { JWRN_MUST_RESYNC }
'Corrupt JPEG data: found marker $%02x instead of RST%d', 'Corrupt JPEG data: found marker $%02x instead of RST%d',
{ JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG', { JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG',
{ JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines', { JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines',
{ JMSG_FIRSTADDONCODE } '', { Must be first entry! } { JMSG_FIRSTADDONCODE } '', { Must be first entry! }
{$ifdef BMP_SUPPORTED} {$ifdef BMP_SUPPORTED}
{ JERR_BMP_BADCMAP } 'Unsupported BMP colormap format', { JERR_BMP_BADCMAP } 'Unsupported BMP colormap format',
{ JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported', { JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported',
{ JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length', { JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length',
{ JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1', { JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1',
{ JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB', { JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB',
{ JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported', { JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported',
{ JERR_BMP_NOT } 'Not a BMP file - does not start with BM', { JERR_BMP_NOT } 'Not a BMP file - does not start with BM',
{ JTRC_BMP } '%dx%d 24-bit BMP image', { JTRC_BMP } '%dx%d 24-bit BMP image',
{ JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped 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 } '%dx%d 24-bit OS2 BMP image',
{ JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image', { JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image',
{$endif} { BMP_SUPPORTED } {$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED} {$ifdef GIF_SUPPORTED}
{ JERR_GIF_BUG } 'GIF output got confused', { JERR_GIF_BUG } 'GIF output got confused',
{ JERR_GIF_CODESIZE } 'Bogus GIF codesize %d', { JERR_GIF_CODESIZE } 'Bogus GIF codesize %d',
{ JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB', { JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB',
{ JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file', { JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file',
{ JERR_GIF_NOT } 'Not a GIF file', { JERR_GIF_NOT } 'Not a GIF file',
{ JTRC_GIF } '%dx%dx%d GIF image', { JTRC_GIF } '%dx%dx%d GIF image',
{ JTRC_GIF_BADVERSION } { JTRC_GIF_BADVERSION }
'Warning: unexpected GIF version number "%c%c%c"', 'Warning: unexpected GIF version number "%c%c%c"',
{ JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x', { JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x',
{ JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input', { JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input',
{ JWRN_GIF_BADDATA } 'Corrupt data in GIF file', { JWRN_GIF_BADDATA } 'Corrupt data in GIF file',
{ JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring', { JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring',
{ JWRN_GIF_ENDCODE } 'Premature end of GIF image', { JWRN_GIF_ENDCODE } 'Premature end of GIF image',
{ JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits', { JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits',
{$endif} { GIF_SUPPORTED } {$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED} {$ifdef PPM_SUPPORTED}
{ JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB', { JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB',
{ JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file', { JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file',
{ JERR_PPM_NOT } 'Not a PPM file', { JERR_PPM_NOT } 'Not a PPM file',
{ JTRC_PGM } '%dx%d PGM image', { JTRC_PGM } '%dx%d PGM image',
{ JTRC_PGM_TEXT } '%dx%d text PGM image', { JTRC_PGM_TEXT } '%dx%d text PGM image',
{ JTRC_PPM } '%dx%d PPM image', { JTRC_PPM } '%dx%d PPM image',
{ JTRC_PPM_TEXT } '%dx%d text PPM image', { JTRC_PPM_TEXT } '%dx%d text PPM image',
{$endif} { PPM_SUPPORTED } {$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED} {$ifdef RLE_SUPPORTED}
{ JERR_RLE_BADERROR } 'Bogus error code from RLE library', { JERR_RLE_BADERROR } 'Bogus error code from RLE library',
{ JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB', { JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB',
{ JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE', { JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE',
{ JERR_RLE_EMPTY } 'Empty RLE file', { JERR_RLE_EMPTY } 'Empty RLE file',
{ JERR_RLE_EOF } 'Premature EOF in RLE header', { JERR_RLE_EOF } 'Premature EOF in RLE header',
{ JERR_RLE_MEM } 'Insufficient memory for RLE header', { JERR_RLE_MEM } 'Insufficient memory for RLE header',
{ JERR_RLE_NOT } 'Not an RLE file', { JERR_RLE_NOT } 'Not an RLE file',
{ JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE', { JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE',
{ JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup', { JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup',
{ JTRC_RLE } '%dx%d full-color RLE file', { JTRC_RLE } '%dx%d full-color RLE file',
{ JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d', { JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d',
{ JTRC_RLE_GRAY } '%dx%d grayscale RLE file', { JTRC_RLE_GRAY } '%dx%d grayscale RLE file',
{ JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d', { 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', { JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d',
{$endif} { RLE_SUPPORTED } {$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED} {$ifdef TARGA_SUPPORTED}
{ JERR_TGA_BADCMAP } 'Unsupported Targa colormap format', { JERR_TGA_BADCMAP } 'Unsupported Targa colormap format',
{ JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file', { JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file',
{ JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB', { JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB',
{ JTRC_TGA } '%dx%d RGB Targa image', { JTRC_TGA } '%dx%d RGB Targa image',
{ JTRC_TGA_GRAY } '%dx%d grayscale Targa image', { JTRC_TGA_GRAY } '%dx%d grayscale Targa image',
{ JTRC_TGA_MAPPED } '%dx%d colormapped Targa image', { JTRC_TGA_MAPPED } '%dx%d colormapped Targa image',
{$else} {$else}
{ JERR_TGA_NOTCOMP } 'Targa support was not compiled', { JERR_TGA_NOTCOMP } 'Targa support was not compiled',
{$endif} { TARGA_SUPPORTED } {$endif} { TARGA_SUPPORTED }
{ JERR_BAD_CMAP_FILE } { JERR_BAD_CMAP_FILE }
'Color map file is invalid or of unsupported format', 'Color map file is invalid or of unsupported format',
{ JERR_TOO_MANY_COLORS } { JERR_TOO_MANY_COLORS }
'Output file format cannot handle %d colormap entries', 'Output file format cannot handle %d colormap entries',
{ JERR_UNGETC_FAILED } 'ungetc failed', { JERR_UNGETC_FAILED } 'ungetc failed',
{$ifdef TARGA_SUPPORTED} {$ifdef TARGA_SUPPORTED}
{ JERR_UNKNOWN_FORMAT } { JERR_UNKNOWN_FORMAT }
'Unrecognized input file format --- perhaps you need -targa', 'Unrecognized input file format --- perhaps you need -targa',
{$else} {$else}
{ JERR_UNKNOWN_FORMAT } 'Unrecognized input file format', { JERR_UNKNOWN_FORMAT } 'Unrecognized input file format',
{$endif} {$endif}
{ JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format', { JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format',
{ JMSG_LASTADDONCODE } ''); { JMSG_LASTADDONCODE } '');
implementation implementation
end. 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; unit imjdinput;
{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. } { Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software. { This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file. For conditions of distribution and use, see the accompanying README file.
This file contains input control logic for the JPEG decompressor. This file contains input control logic for the JPEG decompressor.
These routines are concerned with controlling the decompressor's input These routines are concerned with controlling the decompressor's input
processing (marker reading and coefficient decoding). The actual input processing (marker reading and coefficient decoding). The actual input
reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. } reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjpeglib, imjpeglib,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjinclude, imjutils; imjinclude, imjutils;
{ Initialize the input controller module. { Initialize the input controller module.
This is called only once, when the decompression object is created. } This is called only once, when the decompression object is created. }
{GLOBAL} {GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr); procedure jinit_input_controller (cinfo : j_decompress_ptr);
implementation implementation
{ Private state } { Private state }
type type
my_inputctl_ptr = ^my_input_controller; my_inputctl_ptr = ^my_input_controller;
my_input_controller = record my_input_controller = record
pub : jpeg_input_controller; { public fields } pub : jpeg_input_controller; { public fields }
inheaders : boolean; { TRUE until first SOS is reached } inheaders : boolean; { TRUE until first SOS is reached }
end; {my_input_controller;} end; {my_input_controller;}
{ Forward declarations } { Forward declarations }
{METHODDEF} {METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int; forward; function consume_markers (cinfo : j_decompress_ptr) : int; forward;
{ Routines to calculate various quantities related to the size of the image. } { Routines to calculate various quantities related to the size of the image. }
{LOCAL} {LOCAL}
procedure initial_setup (cinfo : j_decompress_ptr); procedure initial_setup (cinfo : j_decompress_ptr);
{ Called once, when first SOS marker is reached } { Called once, when first SOS marker is reached }
var var
ci : int; ci : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
begin begin
{ Make sure image isn't bigger than I can handle } { Make sure image isn't bigger than I can handle }
if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or
(long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then (long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION)); ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION));
{ For now, precision must match compiled-in value... } { For now, precision must match compiled-in value... }
if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision); ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision);
{ Check that number of components won't exceed internal array sizes } { Check that number of components won't exceed internal array sizes }
if (cinfo^.num_components > MAX_COMPONENTS) then if (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPONENTS); MAX_COMPONENTS);
{ Compute maximum sampling factors; check factor validity } { Compute maximum sampling factors; check factor validity }
cinfo^.max_h_samp_factor := 1; cinfo^.max_h_samp_factor := 1;
cinfo^.max_v_samp_factor := 1; cinfo^.max_v_samp_factor := 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or 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 (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING); ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING);
{cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor, {cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor,
compptr^.h_samp_factor); compptr^.h_samp_factor);
cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor, cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor,
compptr^.v_samp_factor);} compptr^.v_samp_factor);}
if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then
cinfo^.max_h_samp_factor := compptr^.h_samp_factor; cinfo^.max_h_samp_factor := compptr^.h_samp_factor;
if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then
cinfo^.max_v_samp_factor := compptr^.v_samp_factor; cinfo^.max_v_samp_factor := compptr^.v_samp_factor;
Inc(compptr); Inc(compptr);
end; end;
{ We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE. { We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE.
In the full decompressor, this will be overridden by jdmaster.c; 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. } but in the transcoder, jdmaster.c is not used, so we must do it here. }
cinfo^.min_DCT_scaled_size := DCTSIZE; cinfo^.min_DCT_scaled_size := DCTSIZE;
{ Compute dimensions of components } { Compute dimensions of components }
compptr := jpeg_component_info_ptr(cinfo^.comp_info); compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do for ci := 0 to pred(cinfo^.num_components) do
begin begin
compptr^.DCT_scaled_size := DCTSIZE; compptr^.DCT_scaled_size := DCTSIZE;
{ Size in DCT blocks } { Size in DCT blocks }
compptr^.width_in_blocks := JDIMENSION( compptr^.width_in_blocks := JDIMENSION(
jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor), jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor),
long(cinfo^.max_h_samp_factor * DCTSIZE)) ); long(cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.height_in_blocks := JDIMENSION ( compptr^.height_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor * DCTSIZE)) ); long (cinfo^.max_v_samp_factor * DCTSIZE)) );
{ downsampled_width and downsampled_height will also be overridden by { downsampled_width and downsampled_height will also be overridden by
jdmaster.c if we are doing full decompression. The transcoder library jdmaster.c if we are doing full decompression. The transcoder library
doesn't use these values, but the calling application might. } doesn't use these values, but the calling application might. }
{ Size in samples } { Size in samples }
compptr^.downsampled_width := JDIMENSION ( compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor), jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor),
long (cinfo^.max_h_samp_factor)) ); long (cinfo^.max_h_samp_factor)) );
compptr^.downsampled_height := JDIMENSION ( compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor)) ); long (cinfo^.max_v_samp_factor)) );
{ Mark component needed, until color conversion says otherwise } { Mark component needed, until color conversion says otherwise }
compptr^.component_needed := TRUE; compptr^.component_needed := TRUE;
{ Mark no quantization table yet saved for component } { Mark no quantization table yet saved for component }
compptr^.quant_table := NIL; compptr^.quant_table := NIL;
Inc(compptr); Inc(compptr);
end; end;
{ Compute number of fully interleaved MCU rows. } { Compute number of fully interleaved MCU rows. }
cinfo^.total_iMCU_rows := JDIMENSION( cinfo^.total_iMCU_rows := JDIMENSION(
jdiv_round_up(long(cinfo^.image_height), jdiv_round_up(long(cinfo^.image_height),
long(cinfo^.max_v_samp_factor*DCTSIZE)) ); long(cinfo^.max_v_samp_factor*DCTSIZE)) );
{ Decide whether file contains multiple scans } { Decide whether file contains multiple scans }
if (cinfo^.comps_in_scan < cinfo^.num_components) or if (cinfo^.comps_in_scan < cinfo^.num_components) or
(cinfo^.progressive_mode) then (cinfo^.progressive_mode) then
cinfo^.inputctl^.has_multiple_scans := TRUE cinfo^.inputctl^.has_multiple_scans := TRUE
else else
cinfo^.inputctl^.has_multiple_scans := FALSE; cinfo^.inputctl^.has_multiple_scans := FALSE;
end; end;
{LOCAL} {LOCAL}
procedure per_scan_setup (cinfo : j_decompress_ptr); procedure per_scan_setup (cinfo : j_decompress_ptr);
{ Do computations that are needed before processing a JPEG scan } { Do computations that are needed before processing a JPEG scan }
{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker } { cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker }
var var
ci, mcublks, tmp : int; ci, mcublks, tmp : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
begin begin
if (cinfo^.comps_in_scan = 1) then if (cinfo^.comps_in_scan = 1) then
begin begin
{ Noninterleaved (single-component) scan } { Noninterleaved (single-component) scan }
compptr := cinfo^.cur_comp_info[0]; compptr := cinfo^.cur_comp_info[0];
{ Overall image size in MCUs } { Overall image size in MCUs }
cinfo^.MCUs_per_row := compptr^.width_in_blocks; cinfo^.MCUs_per_row := compptr^.width_in_blocks;
cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks; cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks;
{ For noninterleaved scan, always one block per MCU } { For noninterleaved scan, always one block per MCU }
compptr^.MCU_width := 1; compptr^.MCU_width := 1;
compptr^.MCU_height := 1; compptr^.MCU_height := 1;
compptr^.MCU_blocks := 1; compptr^.MCU_blocks := 1;
compptr^.MCU_sample_width := compptr^.DCT_scaled_size; compptr^.MCU_sample_width := compptr^.DCT_scaled_size;
compptr^.last_col_width := 1; compptr^.last_col_width := 1;
{ For noninterleaved scans, it is convenient to define last_row_height { For noninterleaved scans, it is convenient to define last_row_height
as the number of block rows present in the last iMCU row. } as the number of block rows present in the last iMCU row. }
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor); tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor);
if (tmp = 0) then if (tmp = 0) then
tmp := compptr^.v_samp_factor; tmp := compptr^.v_samp_factor;
compptr^.last_row_height := tmp; compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition } { Prepare array describing MCU composition }
cinfo^.blocks_in_MCU := 1; cinfo^.blocks_in_MCU := 1;
cinfo^.MCU_membership[0] := 0; cinfo^.MCU_membership[0] := 0;
end end
else else
begin begin
{ Interleaved (multi-component) scan } { Interleaved (multi-component) scan }
if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then 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, ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan,
MAX_COMPS_IN_SCAN); MAX_COMPS_IN_SCAN);
{ Overall image size in MCUs } { Overall image size in MCUs }
cinfo^.MCUs_per_row := JDIMENSION ( cinfo^.MCUs_per_row := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width), jdiv_round_up(long (cinfo^.image_width),
long (cinfo^.max_h_samp_factor*DCTSIZE)) ); long (cinfo^.max_h_samp_factor*DCTSIZE)) );
cinfo^.MCU_rows_in_scan := JDIMENSION ( cinfo^.MCU_rows_in_scan := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height), jdiv_round_up(long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) ); long (cinfo^.max_v_samp_factor*DCTSIZE)) );
cinfo^.blocks_in_MCU := 0; cinfo^.blocks_in_MCU := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do for ci := 0 to pred(cinfo^.comps_in_scan) do
begin begin
compptr := cinfo^.cur_comp_info[ci]; compptr := cinfo^.cur_comp_info[ci];
{ Sampling factors give # of blocks of component in each MCU } { Sampling factors give # of blocks of component in each MCU }
compptr^.MCU_width := compptr^.h_samp_factor; compptr^.MCU_width := compptr^.h_samp_factor;
compptr^.MCU_height := compptr^.v_samp_factor; compptr^.MCU_height := compptr^.v_samp_factor;
compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height; compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height;
compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size; compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size;
{ Figure number of non-dummy blocks in last MCU column & row } { Figure number of non-dummy blocks in last MCU column & row }
tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width); tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width);
if (tmp = 0) then if (tmp = 0) then
tmp := compptr^.MCU_width; tmp := compptr^.MCU_width;
compptr^.last_col_width := tmp; compptr^.last_col_width := tmp;
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height); tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height);
if (tmp = 0) then if (tmp = 0) then
tmp := compptr^.MCU_height; tmp := compptr^.MCU_height;
compptr^.last_row_height := tmp; compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition } { Prepare array describing MCU composition }
mcublks := compptr^.MCU_blocks; mcublks := compptr^.MCU_blocks;
if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE);
while (mcublks > 0) do while (mcublks > 0) do
begin begin
Dec(mcublks); Dec(mcublks);
cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci; cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci;
Inc(cinfo^.blocks_in_MCU); Inc(cinfo^.blocks_in_MCU);
end; end;
end; end;
end; end;
end; end;
{ Save away a copy of the Q-table referenced by each component present { 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 the current scan, unless already saved during a prior scan.
In a multiple-scan JPEG file, the encoder could assign different components In a multiple-scan JPEG file, the encoder could assign different components
the same Q-table slot number, but change table definitions between scans 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 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 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 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. 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 We do this by copying the table at the start of the first scan containing
the component. the component.
The JPEG spec prohibits the encoder from changing the contents of a Q-table 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 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 anyway, this decoder will simply use the Q-table values that were current
at the start of the first scan for the component. at the start of the first scan for the component.
The decompressor output side looks only at the saved quant tables, The decompressor output side looks only at the saved quant tables,
not at the current Q-table slots. } not at the current Q-table slots. }
{LOCAL} {LOCAL}
procedure latch_quant_tables (cinfo : j_decompress_ptr); procedure latch_quant_tables (cinfo : j_decompress_ptr);
var var
ci, qtblno : int; ci, qtblno : int;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
qtbl : JQUANT_TBL_PTR; qtbl : JQUANT_TBL_PTR;
begin begin
for ci := 0 to pred(cinfo^.comps_in_scan) do for ci := 0 to pred(cinfo^.comps_in_scan) do
begin begin
compptr := cinfo^.cur_comp_info[ci]; compptr := cinfo^.cur_comp_info[ci];
{ No work if we already saved Q-table for this component } { No work if we already saved Q-table for this component }
if (compptr^.quant_table <> NIL) then if (compptr^.quant_table <> NIL) then
continue; continue;
{ Make sure specified quantization table is present } { Make sure specified quantization table is present }
qtblno := compptr^.quant_tbl_no; qtblno := compptr^.quant_tbl_no;
if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or
(cinfo^.quant_tbl_ptrs[qtblno] = NIL) then (cinfo^.quant_tbl_ptrs[qtblno] = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno); ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno);
{ OK, save away the quantization table } { OK, save away the quantization table }
qtbl := JQUANT_TBL_PTR( qtbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(JQUANT_TBL)) ); SIZEOF(JQUANT_TBL)) );
MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL)); MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL));
compptr^.quant_table := qtbl; compptr^.quant_table := qtbl;
end; end;
end; end;
{ Initialize the input modules to read a scan of compressed data. { Initialize the input modules to read a scan of compressed data.
The first call to this is done by jdmaster.c after initializing The first call to this is done by jdmaster.c after initializing
the entire decompressor (during jpeg_start_decompress). the entire decompressor (during jpeg_start_decompress).
Subsequent calls come from consume_markers, below. } Subsequent calls come from consume_markers, below. }
{METHODDEF} {METHODDEF}
procedure start_input_pass (cinfo : j_decompress_ptr); procedure start_input_pass (cinfo : j_decompress_ptr);
begin begin
per_scan_setup(cinfo); per_scan_setup(cinfo);
latch_quant_tables(cinfo); latch_quant_tables(cinfo);
cinfo^.entropy^.start_pass (cinfo); cinfo^.entropy^.start_pass (cinfo);
cinfo^.coef^.start_input_pass (cinfo); cinfo^.coef^.start_input_pass (cinfo);
cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data; cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data;
end; end;
{ Finish up after inputting a compressed-data scan. { Finish up after inputting a compressed-data scan.
This is called by the coefficient controller after it's read all This is called by the coefficient controller after it's read all
the expected data of the scan. } the expected data of the scan. }
{METHODDEF} {METHODDEF}
procedure finish_input_pass (cinfo : j_decompress_ptr); procedure finish_input_pass (cinfo : j_decompress_ptr);
begin begin
cinfo^.inputctl^.consume_input := consume_markers; cinfo^.inputctl^.consume_input := consume_markers;
end; end;
{ Read JPEG markers before, between, or after compressed-data scans. { Read JPEG markers before, between, or after compressed-data scans.
Change state as necessary when a new scan is reached. Change state as necessary when a new scan is reached.
Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI.
The consume_input method pointer points either here or to the The consume_input method pointer points either here or to the
coefficient controller's consume_data routine, depending on whether coefficient controller's consume_data routine, depending on whether
we are reading a compressed data segment or inter-segment markers. } we are reading a compressed data segment or inter-segment markers. }
{METHODDEF} {METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int; function consume_markers (cinfo : j_decompress_ptr) : int;
var var
val : int; val : int;
inputctl : my_inputctl_ptr; inputctl : my_inputctl_ptr;
begin begin
inputctl := my_inputctl_ptr (cinfo^.inputctl); inputctl := my_inputctl_ptr (cinfo^.inputctl);
if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further } if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further }
begin begin
consume_markers := JPEG_REACHED_EOI; consume_markers := JPEG_REACHED_EOI;
exit; exit;
end; end;
val := cinfo^.marker^.read_markers (cinfo); val := cinfo^.marker^.read_markers (cinfo);
case (val) of case (val) of
JPEG_REACHED_SOS: { Found SOS } JPEG_REACHED_SOS: { Found SOS }
begin begin
if (inputctl^.inheaders) then if (inputctl^.inheaders) then
begin { 1st SOS } begin { 1st SOS }
initial_setup(cinfo); initial_setup(cinfo);
inputctl^.inheaders := FALSE; inputctl^.inheaders := FALSE;
{ Note: start_input_pass must be called by jdmaster.c { Note: start_input_pass must be called by jdmaster.c
before any more input can be consumed. jdapimin.c is before any more input can be consumed. jdapimin.c is
responsible for enforcing this sequencing. } responsible for enforcing this sequencing. }
end end
else else
begin { 2nd or later SOS marker } begin { 2nd or later SOS marker }
if (not inputctl^.pub.has_multiple_scans) then if (not inputctl^.pub.has_multiple_scans) then
ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! } ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! }
start_input_pass(cinfo); start_input_pass(cinfo);
end; end;
end; end;
JPEG_REACHED_EOI: { Found EOI } JPEG_REACHED_EOI: { Found EOI }
begin begin
inputctl^.pub.eoi_reached := TRUE; inputctl^.pub.eoi_reached := TRUE;
if (inputctl^.inheaders) then if (inputctl^.inheaders) then
begin { Tables-only datastream, apparently } begin { Tables-only datastream, apparently }
if (cinfo^.marker^.saw_SOF) then if (cinfo^.marker^.saw_SOF) then
ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS); ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS);
end end
else else
begin begin
{ Prevent infinite loop in coef ctlr's decompress_data routine { Prevent infinite loop in coef ctlr's decompress_data routine
if user set output_scan_number larger than number of scans. } if user set output_scan_number larger than number of scans. }
if (cinfo^.output_scan_number > cinfo^.input_scan_number) then if (cinfo^.output_scan_number > cinfo^.input_scan_number) then
cinfo^.output_scan_number := cinfo^.input_scan_number; cinfo^.output_scan_number := cinfo^.input_scan_number;
end; end;
end; end;
JPEG_SUSPENDED:; JPEG_SUSPENDED:;
end; end;
consume_markers := val; consume_markers := val;
end; end;
{ Reset state to begin a fresh datastream. } { Reset state to begin a fresh datastream. }
{METHODDEF} {METHODDEF}
procedure reset_input_controller (cinfo : j_decompress_ptr); procedure reset_input_controller (cinfo : j_decompress_ptr);
var var
inputctl : my_inputctl_ptr; inputctl : my_inputctl_ptr;
begin begin
inputctl := my_inputctl_ptr (cinfo^.inputctl); inputctl := my_inputctl_ptr (cinfo^.inputctl);
inputctl^.pub.consume_input := consume_markers; inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE; inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE; inputctl^.inheaders := TRUE;
{ Reset other modules } { Reset other modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.marker^.reset_marker_reader (cinfo); cinfo^.marker^.reset_marker_reader (cinfo);
{ Reset progression state -- would be cleaner if entropy decoder did this } { Reset progression state -- would be cleaner if entropy decoder did this }
cinfo^.coef_bits := NIL; cinfo^.coef_bits := NIL;
end; end;
{ Initialize the input controller module. { Initialize the input controller module.
This is called only once, when the decompression object is created. } This is called only once, when the decompression object is created. }
{GLOBAL} {GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr); procedure jinit_input_controller (cinfo : j_decompress_ptr);
var var
inputctl : my_inputctl_ptr; inputctl : my_inputctl_ptr;
begin begin
{ Create subobject in permanent pool } { Create subobject in permanent pool }
inputctl := my_inputctl_ptr( inputctl := my_inputctl_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
SIZEOF(my_input_controller)) ); SIZEOF(my_input_controller)) );
cinfo^.inputctl := jpeg_input_controller_ptr(inputctl); cinfo^.inputctl := jpeg_input_controller_ptr(inputctl);
{ Initialize method pointers } { Initialize method pointers }
inputctl^.pub.consume_input := consume_markers; inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.reset_input_controller := reset_input_controller; inputctl^.pub.reset_input_controller := reset_input_controller;
inputctl^.pub.start_input_pass := start_input_pass; inputctl^.pub.start_input_pass := start_input_pass;
inputctl^.pub.finish_input_pass := finish_input_pass; inputctl^.pub.finish_input_pass := finish_input_pass;
{ Initialize state: can't use reset_input_controller since we don't { Initialize state: can't use reset_input_controller since we don't
want to try to reset other modules yet. } want to try to reset other modules yet. }
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE; inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE; inputctl^.inheaders := TRUE;
end; end;
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; unit imjdpostct;
{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the decompression postprocessing controller. { This file contains the decompression postprocessing controller.
This controller manages the upsampling, color conversion, and color This controller manages the upsampling, color conversion, and color
quantization/reduction steps; specifically, it controls the buffering quantization/reduction steps; specifically, it controls the buffering
between upsample/color conversion and color quantization/reduction. between upsample/color conversion and color quantization/reduction.
If no color quantization/reduction is required, then this module has no 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. work to do, and it just hands off to the upsample/color conversion code.
An integrated upsample/convert/quantize process would replace this module An integrated upsample/convert/quantize process would replace this module
entirely. } entirely. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjdeferr, imjdeferr,
imjerror, imjerror,
imjutils, imjutils,
imjpeglib; imjpeglib;
{ Initialize postprocessing controller. } { Initialize postprocessing controller. }
{GLOBAL} {GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr; procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
implementation implementation
{ Private buffer controller object } { Private buffer controller object }
type type
my_post_ptr = ^my_post_controller; my_post_ptr = ^my_post_controller;
my_post_controller = record my_post_controller = record
pub : jpeg_d_post_controller; { public fields } pub : jpeg_d_post_controller; { public fields }
{ Color quantization source buffer: this holds output data from { Color quantization source buffer: this holds output data from
the upsample/color conversion step to be passed to the quantizer. the upsample/color conversion step to be passed to the quantizer.
For two-pass color quantization, we need a full-image buffer; For two-pass color quantization, we need a full-image buffer;
for one-pass operation, a strip buffer is sufficient. } for one-pass operation, a strip buffer is sufficient. }
whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass } whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass }
buffer : JSAMPARRAY; { strip buffer, or current strip of virtual } buffer : JSAMPARRAY; { strip buffer, or current strip of virtual }
strip_height : JDIMENSION; { buffer size in rows } strip_height : JDIMENSION; { buffer size in rows }
{ for two-pass mode only: } { for two-pass mode only: }
starting_row : JDIMENSION; { row # of first row in current strip } starting_row : JDIMENSION; { row # of first row in current strip }
next_row : JDIMENSION; { index of next row to fill/empty in strip } next_row : JDIMENSION; { index of next row to fill/empty in strip }
end; end;
{ Forward declarations } { Forward declarations }
{METHODDEF} {METHODDEF}
procedure post_process_1pass(cinfo : j_decompress_ptr; procedure post_process_1pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward; out_rows_avail : JDIMENSION); forward;
{$ifdef QUANT_2PASS_SUPPORTED} {$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF} {METHODDEF}
procedure post_process_prepass(cinfo : j_decompress_ptr; procedure post_process_prepass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward; out_rows_avail : JDIMENSION); forward;
{METHODDEF} {METHODDEF}
procedure post_process_2pass(cinfo : j_decompress_ptr; procedure post_process_2pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward; out_rows_avail : JDIMENSION); forward;
{$endif} {$endif}
{ Initialize for a processing pass. } { Initialize for a processing pass. }
{METHODDEF} {METHODDEF}
procedure start_pass_dpost (cinfo : j_decompress_ptr; procedure start_pass_dpost (cinfo : j_decompress_ptr;
pass_mode : J_BUF_MODE); pass_mode : J_BUF_MODE);
var var
post : my_post_ptr; post : my_post_ptr;
begin begin
post := my_post_ptr(cinfo^.post); post := my_post_ptr(cinfo^.post);
case (pass_mode) of case (pass_mode) of
JBUF_PASS_THRU: JBUF_PASS_THRU:
if (cinfo^.quantize_colors) then if (cinfo^.quantize_colors) then
begin begin
{ Single-pass processing with color quantization. } { Single-pass processing with color quantization. }
post^.pub.post_process_data := post_process_1pass; post^.pub.post_process_data := post_process_1pass;
{ We could be doing buffered-image output before starting a 2-pass { We could be doing buffered-image output before starting a 2-pass
color quantization; in that case, jinit_d_post_controller did not color quantization; in that case, jinit_d_post_controller did not
allocate a strip buffer. Use the virtual-array buffer as workspace. } allocate a strip buffer. Use the virtual-array buffer as workspace. }
if (post^.buffer = NIL) then if (post^.buffer = NIL) then
begin begin
post^.buffer := cinfo^.mem^.access_virt_sarray post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image, (j_common_ptr(cinfo), post^.whole_image,
JDIMENSION(0), post^.strip_height, TRUE); JDIMENSION(0), post^.strip_height, TRUE);
end; end;
end end
else else
begin begin
{ For single-pass processing without color quantization, { For single-pass processing without color quantization,
I have no work to do; just call the upsampler directly. } I have no work to do; just call the upsampler directly. }
post^.pub.post_process_data := cinfo^.upsample^.upsample; post^.pub.post_process_data := cinfo^.upsample^.upsample;
end; end;
{$ifdef QUANT_2PASS_SUPPORTED} {$ifdef QUANT_2PASS_SUPPORTED}
JBUF_SAVE_AND_PASS: JBUF_SAVE_AND_PASS:
begin begin
{ First pass of 2-pass quantization } { First pass of 2-pass quantization }
if (post^.whole_image = NIL) then if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_prepass; post^.pub.post_process_data := post_process_prepass;
end; end;
JBUF_CRANK_DEST: JBUF_CRANK_DEST:
begin begin
{ Second pass of 2-pass quantization } { Second pass of 2-pass quantization }
if (post^.whole_image = NIL) then if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_2pass; post^.pub.post_process_data := post_process_2pass;
end; end;
{$endif} { QUANT_2PASS_SUPPORTED } {$endif} { QUANT_2PASS_SUPPORTED }
else else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end; end;
post^.next_row := 0; post^.next_row := 0;
post^.starting_row := 0; post^.starting_row := 0;
end; end;
{ Process some data in the one-pass (strip buffer) case. { Process some data in the one-pass (strip buffer) case.
This is used for color precision reduction as well as one-pass quantization. } This is used for color precision reduction as well as one-pass quantization. }
{METHODDEF} {METHODDEF}
procedure post_process_1pass (cinfo : j_decompress_ptr; procedure post_process_1pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); out_rows_avail : JDIMENSION);
var var
post : my_post_ptr; post : my_post_ptr;
num_rows, max_rows : JDIMENSION; num_rows, max_rows : JDIMENSION;
begin begin
post := my_post_ptr (cinfo^.post); post := my_post_ptr (cinfo^.post);
{ Fill the buffer, but not more than what we can dump out in one go. } { 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. } { Note we rely on the upsampler to detect bottom of image. }
max_rows := out_rows_avail - out_row_ctr; max_rows := out_rows_avail - out_row_ctr;
if (max_rows > post^.strip_height) then if (max_rows > post^.strip_height) then
max_rows := post^.strip_height; max_rows := post^.strip_height;
num_rows := 0; num_rows := 0;
cinfo^.upsample^.upsample (cinfo, cinfo^.upsample^.upsample (cinfo,
input_buf, input_buf,
in_row_group_ctr, in_row_group_ctr,
in_row_groups_avail, in_row_groups_avail,
post^.buffer, post^.buffer,
num_rows, { var } num_rows, { var }
max_rows); max_rows);
{ Quantize and emit data. } { Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo, cinfo^.cquantize^.color_quantize (cinfo,
post^.buffer, post^.buffer,
JSAMPARRAY(@ output_buf^[out_row_ctr]), JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows)); int(num_rows));
Inc(out_row_ctr, num_rows); Inc(out_row_ctr, num_rows);
end; end;
{$ifdef QUANT_2PASS_SUPPORTED} {$ifdef QUANT_2PASS_SUPPORTED}
{ Process some data in the first pass of 2-pass quantization. } { Process some data in the first pass of 2-pass quantization. }
{METHODDEF} {METHODDEF}
procedure post_process_prepass (cinfo : j_decompress_ptr; procedure post_process_prepass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail:JDIMENSION); out_rows_avail:JDIMENSION);
var var
post : my_post_ptr; post : my_post_ptr;
old_next_row, num_rows : JDIMENSION; old_next_row, num_rows : JDIMENSION;
begin begin
post := my_post_ptr(cinfo^.post); post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. } { Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then if (post^.next_row = 0) then
begin begin
post^.buffer := cinfo^.mem^.access_virt_sarray post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image, (j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, TRUE); post^.starting_row, post^.strip_height, TRUE);
end; end;
{ Upsample some data (up to a strip height's worth). } { Upsample some data (up to a strip height's worth). }
old_next_row := post^.next_row; old_next_row := post^.next_row;
cinfo^.upsample^.upsample (cinfo, cinfo^.upsample^.upsample (cinfo,
input_buf, in_row_group_ctr, in_row_groups_avail, input_buf, in_row_group_ctr, in_row_groups_avail,
post^.buffer, post^.next_row, post^.strip_height); post^.buffer, post^.next_row, post^.strip_height);
{ Allow quantizer to scan new data. No data is emitted, } { 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. } { but we advance out_row_ctr so outer loop can tell when we're done. }
if (post^.next_row > old_next_row) then if (post^.next_row > old_next_row) then
begin begin
num_rows := post^.next_row - old_next_row; num_rows := post^.next_row - old_next_row;
cinfo^.cquantize^.color_quantize (cinfo, cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[old_next_row]), JSAMPARRAY(@ post^.buffer^[old_next_row]),
JSAMPARRAY(NIL), JSAMPARRAY(NIL),
int(num_rows)); int(num_rows));
Inc(out_row_ctr, num_rows); Inc(out_row_ctr, num_rows);
end; end;
{ Advance if we filled the strip. } { Advance if we filled the strip. }
if (post^.next_row >= post^.strip_height) then if (post^.next_row >= post^.strip_height) then
begin begin
Inc(post^.starting_row, post^.strip_height); Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0; post^.next_row := 0;
end; end;
end; end;
{ Process some data in the second pass of 2-pass quantization. } { Process some data in the second pass of 2-pass quantization. }
{METHODDEF} {METHODDEF}
procedure post_process_2pass (cinfo : j_decompress_ptr; procedure post_process_2pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE; input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION; var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION; in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION; var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); out_rows_avail : JDIMENSION);
var var
post : my_post_ptr; post : my_post_ptr;
num_rows, max_rows : JDIMENSION; num_rows, max_rows : JDIMENSION;
begin begin
post := my_post_ptr(cinfo^.post); post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. } { Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then if (post^.next_row = 0) then
begin begin
post^.buffer := cinfo^.mem^.access_virt_sarray post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image, (j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, FALSE); post^.starting_row, post^.strip_height, FALSE);
end; end;
{ Determine number of rows to emit. } { Determine number of rows to emit. }
num_rows := post^.strip_height - post^.next_row; { available in strip } num_rows := post^.strip_height - post^.next_row; { available in strip }
max_rows := out_rows_avail - out_row_ctr; { available in output area } max_rows := out_rows_avail - out_row_ctr; { available in output area }
if (num_rows > max_rows) then if (num_rows > max_rows) then
num_rows := max_rows; num_rows := max_rows;
{ We have to check bottom of image here, can't depend on upsampler. } { We have to check bottom of image here, can't depend on upsampler. }
max_rows := cinfo^.output_height - post^.starting_row; max_rows := cinfo^.output_height - post^.starting_row;
if (num_rows > max_rows) then if (num_rows > max_rows) then
num_rows := max_rows; num_rows := max_rows;
{ Quantize and emit data. } { Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo, cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[post^.next_row]), JSAMPARRAY(@ post^.buffer^[post^.next_row]),
JSAMPARRAY(@ output_buf^[out_row_ctr]), JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows)); int(num_rows));
Inc(out_row_ctr, num_rows); Inc(out_row_ctr, num_rows);
{ Advance if we filled the strip. } { Advance if we filled the strip. }
Inc(post^.next_row, num_rows); Inc(post^.next_row, num_rows);
if (post^.next_row >= post^.strip_height) then if (post^.next_row >= post^.strip_height) then
begin begin
Inc(post^.starting_row, post^.strip_height); Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0; post^.next_row := 0;
end; end;
end; end;
{$endif} { QUANT_2PASS_SUPPORTED } {$endif} { QUANT_2PASS_SUPPORTED }
{ Initialize postprocessing controller. } { Initialize postprocessing controller. }
{GLOBAL} {GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr; procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean); need_full_buffer : boolean);
var var
post : my_post_ptr; post : my_post_ptr;
begin begin
post := my_post_ptr( post := my_post_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_post_controller)) ); SIZEOF(my_post_controller)) );
cinfo^.post := jpeg_d_post_controller_ptr (post); cinfo^.post := jpeg_d_post_controller_ptr (post);
post^.pub.start_pass := start_pass_dpost; post^.pub.start_pass := start_pass_dpost;
post^.whole_image := NIL; { flag for no virtual arrays } post^.whole_image := NIL; { flag for no virtual arrays }
post^.buffer := NIL; { flag for no strip buffer } post^.buffer := NIL; { flag for no strip buffer }
{ Create the quantization buffer, if needed } { Create the quantization buffer, if needed }
if (cinfo^.quantize_colors) then if (cinfo^.quantize_colors) then
begin begin
{ The buffer strip height is max_v_samp_factor, which is typically { The buffer strip height is max_v_samp_factor, which is typically
an efficient number of rows for upsampling to return. an efficient number of rows for upsampling to return.
(In the presence of output rescaling, we might want to be smarter?) } (In the presence of output rescaling, we might want to be smarter?) }
post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor); post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor);
if (need_full_buffer) then if (need_full_buffer) then
begin begin
{ Two-pass color quantization: need full-image storage. } { Two-pass color quantization: need full-image storage. }
{ We round up the number of rows to a multiple of the strip height. } { We round up the number of rows to a multiple of the strip height. }
{$ifdef QUANT_2PASS_SUPPORTED} {$ifdef QUANT_2PASS_SUPPORTED}
post^.whole_image := cinfo^.mem^.request_virt_sarray post^.whole_image := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components, LongInt(cinfo^.output_width) * cinfo^.out_color_components,
JDIMENSION (jround_up( long(cinfo^.output_height), JDIMENSION (jround_up( long(cinfo^.output_height),
long(post^.strip_height)) ), long(post^.strip_height)) ),
post^.strip_height); post^.strip_height);
{$else} {$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} { QUANT_2PASS_SUPPORTED } {$endif} { QUANT_2PASS_SUPPORTED }
end end
else else
begin begin
{ One-pass color quantization: just make a strip buffer. } { One-pass color quantization: just make a strip buffer. }
post^.buffer := cinfo^.mem^.alloc_sarray post^.buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr (cinfo), JPOOL_IMAGE, (j_common_ptr (cinfo), JPOOL_IMAGE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components, LongInt(cinfo^.output_width) * cinfo^.out_color_components,
post^.strip_height); post^.strip_height);
end; end;
end; end;
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; unit imjerror;
{ This file contains simple error-reporting and trace-message routines. { This file contains simple error-reporting and trace-message routines.
These are suitable for Unix-like systems and others where writing to 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 stderr is the right thing to do. Many applications will want to replace
some or all of these routines. some or all of these routines.
These routines are used by both the compression and decompression code. } These routines are used by both the compression and decompression code. }
{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. } { Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. }
{ note: format_message still contains a hack } { note: format_message still contains a hack }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjdeferr, imjdeferr,
imjpeglib; imjpeglib;
{ {
jversion; jversion;
} }
const const
EXIT_FAILURE = 1; { define halt() codes if not provided } EXIT_FAILURE = 1; { define halt() codes if not provided }
{GLOBAL} {GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); 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 ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int);
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int); p1 : int; p2 : int; p3 : int);
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int); p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string); str : string);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) } { Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int); p1 : int; p2 : int);
{ Informational/debugging messages } { Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long); code : J_MESSAGE_CODE; p1 : long);
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p1 : int;
p2 : int); p2 : int);
procedure TRACEMS3(cinfo : j_common_ptr; procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int; lvl : int;
code : J_MESSAGE_CODE; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int); p1 : int; p2 : int; p3 : int);
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int); p1 : int; p2 : int; p3 : int; p4 : int);
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int); p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string); code : J_MESSAGE_CODE; str : string);
implementation implementation
{ How to format a message string, in format_message() ? } { How to format a message string, in format_message() ? }
{$IFDEF OS2} {$IFDEF OS2}
{$DEFINE NO_FORMAT} {$DEFINE NO_FORMAT}
{$ENDIF} {$ENDIF}
{$IFDEF FPC} {$IFDEF FPC}
{$DEFINE NO_FORMAT} {$DEFINE NO_FORMAT}
{$ENDIF} {$ENDIF}
uses uses
{$IFNDEF NO_FORMAT} {$IFNDEF NO_FORMAT}
{$IFDEF VER70} {$IFDEF VER70}
drivers, { Turbo Vision unit with FormatStr } drivers, { Turbo Vision unit with FormatStr }
{$ELSE} {$ELSE}
sysutils, { Delphi Unit with Format() } sysutils, { Delphi Unit with Format() }
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
imjcomapi; imjcomapi;
{ Error exit handler: must not return to caller. { Error exit handler: must not return to caller.
Applications may override this if they want to get control back after Applications may override this if they want to get control back after
an error. Typically one would longjmp somewhere instead of exiting. an error. Typically one would longjmp somewhere instead of exiting.
The setjmp buffer can be made a private field within an expanded error 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 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 is stored in the error object, so you can generate the message now or
later, at your convenience. later, at your convenience.
You should make sure that the JPEG object is cleaned up (with jpeg_abort You should make sure that the JPEG object is cleaned up (with jpeg_abort
or jpeg_destroy) at some point. } or jpeg_destroy) at some point. }
{METHODDEF} {METHODDEF}
procedure error_exit (cinfo : j_common_ptr); procedure error_exit (cinfo : j_common_ptr);
begin begin
{ Always display the message } { Always display the message }
cinfo^.err^.output_message(cinfo); cinfo^.err^.output_message(cinfo);
{ Let the memory manager delete any temp files before we die } { Let the memory manager delete any temp files before we die }
jpeg_destroy(cinfo); jpeg_destroy(cinfo);
halt(EXIT_FAILURE); halt(EXIT_FAILURE);
end; end;
{ Actual output of an error or trace message. { Actual output of an error or trace message.
Applications may override this method to send JPEG messages somewhere Applications may override this method to send JPEG messages somewhere
other than stderr. } other than stderr. }
{ Macros to simplify using the error and trace message stuff } { Macros to simplify using the error and trace message stuff }
{ The first parameter is either type of cinfo pointer } { The first parameter is either type of cinfo pointer }
{ Fatal errors (print message and exit) } { Fatal errors (print message and exit) }
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.error_exit(cinfo); cinfo^.err^.error_exit(cinfo);
end; end;
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.error_exit (cinfo); cinfo^.err^.error_exit (cinfo);
end; end;
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int); p1 : int; p2 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2; cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.error_exit (cinfo); cinfo^.err^.error_exit (cinfo);
end; end;
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int); p1 : int; p2 : int; p3 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2; cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3; cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.error_exit (cinfo); cinfo^.err^.error_exit (cinfo);
end; end;
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int); p1 : int; p2 : int; p3 : int; p4 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2; cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3; cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.msg_parm.i[3] := p4; cinfo^.err^.msg_parm.i[3] := p4;
cinfo^.err^.error_exit (cinfo); cinfo^.err^.error_exit (cinfo);
end; end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string); str : string);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] } cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
cinfo^.err^.error_exit (cinfo); cinfo^.err^.error_exit (cinfo);
end; end;
{ Nonfatal errors (we can keep going, but the data is probably corrupt) } { Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, -1); cinfo^.err^.emit_message(cinfo, -1);
end; end;
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, -1); cinfo^.err^.emit_message (cinfo, -1);
end; end;
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int); p1 : int; p2 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2; cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, -1); cinfo^.err^.emit_message (cinfo, -1);
end; end;
{ Informational/debugging messages } { Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, lvl); cinfo^.err^.emit_message(cinfo, lvl);
end; end;
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long); code : J_MESSAGE_CODE; p1 : long);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p1 : int;
p2 : int); p2 : int);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1; cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2; cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMS3(cinfo : j_common_ptr; procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int; lvl : int;
code : J_MESSAGE_CODE; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int); p1 : int; p2 : int; p3 : int);
var var
_mp : int8array; _mp : int8array;
begin begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[0] := p1; _mp[1] := p2; _mp[2] := p3;
cinfo^.err^.msg_parm.i := _mp; cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int); p1 : int; p2 : int; p3 : int; p4 : int);
var var
_mp : int8array; _mp : int8array;
begin begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
cinfo^.err^.msg_parm.i := _mp; cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
var var
_mp : ^int8array; _mp : ^int8array;
begin begin
_mp := @cinfo^.err^.msg_parm.i; _mp := @cinfo^.err^.msg_parm.i;
_mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3; _mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3;
_mp^[3] := p4; _mp^[5] := p5; _mp^[3] := p4; _mp^[5] := p5;
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int); p5 : int; p6 : int; p7 : int; p8 : int);
var var
_mp : int8array; _mp : int8array;
begin begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
_mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8; _mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8;
cinfo^.err^.msg_parm.i := _mp; cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string); code : J_MESSAGE_CODE; str : string);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX } cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
cinfo^.err^.emit_message (cinfo, lvl); cinfo^.err^.emit_message (cinfo, lvl);
end; end;
{METHODDEF} {METHODDEF}
procedure output_message (cinfo : j_common_ptr); procedure output_message (cinfo : j_common_ptr);
var var
buffer : string; {[JMSG_LENGTH_MAX];} buffer : string; {[JMSG_LENGTH_MAX];}
begin begin
{ Create the message } { Create the message }
cinfo^.err^.format_message (cinfo, buffer); cinfo^.err^.format_message (cinfo, buffer);
{ Send it to stderr, adding a newline } { Send it to stderr, adding a newline }
WriteLn(output, buffer); WriteLn(output, buffer);
end; end;
{ Decide whether to emit a trace or warning message. { Decide whether to emit a trace or warning message.
msg_level is one of: msg_level is one of:
-1: recoverable corrupt-data warning, may want to abort. -1: recoverable corrupt-data warning, may want to abort.
0: important advisory messages (always display to user). 0: important advisory messages (always display to user).
1: first level of tracing detail. 1: first level of tracing detail.
2,3,...: successively more detailed tracing messages. 2,3,...: successively more detailed tracing messages.
An application might override this method if it wanted to abort on warnings An application might override this method if it wanted to abort on warnings
or change the policy about which messages to display. } or change the policy about which messages to display. }
{METHODDEF} {METHODDEF}
procedure emit_message (cinfo : j_common_ptr; msg_level : int); procedure emit_message (cinfo : j_common_ptr; msg_level : int);
var var
err : jpeg_error_mgr_ptr; err : jpeg_error_mgr_ptr;
begin begin
err := cinfo^.err; err := cinfo^.err;
if (msg_level < 0) then if (msg_level < 0) then
begin begin
{ It's a warning message. Since corrupt files may generate many warnings, { It's a warning message. Since corrupt files may generate many warnings,
the policy implemented here is to show only the first warning, the policy implemented here is to show only the first warning,
unless trace_level >= 3. } unless trace_level >= 3. }
if (err^.num_warnings = 0) or (err^.trace_level >= 3) then if (err^.num_warnings = 0) or (err^.trace_level >= 3) then
err^.output_message(cinfo); err^.output_message(cinfo);
{ Always count warnings in num_warnings. } { Always count warnings in num_warnings. }
Inc( err^.num_warnings ); Inc( err^.num_warnings );
end end
else else
begin begin
{ It's a trace message. Show it if trace_level >= msg_level. } { It's a trace message. Show it if trace_level >= msg_level. }
if (err^.trace_level >= msg_level) then if (err^.trace_level >= msg_level) then
err^.output_message (cinfo); err^.output_message (cinfo);
end; end;
end; end;
{ Format a message string for the most recent JPEG error or message. { 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 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. characters. Note that no '\n' character is added to the string.
Few applications should need to override this method. } Few applications should need to override this method. }
{METHODDEF} {METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string); procedure format_message (cinfo : j_common_ptr; var buffer : string);
var var
err : jpeg_error_mgr_ptr; err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE; msg_code : J_MESSAGE_CODE;
msgtext : string; msgtext : string;
isstring : boolean; isstring : boolean;
begin begin
err := cinfo^.err; err := cinfo^.err;
msg_code := J_MESSAGE_CODE(err^.msg_code); msg_code := J_MESSAGE_CODE(err^.msg_code);
msgtext := ''; msgtext := '';
{ Look up message string in proper table } { Look up message string in proper table }
if (msg_code > JMSG_NOMESSAGE) if (msg_code > JMSG_NOMESSAGE)
and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then
begin begin
msgtext := err^.jpeg_message_table^[msg_code]; msgtext := err^.jpeg_message_table^[msg_code];
end end
else else
if (err^.addon_message_table <> NIL) and if (err^.addon_message_table <> NIL) and
(msg_code >= err^.first_addon_message) and (msg_code >= err^.first_addon_message) and
(msg_code <= err^.last_addon_message) then (msg_code <= err^.last_addon_message) then
begin begin
msgtext := err^.addon_message_table^[J_MESSAGE_CODE msgtext := err^.addon_message_table^[J_MESSAGE_CODE
(ord(msg_code) - ord(err^.first_addon_message))]; (ord(msg_code) - ord(err^.first_addon_message))];
end; end;
{ Defend against bogus message number } { Defend against bogus message number }
if (msgtext = '') then if (msgtext = '') then
begin begin
err^.msg_parm.i[0] := int(msg_code); err^.msg_parm.i[0] := int(msg_code);
msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE]; msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE];
end; end;
{ Check for string parameter, as indicated by %s in the message text } { Check for string parameter, as indicated by %s in the message text }
isstring := Pos('%s', msgtext) > 0; isstring := Pos('%s', msgtext) > 0;
{ Format the message into the passed buffer } { Format the message into the passed buffer }
if (isstring) then if (isstring) then
buffer := Concat(msgtext, err^.msg_parm.s) buffer := Concat(msgtext, err^.msg_parm.s)
else else
begin begin
{$IFDEF VER70} {$IFDEF VER70}
FormatStr(buffer, msgtext, err^.msg_parm.i); FormatStr(buffer, msgtext, err^.msg_parm.i);
{$ELSE} {$ELSE}
{$IFDEF NO_FORMAT} {$IFDEF NO_FORMAT}
buffer := msgtext; buffer := msgtext;
{$ELSE} {$ELSE}
buffer := Format(msgtext, [ buffer := Format(msgtext, [
err^.msg_parm.i[0], err^.msg_parm.i[1], err^.msg_parm.i[0], err^.msg_parm.i[1],
err^.msg_parm.i[2], err^.msg_parm.i[3], err^.msg_parm.i[2], err^.msg_parm.i[3],
err^.msg_parm.i[4], err^.msg_parm.i[5], err^.msg_parm.i[4], err^.msg_parm.i[5],
err^.msg_parm.i[6], err^.msg_parm.i[7] ]); err^.msg_parm.i[6], err^.msg_parm.i[7] ]);
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
end; end;
end; end;
{ Reset error state variables at start of a new image. { Reset error state variables at start of a new image.
This is called during compression startup to reset trace/error This is called during compression startup to reset trace/error
processing to default state, without losing any application-specific processing to default state, without losing any application-specific
method pointers. An application might possibly want to override method pointers. An application might possibly want to override
this method if it has additional error processing state. } this method if it has additional error processing state. }
{METHODDEF} {METHODDEF}
procedure reset_error_mgr (cinfo : j_common_ptr); procedure reset_error_mgr (cinfo : j_common_ptr);
begin begin
cinfo^.err^.num_warnings := 0; cinfo^.err^.num_warnings := 0;
{ trace_level is not reset since it is an application-supplied parameter } { 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" } cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" }
end; end;
{ Fill in the standard error-handling methods in a jpeg_error_mgr object. { Fill in the standard error-handling methods in a jpeg_error_mgr object.
Typical call is: Typical call is:
cinfo : jpeg_compress_struct; cinfo : jpeg_compress_struct;
err : jpeg_error_mgr; err : jpeg_error_mgr;
cinfo.err := jpeg_std_error(@err); cinfo.err := jpeg_std_error(@err);
after which the application may override some of the methods. } after which the application may override some of the methods. }
{GLOBAL} {GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
begin begin
err.error_exit := error_exit; err.error_exit := error_exit;
err.emit_message := emit_message; err.emit_message := emit_message;
err.output_message := output_message; err.output_message := output_message;
err.format_message := format_message; err.format_message := format_message;
err.reset_error_mgr := reset_error_mgr; err.reset_error_mgr := reset_error_mgr;
err.trace_level := 0; { default := no tracing } err.trace_level := 0; { default := no tracing }
err.num_warnings := 0; { no warnings emitted yet } err.num_warnings := 0; { no warnings emitted yet }
err.msg_code := 0; { may be useful as a flag for "no error" } err.msg_code := 0; { may be useful as a flag for "no error" }
{ Initialize message table pointers } { Initialize message table pointers }
err.jpeg_message_table := @jpeg_std_message_table; err.jpeg_message_table := @jpeg_std_message_table;
err.last_jpeg_message := pred(JMSG_LASTMSGCODE); err.last_jpeg_message := pred(JMSG_LASTMSGCODE);
err.addon_message_table := NIL; err.addon_message_table := NIL;
err.first_addon_message := JMSG_NOMESSAGE; { for safety } err.first_addon_message := JMSG_NOMESSAGE; { for safety }
err.last_addon_message := JMSG_NOMESSAGE; err.last_addon_message := JMSG_NOMESSAGE;
jpeg_std_error := @err; jpeg_std_error := @err;
end; end;
end. end.

352
Imaging/JpegLib/imjfdctflt.pas
View File

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

474
Imaging/JpegLib/imjfdctfst.pas
View File

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

594
Imaging/JpegLib/imjfdctint.pas
View File

@ -1,297 +1,297 @@
unit imjfdctint; unit imjfdctint;
{ This file contains a slow-but-accurate integer implementation of the { This file contains a slow-but-accurate integer implementation of the
forward DCT (Discrete Cosine Transform). forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT 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 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. much more complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds. The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 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 The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. } scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. } { Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjutils, imjutils,
imjpeglib, imjpeglib,
imjdct; { Private declarations for DCT subsystem } imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. } { Perform the forward DCT on one block of samples. }
{GLOBAL} {GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM); procedure jpeg_fdct_islow (var data : array of DCTELEM);
implementation implementation
{ This module is specialized to the case DCTSIZE = 8. } { This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8} {$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif} {$endif}
{ The poop on this scaling stuff is as follows: { The poop on this scaling stuff is as follows:
Each 1-D DCT step produces outputs which are a factor of sqrt(N) 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 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 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 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, 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). 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 the IJG code, this factor of 8 is removed by the quantization step
(in jcdctmgr.c), NOT in this module. (in jcdctmgr.c), NOT in this module.
We have to do addition and subtraction of the integer inputs, which We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting 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 as long as possible so that partial sums can be added together with
full fractional precision. full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that 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 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 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 with the recommended scaling. (For 12-bit sample data, the intermediate
array is INT32 anyway.) array is INT32 anyway.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must 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 have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. } shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
const const
CONST_BITS = 13; CONST_BITS = 13;
PASS1_BITS = 2; PASS1_BITS = 2;
{$else} {$else}
const const
CONST_BITS = 13; CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow } PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif} {$endif}
const const
CONST_SCALE = (INT32(1) shl CONST_BITS); CONST_SCALE = (INT32(1) shl CONST_BITS);
const const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. { Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a 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. 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. } For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
{MULTIPLY16C16(var,const)} {MULTIPLY16C16(var,const)}
function Multiply(X, Y: int): INT32; function Multiply(X, Y: int): INT32;
begin begin
Multiply := int(X) * INT32(Y); Multiply := int(X) * INT32(Y);
end; end;
{$else} {$else}
function Multiply(X, Y: INT32): INT32; function Multiply(X, Y: INT32): INT32;
begin begin
Multiply := X * Y; Multiply := X * Y;
end; end;
{$endif} {$endif}
{ Descale and correctly round an INT32 value that's scaled by N bits. { Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. } the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32; function DESCALE(x : INT32; n : int) : INT32;
var var
shift_temp : INT32; shift_temp : INT32;
begin begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED} {$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1)); shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else else
Descale := (shift_temp shr n); Descale := (shift_temp shr n);
{$else} {$else}
Descale := (x + (INT32(1) shl (n-1)) shr n; Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif} {$endif}
end; end;
{ Perform the forward DCT on one block of samples. } { Perform the forward DCT on one block of samples. }
{GLOBAL} {GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM); procedure jpeg_fdct_islow (var data : array of DCTELEM);
type type
PWorkspace = ^TWorkspace; PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM; TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32; tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32; tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32; z1, z2, z3, z4, z5 : INT32;
dataptr : PWorkspace; dataptr : PWorkspace;
ctr : int; ctr : int;
{SHIFT_TEMPS} {SHIFT_TEMPS}
begin begin
{ Pass 1: process rows. } { Pass 1: process rows. }
{ Note results are scaled up by sqrt(8) compared to a true DCT; } { Note results are scaled up by sqrt(8) compared to a true DCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. } { furthermore, we scale the results by 2**PASS1_BITS. }
dataptr := PWorkspace(@data); dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do for ctr := DCTSIZE-1 downto 0 do
begin begin
tmp0 := dataptr^[0] + dataptr^[7]; tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7]; tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6]; tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6]; tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5]; tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5]; tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4]; tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4]; tmp4 := dataptr^[3] - dataptr^[4];
{ Even part per LL&M figure 1 --- note that published figure is faulty; { Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3; tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3; tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2; tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2; tmp12 := tmp1 - tmp2;
dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS); dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS);
dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS); dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS);
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS-PASS1_BITS)); CONST_BITS-PASS1_BITS));
dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS-PASS1_BITS)); CONST_BITS-PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2). { Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16). cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. } i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7; z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6; z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6; z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7; z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { 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) } tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { 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) } z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5); Inc(z3, z5);
Inc(z4, z5); Inc(z4, z5);
dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS)); dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS));
dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, 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^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS));
dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS)); dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS));
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row } Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end; end;
{ Pass 2: process columns. { Pass 2: process columns.
We remove the PASS1_BITS scaling, but leave the results scaled up We remove the PASS1_BITS scaling, but leave the results scaled up
by an overall factor of 8. } by an overall factor of 8. }
dataptr := PWorkspace(@data); dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do for ctr := DCTSIZE-1 downto 0 do
begin begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := 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; { Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3; tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3; tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2; tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2; tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS)); dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS));
dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS)); dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS));
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2). { Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16). cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. } i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7; z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6; z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6; z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7; z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { 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) } tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { 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) } z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5); Inc(z3, z5);
Inc(z4, z5); Inc(z4, z5);
dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3, dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3,
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4, dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4,
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3, dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3,
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4, dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4,
CONST_BITS+PASS1_BITS)); CONST_BITS+PASS1_BITS));
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column } Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end; end;
end; 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; unit imjidctflt;
{$N+} {$N+}
{ This file contains a floating-point implementation of the { This file contains a floating-point implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients. must also perform dequantization of the input coefficients.
This implementation should be more accurate than either of the integer This implementation should be more accurate than either of the integer
IDCT implementations. However, it may not give the same results on all IDCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity. 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 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 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 a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code. complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for 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 scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M. 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 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 possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself. to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. } we use floating point arithmetic. }
{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. } { Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjpeglib, imjpeglib,
imjdct; { Private declarations for DCT subsystem } imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. } { Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL} {GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr; procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR; coef_block : JCOEFPTR;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
output_col : JDIMENSION); output_col : JDIMENSION);
implementation implementation
{ This module is specialized to the case DCTSIZE = 8. } { This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8} {$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif} {$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table { Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a float result. } entry; produce a float result. }
function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT; function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT;
begin begin
Dequantize := ( (coef) * quantval); Dequantize := ( (coef) * quantval);
end; end;
{ Descale and correctly round an INT32 value that's scaled by N bits. { Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. } the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32; function DESCALE(x : INT32; n : int) : INT32;
var var
shift_temp : INT32; shift_temp : INT32;
begin begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED} {$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1)); shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else else
Descale := (shift_temp shr n); Descale := (shift_temp shr n);
{$else} {$else}
Descale := (x + (INT32(1) shl (n-1)) shr n; Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif} {$endif}
end; end;
{ Perform dequantization and inverse DCT on one block of coefficients. } { Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL} {GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr; procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR; coef_block : JCOEFPTR;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
output_col : JDIMENSION); output_col : JDIMENSION);
type type
PWorkspace = ^TWorkspace; PWorkspace = ^TWorkspace;
TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT; TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT;
var var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT; tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT; tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z5, z10, z11, z12, z13 : FAST_FLOAT; z5, z10, z11, z12, z13 : FAST_FLOAT;
inptr : JCOEFPTR; inptr : JCOEFPTR;
quantptr : FLOAT_MULT_TYPE_FIELD_PTR; quantptr : FLOAT_MULT_TYPE_FIELD_PTR;
wsptr : PWorkSpace; wsptr : PWorkSpace;
outptr : JSAMPROW; outptr : JSAMPROW;
range_limit : JSAMPROW; range_limit : JSAMPROW;
ctr : int; ctr : int;
workspace : TWorkspace; { buffers data between passes } workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS} {SHIFT_TEMPS}
var var
dcval : FAST_FLOAT; dcval : FAST_FLOAT;
begin begin
{ Each IDCT routine is responsible for range-limiting its results and { Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could 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 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 range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. } prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. } { Pass 1: process columns from input, store into work array. }
inptr := coef_block; inptr := coef_block;
quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table); quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace; wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do for ctr := pred(DCTSIZE) downto 0 do
begin begin
{ Due to quantization, we will usually find that many of the input { Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all 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 the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed). DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. } column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then (inptr^[DCTSIZE*7]=0) then
begin begin
{ AC terms all zero } { AC terms all zero }
FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
wsptr^[DCTSIZE*0] := dcval; wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval; wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval; wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval; wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval; wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval; wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval; wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval; wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column } Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr)); Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr)); Inc(FAST_FLOAT_PTR(wsptr));
continue; continue;
end; end;
{ Even part } { Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 } tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2; tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 } tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 } tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 } tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13; tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12; tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12; tmp2 := tmp11 - tmp12;
{ Odd part } { Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 } z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5; z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7; z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7; z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 } tmp7 := z11 + z13; { phase 5 }
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 } tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 }
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 } tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6; tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5; tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := tmp0 + tmp7; wsptr^[DCTSIZE*0] := tmp0 + tmp7;
wsptr^[DCTSIZE*7] := tmp0 - tmp7; wsptr^[DCTSIZE*7] := tmp0 - tmp7;
wsptr^[DCTSIZE*1] := tmp1 + tmp6; wsptr^[DCTSIZE*1] := tmp1 + tmp6;
wsptr^[DCTSIZE*6] := tmp1 - tmp6; wsptr^[DCTSIZE*6] := tmp1 - tmp6;
wsptr^[DCTSIZE*2] := tmp2 + tmp5; wsptr^[DCTSIZE*2] := tmp2 + tmp5;
wsptr^[DCTSIZE*5] := tmp2 - tmp5; wsptr^[DCTSIZE*5] := tmp2 - tmp5;
wsptr^[DCTSIZE*4] := tmp3 + tmp4; wsptr^[DCTSIZE*4] := tmp3 + tmp4;
wsptr^[DCTSIZE*3] := tmp3 - tmp4; wsptr^[DCTSIZE*3] := tmp3 - tmp4;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column } Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr)); Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr)); Inc(FAST_FLOAT_PTR(wsptr));
end; end;
{ Pass 2: process rows from work array, store into output array. } { 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. } { Note that we must descale the results by a factor of 8 = 2**3. }
wsptr := @workspace; wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do for ctr := 0 to pred(DCTSIZE) do
begin begin
outptr := JSAMPROW(@(output_buf^[ctr]^[output_col])); outptr := JSAMPROW(@(output_buf^[ctr]^[output_col]));
{ Rows of zeroes can be exploited in the same way as we did with columns. { 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 However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time). 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. } And testing floats for zero is relatively expensive, so we don't bother. }
{ Even part } { Even part }
tmp10 := wsptr^[0] + wsptr^[4]; tmp10 := wsptr^[0] + wsptr^[4];
tmp11 := wsptr^[0] - wsptr^[4]; tmp11 := wsptr^[0] - wsptr^[4];
tmp13 := wsptr^[2] + wsptr^[6]; tmp13 := wsptr^[2] + wsptr^[6];
tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13; tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13;
tmp0 := tmp10 + tmp13; tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13; tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12; tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12; tmp2 := tmp11 - tmp12;
{ Odd part } { Odd part }
z13 := wsptr^[5] + wsptr^[3]; z13 := wsptr^[5] + wsptr^[3];
z10 := wsptr^[5] - wsptr^[3]; z10 := wsptr^[5] - wsptr^[3];
z11 := wsptr^[1] + wsptr^[7]; z11 := wsptr^[1] + wsptr^[7];
z12 := wsptr^[1] - wsptr^[7]; z12 := wsptr^[1] - wsptr^[7];
tmp7 := z11 + z13; tmp7 := z11 + z13;
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562));
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; tmp6 := tmp12 - tmp7;
tmp5 := tmp11 - tmp6; tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5; tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit } { Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3)) outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3)) outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3)) outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3)) outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3)) outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3)) outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3)) outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3)) outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3))
and RANGE_MASK]; and RANGE_MASK];
Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row } Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row }
end; end;
end; end;
end. end.

820
Imaging/JpegLib/imjidctfst.pas
View File

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

880
Imaging/JpegLib/imjidctint.pas
View File

@ -1,440 +1,440 @@
unit imjidctint; unit imjidctint;
{$Q+} {$Q+}
{ This file contains a slow-but-accurate integer implementation of the { This file contains a slow-but-accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients. 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 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 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 a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code. complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds. The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 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 The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. } scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. } { Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjpeglib, imjpeglib,
imjdct; { Private declarations for DCT subsystem } imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. } { Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL} {GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr; procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR; coef_block : JCOEFPTR;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
output_col : JDIMENSION); output_col : JDIMENSION);
implementation implementation
{ This module is specialized to the case DCTSIZE = 8. } { This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8} {$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif} {$endif}
{ The poop on this scaling stuff is as follows: { The poop on this scaling stuff is as follows:
Each 1-D IDCT step produces outputs which are a factor of sqrt(N) 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 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 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 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, 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). 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 We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting 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 as long as possible so that partial sums can be added together with
full fractional precision. full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that 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 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 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 with the recommended scaling. (To scale up 12-bit sample data further, an
intermediate INT32 array would be needed.) intermediate INT32 array would be needed.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must 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 have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. } shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
const const
CONST_BITS = 13; CONST_BITS = 13;
PASS1_BITS = 2; PASS1_BITS = 2;
{$else} {$else}
const const
CONST_BITS = 13; CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow } PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif} {$endif}
const const
CONST_SCALE = (INT32(1) shl CONST_BITS); CONST_SCALE = (INT32(1) shl CONST_BITS);
const const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. { Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a 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. 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. } For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
{$IFDEF BASM16} {$IFDEF BASM16}
{$IFNDEF WIN32} {$IFNDEF WIN32}
{MULTIPLY16C16(var,const)} {MULTIPLY16C16(var,const)}
function Multiply(X, Y: Integer): integer; assembler; function Multiply(X, Y: Integer): integer; assembler;
asm asm
mov ax, X mov ax, X
imul Y imul Y
mov al, ah mov al, ah
mov ah, dl mov ah, dl
end; end;
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
function Multiply(X, Y: INT32): INT32; function Multiply(X, Y: INT32): INT32;
begin begin
Multiply := INT32(X) * INT32(Y); Multiply := INT32(X) * INT32(Y);
end; end;
{$else} {$else}
{#define MULTIPLY(var,const) ((var) * (const))} {#define MULTIPLY(var,const) ((var) * (const))}
function Multiply(X, Y: INT32): INT32; function Multiply(X, Y: INT32): INT32;
begin begin
Multiply := INT32(X) * INT32(Y); Multiply := INT32(X) * INT32(Y);
end; end;
{$endif} {$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table { Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce an int result. In this module, both inputs and result 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. } are 16 bits or less, so either int or short multiply will work. }
function DEQUANTIZE(coef,quantval : int) : int; function DEQUANTIZE(coef,quantval : int) : int;
begin begin
Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval); Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval);
end; end;
{ Descale and correctly round an INT32 value that's scaled by N bits. { Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. } the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32; function DESCALE(x : INT32; n : int) : INT32;
var var
shift_temp : INT32; shift_temp : INT32;
begin begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED} {$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1)); shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else else
Descale := (shift_temp shr n); Descale := (shift_temp shr n);
{$else} {$else}
Descale := (x + (INT32(1) shl (n-1)) shr n; Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif} {$endif}
end; end;
{ Perform dequantization and inverse DCT on one block of coefficients. } { Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL} {GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr; procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr; compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR; coef_block : JCOEFPTR;
output_buf : JSAMPARRAY; output_buf : JSAMPARRAY;
output_col : JDIMENSION); output_col : JDIMENSION);
type type
PWorkspace = ^TWorkspace; PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes } TWorkspace = coef_bits_field; { buffers data between passes }
var var
tmp0, tmp1, tmp2, tmp3 : INT32; tmp0, tmp1, tmp2, tmp3 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32; tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32; z1, z2, z3, z4, z5 : INT32;
inptr : JCOEFPTR; inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR; quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace; wsptr : PWorkspace;
outptr : JSAMPROW; outptr : JSAMPROW;
range_limit : JSAMPROW; range_limit : JSAMPROW;
ctr : int; ctr : int;
workspace : TWorkspace; workspace : TWorkspace;
{SHIFT_TEMPS} {SHIFT_TEMPS}
var var
dcval : int; dcval : int;
var var
dcval_ : JSAMPLE; dcval_ : JSAMPLE;
begin begin
{ Each IDCT routine is responsible for range-limiting its results and { Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could 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 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 range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. } prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. } { Pass 1: process columns from input, store into work array. }
{ Note results are scaled up by sqrt(8) compared to a true IDCT; } { Note results are scaled up by sqrt(8) compared to a true IDCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. } { furthermore, we scale the results by 2**PASS1_BITS. }
inptr := coef_block; inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := PWorkspace(@workspace); wsptr := PWorkspace(@workspace);
for ctr := pred(DCTSIZE) downto 0 do for ctr := pred(DCTSIZE) downto 0 do
begin begin
{ Due to quantization, we will usually find that many of the input { Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all 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 the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed). DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. } column DCT calculations can be simplified this way. }
if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0)) then (inptr^[DCTSIZE*7]=0)) then
begin begin
{ AC terms all zero } { AC terms all zero }
dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS; dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval; wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval; wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval; wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval; wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval; wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval; wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval; wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval; wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column } Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr)); Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr)); Inc(int_ptr(wsptr));
continue; continue;
end; end;
{ Even part: reverse the even part of the forward DCT. } { Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). } { The rotator is sqrt(2)*c(-6). }
z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100); z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp0 := (z2 + z3) shl CONST_BITS; tmp0 := (z2 + z3) shl CONST_BITS;
tmp1 := (z2 - z3) shl CONST_BITS; tmp1 := (z2 - z3) shl CONST_BITS;
tmp10 := tmp0 + tmp3; tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3; tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2; tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2; tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its { Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
z1 := tmp0 + tmp3; z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2; z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2; z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3; z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { 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) } tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { 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) } z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5); Inc(z3, z5);
Inc(z4, z5); Inc(z4, z5);
Inc(tmp0, z1 + z3); Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4); Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3); Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4); Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS)); wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*7] := 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*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*6] := 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*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*5] := 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*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*4] := 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(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr)); Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr)); Inc(int_ptr(wsptr));
end; end;
{ Pass 2: process rows from work array, store into output array. } { 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, } { Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. } { and also undo the PASS1_BITS scaling. }
wsptr := @workspace; wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do for ctr := 0 to pred(DCTSIZE) do
begin begin
outptr := output_buf^[ctr]; outptr := output_buf^[ctr];
Inc(JSAMPLE_PTR(outptr), output_col); Inc(JSAMPLE_PTR(outptr), output_col);
{ Rows of zeroes can be exploited in the same way as we did with columns. { 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 However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time). the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section test takes more time than it's worth. In that case this section
may be commented out. } may be commented out. }
{$ifndef NO_ZERO_ROW_TEST} {$ifndef NO_ZERO_ROW_TEST}
if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) 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 and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then
begin begin
{ AC terms all zero } { AC terms all zero }
JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]), JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]),
PASS1_BITS+3)) and RANGE_MASK]; PASS1_BITS+3)) and RANGE_MASK];
outptr^[0] := dcval_; outptr^[0] := dcval_;
outptr^[1] := dcval_; outptr^[1] := dcval_;
outptr^[2] := dcval_; outptr^[2] := dcval_;
outptr^[3] := dcval_; outptr^[3] := dcval_;
outptr^[4] := dcval_; outptr^[4] := dcval_;
outptr^[5] := dcval_; outptr^[5] := dcval_;
outptr^[6] := dcval_; outptr^[6] := dcval_;
outptr^[7] := dcval_; outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue; continue;
end; end;
{$endif} {$endif}
{ Even part: reverse the even part of the forward DCT. } { Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). } { The rotator is sqrt(2)*c(-6). }
z2 := INT32 (wsptr^[2]); z2 := INT32 (wsptr^[2]);
z3 := INT32 (wsptr^[6]); z3 := INT32 (wsptr^[6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100); z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS; tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;
tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS; tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;
tmp10 := tmp0 + tmp3; tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3; tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2; tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2; tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its { Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := INT32(wsptr^[7]); tmp0 := INT32(wsptr^[7]);
tmp1 := INT32(wsptr^[5]); tmp1 := INT32(wsptr^[5]);
tmp2 := INT32(wsptr^[3]); tmp2 := INT32(wsptr^[3]);
tmp3 := INT32(wsptr^[1]); tmp3 := INT32(wsptr^[1]);
z1 := tmp0 + tmp3; z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2; z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2; z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3; z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { 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) } tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { 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) } z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5); Inc(z3, z5);
Inc(z4, z5); Inc(z4, z5);
Inc(tmp0, z1 + z3); Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4); Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3); Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4); Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3, outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3, outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2, outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2, outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1, outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1, outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0, outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0, outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0,
CONST_BITS+PASS1_BITS+3)) CONST_BITS+PASS1_BITS+3))
and RANGE_MASK]; and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end; end;
end; 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; unit imjinclude;
{ This file exists to provide a single place to fix any problems with { This file exists to provide a single place to fix any problems with
including the wrong system include files. (Common problems are taken including the wrong system include files. (Common problems are taken
care of by the standard jconfig symbols, but on really weird systems care of by the standard jconfig symbols, but on really weird systems
you may have to edit this file.) you may have to edit this file.)
NOTE: this file is NOT intended to be included by applications using the NOTE: this file is NOT intended to be included by applications using the
JPEG library. Most applications need only include jpeglib.h. } JPEG library. Most applications need only include jpeglib.h. }
{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. } { Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
{ Include auto-config file to find out which system include files we need. } { Include auto-config file to find out which system include files we need. }
uses uses
{$ifdef Delphi_Stream} {$ifdef Delphi_Stream}
classes, classes,
{$endif} {$endif}
imjmorecfg; imjmorecfg;
{ Nomssi: { Nomssi:
To write a dest/source manager that handle streams rather than files, To write a dest/source manager that handle streams rather than files,
you can edit the FILEptr definition and the JFREAD() and JFWRITE() you can edit the FILEptr definition and the JFREAD() and JFWRITE()
functions in this unit, you don't need to change the default managers functions in this unit, you don't need to change the default managers
JDATASRC and JDATADST. } JDATASRC and JDATADST. }
{$ifdef Delphi_Stream} {$ifdef Delphi_Stream}
type type
FILEptr = ^TStream; FILEptr = ^TStream;
{$else} {$else}
{$ifdef Delphi_Jpeg} {$ifdef Delphi_Jpeg}
type type
FILEptr = TCustomMemoryStream; FILEptr = TCustomMemoryStream;
{$else} {$else}
type type
FILEptr = ^File; FILEptr = ^File;
{$endif} {$endif}
{$endif} {$endif}
{ We need the NULL macro and size_t typedef. { We need the NULL macro and size_t typedef.
On an ANSI-conforming system it is sufficient to include <stddef.h>. 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 Otherwise, we get them from <stdlib.h> or <stdio.h>; we may have to
pull in <sys/types.h> as well. pull in <sys/types.h> as well.
Note that the core JPEG library does not require <stdio.h>; Note that the core JPEG library does not require <stdio.h>;
only the default error handler and data source/destination modules do. 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. 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>.} You can remove those references if you want to compile without <stdio.h>.}
{ We need memory copying and zeroing functions, plus strncpy(). { We need memory copying and zeroing functions, plus strncpy().
ANSI and System V implementations declare these in <string.h>. ANSI and System V implementations declare these in <string.h>.
BSD doesn't have the mem() functions, but it does have bcopy()/bzero(). BSD doesn't have the mem() functions, but it does have bcopy()/bzero().
Some systems may declare memset and memcpy in <memory.h>. Some systems may declare memset and memcpy in <memory.h>.
NOTE: we assume the size parameters to these functions are of type size_t. NOTE: we assume the size parameters to these functions are of type size_t.
Change the casts in these macros if not! } Change the casts in these macros if not! }
procedure MEMZERO(target : pointer; size : size_t); procedure MEMZERO(target : pointer; size : size_t);
procedure MEMCOPY(dest, src : pointer; size : size_t); procedure MEMCOPY(dest, src : pointer; size : size_t);
{function SIZEOF(object) : size_t;} {function SIZEOF(object) : size_t;}
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
implementation implementation
procedure MEMZERO(target : pointer; size : size_t); procedure MEMZERO(target : pointer; size : size_t);
begin begin
FillChar(target^, size, 0); FillChar(target^, size, 0);
end; end;
procedure MEMCOPY(dest, src : pointer; size : size_t); procedure MEMCOPY(dest, src : pointer; size : size_t);
begin begin
Move(src^, dest^, size); Move(src^, dest^, size);
end; end;
{ In ANSI C, and indeed any rational implementation, size_t is also the { In ANSI C, and indeed any rational implementation, size_t is also the
type returned by sizeof(). However, it seems there are some irrational type returned by sizeof(). However, it seems there are some irrational
implementations out there, in which sizeof() returns an int even though implementations out there, in which sizeof() returns an int even though
size_t is defined as long or unsigned long. To ensure consistent results 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. } we always use this SIZEOF() macro in place of using sizeof() directly. }
{#define {#define
SIZEOF(object) (size_t(sizeof(object))} SIZEOF(object) (size_t(sizeof(object))}
{ The modules that use fread() and fwrite() always invoke them through { The modules that use fread() and fwrite() always invoke them through
these macros. On some systems you may need to twiddle the argument casts. these macros. On some systems you may need to twiddle the argument casts.
CAUTION: argument order is different from underlying functions! } CAUTION: argument order is different from underlying functions! }
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var var
count : uint; count : uint;
begin begin
{$ifdef Delphi_Stream} {$ifdef Delphi_Stream}
count := fp^.Read(buf^, sizeofbuf); count := fp^.Read(buf^, sizeofbuf);
{$else} {$else}
blockread(fp^, buf^, sizeofbuf, count); blockread(fp^, buf^, sizeofbuf, count);
{$endif} {$endif}
JFREAD := size_t(count); JFREAD := size_t(count);
end; end;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var var
count : uint; count : uint;
begin begin
{$ifdef Delphi_Stream} {$ifdef Delphi_Stream}
count := fp^.Write(buf^, sizeofbuf); count := fp^.Write(buf^, sizeofbuf);
{$else} {$else}
blockwrite(fp^, buf^, sizeofbuf, count); blockwrite(fp^, buf^, sizeofbuf, count);
{$endif} {$endif}
JFWRITE := size_t(count); JFWRITE := size_t(count);
end; end;
end. end.

494
Imaging/JpegLib/imjmorecfg.pas
View File

@ -1,247 +1,247 @@
unit imjmorecfg; unit imjmorecfg;
{ This file contains additional configuration options that customize the { This file contains additional configuration options that customize the
JPEG software for special applications or support machine-dependent JPEG software for special applications or support machine-dependent
optimizations. Most users will not need to touch this file. } optimizations. Most users will not need to touch this file. }
{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. } { Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
{$IFDEF FPC} { Free Pascal Compiler } {$IFDEF FPC} { Free Pascal Compiler }
type type
int = longint; int = longint;
uInt = Cardinal; { unsigned int } uInt = Cardinal; { unsigned int }
short = Integer; short = Integer;
ushort = Word; ushort = Word;
long = longint; long = longint;
{$ELSE} {$ELSE}
{$IFDEF WIN32} {$IFDEF WIN32}
{ Delphi 2.0 } { Delphi 2.0 }
type type
int = Integer; int = Integer;
uInt = Cardinal; uInt = Cardinal;
short = SmallInt; short = SmallInt;
ushort = Word; ushort = Word;
long = longint; long = longint;
{$ELSE} {$ELSE}
{$IFDEF VIRTUALPASCAL} {$IFDEF VIRTUALPASCAL}
type type
int = longint; int = longint;
uInt = longint; { unsigned int } uInt = longint; { unsigned int }
short = system.Integer; short = system.Integer;
ushort = system.Word; ushort = system.Word;
long = longint; long = longint;
{$ELSE} {$ELSE}
type type
int = Integer; int = Integer;
uInt = Word; { unsigned int } uInt = Word; { unsigned int }
short = Integer; short = Integer;
ushort = Word; ushort = Word;
long = longint; long = longint;
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
type type
voidp = pointer; voidp = pointer;
type type
int_ptr = ^int; int_ptr = ^int;
size_t = int; size_t = int;
{ Define BITS_IN_JSAMPLE as either { Define BITS_IN_JSAMPLE as either
8 for 8-bit sample values (the usual setting) 8 for 8-bit sample values (the usual setting)
12 for 12-bit sample values 12 for 12-bit sample values
Only 8 and 12 are legal data precisions for lossy JPEG according to the 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! JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. } We do not support run-time selection of data precision, sorry. }
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 } {$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const const
BITS_IN_JSAMPLE = 8; BITS_IN_JSAMPLE = 8;
{$else} {$else}
const const
BITS_IN_JSAMPLE = 12; BITS_IN_JSAMPLE = 12;
{$endif} {$endif}
{ Maximum number of components (color channels) allowed in JPEG image. { Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn 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 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 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 really short on memory. (Each allowed component costs a hundred or so
bytes of storage, whether actually used in an image or not.) } bytes of storage, whether actually used in an image or not.) }
const const
MAX_COMPONENTS = 10; { maximum number of image components } MAX_COMPONENTS = 10; { maximum number of image components }
{ Basic data types. { Basic data types.
You may need to change these if you have a machine with unusual data 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, 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, or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits,
but it had better be at least 16. } but it had better be at least 16. }
{ Representation of a single sample (pixel element value). { Representation of a single sample (pixel element value).
We frequently allocate large arrays of these, so it's important to keep 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 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. } arrays is very slow on your hardware, you might want to change these. }
{$ifdef BITS_IN_JSAMPLE_IS_8} {$ifdef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..255. { 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. } You can use a signed char by having GETJSAMPLE mask it with $FF. }
{ CHAR_IS_UNSIGNED } { CHAR_IS_UNSIGNED }
type type
JSAMPLE = byte; { Pascal unsigned char } JSAMPLE = byte; { Pascal unsigned char }
GETJSAMPLE = int; GETJSAMPLE = int;
const const
MAXJSAMPLE = 255; MAXJSAMPLE = 255;
CENTERJSAMPLE = 128; CENTERJSAMPLE = 128;
{$endif} {$endif}
{$ifndef BITS_IN_JSAMPLE_IS_8} {$ifndef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..4095. { JSAMPLE should be the smallest type that will hold the values 0..4095.
On nearly all machines "short" will do nicely. } On nearly all machines "short" will do nicely. }
type type
JSAMPLE = short; JSAMPLE = short;
GETJSAMPLE = int; GETJSAMPLE = int;
const const
MAXJSAMPLE = 4095; MAXJSAMPLE = 4095;
CENTERJSAMPLE = 2048; CENTERJSAMPLE = 2048;
{$endif} { BITS_IN_JSAMPLE = 12 } {$endif} { BITS_IN_JSAMPLE = 12 }
{ Representation of a DCT frequency coefficient. { Representation of a DCT frequency coefficient.
This should be a signed value of at least 16 bits; "short" is usually OK. 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 Again, we allocate large arrays of these, but you can change to int
if you have memory to burn and "short" is really slow. } if you have memory to burn and "short" is really slow. }
type type
JCOEF = int; JCOEF = int;
JCOEF_PTR = ^JCOEF; JCOEF_PTR = ^JCOEF;
{ Compressed datastreams are represented as arrays of JOCTET. { Compressed datastreams are represented as arrays of JOCTET.
These must be EXACTLY 8 bits wide, at least once they are written to 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 external storage. Note that when using the stdio data source/destination
managers, this is also the data type passed to fread/fwrite. } managers, this is also the data type passed to fread/fwrite. }
type type
JOCTET = Byte; JOCTET = Byte;
jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1; jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
JOCTET_FIELD = array[jTOctet] of JOCTET; JOCTET_FIELD = array[jTOctet] of JOCTET;
JOCTET_FIELD_PTR = ^JOCTET_FIELD; JOCTET_FIELD_PTR = ^JOCTET_FIELD;
JOCTETPTR = ^JOCTET; JOCTETPTR = ^JOCTET;
GETJOCTET = JOCTET; { A work around } GETJOCTET = JOCTET; { A work around }
{ These typedefs are used for various table entries and so forth. { 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 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 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 extraction code like we did for JSAMPLE. (In other words, these
typedefs live at a different point on the speed/space tradeoff curve.) } typedefs live at a different point on the speed/space tradeoff curve.) }
{ UINT8 must hold at least the values 0..255. } { UINT8 must hold at least the values 0..255. }
type type
UINT8 = byte; UINT8 = byte;
{ UINT16 must hold at least the values 0..65535. } { UINT16 must hold at least the values 0..65535. }
UINT16 = Word; UINT16 = Word;
{ INT16 must hold at least the values -32768..32767. } { INT16 must hold at least the values -32768..32767. }
INT16 = int; INT16 = int;
{ INT32 must hold at least signed 32-bit values. } { INT32 must hold at least signed 32-bit values. }
INT32 = longint; INT32 = longint;
type type
INT32PTR = ^INT32; INT32PTR = ^INT32;
{ Datatype used for image dimensions. The JPEG standard only supports { Datatype used for image dimensions. The JPEG standard only supports
images up to 64K*64K due to 16-bit fields in SOF markers. Therefore 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 "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 handle larger images and you don't mind deviating from the spec, you
can change this datatype. } can change this datatype. }
type type
JDIMENSION = uInt; JDIMENSION = uInt;
const const
JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows } JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows }
{ Ordering of RGB data in scanlines passed to or from the application. { 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 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 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 (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. the offsets will also change the order in which colormap data is organized.
RESTRICTIONS: RESTRICTIONS:
1. The sample applications cjpeg,djpeg do NOT support modified RGB formats. 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 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. 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 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 is not 3 (they don't understand about dummy color components!). So you
can't use color quantization if you change that value. } can't use color quantization if you change that value. }
{$ifdef RGB_RED_IS_0} {$ifdef RGB_RED_IS_0}
const const
RGB_RED = 0; { Offset of Red in an RGB scanline element } RGB_RED = 0; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green } RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 2; { Offset of Blue } RGB_BLUE = 2; { Offset of Blue }
{$else} {$else}
const const
RGB_RED = 2; { Offset of Red in an RGB scanline element } RGB_RED = 2; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green } RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 0; { Offset of Blue } RGB_BLUE = 0; { Offset of Blue }
{$endif} {$endif}
{$ifdef RGB_PIXELSIZE_IS_3} {$ifdef RGB_PIXELSIZE_IS_3}
const const
RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element } RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element }
{$else} {$else}
const const
RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value } RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value }
{$endif} {$endif}
{ Definitions for speed-related optimizations. } { Definitions for speed-related optimizations. }
{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying { On some machines (notably 68000 series) "int" is 32 bits, but multiplying
two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER 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. } as short on such a machine. MULTIPLIER must be at least 16 bits wide. }
type type
MULTIPLIER = int; { type for fastest integer multiply } MULTIPLIER = int; { type for fastest integer multiply }
{ FAST_FLOAT should be either float or double, whichever is done faster { 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 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.) 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 Typically, float is faster in ANSI C compilers, while double is faster in
pre-ANSI compilers (because they insist on converting to double anyway). pre-ANSI compilers (because they insist on converting to double anyway).
The code below therefore chooses float if we have ANSI-style prototypes. } The code below therefore chooses float if we have ANSI-style prototypes. }
type type
FAST_FLOAT = double; {float} FAST_FLOAT = double; {float}
implementation implementation
end. 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; unit imjutils;
{ This file contains tables and miscellaneous utility routines needed { This file contains tables and miscellaneous utility routines needed
for both compression and decompression. for both compression and decompression.
Note we prefix all global names with "j" to minimize conflicts with Note we prefix all global names with "j" to minimize conflicts with
a surrounding application. } a surrounding application. }
{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. } { Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. }
interface interface
{$I imjconfig.inc} {$I imjconfig.inc}
uses uses
imjmorecfg, imjmorecfg,
imjinclude, imjinclude,
imjpeglib; imjpeglib;
{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element { 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). } of a DCT block read in natural order (left to right, top to bottom). }
{$ifdef FALSE} { This table is not actually needed in v6a } {$ifdef FALSE} { This table is not actually needed in v6a }
const const
jpeg_zigzag_order : array[0..DCTSIZE2] of int = jpeg_zigzag_order : array[0..DCTSIZE2] of int =
(0, 1, 5, 6, 14, 15, 27, 28, (0, 1, 5, 6, 14, 15, 27, 28,
2, 4, 7, 13, 16, 26, 29, 42, 2, 4, 7, 13, 16, 26, 29, 42,
3, 8, 12, 17, 25, 30, 41, 43, 3, 8, 12, 17, 25, 30, 41, 43,
9, 11, 18, 24, 31, 40, 44, 53, 9, 11, 18, 24, 31, 40, 44, 53,
10, 19, 23, 32, 39, 45, 52, 54, 10, 19, 23, 32, 39, 45, 52, 54,
20, 22, 33, 38, 46, 51, 55, 60, 20, 22, 33, 38, 46, 51, 55, 60,
21, 34, 37, 47, 50, 56, 59, 61, 21, 34, 37, 47, 50, 56, 59, 61,
35, 36, 48, 49, 57, 58, 62, 63); 35, 36, 48, 49, 57, 58, 62, 63);
{$endif} {$endif}
{ jpeg_natural_order[i] is the natural-order position of the i'th element { jpeg_natural_order[i] is the natural-order position of the i'th element
of zigzag order. of zigzag order.
When reading corrupted data, the Huffman decoders could attempt When reading corrupted data, the Huffman decoders could attempt
to reference an entry beyond the end of this array (if the decoded 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 zero run length reaches past the end of the block). To prevent
wild stores without adding an inner-loop test, we put some extra wild stores without adding an inner-loop test, we put some extra
"63"s after the real entries. This will cause the extra coefficient "63"s after the real entries. This will cause the extra coefficient
to be stored in location 63 of the block, not somewhere random. 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 The worst case would be a run-length of 15, which means we need 16
fake entries. } fake entries. }
const const
jpeg_natural_order : array[0..DCTSIZE2+16-1] of int = jpeg_natural_order : array[0..DCTSIZE2+16-1] of int =
(0, 1, 8, 16, 9, 2, 3, 10, (0, 1, 8, 16, 9, 2, 3, 10,
17, 24, 32, 25, 18, 11, 4, 5, 17, 24, 32, 25, 18, 11, 4, 5,
12, 19, 26, 33, 40, 48, 41, 34, 12, 19, 26, 33, 40, 48, 41, 34,
27, 20, 13, 6, 7, 14, 21, 28, 27, 20, 13, 6, 7, 14, 21, 28,
35, 42, 49, 56, 57, 50, 43, 36, 35, 42, 49, 56, 57, 50, 43, 36,
29, 22, 15, 23, 30, 37, 44, 51, 29, 22, 15, 23, 30, 37, 44, 51,
58, 59, 52, 45, 38, 31, 39, 46, 58, 59, 52, 45, 38, 31, 39, 46,
53, 60, 61, 54, 47, 55, 62, 63, 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, { extra entries for safety in decoder }
63, 63, 63, 63, 63, 63, 63, 63); 63, 63, 63, 63, 63, 63, 63, 63);
{ Arithmetic utilities } { Arithmetic utilities }
{GLOBAL} {GLOBAL}
function jdiv_round_up (a : long; b : long) : long; function jdiv_round_up (a : long; b : long) : long;
{GLOBAL} {GLOBAL}
function jround_up (a : long; b : long) : long; function jround_up (a : long; b : long) : long;
{GLOBAL} {GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY; procedure jcopy_sample_rows (input_array : JSAMPARRAY;
source_row : int; source_row : int;
output_array : JSAMPARRAY; dest_row : int; output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION); num_rows : int; num_cols : JDIMENSION);
{GLOBAL} {GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW; procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW; output_row : JBLOCKROW;
num_blocks : JDIMENSION); num_blocks : JDIMENSION);
{GLOBAL} {GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t); procedure jzero_far (target : pointer;{far} bytestozero : size_t);
procedure FMEMZERO(target : pointer; size : size_t); procedure FMEMZERO(target : pointer; size : size_t);
procedure FMEMCOPY(dest,src : pointer; size : size_t); procedure FMEMCOPY(dest,src : pointer; size : size_t);
implementation implementation
{GLOBAL} {GLOBAL}
function jdiv_round_up (a : long; b : long) : long; function jdiv_round_up (a : long; b : long) : long;
{ Compute a/b rounded up to next integer, ie, ceil(a/b) } { Compute a/b rounded up to next integer, ie, ceil(a/b) }
{ Assumes a >= 0, b > 0 } { Assumes a >= 0, b > 0 }
begin begin
jdiv_round_up := (a + b - long(1)) div b; jdiv_round_up := (a + b - long(1)) div b;
end; end;
{GLOBAL} {GLOBAL}
function jround_up (a : long; b : long) : long; function jround_up (a : long; b : long) : long;
{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b } { Compute a rounded up to next multiple of b, ie, ceil(a/b)*b }
{ Assumes a >= 0, b > 0 } { Assumes a >= 0, b > 0 }
begin begin
Inc(a, b - long(1)); Inc(a, b - long(1));
jround_up := a - (a mod b); jround_up := a - (a mod b);
end; end;
{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays { 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 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 are FAR and we're assuming a small-pointer memory model. However, some
DOS compilers provide far-pointer versions of memcpy() and memset() even 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. 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 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.) } is not all that great, because these routines aren't very heavily used.) }
{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros } {$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros }
procedure FMEMZERO(target : pointer; size : size_t); procedure FMEMZERO(target : pointer; size : size_t);
begin begin
FillChar(target^, size, 0); FillChar(target^, size, 0);
end; end;
procedure FMEMCOPY(dest,src : pointer; size : size_t); procedure FMEMCOPY(dest,src : pointer; size : size_t);
begin begin
Move(src^, dest^, size); Move(src^, dest^, size);
end; end;
{$else} { 80x86 case, define if we can } {$else} { 80x86 case, define if we can }
{$ifdef USE_FMEM} {$ifdef USE_FMEM}
FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size)) 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)) FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size))
{$endif} {$endif}
{$endif} {$endif}
{GLOBAL} {GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int; procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int;
output_array : JSAMPARRAY; dest_row : int; output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION); num_rows : int; num_cols : JDIMENSION);
{ Copy some rows of samples from one place to another. { Copy some rows of samples from one place to another.
num_rows rows are copied from input_array[source_row++] num_rows rows are copied from input_array[source_row++]
to output_array[dest_row++]; these areas may overlap for duplication. 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. } The source and destination arrays must be at least as wide as num_cols. }
var var
inptr, outptr : JSAMPLE_PTR; {register} inptr, outptr : JSAMPLE_PTR; {register}
{$ifdef FMEMCOPY} {$ifdef FMEMCOPY}
count : size_t; {register} count : size_t; {register}
{$else} {$else}
count : JDIMENSION; {register} count : JDIMENSION; {register}
{$endif} {$endif}
row : int; {register} row : int; {register}
begin begin
{$ifdef FMEMCOPY} {$ifdef FMEMCOPY}
count := size_t(num_cols * SIZEOF(JSAMPLE)); count := size_t(num_cols * SIZEOF(JSAMPLE));
{$endif} {$endif}
Inc(JSAMPROW_PTR(input_array), source_row); Inc(JSAMPROW_PTR(input_array), source_row);
Inc(JSAMPROW_PTR(output_array), dest_row); Inc(JSAMPROW_PTR(output_array), dest_row);
for row := pred(num_rows) downto 0 do for row := pred(num_rows) downto 0 do
begin begin
inptr := JSAMPLE_PTR(input_array^[0]); inptr := JSAMPLE_PTR(input_array^[0]);
Inc(JSAMPROW_PTR(input_array)); Inc(JSAMPROW_PTR(input_array));
outptr := JSAMPLE_PTR(output_array^[0]); outptr := JSAMPLE_PTR(output_array^[0]);
Inc(JSAMPROW_PTR(output_array)); Inc(JSAMPROW_PTR(output_array));
{$ifdef FMEMCOPY} {$ifdef FMEMCOPY}
FMEMCOPY(outptr, inptr, count); FMEMCOPY(outptr, inptr, count);
{$else} {$else}
for count := pred(num_cols) downto 0 do for count := pred(num_cols) downto 0 do
begin begin
outptr^ := inptr^; { needn't bother with GETJSAMPLE() here } outptr^ := inptr^; { needn't bother with GETJSAMPLE() here }
Inc(inptr); Inc(inptr);
Inc(outptr); Inc(outptr);
end; end;
{$endif} {$endif}
end; end;
end; end;
{GLOBAL} {GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW; procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW; output_row : JBLOCKROW;
num_blocks : JDIMENSION); num_blocks : JDIMENSION);
{ Copy a row of coefficient blocks from one place to another. } { Copy a row of coefficient blocks from one place to another. }
{$ifdef FMEMCOPY} {$ifdef FMEMCOPY}
begin begin
FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF))); FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF)));
{$else} {$else}
var var
inptr, outptr : JCOEFPTR; {register} inptr, outptr : JCOEFPTR; {register}
count : long; {register} count : long; {register}
begin begin
inptr := JCOEFPTR (input_row); inptr := JCOEFPTR (input_row);
outptr := JCOEFPTR (output_row); outptr := JCOEFPTR (output_row);
for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do
begin begin
outptr^ := inptr^; outptr^ := inptr^;
Inc(outptr); Inc(outptr);
Inc(inptr); Inc(inptr);
end; end;
{$endif} {$endif}
end; end;
{GLOBAL} {GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t); procedure jzero_far (target : pointer;{far} bytestozero : size_t);
{ Zero out a chunk of FAR memory. } { Zero out a chunk of FAR memory. }
{ This might be sample-array data, block-array data, or alloc_large data. } { This might be sample-array data, block-array data, or alloc_large data. }
{$ifdef FMEMZERO} {$ifdef FMEMZERO}
begin begin
FMEMZERO(target, bytestozero); FMEMZERO(target, bytestozero);
{$else} {$else}
var var
ptr : byteptr; ptr : byteptr;
count : size_t; {register} count : size_t; {register}
begin begin
ptr := target; ptr := target;
for count := bytestozero-1 downto 0 do for count := bytestozero-1 downto 0 do
begin begin
ptr^ := 0; ptr^ := 0;
Inc(ptr); Inc(ptr);
end; end;
{$endif} {$endif}
end; end;
end. end.

760
Imaging/JpegLib/readme.txt
View File

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

228
Imaging/ZLib/imadler.pas
View File

@ -1,114 +1,114 @@
Unit imadler; Unit imadler;
{ {
adler32.c -- compute the Adler-32 checksum of a data stream adler32.c -- compute the Adler-32 checksum of a data stream
Copyright (C) 1995-1998 Mark Adler Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt For conditions of distribution and use, see copyright notice in readme.txt
} }
interface interface
{$I imzconf.inc} {$I imzconf.inc}
uses uses
imzutil; imzutil;
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and { 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 return the updated checksum. If buf is NIL, this function returns
the required initial value for the checksum. the required initial value for the checksum.
An Adler-32 checksum is almost as reliable as a CRC32 but can be computed An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
much faster. Usage example: much faster. Usage example:
var var
adler : uLong; adler : uLong;
begin begin
adler := adler32(0, Z_NULL, 0); adler := adler32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do while (read_buffer(buffer, length) <> EOF) do
adler := adler32(adler, buffer, length); adler := adler32(adler, buffer, length);
if (adler <> original_adler) then if (adler <> original_adler) then
error(); error();
end; end;
} }
implementation implementation
const const
BASE = uLong(65521); { largest prime smaller than 65536 } BASE = uLong(65521); { largest prime smaller than 65536 }
{NMAX = 5552; original code with unsigned 32 bit integer } {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 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 = 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 } { 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. } { The penalty is the time loss in the extra MOD-calls. }
{ ========================================================================= } { ========================================================================= }
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
var var
s1, s2 : uLong; s1, s2 : uLong;
k : int; k : int;
begin begin
s1 := adler and $ffff; s1 := adler and $ffff;
s2 := (adler shr 16) and $ffff; s2 := (adler shr 16) and $ffff;
if not Assigned(buf) then if not Assigned(buf) then
begin begin
adler32 := uLong(1); adler32 := uLong(1);
exit; exit;
end; end;
while (len > 0) do while (len > 0) do
begin begin
if len < NMAX then if len < NMAX then
k := len k := len
else else
k := NMAX; k := NMAX;
Dec(len, k); Dec(len, k);
{ {
while (k >= 16) do while (k >= 16) do
begin begin
DO16(buf); DO16(buf);
Inc(buf, 16); Inc(buf, 16);
Dec(k, 16); Dec(k, 16);
end; end;
if (k <> 0) then if (k <> 0) then
repeat repeat
Inc(s1, buf^); Inc(s1, buf^);
Inc(puf); Inc(puf);
Inc(s2, s1); Inc(s2, s1);
Dec(k); Dec(k);
until (k = 0); until (k = 0);
} }
while (k > 0) do while (k > 0) do
begin begin
Inc(s1, buf^); Inc(s1, buf^);
Inc(s2, s1); Inc(s2, s1);
Inc(buf); Inc(buf);
Dec(k); Dec(k);
end; end;
s1 := s1 mod BASE; s1 := s1 mod BASE;
s2 := s2 mod BASE; s2 := s2 mod BASE;
end; end;
adler32 := (s2 shl 16) or s1; adler32 := (s2 shl 16) or s1;
end; end;
{ {
#define DO1(buf,i) #define DO1(buf,i)
begin begin
Inc(s1, buf[i]); Inc(s1, buf[i]);
Inc(s2, s1); Inc(s2, s1);
end; end;
#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); #define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); #define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); #define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
#define DO16(buf) DO8(buf,0); DO8(buf,8); #define DO16(buf) DO8(buf,0); DO8(buf,8);
} }
end. 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; Unit iminfutil;
{ types and macros common to blocks and codes { types and macros common to blocks and codes
Copyright (C) 1995-1998 Mark Adler Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is part of the implementation of the compression library and is
subject to change. subject to change.
Pascal tranlastion Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt For conditions of distribution and use, see copyright notice in readme.txt
} }
interface interface
{$I imzconf.inc} {$I imzconf.inc}
uses uses
imzutil, impaszlib; imzutil, impaszlib;
{ copy as much as possible from the sliding window to the output area } { copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state; function inflate_flush(var s : inflate_blocks_state;
var z : z_stream; var z : z_stream;
r : int) : int; r : int) : int;
{ And'ing with mask[n] masks the lower n bits } { And'ing with mask[n] masks the lower n bits }
const const
inflate_mask : array[0..17-1] of uInt = ( inflate_mask : array[0..17-1] of uInt = (
$0000, $0000,
$0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
$01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff); $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);
{procedure GRABBITS(j : int);} {procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);} {procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);} {procedure NEEDBITS(j : int);}
implementation implementation
{ macros for bit input with no checking and for returning unused bytes } { macros for bit input with no checking and for returning unused bytes }
procedure GRABBITS(j : int); procedure GRABBITS(j : int);
begin begin
{while (k < j) do {while (k < j) do
begin begin
Dec(z^.avail_in); Dec(z^.avail_in);
Inc(z^.total_in); Inc(z^.total_in);
b := b or (uLong(z^.next_in^) shl k); b := b or (uLong(z^.next_in^) shl k);
Inc(z^.next_in); Inc(z^.next_in);
Inc(k, 8); Inc(k, 8);
end;} end;}
end; end;
procedure DUMPBITS(j : int); procedure DUMPBITS(j : int);
begin begin
{b := b shr j; {b := b shr j;
Dec(k, j);} Dec(k, j);}
end; end;
procedure NEEDBITS(j : int); procedure NEEDBITS(j : int);
begin begin
(* (*
while (k < j) do while (k < j) do
begin begin
{NEEDBYTE;} {NEEDBYTE;}
if (n <> 0) then if (n <> 0) then
r :=Z_OK r :=Z_OK
else else
begin begin
{UPDATE} {UPDATE}
s.bitb := b; s.bitb := b;
s.bitk := k; s.bitk := k;
z.avail_in := n; z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
result := inflate_flush(s,z,r); result := inflate_flush(s,z,r);
exit; exit;
end; end;
Dec(n); Dec(n);
b := b or (uLong(p^) shl k); b := b or (uLong(p^) shl k);
Inc(p); Inc(p);
Inc(k, 8); Inc(k, 8);
end; end;
*) *)
end; end;
procedure NEEDOUT; procedure NEEDOUT;
begin begin
(* (*
if (m = 0) then if (m = 0) then
begin begin
{WRAP} {WRAP}
if (q = s.zend) and (s.read <> s.window) then if (q = s.zend) and (s.read <> s.window) then
begin begin
q := s.window; q := s.window;
if LongInt(q) < LongInt(s.read) then if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1) m := uInt(LongInt(s.read)-LongInt(q)-1)
else else
m := uInt(LongInt(s.zend)-LongInt(q)); m := uInt(LongInt(s.zend)-LongInt(q));
end; end;
if (m = 0) then if (m = 0) then
begin begin
{FLUSH} {FLUSH}
s.write := q; s.write := q;
r := inflate_flush(s,z,r); r := inflate_flush(s,z,r);
q := s.write; q := s.write;
if LongInt(q) < LongInt(s.read) then if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1) m := uInt(LongInt(s.read)-LongInt(q)-1)
else else
m := uInt(LongInt(s.zend)-LongInt(q)); m := uInt(LongInt(s.zend)-LongInt(q));
{WRAP} {WRAP}
if (q = s.zend) and (s.read <> s.window) then if (q = s.zend) and (s.read <> s.window) then
begin begin
q := s.window; q := s.window;
if LongInt(q) < LongInt(s.read) then if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1) m := uInt(LongInt(s.read)-LongInt(q)-1)
else else
m := uInt(LongInt(s.zend)-LongInt(q)); m := uInt(LongInt(s.zend)-LongInt(q));
end; end;
if (m = 0) then if (m = 0) then
begin begin
{UPDATE} {UPDATE}
s.bitb := b; s.bitb := b;
s.bitk := k; s.bitk := k;
z.avail_in := n; z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
result := inflate_flush(s,z,r); result := inflate_flush(s,z,r);
exit; exit;
end; end;
end; end;
end; end;
r := Z_OK; r := Z_OK;
*) *)
end; end;
{ copy as much as possible from the sliding window to the output area } { copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state; function inflate_flush(var s : inflate_blocks_state;
var z : z_stream; var z : z_stream;
r : int) : int; r : int) : int;
var var
n : uInt; n : uInt;
p : pBytef; p : pBytef;
q : pBytef; q : pBytef;
begin begin
{ local copies of source and destination pointers } { local copies of source and destination pointers }
p := z.next_out; p := z.next_out;
q := s.read; q := s.read;
{ compute number of bytes to copy as far as end of window } { compute number of bytes to copy as far as end of window }
if ptr2int(q) <= ptr2int(s.write) then if ptr2int(q) <= ptr2int(s.write) then
n := uInt(ptr2int(s.write) - ptr2int(q)) n := uInt(ptr2int(s.write) - ptr2int(q))
else else
n := uInt(ptr2int(s.zend) - ptr2int(q)); n := uInt(ptr2int(s.zend) - ptr2int(q));
if (n > z.avail_out) then if (n > z.avail_out) then
n := z.avail_out; n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK; r := Z_OK;
{ update counters } { update counters }
Dec(z.avail_out, n); Dec(z.avail_out, n);
Inc(z.total_out, n); Inc(z.total_out, n);
{ update check information } { update check information }
if Assigned(s.checkfn) then if Assigned(s.checkfn) then
begin begin
s.check := s.checkfn(s.check, q, n); s.check := s.checkfn(s.check, q, n);
z.adler := s.check; z.adler := s.check;
end; end;
{ copy as far as end of window } { copy as far as end of window }
zmemcpy(p, q, n); zmemcpy(p, q, n);
Inc(p, n); Inc(p, n);
Inc(q, n); Inc(q, n);
{ see if more to copy at beginning of window } { see if more to copy at beginning of window }
if (q = s.zend) then if (q = s.zend) then
begin begin
{ wrap pointers } { wrap pointers }
q := s.window; q := s.window;
if (s.write = s.zend) then if (s.write = s.zend) then
s.write := s.window; s.write := s.window;
{ compute bytes to copy } { compute bytes to copy }
n := uInt(ptr2int(s.write) - ptr2int(q)); n := uInt(ptr2int(s.write) - ptr2int(q));
if (n > z.avail_out) then if (n > z.avail_out) then
n := z.avail_out; n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK; r := Z_OK;
{ update counters } { update counters }
Dec( z.avail_out, n); Dec( z.avail_out, n);
Inc( z.total_out, n); Inc( z.total_out, n);
{ update check information } { update check information }
if Assigned(s.checkfn) then if Assigned(s.checkfn) then
begin begin
s.check := s.checkfn(s.check, q, n); s.check := s.checkfn(s.check, q, n);
z.adler := s.check; z.adler := s.check;
end; end;
{ copy } { copy }
zmemcpy(p, q, n); zmemcpy(p, q, n);
Inc(p, n); Inc(p, n);
Inc(q, n); Inc(q, n);
end; end;
{ update pointers } { update pointers }
z.next_out := p; z.next_out := p;
s.read := q; s.read := q;
{ done } { done }
inflate_flush := r; inflate_flush := r;
end; end;
end. end.

50
Imaging/ZLib/imzconf.inc
View File

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

382
Imaging/ZLib/imzutil.pas
View File

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

256
Imaging/ZLib/readme.txt
View File

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

78
Logging.pas
View File

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

266
MulProvider/UAnimDataProvider.pas
View File

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

202
MulProvider/UArtProvider.pas
View File

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

126
MulProvider/UGumpProvider.pas
View File

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

306
MulProvider/UHueProvider.pas
View File

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

124
MulProvider/ULightProvider.pas
View File

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

258
MulProvider/UMulManager.pas
View File

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

782
MulProvider/UMulProvider.pas
View File

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

212
MulProvider/URadarProvider.pas
View File

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

342
MulProvider/UTileDataProvider.pas
View File

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

138
ResourceBuilder.pas
View File

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

178
Server/UNetState.pas
View File

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

436
Server/UPacketHandlers.pas
View File

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

452
Server/UPackets.pas
View File

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

288
UBufferedStreams.pas
View File

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

508
UEnhancedMemoryStream.pas
View File

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

334
ULinkedList.pas
View File

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

650
UOLib/UArt.pas
View File

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

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