rs26src.zip from torry.net

This commit is contained in:
S Groesz 2020-09-21 23:06:13 +00:00
commit fa01ec3931
79 changed files with 13525 additions and 0 deletions

Binary file not shown.

View File

@ -0,0 +1,66 @@
unit AboutDlgUnit;
{-------------------------------------------------------------------------------
About Dialog Unit
-----------------
The about dialog shows copyright and other information about Resource.
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls, ExtCtrls, ShellAPI;
type
TAboutDlg = class(TForm)
Label1: TLabel;
CopyrightLabel: TLabel;
VersionLabel: TLabel;
Label4: TLabel;
Label5: TLabel;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
procedure FormShow(Sender: TObject);
procedure Label2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
AboutDlg: TAboutDlg;
(**) implementation (**)
uses CreditFormUnit, StructsUnit;
{$R *.DFM}
procedure TAboutDlg.FormShow(Sender: TObject);
begin
VersionLabel.Caption := reSourceVerStr;
CopyrightLabel.Caption := reSourceCopyrightStr;
end;
procedure TAboutDlg.Label2Click(Sender: TObject);
begin
ShellExecute(0, Nil, 'http://gruv.tripod.com/resource/', Nil, Nil, SW_NORMAL);
end;
procedure TAboutDlg.Button1Click(Sender: TObject);
begin
CreditsForm.ShowModal;
end;
end.

Binary file not shown.

View File

@ -0,0 +1,101 @@
unit AddOptionsDlgUnit;
{-------------------------------------------------------------------------------
Add Options Dialog Unit
-----------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
Shown when the user wants to add files to the archive.
Allows user to select files to add to the archive through the use of
a FileList. A directory tree allows the uses to change directory easily.
User can also change drive through a combo box.
No typing in of files to add is required. User need only select the files
to add.
Notes:
The dialog will check if the user selected the archive file itself to
be added. It is impossible to add the archive file to itself so an error
will be reported. The archive file will be deselected from the FileList and
the user can confirm again the files he selected.
This check is only done when the OK button is pressed because it is the most
efficient implementation for the set of controls. There are no support events
for "OnSelectChange" or similar events.
Not supported:
Directories cannot be added to the archive. To add all files in a directory,
select all of them in the FileList.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls, FileCtrl;
type
TAddOptionsDlg = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
DirectoryListBox: TDirectoryListBox;
FileListBox: TFileListBox;
DriveComboBox: TDriveComboBox;
procedure FormCreate(Sender: TObject);
procedure OKBtnClick(Sender: TObject);
private
public
{set parameters before calling for error check}
archive_file_folder, archive_file_name: string;
end;
var
AddOptionsDlg: TAddOptionsDlg;
(**) implementation (**)
{$R *.DFM}
procedure TAddOptionsDlg.FormCreate(Sender: TObject);
begin
{$IFDEF DEBUG}
//DirectoryListBox.Directory := 'c:\ctest\corpus';
{$ENDIF}
end;
procedure TAddOptionsDlg.OKBtnClick(Sender: TObject);
var
i: integer;
begin
// Check that the archive file is not added in
// The directory format stored in FileListBox.Directory does not include
// the back slash, so it must be added
if (CompareText(FileListBox.Directory + '\', archive_file_folder) = 0) then
begin
for i := 0 to FileListBox.Items.Count-1 do
begin
if FileListBox.Selected[i] then
if (CompareText(FileListBox.Items[i], archive_file_name) = 0) then
begin
// found the archive file that was selected
// show message box to deselect it
Application.MessageBox('You have selected the archive file. It will be deselected.',
'Select Error', 0);
// deselect the file
FileListBox.Selected[i] := false;
// prevent the form from closing for the user to confirm selection again
ModalResult := 0;
break;
end;
end;
end;
end;
end.

Binary file not shown.

View File

@ -0,0 +1,72 @@
unit BrowseForDirUnit;
{-------------------------------------------------------------------------------
Browse for Dir Unit
-------------------
Contains a form which allows the user to select a directory by means of
a directory tree.
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Used in:
ConigDialog, where the user selects the custom temp directory.
Usage:
retrieve the directory from the directory property.
The dialog box will open in the current directory.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, FileCtrl;
type
TBrowseForDirForm = class(TForm)
DirectoryListBox: TDirectoryListBox;
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
Label1: TLabel;
Label2: TLabel;
procedure OKBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
fdirectory: string;
public
property directory: string read fdirectory;
end;
var
BrowseForDirForm: TBrowseForDirForm;
(**) implementation (**)
Uses Main;
{$R *.DFM}
procedure TBrowseForDirForm.OKBtnClick(Sender: TObject);
begin
fdirectory := DirectoryListBox.Directory;
end;
procedure TBrowseForDirForm.CancelBtnClick(Sender: TObject);
begin
fdirectory := '';
end;
procedure TBrowseForDirForm.FormShow(Sender: TObject);
begin
CentreFormToMain(Self);
end;
end.

Binary file not shown.

View File

@ -0,0 +1,204 @@
unit CompressionStatsDlgUnit;
{-------------------------------------------------------------------------------
Compression Statistics Dialog Unit
----------------------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
The compression stats dialog shows compression stats and averages for the
files in the archive.
Useful for comparing against other archivers.
Features:
Able to print out the compression stats.
Font can be changed.
Workings:
The stats are calculated just before the form is shown. (OnShow)
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons, ComCtrls;
type
TCompressionStatsDlg = class(TForm)
RichEdit: TRichEdit;
PrintDialog: TPrintDialog;
MainMenu: TMainMenu;
File1: TMenuItem;
MIPrint: TMenuItem;
MIExit: TMenuItem;
FontDialog: TFontDialog;
RichEditPopup: TPopupMenu;
MIFont: TMenuItem;
N1: TMenuItem;
MICopytoClipboard: TMenuItem;
procedure MIPrintClick(Sender: TObject);
procedure MIExitClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FontDialogApply(Sender: TObject; Wnd: Integer);
procedure MIFontClick(Sender: TObject);
procedure MICopytoClipboardClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
CompressionStatsDlg: TCompressionStatsDlg;
(**) implementation (**)
uses Main, ArchiveHeadersUnit, StructsUnit;
{$R *.DFM}
procedure TCompressionStatsDlg.MIPrintClick(Sender: TObject);
begin
if PrintDialog.Execute then
begin
// print the statistics
RichEdit.Print('Caption');
end;
end;
procedure TCompressionStatsDlg.MIExitClick(Sender: TObject);
begin
Close;
end;
procedure TCompressionStatsDlg.FormShow(Sender: TObject);
procedure AddColLine(const s: string);
begin
// The tabs have to be set for every paragraph in Rich Edit.
// Each line is a paragraph, so the tabs have to be set for every line.
with RichEdit do
begin
SelStart := length(Text);
With Paragraph do
begin
Tab[0] := 100; // filename
Tab[1] := Tab[0] + 80; // uncompressed
Tab[2] := Tab[1] + 80; // compressed
Tab[3] := Tab[2] + 80; // ratio
Tab[4] := Tab[3] + 80; // bits per byte
end;
Lines.Add(s);
end;
end;
var
i: integer;
CentralFileHeader: TCentralFileHeader;
s, ws: string;
total_bits_per_byte: extended;
bits_per_byte: extended;
compression_ratio, total_ratio: integer; // ratios
total_raw_size, total_compressed_size: integer;
num_files: integer;
begin
CentreFormToMain(Self);
with RichEdit.Lines, MainForm do
begin
num_files := Resource1.ArchiveMan.ArchiveFile.CentralDir.Count;
total_bits_per_byte := 0;
total_ratio := 0;
total_raw_size := 0;
total_compressed_size := 0;
Clear;
Add('reSource Engine ' + reSourceVerStr);
Add('Burrows Wheeler Transformation (BWT) Compression');
Add('');
Add('Compression statistics for file: ' + Resource1.ArchiveMan.archive_file_full_path);
Add('');
if (num_files > 0) then
begin
AddColLine('File name' + #9 + 'Raw size' + #9 + 'Compressed' + #9 + 'Ratio' + #9 + 'Bits per byte');
AddColLine('---------' + #9 + '--------' + #9 + '----------' + #9 + '-----' + #9 + '-------------');
for i := 0 to num_files-1 do
begin
CentralFileHeader := Resource1.ArchiveMan.ArchiveFile.CentralDir[i] as TCentralFileHeader;
with CentralFileHeader do
begin
// update bits per byte
bits_per_byte := GetBitsPerByte(compressed_size, uncompressed_size);
total_bits_per_byte := total_bits_per_byte + bits_per_byte;
// update compression ratio
compression_ratio := GetCompressionRatio(compressed_size, uncompressed_size);
inc(total_ratio, compression_ratio);
// update totals
inc(total_raw_size, uncompressed_size);
inc(total_compressed_size, compressed_size);
s := '';
s := filename + #9 +
IntToStr(uncompressed_size) + #9 +
IntToStr(compressed_size) + #9 +
IntToStr(compression_ratio) + '%' + #9 +
GetBitsPerByteStr(compressed_size, uncompressed_size);
AddColLine(s);
end;
end;
Str((total_bits_per_byte / num_files):5:3 {(total_compressed_size * 8 / total_raw_size):5:3}, ws);
s := 'Average' + #9 +
IntToStr(total_raw_size) + #9 +
IntToStr(total_compressed_size) + #9 +
IntToStr(total_ratio div num_files) + '%' + #9 + // add average ratio
ws; // add average bits per byte
AddColLine('---------' + #9 + '------------' + #9 + '----------' + #9 + '-----' + #9 + '-------------');
AddColLine(s);
Add('');
Add('Number of files: ' + IntToStr(num_files));
end
else
begin
Add('There are no files in this archive.');
end;
end; {with}
end;
procedure TCompressionStatsDlg.FontDialogApply(Sender: TObject;
Wnd: Integer);
begin
RichEdit.Font := FontDialog.Font;
end;
procedure TCompressionStatsDlg.MIFontClick(Sender: TObject);
begin
FontDialog.Font := RichEdit.Font;
if FontDialog.Execute then
RichEdit.Font := FontDialog.Font;
end;
procedure TCompressionStatsDlg.MICopytoClipboardClick(Sender: TObject);
begin
MainForm.ShowBusy;
with RichEdit do
begin
SelectAll; // select everything then copy to clipboard
CopyToClipBoard;
SelLength := 0; // deselect everything
end;
MainForm.ShowReady;
end;
end.

Binary file not shown.

View File

@ -0,0 +1,144 @@
unit ConfigDlgUnit;
{-------------------------------------------------------------------------------
Configuration Dialog Unit
-------------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
The interface for ConfigMan.
Anything that is configurable by the user is exposed through ConfigDlg
It will also check if the input is valid.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls;
type
TConfigDlg = class(TForm)
PageControl: TPageControl;
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
TabSheet1: TTabSheet;
GroupBox1: TGroupBox;
RBUseWindowsDefaultTempDir: TRadioButton;
RBUseCustomTempDir: TRadioButton;
WinDefTempDirLabel: TLabel;
TabSheet2: TTabSheet;
GroupBox2: TGroupBox;
XBConfirmOnDelete: TCheckBox;
CustomTempDirBtn: TBitBtn;
CustomTempDirLabel: TLabel;
procedure FormActivate(Sender: TObject);
procedure CustomTempDirBtnClick(Sender: TObject);
procedure OKBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
public
end;
var
ConfigDlg: TConfigDlg;
(**) implementation (**)
uses ConfigUnit, BrowseForDirUnit, EDosUnit, Main;
{$R *.DFM}
{-------------------------------------------------------------------------------
FormActivate
------------
Init all the fields with their respective data from ConfigMan.
-------------------------------------------------------------------------------}
procedure TConfigDlg.FormActivate(Sender: TObject);
begin
// read in the config from ConfigMan
with ConfigMan do
begin
// temporary directory
WinDefTempDirLabel.Caption := ConfigMan.default_temp_dir;
if (temp_dir = default_temp_dir) then
RBUseWindowsDefaultTempDir.Checked := true
else
begin
RBUseCustomTempDir.Checked := true;
CustomTempDirLabel.Caption := temp_dir;
end;
// confirmation
XBConfirmOnDelete.Checked := confirm_on_delete;
end;
end;
{-------------------------------------------------------------------------------
CustomTempDirBtnClick
---------------------
Let the user choose their own cutom directory using BrowseForDirForm.
Will auto select the radio button for custom temp dir if user has not done so
-------------------------------------------------------------------------------}
procedure TConfigDlg.CustomTempDirBtnClick(Sender: TObject);
var
dir: string;
begin
if (BrowseForDirForm.ShowModal = mrOK) then
begin
dir := BrowseForDirForm.Directory;
EDos.AddSlash(dir);
CustomTempDirLabel.Caption := dir;
RBUseCustomTempDir.Checked := true;
end
else
RBUseWindowsDefaultTempDir.Checked := true;
end;
{-------------------------------------------------------------------------------
OKBtnClick
----------
Save the config to ConfigMan
-------------------------------------------------------------------------------}
procedure TConfigDlg.OKBtnClick(Sender: TObject);
begin
// save the config to ConfigMan
// confirm on delete
ConfigMan.confirm_on_delete := XBConfirmOnDelete.Checked;
// temporary directory
if (RBUseWindowsDefaultTempDir.Checked) then
ConfigMan.temp_dir := ConfigMan.default_temp_dir
else
begin
// check the temp_dir is not empty
if (CustomTempDirLabel.Caption = '') then
begin
Application.MessageBox('The custom temporary directory is invalid. Please correct it.', 'Error', 0);
PageControl.ActivePage := TabSheet1;
ModalResult := 0;
end
else
ConfigMan.temp_dir := CustomTempDirLabel.Caption;
end;
end;
procedure TConfigDlg.FormShow(Sender: TObject);
begin
CentreFormToMain(Self);
end;
end.

View File

@ -0,0 +1,97 @@
unit ConfigUnit;
{-------------------------------------------------------------------------------
Configuration Unit
------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
All configurable variables are stored in the ConfigMan class.
The user uses the interface, ConfigDlg to change these values.
-------------------------------------------------------------------------------}
(**) interface (**)
uses SysUtils, Windows;
type
TConfigMan = class
private
FShowDebugForm: boolean;
procedure EnableDebugForm(enable: boolean);
public
ClipDebugFormToMainForm: boolean;
temp_dir: string;
default_temp_dir: string;
confirm_on_delete: boolean;
property ShowDebugForm: boolean read FShowDebugForm write EnableDebugForm;
constructor Create;
procedure ResetDefaults;
end;
var
ConfigMan: TConfigMan;
(**) implementation (**)
uses DebugFormUnit, EDosUnit;
constructor TConfigMan.Create;
begin
inherited Create;
ResetDefaults;
end;
procedure TConfigMan.ResetDefaults;
var
dir: PChar;
begin
ShowDebugForm := false;
ClipDebugFormToMainForm := true;
// get the windows default temp dir
dir := StrAlloc(MAX_PATH + 1);
GetTempPath(MAX_PATH, dir);
default_temp_dir := dir;
StrDispose(dir);
EDos.AddSlash(default_temp_dir);
temp_dir := default_temp_dir;
confirm_on_delete := false;
end;
procedure TConfigMan.EnableDebugForm(enable: boolean);
begin
FShowDebugForm := enable;
if (enable = false) then
begin
if Assigned(DebugForm) then
begin
DebugForm.Free;
DebugForm := nil;
end;
end
else
begin
DebugForm := TDebugForm.Create(nil);
DebugForm.Show;
end;
end;
initialization
ConfigMan := TConfigMan.Create;
finalization
ConfigMan.Free;
end.

View File

@ -0,0 +1,99 @@
object CreditsForm: TCreditsForm
Left = 250
Top = 171
BorderStyle = bsDialog
Caption = 'Credits'
ClientHeight = 276
ClientWidth = 369
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo1: TMemo
Left = 9
Top = 14
Width = 352
Height = 211
Lines.Strings = (
'read readme.txt for more info'
'read resource.txt for description of files and more information ' +
'about'
'understanding this whole program.'
''
''
'credits:'
'i would like to thank:'
''
' Mark Nelson, who with his wonderful book,'
''
' Michael Burrows and David J. Wheeler for the block sorting'
'algorithm.'
''
' Peter Fenwick'#39's for his tuned structured arithmetic encoder'
''
' Kunihiko Sadakane'#39's Suffix sort, which rocks, and imho is th' +
'e'
'best'
' general purpose sorter for the block sorting algorithm.'
''
' Angus Johnson, Anders Melander & Graham Wideman for their'
'wonderful, totally incredible drag and drop package. I had'
'managed to incorporate the older version of their package into'
'resource and it turned instantly totally drag and drop to and fr' +
'om'
'explorer.. simply amazing.'
''
' Julian Seward, author of BZip. BZip really inspired me to wri' +
'te on,'
'although i didn'#39't really understand much of the '#39'c'#39' implementati' +
'on of'
'the BWT algorithm... ;-)'
''
''
' the author(s) of the delphi superpage and delphi deli, withou' +
't'
'which i may not even have been able to have finished.'
''
''
' and of course Inprise for creating Delphi, which is totally r' +
'adical!'
' (and Inprise: when are we gonna have inline functions? it wil' +
'l'
'surely'
'speed up delphi apps alot!)'
''
' loop guru for excellent groove and inspirational music. if yo' +
'u'
'haven'#39't listened to them, you don'#39't know what real cross cultura' +
'l,'
#39'no'
'barriers'#39' is...')
ScrollBars = ssVertical
TabOrder = 0
end
object Button1: TButton
Left = 288
Top = 240
Width = 75
Height = 25
Cancel = True
Caption = 'Close'
ModalResult = 1
TabOrder = 1
end
end

View File

@ -0,0 +1,39 @@
unit CreditFormUnit;
{-------------------------------------------------------------------------------
Credits Form
Shows credits.
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
-------------------------------------------------------------------------------}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TCreditsForm = class(TForm)
Memo1: TMemo;
Button1: TButton;
private
{ Private declarations }
public
{ Public declarations }
end;
var
CreditsForm: TCreditsForm;
implementation
{$R *.DFM}
end.

Binary file not shown.

View File

@ -0,0 +1,92 @@
unit DebugFormUnit;
{-------------------------------------------------------------------------------
DebugFormUnit
-------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
Currently defunct.
Used for showing the status or stage of the compression. Useful to detect
for stalls or 'hangs' that may occur (and many did).
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TDebugForm = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
ArrowImage: TImage;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure DoingSorting;
procedure DoingMTF;
procedure DoingTransform;
procedure DoingAriCompress;
end;
var
DebugForm: TDebugForm;
(**) implementation (**)
uses ConfigUnit;
{$R *.DFM}
const
ArrowInitialTop = 15;
ArrowMoveHeight = 25;
procedure TDebugForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
DebugForm := nil;
ConfigMan.ShowDebugForm := false;
end;
procedure TDebugForm.DoingSorting;
begin
ArrowImage.Top := ArrowInitialTop;
Application.ProcessMessages;
end;
procedure TDebugForm.DoingTransform;
begin
ArrowImage.Top := ArrowInitialTop + ArrowMoveHeight;
Application.ProcessMessages;
end;
procedure TDebugForm.DoingMTF;
begin
ArrowImage.Top := ArrowInitialTop + ArrowMoveHeight*2;
Application.ProcessMessages;
end;
procedure TDebugForm.DoingAriCompress;
begin
ArrowImage.Top := ArrowInitialTop + ArrowMoveHeight*3;
Application.ProcessMessages;
end;
end.

Binary file not shown.

View File

@ -0,0 +1,92 @@
unit ExtractOptionsDlgUnit;
{-------------------------------------------------------------------------------
ExtractOptionsDlgUnit
---------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Desc:
Shows a directory list that allows the user to select the directory
to extract to.
-------------------------------------------------------------------------------}
{ if not EDos.FileExists(DriveComboBox.drive + ':') then
begin
Application.MessageBox(PChar('The drive ' + DriveComboBox.drive + ' is not available. Please select another drive.'),
'IO Error', 0);
end;}
(**) interface (**)
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls, FileCtrl, ComCtrls, Dialogs;
type
TExtractOptionsDlg = class(TForm)
GroupBox1: TGroupBox;
RBExtractAllFiles: TRadioButton;
RBExtractSelectedFiles: TRadioButton;
Label1: TLabel;
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
DirTree: TDirectoryListBox;
DriveComboBox: TDriveComboBox;
procedure DirectoryListBoxChange(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
public
function ExtractDir: string;
end;
var
ExtractOptionsDlg: TExtractOptionsDlg;
(**) implementation (**)
uses EDosUnit, Main;
{$R *.DFM}
function TExtractOptionsDlg.ExtractDir: string;
begin
result := DirTree.Directory;
EDos.AddSlash(result);
end;
procedure TExtractOptionsDlg.DirectoryListBoxChange(Sender: TObject);
begin
//ExtractDirEdit.Text := DirectoryListBox.Directory;
end;
procedure TExtractOptionsDlg.FormActivate(Sender: TObject);
begin
//ExtractDirEdit.Text := DirectoryListBox.Directory;
end;
procedure TExtractOptionsDlg.FormCreate(Sender: TObject);
begin
{$IFDEF DEBUG}
//DirTree.Directory := 'c:\ctestout';
{$ENDIF}
end;
procedure TExtractOptionsDlg.FormShow(Sender: TObject);
begin
CentreFormToMain(Self);
end;
end.

Binary file not shown.

View File

@ -0,0 +1,110 @@
unit FileAttrDlgUnit;
{-------------------------------------------------------------------------------
File Attribute Dialog Unit
--------------------------
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Interface for the user to change the file attributes in the archive.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons,
ArchiveHeadersUnit;
type
TFileAttrDlg = class(TForm)
NameEdit: TEdit;
Label1: TLabel;
Label2: TLabel;
GroupBox1: TGroupBox;
XBReadOnly: TCheckBox;
XBHidden: TCheckBox;
XBArchive: TCheckBox;
XBSystem: TCheckBox;
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
LastModifiedDateLabel: TLabel;
Label3: TLabel;
SizeLabel: TLabel;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
function Execute(CentralFileHeader: TCentralFileHeader): integer;
procedure GetCentralFileHeader(CentralFileHeader: TCentralFileHeader);
end;
var
FileAttrDlg: TFileAttrDlg;
(**) implementation (**)
uses Main;
{$R *.DFM}
function TFileAttrDlg.Execute(CentralFileHeader: TCentralFileHeader): integer;
var
s: string;
begin
// initialize fields with info from CentralFileHeader
with CentralFileHeader do
begin
// name
NameEdit.Text := FileName;
// size
SizeLabel.Caption := Format('%d', [uncompressed_size]) + ' bytes';
// date
DateTimeToString(s, 'dddd, mmmm d, yyyy hh:nn:ss AM/PM', FileDateToDateTime(time));
LastModifiedDateLabel.Caption := s;
// attributes
XBReadOnly.Checked := (attr and faReadOnly <> 0);
XBArchive.Checked := (attr and faArchive <> 0);
XBHidden.Checked := (attr and faHidden <> 0);
XBSystem.Checked := (attr and faSysFile <> 0);
end;
result := ShowModal;
end;
{-------------------------------------------------------------------------------
GetCentralFileHeader
--------------------
Updates CentralFileHeader with the data in the dialog
-------------------------------------------------------------------------------}
procedure TFileAttrDlg.GetCentralFileHeader(CentralFileHeader: TCentralFileHeader);
var
nattr: integer;
begin
// store new attribute in nattr
nattr := 0;
if (XBReadOnly.Checked) then nattr := nattr or faReadOnly;
if (XBArchive.Checked) then nattr := nattr or faArchive;
if (XBHidden.Checked) then nattr := nattr or faHidden;
if (XBSystem.Checked) then nattr := nattr or faSysFile;
with CentralFileHeader do
begin
FileName := NameEdit.Text;
attr := nattr;
end;
end;
procedure TFileAttrDlg.FormShow(Sender: TObject);
begin
CentreFormToMain(Self);
end;
end.

Binary file not shown.

View File

@ -0,0 +1,76 @@
unit ProgStatsDlgUnit;
{-------------------------------------------------------------------------------
Program Statistics Dialog
-------------------------
show program statistics
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
Use:
To check if memory is enough, or if we are out of memory.
To help in debugging if the user reports a bug to the developer.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TProgStatsDlg = class(TForm)
RichEdit: TRichEdit;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
ProgStatsDlg: TProgStatsDlg;
(**) implementation (**)
uses Main, StructsUnit;
{$R *.DFM}
procedure TProgStatsDlg.FormShow(Sender: TObject);
var
HeapStatus: THeapStatus;
begin
CentreFormToMain(Self);
// fill in the program stats richedit
HeapStatus := GetHeapStatus;
with RichEdit.Lines, RichEdit, HeapStatus do
begin
Clear;
Add('reSource ' + reSourceVerStr);
Add('Burrows Wheeler Transformation (BWT) Compressor');
Add(reSourceCopyrightStr);
Add('');
Add('Engine:');
Add('Block Size = ' + IntToStr(BlockSize));
Add('');
Add('Program:');
Add('rs Total Allocated = ' + IntToStr(TotalAllocated));
Add('Heap manager overhead = ' + IntToStr(Overhead));
Add('');
Add('System:');
Add('Win Total Address Space = ' + IntToStr(TotalAddrSpace));
Add('Win Total Uncommitted = ' + IntToStr(TotalUncommitted));
SelStart := 0;
end;
end;
end.

BIN
Archiver Demo/RSIcon2.ico Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 766 B

View File

@ -0,0 +1,5 @@
//SUPPRESSIONPROJ:ReSource
//VERSION:5.00
//ENABLE:Yes
!include DELPHI.SUP

View File

@ -0,0 +1,35 @@
-$A+
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J+
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q+
-$R+
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-LE"c:\borland\delphi5\Projects\Bpl"
-LN"c:\borland\delphi5\Projects\Bpl"

109
Archiver Demo/ReSource.dof Normal file
View File

@ -0,0 +1,109 @@
[Compiler]
A=1
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=1
R=1
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=
UnitOutputDir=
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=
Packages=VCL50;VCLX50;VCLSMP50;VCLDB50;VCLADO50;ibevnt50;VCLBDE50;VCLDBX50;QRPT50;TEEUI50;TEEDB50;TEE50;DSS50;TEEQR50;VCLIB50;VCLMID50;VCLIE50;INETDB50;INET50;NMFAST50;WEBMID50;dclocx50;dclaxserver50;DragDropD5;ColorPicker;preview;Icsdel50;galoled
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
[Language]
ActiveLang=
ProjectLang=$00000409
RootDir=
[Version Info]
IncludeVerInfo=1
AutoIncBuild=0
MajorVer=2
MinorVer=6
Release=0
Build=0
Debug=0
PreRelease=1
Special=0
Private=0
DLL=0
Locale=1033
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=Resource
FileVersion=2.6.0.0
InternalName=Resource experimental
LegalCopyright=Victor K
LegalTrademarks=
OriginalFilename=Resource
ProductName=Resource
ProductVersion=1.0.0.0
Comments=The BWT Block compressor
[HistoryLists\hlUnitAliases]
Count=1
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[HistoryLists\hlSearchPath]
Count=1
Item0=C:\Save\Delphi\resource\Component
[HistoryLists\hlUnitOutputDirectory]
Count=1
Item0=C:\temp\rs
[HistoryLists\hlOutputDirectorry]
Count=2
Item0=C:\temp\rs
Item1=c:\temp\cg
[HistoryLists\hlBPLOutput]
Count=1
Item0=c:\temp\rs

View File

@ -0,0 +1,34 @@
program reSource;
uses
Forms,
main in 'main.pas' {MainForm},
DebugFormUnit in 'DebugFormUnit.pas' {DebugForm},
ConfigUnit in 'ConfigUnit.pas',
ExtractOptionsDlgUnit in 'ExtractOptionsDlgUnit.pas' {ExtractOptionsDlg},
AddOptionsDlgUnit in 'AddOptionsDlgUnit.pas' {AddOptionsDlg},
AboutDlgUnit in 'AboutDlgUnit.pas' {AboutDlg},
ConfigDlgUnit in 'ConfigDlgUnit.pas' {ConfigDlg},
FileAttrDlgUnit in 'FileAttrDlgUnit.pas' {FileAttrDlg},
BrowseForDirUnit in 'BrowseForDirUnit.pas' {BrowseForDirForm},
CompressionStatsDlgUnit in 'CompressionStatsDlgUnit.pas' {CompressionStatsDlg},
ProgStatsDlgUnit in 'ProgStatsDlgUnit.pas' {ProgStatsDlg},
CreditFormUnit in 'CreditFormUnit.pas' {CreditsForm};
{$R *.RES}
begin
Application.Initialize;
Application.Title := 'reSource v2.6';
Application.CreateForm(TMainForm, MainForm);
Application.CreateForm(TExtractOptionsDlg, ExtractOptionsDlg);
Application.CreateForm(TAddOptionsDlg, AddOptionsDlg);
Application.CreateForm(TAboutDlg, AboutDlg);
Application.CreateForm(TConfigDlg, ConfigDlg);
Application.CreateForm(TFileAttrDlg, FileAttrDlg);
Application.CreateForm(TBrowseForDirForm, BrowseForDirForm);
Application.CreateForm(TCompressionStatsDlg, CompressionStatsDlg);
Application.CreateForm(TProgStatsDlg, ProgStatsDlg);
Application.CreateForm(TCreditsForm, CreditsForm);
Application.Run;
end.

282
Archiver Demo/ReSource.dsk Normal file
View File

@ -0,0 +1,282 @@
[Closed Files]
File_0=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\ProgStatsDlgUnit.pas',0,1,1,1,13,1,0
File_1=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\main.pas',0,1,1,1,13,1,0
File_2=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\FileAttrDlgUnit.pas',0,1,1,1,12,1,0
File_3=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\ExtractOptionsDlgUnit.pas',0,1,1,1,12,1,0
File_4=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\DebugFormUnit.pas',0,1,1,1,12,1,0
File_5=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\CreditFormUnit.pas',0,1,1,1,12,0,0
File_6=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\ConfigUnit.pas',0,1,1,1,12,0,0
File_7=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\ConfigDlgUnit.pas',0,1,1,1,12,0,0
File_8=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\CompressionStatsDlgUnit.pas',0,1,1,1,12,0,0
File_9=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\BrowseForDirUnit.pas',0,1,1,1,14,1,0
[Modules]
Module0=C:\Save\Delphi\resource\Archiver Demo\ReSource.dpr
Count=1
EditWindowCount=1
[C:\Save\Delphi\resource\Archiver Demo\ReSource.dpr]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[C:\Save\Delphi\resource\Archiver Demo\ProjectGroup1.bpg]
FormState=0
FormOnTop=0
[EditWindow0]
ViewCount=1
CurrentView=0
View0=0
CodeExplorer=CodeExplorer@EditWindow0
MessageView=MessageView@EditWindow0
Create=1
Visible=1
State=2
Left=229
Top=232
Width=564
Height=334
MaxLeft=-4
MaxTop=100
MaxWidth=808
MaxHeight=476
ClientWidth=800
ClientHeight=449
LeftPanelSize=0
LeftPanelClients=CodeExplorer@EditWindow0
LeftPanelData=00000400010000000C000000436F64654578706C6F7265720000000000000000000000000000000000FFFFFFFF
RightPanelSize=0
BottomPanelSize=77
BottomPanelClients=CallStackWindow,WatchWindow,MessageView@EditWindow0
BottomPanelData=00000400020000000F00000043616C6C537461636B57696E646F770B000000576174636857696E646F772003000000000000004D000000000000000100000000200300000B0000004D65737361676556696577FFFFFFFF
[View0]
Module=C:\Save\Delphi\resource\Archiver Demo\ReSource.dpr
CursorX=59
CursorY=9
TopLine=1
LeftCol=1
[Watches]
Count=0
[Breakpoints]
Count=1
Breakpoint0='C:\Save\Delphi\resource\Component\BWTCompressUnit.pas',299,'',0,1,'',1,0,0,'',1,'','',''
[AddressBreakpoints]
Count=0
[Main Window]
Create=1
Visible=1
State=2
Left=0
Top=28
Width=777
Height=105
MaxLeft=-1
MaxTop=-1
MaxWidth=808
MaxHeight=105
ClientWidth=800
ClientHeight=78
[ProjectManager]
Create=1
Visible=0
State=0
Left=155
Top=124
Width=448
Height=413
MaxLeft=-1
MaxTop=-1
ClientWidth=440
ClientHeight=391
TBDockHeight=303
LRDockWidth=510
Dockable=1
[CPUWindow]
Create=1
Visible=0
State=0
Left=10
Top=108
Width=732
Height=433
MaxLeft=-1
MaxTop=-1
ClientWidth=724
ClientHeight=406
DumpPane=79
DisassemblyPane=349
RegisterPane=231
FlagPane=64
[AlignmentPalette]
Create=1
Visible=0
State=0
Left=50
Top=119
Width=156
Height=80
MaxLeft=-1
MaxTop=-1
ClientWidth=150
ClientHeight=60
[PropertyInspector]
Create=1
Visible=1
State=0
Left=304
Top=200
Width=236
Height=303
MaxLeft=-1
MaxTop=-1
ClientWidth=226
ClientHeight=279
TBDockHeight=494
LRDockWidth=164
Dockable=0
SplitPos=108
ArrangeBy=Name
SelectedItem=
ExpandedItems=BorderIcons,Brush,Dragtypes,Font.Style,Options,Pen
HiddenCategories=Legacy
ShowStatusBar=1
[WatchWindow]
Create=1
Visible=0
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=421
Dockable=1
[BreakpointWindow]
Create=1
Visible=0
State=0
Left=181
Top=255
Width=453
Height=197
MaxLeft=-1
MaxTop=-1
ClientWidth=445
ClientHeight=175
TBDockHeight=197
LRDockWidth=453
Dockable=1
Column0Width=100
Column1Width=75
Column2Width=225
Column3Width=40
Column4Width=75
Column5Width=75
[CallStackWindow]
Create=1
Visible=0
State=0
Left=412
Top=0
Width=388
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=388
ClientHeight=77
TBDockHeight=77
LRDockWidth=379
Dockable=1
[LocalVarsWindow]
Create=1
Visible=0
State=0
Left=273
Top=197
Width=421
Height=192
MaxLeft=-1
MaxTop=-1
ClientWidth=413
ClientHeight=170
TBDockHeight=192
LRDockWidth=421
Dockable=1
[ToDo List]
Create=1
Visible=0
State=0
Left=154
Top=175
Width=470
Height=250
MaxLeft=-1
MaxTop=-1
ClientWidth=462
ClientHeight=228
TBDockHeight=250
LRDockWidth=470
Dockable=1
Column0Width=260
Column1Width=30
Column2Width=100
Column3Width=70
Column4Width=70
SortOrder=4
ShowHints=1
ShowChecked=1
[CodeExplorer@EditWindow0]
Create=1
Visible=0
State=0
Left=0
Top=12
Width=200
Height=348
MaxLeft=-1
MaxTop=-1
ClientWidth=200
ClientHeight=348
TBDockHeight=305
LRDockWidth=200
Dockable=1
[MessageView@EditWindow0]
Create=1
Visible=1
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=443
Dockable=1
[DockHosts]
DockHostCount=0

View File

@ -0,0 +1,42 @@
-$A+
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J+
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q+
-$R+
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-E"c:\temp\cg"
-N"c:\temp\cg"
-LE"c:\borland\delphi5\Projects\Bpl"
-LN"c:\borland\delphi5\Projects\Bpl"
-U"c:\save\delphi\flib"
-O"c:\save\delphi\flib"
-I"c:\save\delphi\flib"
-R"c:\save\delphi\flib"
-Z

BIN
Archiver Demo/main.dfm Normal file

Binary file not shown.

2018
Archiver Demo/main.pas Normal file

File diff suppressed because it is too large Load Diff

BIN
Archiver Demo/reSource.res Normal file

Binary file not shown.

204
Archiver Demo2/Main.dfm Normal file
View File

@ -0,0 +1,204 @@
object MainForm: TMainForm
Left = 261
Top = 106
BorderStyle = bsDialog
Caption = 'reSource Demo 2'
ClientHeight = 394
ClientWidth = 443
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 8
Top = 8
Width = 335
Height = 13
Caption =
'This demo shows the use of CompressToFile and DecompressFromFile' +
'.'
end
object Label2: TLabel
Left = 8
Top = 24
Width = 312
Height = 13
Caption =
'These procedures compress one file to it'#39's corresponding archiv' +
'e.'
end
object Label3: TLabel
Left = 29
Top = 59
Width = 44
Height = 13
Caption = 'File Path:'
FocusControl = SourceFileEdit
end
object Label4: TLabel
Left = 8
Top = 81
Width = 64
Height = 13
Caption = 'Archive Path:'
FocusControl = ArchiveFileEdit
end
object Label5: TLabel
Left = 148
Top = 374
Width = 131
Height = 18
Caption = 'reSource Demo 2'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold, fsItalic]
ParentFont = False
end
object Bevel1: TBevel
Left = 0
Top = 155
Width = 441
Height = 9
Shape = bsBottomLine
end
object Label6: TLabel
Left = 8
Top = 218
Width = 64
Height = 13
Caption = 'Archive Path:'
FocusControl = DecompressArchiveEdit
end
object Label7: TLabel
Left = 8
Top = 179
Width = 106
Height = 13
Caption = 'Name of file to extract:'
end
object Label8: TLabel
Left = 264
Top = 172
Width = 157
Height = 13
Caption = '(The file must exist in the archive)'
end
object Label9: TLabel
Left = 8
Top = 245
Width = 72
Height = 13
Caption = 'Destination Dir:'
end
object Label10: TLabel
Left = 264
Top = 188
Width = 143
Height = 13
Caption = 'Leave blank to extract all files.'
end
object CompressBtn: TButton
Left = 56
Top = 120
Width = 345
Height = 33
Caption = 'Compress File to Archive'
TabOrder = 4
OnClick = CompressBtnClick
end
object DecompressBtn: TButton
Left = 56
Top = 337
Width = 345
Height = 33
Caption = 'Decompress File From Archive'
TabOrder = 9
OnClick = DecompressBtnClick
end
object SourceFileEdit: TEdit
Left = 80
Top = 54
Width = 321
Height = 21
TabOrder = 0
end
object ArchiveFileEdit: TEdit
Left = 80
Top = 78
Width = 321
Height = 21
TabOrder = 2
end
object BrowseSourceBtn: TButton
Left = 408
Top = 55
Width = 25
Height = 21
Caption = '...'
TabOrder = 1
OnClick = BrowseSourceBtnClick
end
object BrowseArchiveBtn: TButton
Left = 408
Top = 79
Width = 25
Height = 21
Caption = '...'
TabOrder = 3
OnClick = BrowseArchiveBtnClick
end
object DecompressArchiveEdit: TEdit
Left = 88
Top = 215
Width = 313
Height = 21
TabOrder = 6
end
object BrowseBtn2: TButton
Left = 408
Top = 216
Width = 25
Height = 21
Caption = '...'
TabOrder = 7
OnClick = BrowseBtn2Click
end
object ExtractFileNameEdit: TEdit
Left = 124
Top = 175
Width = 133
Height = 21
TabOrder = 5
end
object DirListBox: TDirectoryListBox
Left = 89
Top = 245
Width = 169
Height = 81
ItemHeight = 16
TabOrder = 8
end
object SaveDialog1: TSaveDialog
Filter = 'reSource Archive (*.rs)|*.rs'
Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing]
Title = 'The File To Compress'
Left = 408
Top = 104
end
object OpenDialog1: TOpenDialog
Title = 'Select Archive File. Type a new name to Create a new Archive.'
Left = 400
Top = 24
end
object Resource1: TResource
Left = 8
Top = 104
end
end

113
Archiver Demo2/Main.pas Normal file
View File

@ -0,0 +1,113 @@
unit Main;
{ reSource Demo 2
Demonstrates the use of reSource to compress/decompress one file
at a time.
This behaviour is more similar to like what MS does in some of
their installation disks, where each individual file is compressed.
The main procedures are:
CompressToArchive
DecompressFromArchive
}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,
// engine - include the following units in your app to access TCentralFileHeader etc.
// your search path must contain the dir the units are located in.
ResourceCompUnit,
ArchiveHeadersUnit, ErrorUnit, EDosUnit, ArchiveManagerUnit, StructsUnit,
ExtCtrls, FileCtrl;
type
TMainForm = class(TForm)
Label1: TLabel;
Label2: TLabel;
CompressBtn: TButton;
DecompressBtn: TButton;
Label3: TLabel;
Label4: TLabel;
SourceFileEdit: TEdit;
ArchiveFileEdit: TEdit;
Label5: TLabel;
BrowseSourceBtn: TButton;
BrowseArchiveBtn: TButton;
SaveDialog1: TSaveDialog;
OpenDialog1: TOpenDialog;
Resource1: TResource;
Bevel1: TBevel;
DecompressArchiveEdit: TEdit;
Label6: TLabel;
BrowseBtn2: TButton;
ExtractFileNameEdit: TEdit;
Label7: TLabel;
Label8: TLabel;
DirListBox: TDirectoryListBox;
Label9: TLabel;
Label10: TLabel;
procedure BrowseSourceBtnClick(Sender: TObject);
procedure BrowseArchiveBtnClick(Sender: TObject);
procedure CompressBtnClick(Sender: TObject);
procedure DecompressBtnClick(Sender: TObject);
procedure BrowseBtn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
(**) implementation (**)
{$R *.DFM}
procedure TMainForm.BrowseSourceBtnClick(Sender: TObject);
var
s: string;
begin
if OpenDialog1.Execute then
begin
s := OpenDialog1.FileName;
SourceFileEdit.Text := s;
// suggest a name for the archive file
if ArchiveFileEdit.Text = '' then
ArchiveFileEdit.Text := ChangeFileExt(s, '.rs');
end;
end;
procedure TMainForm.BrowseArchiveBtnClick(Sender: TObject);
begin
if SaveDialog1.Execute then
begin
ArchiveFileEdit.Text := SaveDialog1.FileName;
end;
end;
procedure TMainForm.CompressBtnClick(Sender: TObject);
begin
reSource1.CompressToArchive(SourceFileEdit.Text, ArchiveFileEdit.Text);
end;
procedure TMainForm.DecompressBtnClick(Sender: TObject);
begin
reSource1.DecompressFromArchive(DecompressArchiveEdit.Text, DirListBox.Directory,
ExtractFileNameEdit.Text);
end;
procedure TMainForm.BrowseBtn2Click(Sender: TObject);
begin
{Archive for decompression}
if SaveDialog1.Execute then
begin
DecompressArchiveEdit.Text := SaveDialog1.FileName;
end;
end;
end.

View File

@ -0,0 +1,35 @@
-$A+
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J+
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-LE"c:\borland\delphi5\Projects\Bpl"
-LN"c:\borland\delphi5\Projects\Bpl"

View File

@ -0,0 +1,105 @@
[Compiler]
A=1
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=
UnitOutputDir=
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=
Packages=VCL50;VCLX50;VCLSMP50;VCLDB50;VCLADO50;ibevnt50;VCLBDE50;VCLDBX50;QRPT50;TEEUI50;TEEDB50;TEE50;DSS50;TEEQR50;VCLIB50;VCLMID50;VCLIE50;INETDB50;INET50;NMFAST50;WEBMID50;dclocx50;dclaxserver50;ColorPicker;preview;Icsdel50;galoled;NtfyIcon
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
[Language]
ActiveLang=
ProjectLang=$00000409
RootDir=
[Version Info]
IncludeVerInfo=0
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=0
Build=0
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1033
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=
FileVersion=1.0.0.0
InternalName=
LegalCopyright=
LegalTrademarks=
OriginalFilename=
ProductName=
ProductVersion=1.0.0.0
Comments=
[HistoryLists\hlUnitAliases]
Count=1
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[HistoryLists\hlSearchPath]
Count=2
Item0=c:\temp\rs
Item1=C:\Save\Delphi\resource\Component
[HistoryLists\hlUnitOutputDirectory]
Count=1
Item0=C:\temp\rs
[HistoryLists\hlOutputDirectorry]
Count=1
Item0=C:\temp\rs

View File

@ -0,0 +1,14 @@
program reSourceDemo2;
uses
Forms,
Main in 'Main.pas' {MainForm};
{$R *.RES}
begin
Application.Initialize;
Application.Title := 'reSource Demo 2';
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

View File

@ -0,0 +1,283 @@
[Closed Files]
File_0=SourceModule,'C:\Save\Delphi\resource\Archiver Demo2\Main.pas',0,1,14,3,23,0,0
File_1=SourceModule,'C:\Save\Delphi\resource\Component\BWTExpandUnit.pas',0,1,226,35,234,0,0
File_2=SourceModule,'C:\Save\Delphi\resource\Component\ResourceCompUnit.pas',0,1,268,2,274,0,0
File_3=SourceModule,'C:\Save\Delphi\resource\Component\ArchiveManagerUnit.pas',0,1,479,30,479,0,0
File_4=SourceModule,'C:\Save\Delphi\resource\Component\BWTBaseUnit.pas',0,1,1,1,1,0,0
File_5=SourceModule,'C:\Save\Delphi\resource\Component\BWTCompressUnit.pas',0,1,1,1,1,0,0
File_6=SourceModule,'C:\Save\Delphi\resource\Archiver Demo\main.pas',0,1,1956,14,1959,1,0
File_7=SourceModule,'C:\Save\Delphi\newr2\Component\StructsUnit.pas',0,1,1,1,7,0,0
File_8=SourceModule,'C:\Save\Delphi\newr2\Component\StrucAriEncoderUnit.pas',0,1,1,1,9,0,0
File_9=SourceModule,'C:\Save\Delphi\newr2\Component\StrucAriDecoderUnit.pas',0,1,1,1,9,0,0
[Modules]
Module0=C:\Save\Delphi\resource\Archiver Demo2\reSourceDemo2.dpr
Count=1
EditWindowCount=1
[C:\Save\Delphi\resource\Archiver Demo2\reSourceDemo2.dpr]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[C:\Save\Delphi\resource\Archiver Demo2\ProjectGroup1.bpg]
FormState=0
FormOnTop=0
[EditWindow0]
ViewCount=1
CurrentView=0
View0=0
CodeExplorer=CodeExplorer@EditWindow0
MessageView=MessageView@EditWindow0
Create=1
Visible=1
State=2
Left=229
Top=232
Width=564
Height=334
MaxLeft=-4
MaxTop=100
MaxWidth=808
MaxHeight=476
ClientWidth=800
ClientHeight=449
LeftPanelSize=0
LeftPanelClients=CodeExplorer@EditWindow0
LeftPanelData=00000400010000000C000000436F64654578706C6F7265720000000000000000000000000000000000FFFFFFFF
RightPanelSize=0
BottomPanelSize=0
BottomPanelClients=CallStackWindow,WatchWindow,MessageView@EditWindow0
BottomPanelData=00000400030000000F00000043616C6C537461636B57696E646F770B000000576174636857696E646F770B0000004D657373616765566965772003000000000000004D00000000000000FFFFFFFF
[View0]
Module=C:\Save\Delphi\resource\Archiver Demo2\reSourceDemo2.dpr
CursorX=52
CursorY=10
TopLine=1
LeftCol=1
[Watches]
Count=2
Watch0='CFH.FileName',256,0,18,1,0
Watch1='FileName',256,0,18,1,0
[Breakpoints]
Count=0
[AddressBreakpoints]
Count=0
[Main Window]
Create=1
Visible=1
State=2
Left=0
Top=28
Width=777
Height=105
MaxLeft=-1
MaxTop=-1
MaxWidth=808
MaxHeight=105
ClientWidth=800
ClientHeight=78
[ProjectManager]
Create=1
Visible=0
State=0
Left=155
Top=124
Width=448
Height=413
MaxLeft=-1
MaxTop=-1
ClientWidth=440
ClientHeight=391
TBDockHeight=303
LRDockWidth=510
Dockable=1
[CPUWindow]
Create=1
Visible=0
State=0
Left=10
Top=108
Width=732
Height=433
MaxLeft=-1
MaxTop=-1
ClientWidth=724
ClientHeight=406
DumpPane=79
DisassemblyPane=349
RegisterPane=231
FlagPane=64
[AlignmentPalette]
Create=1
Visible=0
State=0
Left=50
Top=119
Width=156
Height=80
MaxLeft=-1
MaxTop=-1
ClientWidth=150
ClientHeight=60
[PropertyInspector]
Create=1
Visible=1
State=0
Left=304
Top=200
Width=236
Height=303
MaxLeft=-1
MaxTop=-1
ClientWidth=226
ClientHeight=279
TBDockHeight=494
LRDockWidth=164
Dockable=0
SplitPos=108
ArrangeBy=Name
SelectedItem=
ExpandedItems=BorderIcons,Brush,Dragtypes,Font.Style,Options,Pen
HiddenCategories=Legacy
ShowStatusBar=1
[WatchWindow]
Create=1
Visible=0
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=421
Dockable=1
[BreakpointWindow]
Create=1
Visible=0
State=0
Left=181
Top=255
Width=453
Height=197
MaxLeft=-1
MaxTop=-1
ClientWidth=445
ClientHeight=175
TBDockHeight=197
LRDockWidth=453
Dockable=1
Column0Width=100
Column1Width=75
Column2Width=225
Column3Width=40
Column4Width=75
Column5Width=75
[CallStackWindow]
Create=1
Visible=0
State=0
Left=412
Top=0
Width=388
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=388
ClientHeight=77
TBDockHeight=77
LRDockWidth=379
Dockable=1
[LocalVarsWindow]
Create=1
Visible=0
State=0
Left=273
Top=197
Width=421
Height=192
MaxLeft=-1
MaxTop=-1
ClientWidth=413
ClientHeight=170
TBDockHeight=192
LRDockWidth=421
Dockable=1
[ToDo List]
Create=1
Visible=0
State=0
Left=154
Top=175
Width=470
Height=250
MaxLeft=-1
MaxTop=-1
ClientWidth=462
ClientHeight=228
TBDockHeight=250
LRDockWidth=470
Dockable=1
Column0Width=260
Column1Width=30
Column2Width=100
Column3Width=70
Column4Width=70
SortOrder=4
ShowHints=1
ShowChecked=1
[CodeExplorer@EditWindow0]
Create=1
Visible=0
State=0
Left=0
Top=12
Width=200
Height=348
MaxLeft=-1
MaxTop=-1
ClientWidth=200
ClientHeight=348
TBDockHeight=305
LRDockWidth=200
Dockable=1
[MessageView@EditWindow0]
Create=1
Visible=0
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=443
Dockable=1
[DockHosts]
DockHostCount=0

Binary file not shown.

View File

@ -0,0 +1,518 @@
unit ArchiveFileUnit;
{-------------------------------------------------------------------------------
Archive File Unit
-----------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Notes:
Anything related to the file itself physically.
Seek/Read/Write
-------------------------------------------------------------------------------}
(**) interface (**)
uses SysUtils, Classes,
// resource units
bit_file_unit, Contnrs;
type
TArchiveFile = class;
TCentralDir = class(TObjectList)
private
ArchiveFile: TArchiveFile;
central_dir_offset: integer;
// info from end of central dir record
fblock_size: integer;
public
property block_size: integer read fblock_size;
constructor Create(_ArchiveFile: TArchiveFile);
{destructor Destroy; override;}
{procedure Clear;
procedure Delete(Index: Integer);}
// read/write from assigned file
procedure Read;
procedure Write;
procedure WriteToFile(NArchiveFile: TArchiveFile); // write to another archive file
function GetCentralDirOffset: integer;
function SeekToCentralDir: boolean;
function FileNameExists(filename: string): boolean;
end;
TArchiveFile = class(TBitFile)
private
protected
public
CentralDir: TCentralDir;
filename: string;
constructor CreateNew(const _filename: string; OpenExisting: boolean);
//constructor OpenExisting(const _filename: string);
destructor Destroy; override;
procedure ReadString(var s: string);
procedure ReadLongint(var a: longint);
procedure ReadLongword(var a: longword);
procedure WriteString(const s: string);
procedure WriteLongint(const a: longint);
procedure WriteLongword(const a: longword);
// new style function overloading
procedure ReadData(var a: longint); overload;
procedure ReadData(var a: longword); overload;
procedure WriteData(const a: longint); overload;
procedure WriteData(const a: longword); overload;
procedure ReserveSpace(const num_bytes: integer);
{function IsEmptyArchive: boolean;}
// Archive related
procedure SeekToDataStart;
end;
procedure ArchiveFileBlockCopy(SourceFile, DestFile: TArchiveFile; size: integer);
(**) implementation (**)
uses StructsUnit, ErrorUnit, ArchiveHeadersUnit;
{-------------------------------------------------------------------------------
ArchiveFileBlockCopy
--------------------
Works similarly to TStream.CopyFrom but is more efficient in that a bigger
buffer is used (64kbytes).
IN Assertion:
Buffering has been disabled for both files.
The files have been seeked to the position to read/write.
-------------------------------------------------------------------------------}
procedure ArchiveFileBlockCopy(SourceFile, DestFile: TArchiveFile; size: integer);
var
buf: P64kBlock;
bytes_to_read: integer;
const
bufsize = sizeof(T64kBlock);
begin
New(buf);
while (size > 0) do
begin
if (size > bufsize) then
bytes_to_read := bufsize
else
bytes_to_read := size;
dec(size, bytes_to_read);
SourceFile.Read(buf^, bytes_to_read);
DestFile.Write(buf^, bytes_to_read);
end;
Dispose(buf);
end;
(*******************************************************************************
TCentralDir
-----------
Central Directory class
*******************************************************************************)
constructor TCentralDir.Create(_ArchiveFile: TArchiveFile);
begin
inherited Create;
ArchiveFile := _ArchiveFile;
central_dir_offset := -1;
Read;
end;
{-------------------------------------------------------------------------------
GetCentralDirOffset
Returns the central_dir_offset of it has not been read yet.
Desc:
The central directory offset is stored in the last 4 bytes of the file.
It is inefficient to keep reading this porition to get the central directory
offset. So it is cached and stored in central_dir_offset. If it has not
been read yet, a -1 is assigned.
-------------------------------------------------------------------------------}
function TCentralDir.GetCentralDirOffset: integer;
begin
if (central_dir_offset = -1) then
begin
// the offset has not been read in yet
// read it in
// seek to the start of the central directory
with ArchiveFile do
begin
if (Size > 0) then
begin
DisableBuf;
SmartSeek(-4, soFromEnd); // seek to last four bytes
Read(central_dir_offset, 4); // get main_directory_offset
EnableBuf;
end;
end;
end;
result := central_dir_offset;
end;
{-------------------------------------------------------------------------------
SeekToCentralDir
----------------
Seeks to the central dir in the archive file.
returns false if CentralDir does not exist (archive is empty)
-------------------------------------------------------------------------------}
function TCentralDir.SeekToCentralDir: boolean;
begin
if (GetCentralDirOffset >= 0) then
begin
// seek to central directory
with ArchiveFile do
begin
DisableBuf;
SmartSeek(central_dir_offset, soFromBeginning);
EnableBuf;
end;
result := true;
end
else
result := false;
end;
{-------------------------------------------------------------------------------
Read
----
Reads the CentralDir from the archive file
-------------------------------------------------------------------------------}
procedure TCentralDir.Read;
var
ArchiveHeader: TArchiveHeader;
CentralDirEndHeader: TCentralDirEndHeader;
begin
Clear;
with ArchiveFile do
begin
{if not IsEmptyArchive then
begin}
if SeekToCentralDir then
begin
{GetCentralDirOffset;
// seek to central directory
DisableBuf;
SmartSeek(central_dir_offset, soFromBeginning);
EnableBuf;}
// read in the central file headers until an end of central dir rec is encountered
repeat
ArchiveHeader := GetArchiveHeader(ArchiveFile);
if (ArchiveHeader is TCentralFileHeader) then
Add(ArchiveHeader)
else
break;
until false;
CentralDirEndHeader := (ArchiveHeader as TCentralDirEndHeader);
fblock_size := CentralDirEndHeader.block_size;
CentralDirEndHeader.free;
end; // SeekToCentralDir
{end; // if not IsEmptyArchive}
end; // with Archive File
end; // procedure
{-------------------------------------------------------------------------------
WriteToFile
-----------
IN Assertion: The file has been seeked to the correct location to write the
the CentralDir Info.
Writes:
[central file header] ...
[end of central directory record]
-------------------------------------------------------------------------------}
procedure TCentralDir.Write;
begin
WriteToFile(ArchiveFile);
end;
procedure TCentralDir.WriteToFile(NArchiveFile: TArchiveFile);
var
i: integer; // counter
CentralFileHeader: TCentralFileHeader;
CentralDirEndHeader: TCentralDirEndHeader;
begin
// the CentralDirEndHeader will be written last
CentralDirEndHeader := TCentralDirEndHeader.Create;
with CentralDirEndHeader do
begin
block_size := BlockSize;
central_file_header_offset := NArchiveFile.Position;
end;
// write [central file header]
for i := 0 to Count - 1 do
begin
CentralFileHeader := TCentralFileHeader(items[i]);
CentralFileHeader.WriteToFile(NArchiveFile);
end;
CentralDirEndHeader.WriteToFile(NArchiveFile);
CentralDirEndHeader.free;
end;
{-------------------------------------------------------------------------------
FileNameExists
--------------
returns true if a CentralFileHeader with the same filename exists
Notes:
Used to check for duplicate file names when a file is to be added to
the archive.
Desc:
Does a case insensitive comparison of all the entries in CentralDir to look
for the filename.
-------------------------------------------------------------------------------}
function TCentralDir.FileNameExists(filename: string): boolean;
var
i: integer; // counter
CFH: TCentralFileHeader; // entry in CentralDir
begin
filename := UpperCase(filename);
result := false;
for i := 0 to Count-1 do
begin
CFH := Items[i] as TCentralFileHeader;
if (filename = Uppercase(CFH.filename)) then
begin
result := true;
break;
end;
end;
end;
(*******************************************************************************
TArchiveFile
------------
The Archive file class
*******************************************************************************)
{-------------------------------------------------------------------------------
CreateNew
---------
Creates a new archive with filename.
Desc:
If the file exists, it will be zeroed.
The Resource archive signature and an empty central directory will be added
to it to make it a valid archive.
The CentralDir is read again at the end to obtain its offset.
-------------------------------------------------------------------------------}
constructor TArchiveFile.CreateNew(const _filename: string; OpenExisting: boolean);
var
RAH: TResourceArchiveHeader;
begin
if OpenExisting then
begin
inherited Create(_filename, fmOpenRead or fmShareDenyWrite);
filename := _filename;
// test the signature to see if it is a valid archive
RAH := TResourceArchiveHeader.Create;
RAH.ReadFromFile(Self);
RAH.Free;
// create a new central dir and read it from the file
CentralDir := TCentralDir.Create(Self);
CentralDir.Read;
end
else
begin
inherited Create(_filename, fmCreate);
filename := _filename;
// write the signature to make it a valid archive
RAH := TResourceArchiveHeader.Create;
RAH.WriteToFile(Self);
RAH.Free;
// create a new central dir and write it
CentralDir := TCentralDir.Create(Self);
CentralDir.Write;
ResetBuffer;
CentralDir.Read;
end;
end;
{-------------------------------------------------------------------------------
Open
----
Opens an existing file of filename.
Desc:
The signature of the file will be checked to ensure it is valid.
Notes:
If the file does not exist an exception will occur.
-------------------------------------------------------------------------------}
{constructor TArchiveFile.OpenExisting(const _filename: string);
var
RAH: TResourceArchiveHeader;
begin
inherited Create(_filename, fmOpenRead or fmShareDenyWrite);
filename := _filename;
// test the signature to see if it is a valid archive
RAH := TResourceArchiveHeader.Create;
RAH.ReadFromFile(Self);
RAH.Free;
// create a new central dir and read it from the file
CentralDir := TCentralDir.Create(Self);
CentralDir.Read;
end;}
{-------------------------------------------------------------------------------
Destroy
-------
Frees up resources allocated by the constructor.
-------------------------------------------------------------------------------}
destructor TArchiveFile.Destroy;
begin
CentralDir.Free;
inherited Destroy;
end;
{function TArchiveFile.IsEmptyArchive: boolean;
begin
// if the file is 0 bytes long, then this is a new or empty archive
result := (Size = 0);
end;}
{-------------------------------------------------------------------------------
ReadString
----------
Desc:
Strings are null terminated
Read in characters until a null is encountered
-------------------------------------------------------------------------------}
procedure TArchiveFile.ReadString(var s: string);
var
c: char;
begin
repeat
GetNextByte(byte(c));
if (c = #0) then break;
s := s + c;
until false;
end;
{-------------------------------------------------------------------------------
ReadLongInt
-----------
Reads in a longinteger from the buffer
-------------------------------------------------------------------------------}
procedure TArchiveFile.ReadLongint(var a: longint);
begin
ReadBuf(a, sizeof(a));
end;
procedure TArchiveFile.ReadLongword(var a: longword);
begin
ReadBuf(a, sizeof(a));
end;
procedure TArchiveFile.ReadData(var a: longint);
begin
ReadBuf(a, sizeof(a));
end;
procedure TArchiveFile.ReadData(var a: longword);
begin
ReadBuf(a, sizeof(a));
end;
{-------------------------------------------------------------------------------
WriteString
-----------
writes out the string s and a null terminator
-------------------------------------------------------------------------------}
procedure TArchiveFile.WriteString(const s: string);
var
i: integer;
begin
for i := 1 to length(s) do
WriteByte(byte(s[i]));
WriteByte(0); // write the string terminator
end;
{-------------------------------------------------------------------------------
WriteLongInt
------------
Writes out the longinteger 'a' to the buffer
-------------------------------------------------------------------------------}
procedure TArchiveFile.WriteLongint(const a: longint);
begin
WriteBuf(a, sizeof(a));
end;
procedure TArchiveFile.WriteLongword(const a: longword);
begin
WriteBuf(a, sizeof(a));
end;
procedure TArchiveFile.WriteData(const a: longint);
begin
WriteBuf(a, sizeof(a));
end;
procedure TArchiveFile.WriteData(const a: longword);
begin
WriteBuf(a, sizeof(a));
end;
{-------------------------------------------------------------------------------
ReserveSpace
------------
writes out num_bytes of blank data to reserve the space for future use
-------------------------------------------------------------------------------}
procedure TArchiveFile.ReserveSpace(const num_bytes: integer);
var
i: integer;
begin
for i := 1 to num_bytes do
WriteByte(0);
end;
{-------------------------------------------------------------------------------
SeekToDataStart
---------------
seeks to the start of the data segment of the archive
Desc:
The data segment starts after the archive header (signature)
Seek to the position after the header
-------------------------------------------------------------------------------}
procedure TArchiveFile.SeekToDataStart;
begin
SmartSeek(RESOURCE_ARCHIVE_HEADER_SIZE, soFromBeginning);
end;
end.

View File

@ -0,0 +1,450 @@
unit ArchiveHeadersUnit;
{-------------------------------------------------------------------------------
Archive Headers Unit
--------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Notes:
The archive contains multiple segments.
Each segment has its own header.
TArchiveHeader: The parent header the other headers derive from. Defines
what procedures the header should have and override.
Can be used as an abstract base class.
TResourceArchiveHeader: Every Resource archive has the resource signature
TDataBlockHeader: Every data block in the archive has a DataBlockHeader
TCentralFileHeader, TCentralDirEndHeader:
These make up the CentralDir. The archive may have many CentralFileHeaders.
The order these headers appear in the archive file is such as they appear
above. Read ArcStruc.txt for more details about the headers.
Every header has a signature. Override GetSignature to return the signature for
the particular header type.
Signatures are for verifying that the data currently being read is of the correct
type.
Remember to update XXXX_SIZE if any header changes. The size is 4 (signature) + any data
in bytes.
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, Sysutils, ShellAPI, ArchiveFileUnit;
{Signatures}
const
RESOURCE_ARCHIVE_SIGNATURE = $4B565352; {RSVK}
DATA_HEADER_SIGNATURE = $41544144; {DATA}
CENTRAL_FILE_HEADER_SIGNATURE = $53484643; {CFHS}
END_OF_CENTRAL_DIRECTORY_SIGNATURE = $52444345; {ECDR}
{Header size = Signature (4) + data}
const
DATA_HEADER_SIZE = 20;
RESOURCE_ARCHIVE_HEADER_SIZE = 4;
type
{Exceptions}
ESignatureWrong = class(Exception)
public
constructor Create;
end;
TArchiveHeader = class
private
signature: longint;
procedure CheckSignature(ArchiveFile: TArchiveFile); overload;
procedure CheckSignature(Stream: TStream); overload;
protected
function GetSignature: longint; virtual;
procedure Read(ArchiveFile: TArchiveFile); virtual;
procedure Write(ArchiveFile: TArchiveFile); virtual;
procedure ReadStream(Stream: TStream); virtual;
procedure WriteStream(Stream: TStream); virtual;
public
constructor Create;
procedure ReadFromFile(ArchiveFile: TArchiveFile);
procedure WriteToFile(ArchiveFile: TArchiveFile);
{Stream Support}
procedure ReadFromStream(Stream: TStream);
procedure WriteToStream(Stream: TStream);
end;
TResourceArchiveHeader = class(TArchiveHeader)
public
function GetSignature: longint; override;
end;
TDataBlockHeader = class(TArchiveHeader)
protected
function GetSignature: longint; override;
procedure Read(ArchiveFile: TArchiveFile); override;
procedure Write(ArchiveFile: TArchiveFile); override;
public
crc32: longword;
compressed_size: longint;
first_sym_index: longint;
virtual_char_index: longint;
end;
TCentralFileHeader = class(TArchiveHeader)
private
function GetTimeStr: string;
function GetShellSmallIconIndex: integer;
function GetShellTypeName: string;
published
protected
FShellSmallIconIndex: integer;
FShellTypeName: string;
FTimeStr: string;
function GetSignature: longint; override;
procedure Read(ArchiveFile: TArchiveFile); override;
procedure Write(ArchiveFile: TArchiveFile); override;
procedure FillShellInfo; // for getting FShellTypeName and FTimeStr
public
compressed_size: longint;
uncompressed_size: longint;
num_blocks: longint;
data_offset: longint;
// attributes
time: longint;
attr: longint;
filename: string;
folder: string;
{---- not saved in file, used in file listing ----}
deleted: boolean; // flag for delete
Property TimeStr: string read GetTimeStr; // to get the time in a string format
property ShellSmallIconIndex: integer read GetShellSmallIconIndex;
property ShellTypeName: string read GetShellTypeName;
constructor Create;
end;
TCentralDirEndHeader = class(TArchiveHeader)
protected
function GetSignature: longint; override;
procedure Read(ArchiveFile: TArchiveFile); override;
procedure Write(ArchiveFile: TArchiveFile); override;
public
block_size: integer;
central_file_header_offset: integer;
end;
function GetArchiveHeader(ArchiveFile: TArchiveFile): TArchiveHeader;
(**) implementation (**)
uses ErrorUnit, StructsUnit;
constructor ESignatureWrong.Create;
begin
inherited Create('Wrong Signature. Archive could be corrupted.');
end;
{-------------------------------------------------------------------------------
GetArchiveHeader
----------------
Gets the archive header according to the next signature
Desc:
Will read in the signature, determine the header type and return the
appropriate archive header.
Notes:
Only support 2 header types: CentralFileHeader and CentralDirEndHeader
It is only used for reading these two headers.
-------------------------------------------------------------------------------}
function GetArchiveHeader(ArchiveFile: TArchiveFile): TArchiveHeader;
var
signature: longint;
ArchiveHeader: TArchiveHeader;
begin
ArchiveFile.ReadLongint(signature);
case (signature) of
CENTRAL_FILE_HEADER_SIGNATURE: ArchiveHeader := TCentralFileHeader.Create;
END_OF_CENTRAL_DIRECTORY_SIGNATURE: ArchiveHeader := TCentralDirEndHeader.Create;
else
raise ESignatureWrong.Create;
end;
ArchiveHeader.Read(ArchiveFile);
result := ArchiveHeader;
end;
(*******************************************************************************
TArchiveHeader
*******************************************************************************)
constructor TArchiveHeader.Create;
begin
inherited Create;
signature := GetSignature;
end;
{-------------------------------------------------------------------------------
Read/Write/GetSignature
-----------------------
the default read/write for ArchiveHeader does nothing
similarly, the default signature is zero
Notes:
Read/Write is supposed to read/write the data to the file
ReadFromFile/WriteToFile reads/writes the signature and data
-------------------------------------------------------------------------------}
procedure TArchiveHeader.Read(ArchiveFile: TArchiveFile);
begin
end;
procedure TArchiveHeader.Write(ArchiveFile: TArchiveFile);
begin
end;
procedure TArchiveHeader.ReadStream(Stream: TStream);
begin
end;
procedure TArchiveHeader.WriteStream(Stream: TStream);
begin
end;
function TArchiveHeader.GetSignature: longint;
begin
result := 0;
end;
{-------------------------------------------------------------------------------
CheckSignature
--------------
reads in the signature and checks if it is correct.
Desc:
will raise the exception ESignatureWrong if the signature is wrong
-------------------------------------------------------------------------------}
procedure TArchiveHeader.CheckSignature(ArchiveFile: TArchiveFile);
var
n: longint;
begin
// read in and check the signature first
ArchiveFile.ReadLongint(n);
if (n <> signature) then
begin
raise ESignatureWrong.Create;
end;
end;
procedure TArchiveHeader.CheckSignature(Stream: TStream);
var
n: longint;
begin
// read in and check the signature first
Stream.ReadBuffer(n, Sizeof(n));
if (n <> signature) then
begin
raise ESignatureWrong.Create;
end;
end;
{-------------------------------------------------------------------------------
ReadFromFile/WriteToFile
------------------------
reads/writes the header with its signature to the file
IN Assertion: ArchiveFile has been seeked to the location to read/write.
-------------------------------------------------------------------------------}
procedure TArchiveHeader.ReadFromFile(ArchiveFile: TArchiveFile);
begin
CheckSignature(ArchiveFile);
Read(ArchiveFile);
end;
procedure TArchiveHeader.WriteToFile(ArchiveFile: TArchiveFile);
begin
// write out the signature first
ArchiveFile.WriteLongint(signature);
Write(ArchiveFile);
end;
procedure TArchiveHeader.ReadFromStream(Stream: TStream);
begin
CheckSignature(Stream);
ReadStream(Stream);
end;
procedure TArchiveHeader.WriteToStream(Stream: TStream);
begin
// write out the signature first
Stream.WriteBuffer(signature, Sizeof(signature));
WriteStream(Stream);
end;
(*******************************************************************************
TResourceArchiveHeader
*******************************************************************************)
function TResourceArchiveHeader.GetSignature: longint;
begin
result := RESOURCE_ARCHIVE_SIGNATURE;
end;
(*******************************************************************************
TDataBlockHeader
*******************************************************************************)
function TDataBlockHeader.GetSignature: longint;
begin
result := DATA_HEADER_SIGNATURE;
end;
procedure TDataBlockHeader.Read(ArchiveFile: TArchiveFile);
begin
with ArchiveFile do
begin
ReadData(crc32);
ReadData(compressed_size);
ReadData(first_sym_index);
ReadData(virtual_char_index);
end;
end;
procedure TDataBlockHeader.Write(ArchiveFile: TArchiveFile);
begin
with ArchiveFile do
begin
WriteData(crc32);
WriteData(compressed_size);
WriteData(first_sym_index);
WriteData(virtual_char_index);
end;
end;
(*******************************************************************************
TCentralFileHeader
*******************************************************************************)
constructor TCentralFileHeader.Create;
begin
inherited Create;
//info_cached := false;
FTimeStr := '?';
FShellSmallIconIndex := -1; // only retrieve these data when they are needed
FShellTypeName := '?';
end;
procedure TCentralFileHeader.FillShellInfo;
var
FileInfo: TSHFileInfo;
begin
SHGetFileInfo(PChar(filename),
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES);
FShellSmallIconIndex := FileInfo.iIcon;
FShellTypeName := FileInfo.szTypeName;
end;
function TCentralFileHeader.GetShellSmallIconIndex: integer;
begin
if FShellSmallIconIndex = -1 then
FillShellInfo;
result := FShellSmallIconIndex;
end;
function TCentralFileHeader.GetShellTypeName: string;
begin
if FShellTypeName = '?' then
FillShellInfo;
result := FShellTypeName;
end;
function TCentralFileHeader.GetSignature: longint;
begin
result := CENTRAL_FILE_HEADER_SIGNATURE;
end;
function TCentralFileHeader.GetTimeStr: string;
begin
if FTimeStr = '?' then
begin
FTimeStr := DateTimeToStr(FileDateToDateTime(time));
end;
result := FTimeStr;
end;
procedure TCentralFileHeader.Read(ArchiveFile: TArchiveFile);
var
s: string;
begin
with ArchiveFile do
begin
ReadLongint(compressed_size);
ReadLongint(uncompressed_size);
ReadLongint(num_blocks);
ReadLongint(data_offset);
ReadLongint(time);
ReadLongint(attr);
end;
// filename variable name clash, so must read outside with block
// split filename and path
ArchiveFile.ReadString(s);
folder := ExtractFilePath(s);
filename := ExtractFileName(s);
// not saved
deleted := false;
end;
procedure TCentralFileHeader.Write(ArchiveFile: TArchiveFile);
begin
with ArchiveFile do
begin
WriteLongint(compressed_size);
WriteLongint(uncompressed_size);
WriteLongint(num_blocks);
WriteLongint(data_offset);
WriteLongint(time);
WriteLongint(attr);
end;
ArchiveFile.WriteString(folder + filename);
end;
(*******************************************************************************
TCentralDirEndHeader
*******************************************************************************)
function TCentralDirEndHeader.GetSignature: longint;
begin
result := END_OF_CENTRAL_DIRECTORY_SIGNATURE;
end;
procedure TCentralDirEndHeader.Read(ArchiveFile: TArchiveFile);
begin
With ArchiveFile do
begin
ReadLongint(block_size);
ReadLongint(central_file_header_offset);
end;
end;
procedure TCentralDirEndHeader.Write(ArchiveFile: TArchiveFile);
begin
With ArchiveFile do
begin
WriteLongint(block_size);
WriteLongint(central_file_header_offset);
end;
end;
end.

View File

@ -0,0 +1,947 @@
unit ArchiveManagerUnit;
{-------------------------------------------------------------------------------
Archive Manager
---------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
The archive manager is the engine to operate on the archive file.
It defines how the operations add/delete/extract/property change is
to be performed.
An ArchiveManager is assigned to each archive. Files can be added, deleted
and modified from the archive. File attributes can also be changed.
Notes:
The Add procedure chops a file into several smaller blocks and adds them
to an archive. If the file to compress is smaller than a block, the file size
is used instead.
To Use:
Create the archive manager. One archive manager can operate on only one
archive at a time.
-------------------------------------------------------------------------------}
(**) interface (**)
uses Windows, Forms, SysUtils, Classes, Dialogs,
{CG}
ErrorUnit,
BWTCompressUnit, BWTExpandUnit, EDosUnit, ArchiveFileUnit, StructsUnit;
type
{Exceptions}
EArchiveOpenError = class(Exception)
constructor Create;
end;
EUserCancel = class(Exception);
EFileNotExtracted = class(Exception);
EFileNothingDone = class(Exception);
TArchiveManager = class
private
Expander: TExpander;
// add properties. set only during add.
infile_size: integer;
protected
FOnCentralDirChange: TNotifyEvent;
procedure CentralDirChange;
function GetTempFileName: string;
procedure StartTempProcessing(var TempFile: TArchiveFile);
procedure EndTempProcessing(TempFile: TArchiveFile);
procedure ShowProgress(a: integer); virtual;
procedure ShowStatusMsg(s: string); virtual;
procedure AddLog(s: string); virtual; // for debugging. logging operations
public
ArchiveFile: TArchiveFile; // Contains the Central Dir (List of files in archive)
{archive file property}
archive_file_folder, archive_file_name, archive_file_full_path: string;
{------ MUST SET THE FOLLOWING -------------------}
{Parameters. Must set before calling any action}
TempDir: string; // The temporary dir to use
{extract options. set before calling ExtractFile}
dest_dir: string;
{-------------------------------------------------}
use_folder_names: boolean; // folders not implemented. ignore this
// used to count number of bytes processed in FSortUnit
// Archive manager will reset every file
bytes_processed: integer;
{These events can be assigned}
OnShowProgress: TIntEvent; {Progress bar not implemented because of new algo}
OnShowStatusMsg: TStrEvent;
OnAddLog: TStrEvent;
property OnCentralDirChange: TNotifyEvent read FOnCentralDirChange write FOnCentralDirChange;
{add properties. read only.}
property AddFileSize: integer read infile_size;
constructor Create;
destructor Destroy; override;
{operations}
procedure OpenArchive(const new_archive_file_name: string; const create_new_prompt: boolean);
procedure CloseArchive;
function IsArchiveOpen: boolean;
function AddFiles(FileList: TStrings; const infile_dir: string): integer;
procedure ExtractList(List: TList;
var files_extracted, extracted_size: integer);
procedure ExtractListToTemp(List: TList;
var files_extracted, extracted_size: integer; var temp_dir: string);
procedure DeleteFiles;
procedure WriteCentralDir;
{operations support}
procedure CopyData(SourceFile, DestFile: TArchiveFile; SourceCentralDir: TCentralDir);
function GetTempDir: string;
end;
var
Compressor: TCompressor; // one compressor class use multiple. all memory is allocated upon creation
(**) implementation (**)
uses ArchiveHeadersUnit;
constructor EArchiveOpenError.Create;
begin
inherited Create('Error opening archive');
end;
{constructor EUserCancle.Create;
begin
inherited Create('User canceled operation');
end;}
constructor TArchiveManager.Create;
begin
inherited Create;
dest_dir := '';
TempDir := 'c:\';
Compressor := TCompressor.Create;
Expander := TExpander.Create;
end;
destructor TArchiveManager.Destroy;
begin
Compressor.Free;
Expander.free;
inherited Destroy;
end;
{-------------------------------------------------------------------------------
CentralDirChange
----------------
will call the event handler if it is assigned
-------------------------------------------------------------------------------}
procedure TArchiveManager.CentralDirChange;
begin
if Assigned(FOnCentralDirChange) then FOnCentralDirChange(Self);
end;
procedure TArchiveManager.CloseArchive;
begin
FreeAndNil(ArchiveFile);
AddLog('Archive Closed - ' + archive_file_full_path);
end;
{-------------------------------------------------------------------------------
OpenArchive
-----------
will open the archive if new_archive_file_name
will display a prompt to create a new archive if requested
will append SRESOURCE_EXT to the end of the file name if an extension does not exist
to prevent a opening of a directory. opening files without extensions is not
supported.
Desc:
inits archive_file_name, archive_file_folder, archive_file_full_path
Notes:
The full path of the file should be passed to prevent any dir confusion.
-------------------------------------------------------------------------------}
procedure TArchiveManager.OpenArchive(const new_archive_file_name: string; const create_new_prompt: boolean);
begin
archive_file_full_path := ExpandFileName(new_archive_file_name);
archive_file_folder := ExtractFilePath(archive_file_full_path);
archive_file_name := ExtractFileName(archive_file_full_path);
// search for the ending 'dot' in the archive_file_name.
// if it does not exist, add one to archive_file_full_path and archive_file_name
if Pos('.', archive_file_name) = 0 then
begin
archive_file_full_path := archive_file_full_path + '.';
archive_file_name := archive_file_name + '.';
end;
// search for the extension. If it does not exist, add it.
if archive_file_name[length(archive_file_name)] = '.' then
begin
archive_file_full_path := archive_file_full_path + SRESOURCE_EXT;
archive_file_name := archive_file_name + SRESOURCE_EXT;
end;
// Change to the directory of the archive to open it
CHDir(archive_file_folder);
// Open the archive file.
// If the archive does not exist, then create a new one.
if FileExists(archive_file_name) then
ArchiveFile := TArchiveFile.CreateNew(archive_file_name, true)
else
begin
// check if the user really wants a new archive created
if create_new_prompt then
if (Application.MessageBox(PChar('The archive file ' + archive_file_full_path + ' does not exist. Do you want to create a new file?'),
'Create new archive?', MB_YESNOCANCEL) <> IDYES) then raise EUserCancel.Create('Create new archive cancelled');
ArchiveFile := TArchiveFile.CreateNew(archive_file_name, false);
end;
CentralDirChange;
AddLog('Archive Opened - ' + archive_file_full_path);
AddLog('CentralDir Loaded');
end;
{-------------------------------------------------------------------------------
GetTempFileName
---------------
Desc:
Uses the winows API GetTempFileName. the temporary file will have an 'RS'
prefix.
-------------------------------------------------------------------------------}
function TArchiveManager.GetTempFileName: string;
var
name: PChar;
s: string;
begin
name := StrAlloc(MAX_PATH + 1);
Windows.GetTempFileName(PChar(TempDir), 'RSVICTORK', 0, name);
s := string(name);
StrDispose(name);
result := s;
end;
{-------------------------------------------------------------------------------
StartTempProcessing
-------------------
Creates a new TempFile and seeks to the position to start adding data
-------------------------------------------------------------------------------}
procedure TArchiveManager.StartTempProcessing(var TempFile: TArchiveFile);
begin
TempFile := TArchiveFile.CreateNew(GetTempFileName, false);
TempFile.SeekToDataStart;
end;
{-------------------------------------------------------------------------------
EndTempProcessing
-----------------
Desc:
closes the current archive
deletes the archive
renames the temp archive to replace the current archive
-------------------------------------------------------------------------------}
procedure TArchiveManager.EndTempProcessing(TempFile: TArchiveFile);
var
temp_file_name: string;
begin
// save file names since we are freeing the objects
temp_file_name := TempFile.filename;
// close TempFile and ArchiveFile to perform file operations
TempFile.Free;
CloseArchive;
// perform operations
DeleteFile(archive_file_full_path);
RenameFile(temp_file_name, archive_file_full_path);
// temp file is now the new archive file
OpenArchive(archive_file_full_path, true);
end;
{-------------------------------------------------------------------------------
WriteCentralDir
---------------
Rewrites the central dir in memory to the archive file
Used when a file property in the archive changes and the CentralDir
has to be rewritten to reflect the change.
-------------------------------------------------------------------------------}
procedure TArchiveManager.WriteCentralDir;
var
TempFile: TArchiveFile;
begin
StartTempProcessing(TempFile);
CopyData(ArchiveFile, TempFile, ArchiveFile.CentralDir);
ArchiveFile.CentralDir.WriteToFile(TempFile);
AddLog('Write CentralDir OK.');
EndTempProcessing(TempFile);
CentralDirChange;
end;
{-------------------------------------------------------------------------------
CopyData
--------
Desc: Copies the data portion from SourceFile to DestFile, using
info from CentralDir (the source file's central dir)
If no data, the SourceFile and DestFile is seeked to DataStartPos
-------------------------------------------------------------------------------}
procedure TArchiveManager.CopyData(SourceFile, DestFile: TArchiveFile; SourceCentralDir: TCentralDir);
var
bytes_to_copy: integer;
begin
bytes_to_copy := SourceCentralDir.GetCentralDirOffset - RESOURCE_ARCHIVE_HEADER_SIZE;
DestFile.DisableBuf;
SourceFile.SeekToDataStart;
DestFile.SeekToDataStart;
ArchiveFileBlockCopy(SourceFile, DestFile, bytes_to_copy);
DestFile.EnableBuf;
end;
{-------------------------------------------------------------------------------
GetTempDir
Returns a temporary directory that is empty
the temp dir is in the default temp dir
-------------------------------------------------------------------------------}
function TArchiveManager.GetTempDir: string;
var
s: string;
OK: boolean;
i: integer;
begin
i := 0;
OK := false;
result := '';
repeat
try
s := IncludeTrailingBackslash(TempDir) + 'rs' {'This folder is safe to delete if reSource is closed '} + IntToStr(i);
MKDir(s);
// if we reached here, then the dir has been created with no exception
OK := true;
except
on E: EInOutError do
begin
{183 - dir exists try again}
if (E.ErrorCode <> 183) then
begin
{5 and other values - drive not ready}
ShowError('Cannot create temp directory. ' + IntToStr(E.ErrorCode));
raise; // unable to handle. exit and abandon operation.
end;
end; // EInOutError
end;
inc(i);
{really cannot create after 300 attempts, then abandon operation}
if i = 300 then
begin
// ShowError('Temp dir may be full. Tried ' + IntToStr(i) + ' times.');
raise EInOutError.Create('Temp dir may be full. Tried ' + IntToStr(i) + ' times.');
end;
until OK;
result := s;
end;
{-------------------------------------------------------------------------------
DeleteFiles
Algo:
Basically works with the central file directory
- Delete the file headers from the central dir with the deleted flag set.
- rebuild a new archive with the new central directory, updating the central
dir with the new data offsets.
- delete old archive, rename new archive.
Notes:
verbal explanation of how total_data_size is calculated:
total_data_size := total_compressed_size + totol_size_of_data_headers
- total_size_of_data_headers := DATA_HEADER_SIZE * num_data_blocks
-------------------------------------------------------------------------------}
procedure TArchiveManager.DeleteFiles;
var
i: integer; // counter
CentralFileHeader: TCentralFileHeader;
TempFile: TArchiveFile;
total_data_size: integer;
begin
with ArchiveFile do
begin
for i := CentralDir.Count-1 downto 0 do
begin
CentralFileHeader := TCentralFileHeader(CentralDir[i]);
if CentralFileHeader.Deleted then CentralDir.Delete(i);
end;
end;
// rebuild archive
// data: read from ArchiveFile, write to TempFile
StartTempProcessing(TempFile);
ArchiveFile.DisableBuf;
TempFile.DisableBuf;
for i := 0 to ArchiveFile.CentralDir.Count-1 do
begin
CentralFileHeader := ArchiveFile.CentralDir[i] as TCentralFileHeader;
ArchiveFile.Seek(CentralFileHeader.data_offset, soFromBeginning);
CentralFileHeader.data_offset := TempFile.Position;
total_data_size := CentralFileHeader.compressed_size + DATA_HEADER_SIZE * CentralFileHeader.num_blocks;
ArchiveFileBlockCopy(ArchiveFile, TempFile, total_data_size);
end;
// copy over the central dir
TempFile.EnableBuf;
ArchiveFile.CentralDir.WriteToFile(TempFile);
EndTempProcessing(TempFile);
CentralDirChange;
end;
{-------------------------------------------------------------------------------
ExtractList
IN Assertion:
dest_dir, the destination directory is set.
Desc:
Extracts files in a list, which contains pointers to the central file
header of the files.
Algo:
Sorts the list of indexes according to their data offsets in the archive.
This is to optimize extraction.
-------------------------------------------------------------------------------}
procedure TArchiveManager.ExtractList(List: TList;
var files_extracted, extracted_size: integer);
{-------------------------------------------------------------------------------
ExtractFile
IN Assertion:
dest_dir, the default destination directory is set.
Desc:
Extract the file referred by index in the CentralDir
Also imprint the file's attributes as stored in the CentralDir
Algo:
Get the CentralFileHeader for the file at index.
Create the file of filename
Seek to the data pos in ArchiveFile
BWTExpand the file
Extract directory:
If full path (drive+dir) specified, it is used.
If relative path (dir only), then add dest_dir to it.
If empty path, use dest_dir.
If UseFolderNames then
dir := CentralFileHeader.Folder
else
dir := '';
if (dir < 2) and (2nd char not a ':') then
dir := dest_dir + dir;
Notes:
Will check if destination file exist. EnsureDestFileClear will strip any
readonly or system bit from the file to overwrite. The Create para will then
rewrite the file.
-------------------------------------------------------------------------------}
procedure ExtractFile(CFH: TCentralFileHeader);
var
//CentralFileHeader: TCentralFileHeader;
OutFile: TFileStream;
i: integer; // counter
extract_folder: string;
out_file_path: string;
procedure EnsureDestFileClear;
begin
if FileExists(out_file_path) then
case Application.MessageBox(PChar('The file ' + out_file_path + ' exists. Do you want to overwrite the file?'), 'Warning', MB_YESNOCANCEL) of
IDYES:
begin
if (FileSetAttr(out_file_path, faArchive) <> 0) then
raise EInOutError.Create('Cannot clear dest file attributes');
end;
IDNO: raise EFileNotExtracted.Create('Destination file exists. File not extracted.');
IDCANCEL: raise EUserCancel.Create('Extract operation cancelled');
end;
end;
begin
// reset progress bar
ShowProgress(0);
ShowStatusMsg('');
//CentralFileHeader := TCentralFileHeader(ArchiveFile.CentralDir[index]);
// determine the directory to extract to
If use_folder_names then
begin
extract_folder := CFH.Folder;
// if it is relative, then must add dest_dir
if (length(extract_folder) < 2) or
((length(extract_folder) > 2) and (extract_folder[2] <> ':')) then
extract_folder := dest_dir + extract_folder;
end
else
extract_folder := dest_dir;
// out_file_path is the final full path to the file
out_file_path := extract_folder + CFH.filename;
EnsureDestFileClear;
// status bar notice
ShowStatusMsg('Extracting ' + out_file_path);
AddLog('Total number of blocks - '+IntToStr(CFH.num_blocks));
OutFile := TFileStream.Create(out_file_path, fmCreate);
try
ArchiveFile.SmartSeek(CFH.data_offset, soFromBeginning);
for i := 1 to CFH.num_blocks do
begin
Expander.ExpandBlock(ArchiveFile, OutFile);
// update file progress bar and process paint messages
if Expander.GetLastCRC32Result = true then
AddLog('Block '+IntToStr(i-1)+' Expand and CRC32 Check OK.')
else
AddLog('Block '+IntToStr(i-1)+' Expand Error.');
ShowProgress(i * 100 div CFH.num_blocks);
Application.ProcessMessages;
end;
finally
// set attributes that require the file handle
FileSetDate(OutFile.Handle, CFH.time);
OutFile.free;
// set attributes that require the file path
FileSetAttr(out_file_path, CFH.attr);
end;
end;
var
i: integer;
CFH: TCentralFileHeader;
begin
{Implement sort}
files_extracted := 0;
extracted_size := 0;
for i := 0 to List.Count-1 do
begin
try
CFH := TCentralFileHeader(List[i]);
ExtractFile(CFH);
inc(files_extracted);
inc(extracted_size, CFH.uncompressed_size);
except
on EFileNotExtracted do begin {nothing} end;
end;
end;
end;
procedure TArchiveManager.ExtractListToTemp(List: TList;
var files_extracted, extracted_size: integer; var temp_dir: string);
begin
{Create the temporary directory.
Set dest_dir to the temp dir.
Call ExtractIndexes to do the extraction}
dest_dir := GetTempDir; // set the dest dir
EDos.AddSlash(dest_dir);
temp_dir := dest_dir; // return the dest dir
ExtractList(List, files_extracted, extracted_size);
end;
(*
{-------------------------------------------------------------------------------
ExtractSelIdx
IN Assertion:
dest_dir, the default destination directory is set.
Desc:
Extracts files with their indexes in the index list.
The index must be the same as the file's index in the central directory.
Algo:
Sorts the list of indexes according to their data offsets in the archive.
This is to optimize extraction.
-------------------------------------------------------------------------------}
procedure TArchiveManager.ExtractIndexes(indexlist: TIndexList;
var files_extracted, extracted_size: integer);
{-------------------------------------------------------------------------------
ExtractFile
IN Assertion:
dest_dir, the default destination directory is set.
Desc:
Extract the file referred by index in the CentralDir
Also imprint the file's attributes as stored in the CentralDir
Algo:
Get the CentralFileHeader for the file at index.
Create the file of filename
Seek to the data pos in ArchiveFile
BWTExpand the file
Extract directory:
If full path (drive+dir) specified, it is used.
If relative path (dir only), then add dest_dir to it.
If empty path, use dest_dir.
If UseFolderNames then
dir := CentralFileHeader.Folder
else
dir := '';
if (dir < 2) and (2nd char not a ':') then
dir := dest_dir + dir;
Notes:
Will check if destination file exist. EnsureDestFileClear will strip any
readonly or system bit from the file to overwrite. The Create para will then
rewrite the file.
-------------------------------------------------------------------------------}
procedure ExtractFile(index: integer);
var
CentralFileHeader: TCentralFileHeader;
OutFile: TFileStream;
i: integer; // counter
extract_folder: string;
out_file_path: string;
procedure EnsureDestFileClear;
begin
if FileExists(out_file_path) then
case Application.MessageBox(PChar('The file ' + out_file_path + ' exists. Do you want to overwrite the file?'), 'Warning', MB_YESNOCANCEL) of
IDYES:
begin
if (FileSetAttr(out_file_path, faArchive) <> 0) then
raise EInOutError.Create('Cannot clear dest file attributes');
end;
IDNO: raise EFileNotExtracted.Create('Destination file exists. File not extracted.');
IDCANCEL: raise EUserCancel.Create('Extract operation cancelled');
end;
end;
begin
// reset progress bar
MainForm.ShowProgress(0);
MainForm.ShowStatusMessage('');
CentralFileHeader := TCentralFileHeader(ArchiveFile.CentralDir[index]);
// determine the directory to extract to
If use_folder_names then
begin
extract_folder := CentralFileHeader.Folder;
// if it is relative, then must add dest_dir
if (length(extract_folder) < 2) or
((length(extract_folder) > 2) and (extract_folder[2] <> ':')) then
extract_folder := dest_dir + extract_folder;
end
else
extract_folder := dest_dir;
// out_file_path is the final full path to the file
out_file_path := extract_folder + CentralFileHeader.filename;
EnsureDestFileClear;
// status bar notice
MainForm.ShowStatusMessage('Extracting ' + out_file_path);
OutFile := TFileStream.Create(out_file_path, fmCreate);
try
ArchiveFile.SmartSeek(CentralFileHeader.data_offset, soFromBeginning);
for i := 1 to CentralFileHeader.num_blocks do
begin
Expander.ExpandBlock(ArchiveFile, OutFile);
// update file progress bar and process paint messages
MainForm.ShowProgress(i * 100 div CentralFileHeader.num_blocks);
Application.ProcessMessages;
end;
finally
// set attributes that require the file handle
FileSetDate(OutFile.Handle, CentralFileHeader.time);
OutFile.free;
// set attributes that require the file path
FileSetAttr(out_file_path, CentralFileHeader.attr);
end;
end;
var
i: integer;
begin
{Implement sort}
files_extracted := 0;
extracted_size := 0;
for i := 0 to length(indexlist)-1 do
begin
try
ExtractFile(indexlist[i]);
inc(files_extracted);
//inc(extracted_size, CentralFileHeader.uncompressed_size);
except
on EFileNotExtracted do begin {nothing} end;
end;
end;
end;
{-------------------------------------------------------------------------------
ExtractIndexesToTemp
Creates the temp dir and extracts to the temp dir
-------------------------------------------------------------------------------}
procedure TArchiveManager.ExtractIndexesToTemp(indexlist: TIndexList;
var files_extracted, extracted_size: integer; var temp_dir: string);
begin
{Create the temporary directory.
Set dest_dir to the temp dir.
Call ExtractIndexes to do the extraction}
dest_dir := GetTempDir; // set the dest dir
EDos.AddSlash(dest_dir);
temp_dir := dest_dir; // return the dest dir
ExtractIndexes(indexlist, files_extracted, extracted_size);
end;
*)
{-------------------------------------------------------------------------------
AddFiles
Desc:
Add multiple files to the archive
the files are in the directory infile_dir
Notes:
The files to add are in a TStrings
if full paths are transferred in FileList, then infile_dir must be null.
if FileList count is 0 it will exit.
Will check if files added is a directory.
Algo:
Open Temp File
Do the following for all files in FileList
1) Check if it is a folder. Folders cannot be added.
2) Check if there is a file of a duplicate name. Warn the user if so.
3) Compress the block and append the block (new data).
4) Add the file info to the central directory.
Write the central directory.
Close Temp File
-------------------------------------------------------------------------------}
function TArchiveManager.AddFiles(FileList: TStrings; const infile_dir: string): integer;
var
TempFile: TArchiveFile; // temp archive
CentralFileHeader: TCentralFileHeader;
infile_name: string;
{-----------------------------------------------------------------------------
AppendNewData
Compresses the new file and appends the new data to the file.
IN Assertion: TempFile has been seeked to the correct position to add the
new data
-----------------------------------------------------------------------------}
procedure AppendNewData;
var
InFile: TFileStream; // file to add
block: PBlock;
bytes_read, block_compressed_size: integer;
EstimatedNumBlocks: integer;
//infile_size: integer;
begin
InFile := TFileStream.create(infile_name, fmOpenRead or fmShareDenyWrite);
infile_size := InFile.Size;
{Msg}
if infile_size > 0 then
begin
EstimatedNumBlocks := infile_size div BlockSize;
if (EstimatedNumBlocks = 0) or ((infile_size mod BlockSize) > 0) then
inc(EstimatedNumBlocks);
end
else
EstimatedNumBlocks := 0;
AddLog('File size = ' + IntToStr(infile_size)
+' bytes (Num blocks='+IntToStr(EstimatedNumBlocks)+')');
// ShowProgress(0); {Progress bar does not work}
bytes_processed := 0; // reset counter
// Compress the infile block by block to tempfile
block := Compressor.GetInBlock;
CentralFileHeader.data_offset := TempFile.Position;
bytes_read := infile.Read(block^[0], BlockSize);
while (bytes_read > 0) do
begin
//TempFile.SmartSeek(TempFile.Position, soFromBeginning);
Compressor.CompressInBlockToFile(bytes_read, TempFile, block_compressed_size);
with CentralFileHeader do
begin
inc(num_blocks);
inc(compressed_size, block_compressed_size);
inc(uncompressed_size, bytes_read);
end;
with CentralFileHeader do
AddLog('Block ' + IntToStr(num_blocks-1)+' OK, (Raw size='+
IntToStr(bytes_read)+' Compressed= ' + IntToStr(block_compressed_size) + ')');
block := Compressor.GetInBlock; // in_block may have been swapped again.
bytes_read := infile.Read(block^[0], BlockSize);
//MainForm.ShowProgress(CentralFileHeader.uncompressed_size * 100 div infile_size);
//Application.ProcessMessages;
//TempFile.ResetBuffer;
end;
InFile.Free;
end;
var
i: integer;
SearchRec: TSearchRec;
files_added: integer;
begin
if (FileList.Count = 0) then
begin
result := 0; // nothing to do if no files
Exit;
end;
StartTempProcessing(TempFile);
// copy existing data to tempfile
CopyData(ArchiveFile, TempFile, ArchiveFile.CentralDir);
files_added := 0;
// change to the directory to add the file from
if (infile_dir <> '') then
CHDir(infile_dir);
// append new data to tempfile
for i := 0 to FileList.Count-1 do
begin
infile_name := FileList[i];
ShowStatusMsg('Adding file - ' + infile_name);
FindFirst(infile_name, faAnyFile, SearchRec); // get file stats
// Check if it is a folders. Adding folders is not supported.
if (SearchRec.Attr and faDirectory <> 0) then
begin
Application.MessageBox(PChar('Could not add: ''' + infile_name + '''. Adding of folders is not supported.'),
'Error', MB_OK);
// move on to next file
Continue;
end;
// Check if another file with a duplicate name exists
if (ArchiveFile.CentralDir.FileNameExists(ExtractFileName(infile_name))) then
begin
if (Application.MessageBox(PChar('A file of name ''' + ExtractFileName(infile_name) + ''' already exists in the archive. Do you still want to add the file?'),
'Confirmation', MB_YESNO) = IDNo) then Continue;
end;
CentralFileHeader := TCentralFileHeader.Create;
with CentralFileHeader do
begin
// these values filled in later
compressed_size := 0;
uncompressed_size := 0;
num_blocks := 0;
// init file attr
filename := infile_name;
time := SearchRec.Time;
attr := SearchRec.Attr;
end;
try
AppendNewData; // this may raise EFOpenError for input file
ArchiveFile.CentralDir.Add(CentralFileHeader);
inc(files_added);
except
on EFOpenError do
begin
// file cannot be opened. may have to skip it.
Application.Messagebox(PChar('Cannot open file: ''' + infile_name + '''.' + #13 + 'It will not be added.'), ' Error', 0);
end;
end; {except}
end;
// write out the CentralDir
ArchiveFile.CentralDir.WriteToFile(TempFile);
EndTempProcessing(TempFile);
CentralDirChange;
// return the number of files added
result := files_added;
end;
procedure TArchiveManager.ShowProgress(a: integer);
begin
if Assigned(OnShowProgress) then OnShowProgress(Self, a);
end;
procedure TArchiveManager.ShowStatusMsg(s: string);
begin
if s <> '' then
AddLog(s);
if Assigned(OnShowStatusMsg) then OnShowStatusMsg(Self, s);
end;
procedure TArchiveManager.AddLog(s: string);
begin
if Assigned(OnAddLog) then OnAddLog(Self, 'ArchiveMan: ' + s);
end;
function TArchiveManager.IsArchiveOpen: boolean;
begin
result := ArchiveFile <> nil;
end;
end.

46
Component/BWTBaseUnit.pas Normal file
View File

@ -0,0 +1,46 @@
unit BWTBaseUnit;
{-------------------------------------------------------------------------------
Burrows Wheeler Transformation
Base Unit
------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
The base unit for TBWTCompress and TBWTExpand
contains common procedures used by both of them.
-------------------------------------------------------------------------------}
(**) interface (**)
uses StructsUnit;
type
TBWTBase = class
protected
in_block ,out_block: PBlock;
procedure SwapBlocks;
public
end;
(**) implementation (**)
{-------------------------------------------------------------------------------
Swap Blocks
in_block and out_block exchange pointer values
-------------------------------------------------------------------------------}
procedure TBWTBase.SwapBlocks;
var
temp_block: PBlock;
begin
temp_block := in_block;
in_block := out_block;
out_block := temp_block;
end;
end.

View File

@ -0,0 +1,691 @@
unit BWTCompressUnit;
{-------------------------------------------------------------------------------
Burrows Wheeler Transformation
Block Compression Unit
------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
This is the class that brings all the engines together.
It uses the FSortUnit, MTFEncoder, StrucAriEncoder.
The whole compression for a block consists of:
1) Burrows Wheeler Transformation (Sort + Retrieve last column)
2) Move To Front encoding
3) Structured Arithmetic encoding
Brief Explanation:
1) BWT is the trick to the high performance compression
2) Move to Front coding is done to transform the block into a series
of numbers. The more frequantly appearing characters will thus be
transformed to lower numbers, resulting a low numbers dominating the
block (0 and 1s especially). This aids Arithmetic coding.
3) Arithmetic coding is performed with a structured or hierarchical model.
Read the system doc for more information about the structured
arithmetic model.
For a more in depth discussion of the compression process, refer
to the system doc.
Usage:
- just create the object and call CompressBlockToFile
CompressBlockToFile writes out the data header and the data
- to not use the structured arithmetic encoder, undefine USE_STRUC_ARI
Notes:
- read notes.txt for information about the block swapping technique used
- certain debug procedures have been commented out to prevent hints
- the general rule is pass only what is needed for the engine wrappers
-------------------------------------------------------------------------------}
(**) interface (**)
uses // delphi
Classes, Forms, SysUtils, Dialogs,
// general
OFile, StructsUnit, ArchiveFileUnit, ArchiveHeadersUnit, CRC32Unit,
// engine
RLEUnit, FSortUnit, MTFEncoderUnit, MTFDecoderUnit, BWTExpandUnit,
FileStrucAriEncoderUnit, StreamStrucAriEncoderUnit,
// base
BWTBaseUnit;
type
TCompressor = class(TBWTBase)
private
//block1, block2: PBlock;
index: PLongintBlock;
// Debug
{original_block: PBlock;
recovered_block: PBlock;}
{Expander: TExpander;}
// Classes
FastSorter: TFastSorter;
MTFEncoder: TMTFEncoder;
FileStrucAriEncoder: TFileStrucAriEncoder;
StreamAriEncoder: TStreamAriEncoder;
{RunLengthEncoder: TRunLengthEncoder;}
// Main compression routines
{procedure AllocateStructs;
procedure FreeStructs;}
procedure InitStructs;
procedure SortBlock(var block_length: longint);
procedure MTFGetTransformedBlock(var block_length, first_sym_index, virtual_char_index: longint);
procedure AriEncodeBlock(ArchiveFile: TArchiveFile; block_length: longint);
procedure AriEncodeBlockToStream(OutStream: TStream; block_length: longint; var OutSize: integer);
procedure FillInBlockFromStream(Stream: TStream; var BlockLength: integer);
{procedure GetTransformedBlock(var first_sym_index, virtual_char_index: longint);
procedure MTFEncodeBlock;}
{procedure RLEEncode;}
// Debug
{procedure DoBlockRecover;
procedure DumpBlock(var b; bsize: longint; FileName: string);
procedure DumpSortedBlock;
procedure DumpTransformedBlock;
procedure DumpRecoveredBlock;
procedure CheckSortedBlock;
{procedure CheckRecoveredBlock;}
// Debug output
{procedure DebugShowDoingSorting;
procedure DebugShowDoingTransform;}
{procedure DebugShowDoingMTF;}
{procedure DebugShowDoingAriCompress;}
public
constructor Create;
destructor Destroy; override;
function GetInBlock: PBlock; // fill the inblock then compress it
procedure CompressInBlockToFile(block_length: longint; ArchiveFile: TArchiveFile;
var packed_size: integer);
procedure CompressStream(InStream, OutStream: TStream);
end;
(**) implementation (**)
uses ErrorUnit;
constructor TCompressor.Create;
begin
inherited Create;
//AllocateStructs;
FastSorter := TFastSorter.Create;
MTFEncoder := TMTFEncoder.create;
FileStrucAriEncoder := TFileStrucAriEncoder.Create;
StreamAriEncoder := TStreamAriEncoder.Create;
{Debug}
{Expander := TExpander.Create;}
end;
destructor TCompressor.Destroy;
begin
{Debug}
{Expander.Free;}
FileStrucAriEncoder.Free;
MTFEncoder.Free;
FastSorter.Free;
//FreeStructs;
inherited Destroy;
end;
(*
{-------------------------------------------------------------------------------
AllocateStructs
---------------
Allocate memory for the block transformation and assign in_block and out_block
-------------------------------------------------------------------------------}
procedure TCompressor.AllocateStructs;
begin
New(block1);
New(block2);
New(index);
// Debug
{New(recovered_block);
New(original_block);}
end;
{-------------------------------------------------------------------------------
FreeStructs
Free whatever memory that was allocated by AllocateStructs
-------------------------------------------------------------------------------}
procedure TCompressor.FreeStructs;
begin
// Debug
{Dispose(original_block);
Dispose(recovered_block);}
Dispose(index);
Dispose(block2);
Dispose(block1);
end;
*)
{-------------------------------------------------------------------------------
InitStructs
inits swap block structures.
pass the block1 to be assigned
inits the index.
Assigns an index to every position in block. Each entry in index indicates the
start of a string.
-------------------------------------------------------------------------------}
procedure TCompressor.InitStructs;
begin
// Assign block pointers for the swapblocks system
// in_block was assigned when GetInBlock was called. it took block1
out_block := BlockMan.block2;
index := BlockMan.longintblock1;
end;
function TCompressor.GetInBlock: PBlock; // fill the inblock then compress it
begin
in_block := BlockMan.block1;
result := BlockMan.block1;
end;
{-------------------------------------------------------------------------------
CompressBlockToFile
-------------------
Writes out the data header + data
IN Assertion: ArchiveFile has been seeked to the next write position
OUT Assertion: ArchiveFile is seeked to the next output position
-------------------------------------------------------------------------------}
procedure TCompressor.CompressInBlockToFile;
var
data_header_offset, // offset of the data header
next_free_pos: integer; // the next output position when ArchiveFile is returned
ari_data_size: longword; // size of the arithmetic data
crc: longword; // crc calculated for this block
first_sym_index, virtual_char_index: longint;
DataBlockHeader: TDataBlockHeader; // the data header
begin
{Compression process:
Sort
Transform
Move To Front
Ari Code}
// reserve space for the block size first
data_header_offset := ArchiveFile.Position;
ArchiveFile.ReserveSpace(DATA_HEADER_SIZE);
ArchiveFile.ResetBuffer;
InitStructs;
CalculateCRC32(in_block, block_length, crc);
SortBlock(block_length);
MTFGetTransformedBlock(block_length, first_sym_index, virtual_char_index);
AriEncodeBlock(ArchiveFile, block_length);
// save the current position
next_free_pos := ArchiveFile.Position;
// some calculations
ari_data_size := next_free_pos - data_header_offset -DATA_HEADER_SIZE;
// seek back to start of data block to write the data header of this block
ArchiveFile.SmartSeek(data_header_offset, soFromBeginning);
DataBlockHeader := TDataBlockHeader.Create;
DataBlockHeader.crc32 := crc;
DataBlockHeader.compressed_size := ari_data_size;
DataBlockHeader.first_sym_index := first_sym_index;
DataBlockHeader.virtual_char_index := virtual_char_index;
DataBlockHeader.WriteToFile(ArchiveFile);
DataBlockHeader.Free;
// seek back to where we left off
ArchiveFile.SmartSeek(next_free_pos, soFromBeginning);
// allow screen update
Application.ProcessMessages;
// return values
packed_size := ari_data_size;
end;
{-------------------------------------------------------------------------------
CompressStream
-------------------
Writes Compressed Data Only to OutStream.
No block information is stored.
IN Assertion: ArchiveFile has been seeked to the next write position
OUT Assertion: ArchiveFile is seeked to the next output position
-------------------------------------------------------------------------------}
procedure TCompressor.CompressStream(InStream, OutStream: TStream);
var
BlockLength: integer; // actual size of data in block
crc: longword; // crc calculated for this block
AriDataSize: longint; // size of the arithmetic data
first_sym_index, virtual_char_index: longint;
DataBlockHeader: TDataBlockHeader; // the data header
begin
{Compression process:
Sort
Transform
Move To Front
Ari Code}
GetInBlock; // init in_block.
InitStructs;
While (InStream.Position < InStream.Size) do
begin
FillInBlockFromStream(InStream, BlockLength);
CalculateCRC32(in_block, BlockLength, crc);
SortBlock(BlockLength);
MTFGetTransformedBlock(BlockLength, first_sym_index, virtual_char_index);
AriEncodeBlockToStream(OutStream, BlockLength, AriDataSize);
end;
(*
InitStructs;
CalculateCRC32(in_block, block_length, crc);
SortBlock(block_length);
MTFGetTransformedBlock(block_length, first_sym_index, virtual_char_index);
AriEncodeBlock(ArchiveFile, block_length);
// save the current position
next_free_pos := ArchiveFile.Position;
// some calculations
ari_data_size := next_free_pos - data_header_offset -DATA_HEADER_SIZE;
// seek back to start of data block to write the data header of this block
ArchiveFile.SmartSeek(data_header_offset, soFromBeginning);
DataBlockHeader := TDataBlockHeader.Create;
with DataBlockHeader do
begin
crc32 := crc;
compressed_size := ari_data_size;
end;
DataBlockHeader.first_sym_index := first_sym_index;
DataBlockHeader.virtual_char_index := virtual_char_index;
DataBlockHeader.WriteToFile(ArchiveFile);
DataBlockHeader.Free;
// seek back to where we left off
ArchiveFile.SmartSeek(next_free_pos, soFromBeginning);
// allow screen update
Application.ProcessMessages;
// return values
packed_size := ari_data_size;
*)
end;
procedure TCompressor.FillInBlockFromStream(Stream: TStream; var BlockLength: integer);
begin
BlockLength := Stream.Read(in_block^[0], BlockSize);
end;
{-------------------------------------------------------------------------------
RLEEncode
Run Length Encode the block for faster sorting.
OUT Assertion: block_length is set to the new length
-------------------------------------------------------------------------------}
{procedure TCompressor.RLEEncode;
var
RLEEncoder: TRunLengthEncoder;
begin
RLEEncoder := TRunLengthEncoder.Create;
RLEEncoder.EncodeBlock(in_block, out_block, block_length, block_length);
RLEEncoder.Free;
SwapBlocks;
end;}
{-------------------------------------------------------------------------------
SortBlock
-------------------------------------------------------------------------------}
procedure TCompressor.SortBlock(var block_length: longint);
var
i: longint;
begin
for i := 0 to block_length-1 do
index[i] := i;
//DebugShowDoingSorting;
FastSorter.SortBlock(in_block, index, block_length);
// SadaSort adds a virtual char
inc(block_length);
// debug check
{DumpSortedBlock;}
{CheckSortedBlock;}
// in_block is not changed, only Index is created.
// swapblocks need not be called
end;
{-------------------------------------------------------------------------------
GetTransformedBlock and MTF encode
Get the last column l
-------------------------------------------------------------------------------}
procedure TCompressor.MTFGetTransformedBlock(var block_length, first_sym_index, virtual_char_index: longint);
var
i, j: longint;
begin
//DebugShowDoingTransform;
MTFEncoder.Init;
// mirror the last byte in block to block[-1], so when i = 0, block^[i-1] works
in_block^[-1] := in_block^[block_length-1];
// sada sort account for vitual. don't pass it to the mtf.
// we remove it from out_block and store its index.
i := 0; // in_block index
j := 0; // out_block index
virtual_char_index := -2;
while (i < block_length) do
begin
if (index[i] = 1) then
first_sym_index := i;
// the virtual char is accessed when in_block[-1] is accessed
if ((index[i]-1) = -1) then
virtual_char_index := j // we skip the virtual char
else
begin
out_block[j] := MTFEncoder.Encode(in_block[index[i]-1]);
inc(j);
end;
inc(i);
end;
if (virtual_char_index = -2) then
begin
// fatal error: virtual_char_index may not have been initialized at all
ShowError('virtual_char_index not initialized.');
end;
// we have taken out the virtual char, so we dec block_length
dec(block_length);
SwapBlocks;
end;
{-------------------------------------------------------------------------------
AriEncodeBlock
Notes:
Arithmetic compress block and output block
-------------------------------------------------------------------------------}
procedure TCompressor.AriEncodeBlock(ArchiveFile: TArchiveFile; block_length: longint);
begin
//DebugShowDoingAriCompress;
// FileStrucAriEncoder := TFileStrucAriEncoder.Create;
FileStrucAriEncoder.EncodeBlock(ArchiveFile, in_block, block_length);
// debug check
{DecodeBlock(recovered_block, rsize);
CompareBlocks(mtf_block, recovered_block, block_length, 'Decompression error.');}
end;
procedure TCompressor.AriEncodeBlockToStream(OutStream: TStream; block_length: longint; var OutSize: integer);
begin
StreamAriEncoder.EncodeBlock(OutStream, in_block, block_length, OutSize);
end;
(*
procedure TCompressor.GetTransformedBlock(var first_sym_index, virtual_char_index: longint);
var
i, j: longint;
begin
DebugShowDoingTransform;
// mirror the last byte in block to block[-1], so when i = 0, block^[i-1] works
in_block^[-1] := in_block^[block_length-1];
// sada sort account for vitual. don't pass it to the mtf.
// we remove it from out_block and store its index.
i := 0; // in_block index
j := 0; // out_block index
virtual_char_index := -2;
while (i < block_length) do
begin
if (index^[i] = 1) then
first_sym_index := i;
// the virtual char is accessed when in_block[-1] is accessed
if ((index^[i]-1) = -1) then
virtual_char_index := j // we skip the virtual char
else
begin
out_block^[j] := in_block^[longint(index[i])-1];
inc(j);
end;
inc(i);
end;
//ShowMessage('Virtual char index: ' + IntToStr(virtual_char_index));
if (virtual_char_index = -2) then
begin
// fatal error: virtual_char_index may not have been initialized at all
ShowError('virtual_char_index not initialized.');
end;
// we have taken out the virtual char, so we dec block_length
dec(block_length);
// debug check
{DumpTransformedBlock;}
{DoBlockRecover;
CheckRecoveredBlock;}
SwapBlocks;
end;
{-------------------------------------------------------------------------------
MTFEncodeBlock
-------------------------------------------------------------------------------}
procedure TCompressor.MTFEncodeBlock;
var
MTFEncoder: TMTFEncoder;
{MTFDecoder: TMTFDecoder;}
begin
DebugShowDoingMTF;
MTFEncoder := TMTFEncoder.create;
MTFEncoder.EncodeBlock(in_block, out_block, block_length);
MTFEncoder.free;
SwapBlocks;
// debug check
{MTFDecoder := TMTFDecoder.create;
MTFDecoder.DecodeBlock(mtf_block, recovered_block, block_length);
MTFDecoder.free;}
end;
*)
(*******************************************************************************
Debuging routines
*******************************************************************************)
(*
procedure TCompressor.DoBlockRecover;
{var
RecoveredBlockLength: Longint;}
begin
//Expander.ExpandBlock(block, recovered_block, first_sym_index, block_length, RecoveredBlockLength);
//Expander.ExpandBlock(transformed_block, recovered_block, first_sym_index, block_length, RecoveredBlockLength);
end;
{-------------------------------------------------------------------------------
DumpSortedBlock
---------------
Dumps the data in block sorted in alphabetical order.
Used to visually confirm the reliability of the sorting algorithm.
-------------------------------------------------------------------------------}
procedure TCompressor.DumpSortedBlock;
var
f: text;
i: integer;
begin
AssignFile(f, 'c:\ctest\SortedBlockDump.txt');
Rewrite(f);
writeln(f, 'Sorted Block Dump file');
writeln(f, 'reSource eXperimental (C) 1997 F-inc');
writeln(f, '=======================================');
writeln(f, 'block_length: ', block_length);
writeln(f, '=======================================');
for i := 0 to block_length-1 do
{if (index^[i] = block_length) then
write(f, '?')
else}
//write(f, char(block^[index^[i]]));
Close(f);
end;
{-------------------------------------------------------------------------------
DumpBlock
---------
Dumps the block, b to a file.
Used by DumpTransformedBlock
-------------------------------------------------------------------------------}
procedure TCompressor.DumpBlock(var b; bsize: longint; FileName: string);
var
f: TOFile;
begin
f := TOFile.create(FileName);
f.Rewrite(1);
f.BlockWrite(b, block_length);
f.free;
end;
procedure TCompressor.DumpRecoveredBlock;
begin
DumpBlock(recovered_block^, block_length, 'c:\ctest\out Recovered Block.txt');
end;
{-------------------------------------------------------------------------------
DumpTransformedBlock
--------------------
Dumps the transformed block to file.
This is actually L, or the last column in the transformation matrix.
IN Assertion: DoBlockTransform was called.
-------------------------------------------------------------------------------}
procedure TCompressor.DumpTransformedBlock;
begin
// DumpBlock(block^, block_length, 'c:\ctest\out Transformed Block.txt');
end;
*)
{-------------------------------------------------------------------------------
CheckSortedBlock
----------------
Checks the sorted block for ascending order.
Only displays an error when one has occured.
-------------------------------------------------------------------------------}
(*
procedure TCompressor.CheckSortedBlock;
var
i: integer;
begin
{Checks: INBLOCK
Assertion: Index has been created}
i := 1;
while (i < block_length-1) and (in_block^[Index^[i]] >= in_block^[Index^[i-1]]) do
inc(i);
{An error has occured if i did not reach the end of block}
if (i < block_length-1) then
ShowError('Block not sorted correctly');
end;
{-------------------------------------------------------------------------------
CheckRecoveredBlock
-------------------
Does a byte to byte comparison of the recovered block and the original block.
Shows an error and the position where the first different byte was found.
-------------------------------------------------------------------------------}
procedure TCompressor.CheckRecoveredBlock;
var
i: longint;
begin
//DumpRecoveredBlock;
{recovered_block must be the same as original block}
for i := 0 to block_length-1 do
if recovered_block^[i] <> original_block^[i] then
begin
ShowError('Recovered block differs from original block at ' + IntToStr(i));
break;
end;
{Alternate way of comparing using CompareMem.
Position of difference start will not be shown.
if not CompareMem(recovered_block, block, block_length-1) then
ShowError('Recovered block differs from original block');}
end;
*)
(*******************************************************************************
Debug Output routines
*******************************************************************************)
{procedure TCompressor.DebugShowDoingSorting;
begin
if ConfigMan.ShowDebugForm then DebugForm.DoingSorting;
end;
procedure TCompressor.DebugShowDoingTransform;
begin
if ConfigMan.ShowDebugForm then DebugForm.DoingTransform;
end;}
{procedure TCompressor.DebugShowDoingMTF;
begin
if ConfigMan.ShowDebugForm then DebugForm.DoingMTF;
end;}
{procedure TCompressor.DebugShowDoingAriCompress;
begin
if ConfigMan.ShowDebugForm then DebugForm.DoingAriCompress;
end;}
end.

376
Component/BWTExpandUnit.pas Normal file
View File

@ -0,0 +1,376 @@
unit BWTExpandUnit;
{-------------------------------------------------------------------------------
Burrows Wheeler Transformation
Block Expansion Unit
------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Notes:
SwapBlock
After every decoding procedure is called, SwapBlocks is called.
in_block will always contain the latest block and out_block the block
to be used for further decoding.
block_length will always contain the length of in_block.
-------------------------------------------------------------------------------}
(**) interface (**)
uses // delphi
SysUtils, Classes, Dialogs,
// general
StructsUnit, ArchiveFileUnit, ArchiveHeadersUnit, CRC32Unit,
// engine
RLEUnit, MTFDecoderUnit, GroupAriModelUnit,
// arithmetic engine
FileStrucAriDecoderUnit,
// base class
BWTBaseUnit;
type
T256longintarray = array[-1..255] of longint;
P256longintarray = ^T256longintarray;
TExpander = class(TBWTBase)
private
FLastCRC32Result: boolean;
//block1, block2: PBlock;
block_length: integer; // length of out_block
transformation_block: PLongintBlock;
count, running_total: P256longintarray;
//count, running_total: array[-1..255] of longint;
// classes
FileStrucAriDecoder: TFileStrucAriDecoder;
MTFDecoder: TMTFDecoder;
{procedure AllocateStructs;
procedure FreeStructs;}
procedure InitStructs;
// Decoding routines
procedure AriDecode(InFile: TArchiveFile);
procedure MTFDecode(const virtual_char_index: longint);
procedure RecoverSortedBlock(const first_sym_index, virtual_char_index: longint);
//procedure RLEDecode;
public
//property OnProgressChange
//procedure ExpandStream(InStream, OutStream: TStream);
procedure ExpandBlock(InFile: TArchiveFile; OutFile: TFileStream);
{Can call these after ExpandBlock to get error results}
function GetLastCRC32Result: boolean;
constructor Create;
destructor Destroy; override;
end;
(**) implementation (**)
uses ErrorUnit;
{-------------------------------------------------------------------------------
Create
Destroy
-------------------------------------------------------------------------------}
constructor TExpander.Create;
begin
inherited Create;
MTFDecoder := TMTFDecoder.create;
FileStrucAriDecoder := TFileStrucAriDecoder.Create;
end;
destructor TExpander.Destroy;
begin
FileStrucAriDecoder.Free;
MTFDecoder.free;
inherited Destroy;
end;
{-------------------------------------------------------------------------------
Allocate Structs
Free Structs
Swap Blocks
in_block and out_block exchange pointer values
-------------------------------------------------------------------------------}
{procedure TExpander.AllocateStructs;
begin
New(transformation_block);
New(block1);
New(block2);
in_block := block1;
out_block := block2;
end;
procedure TExpander.FreeStructs;
begin
Dispose(block2);
Dispose(block1);
Dispose(transformation_block);
end;}
procedure TExpander.InitStructs;
begin
in_block := BlockMan.block1;
out_block := BlockMan.block2;
transformation_block := BlockMan.longintblock1;
// blocksize is definitely greater than 256, so count and running_total
// can use longintblock
count := P256longintarray(BlockMan.longintblock2);
running_total := P256longintarray(BlockMan.longintblock3);
end;
{-------------------------------------------------------------------------------
ExpandBlock
IN Assertion:
InFile has been seeed to the pos to retrieve the block
OutFile has been seeked to the pos to add data
-------------------------------------------------------------------------------}
procedure TExpander.ExpandBlock(InFile: TArchiveFile; OutFile: TFileStream);
var
DataBlockHeader: TDataBlockHeader;
crc: longword;
begin
//AllocateStructs;
{InFile := _InFile;
OutFile := _OutFile;}
//InFile.ResetBuffer;
InitStructs;
DataBlockHeader := TDataBlockHeader.Create;
DataBlockHeader.ReadFromFile(InFile);
InFile.SetReadByteLimit(DataBlockHeader.compressed_size);
AriDecode(Infile);
MTFDecode(DataBlockHeader.virtual_char_index);
RecoverSortedBlock(DataBlockHeader.first_sym_index, DataBlockHeader.virtual_char_index);
{RLEDecode;}
// check crc
CalculateCRC32(in_block, block_length, crc);
if (DataBlockHeader.crc32 <> crc) then
begin
ShowMessage('CRC does not match!');
FLastCRC32Result := false;
end
else
begin
FLastCRC32Result := true;
end;
// Write to OutFile
OutFile.Write(in_block[0], block_length);
//FreeStructs;
end;
{-------------------------------------------------------------------------------
24/04/2001. IN DEVELOPMENT. DO NOT USE.
ExpandStream
Notes:
Stream compression/decompression does not maintain any data header.
You must specify the block size yourself.
IN Assertion:
InStream has been seeed to the pos to retrieve the block
OutStream has been seeked to the pos to add data
-------------------------------------------------------------------------------}
(*
procedure TExpander.ExpandStream(InStream, OutStream: TStream);
var
DataBlockHeader: TDataBlockHeader;
crc: longword;
begin
InitStructs;
//DataBlockHeader := TDataBlockHeader.Create;
//DataBlockHeader.ReadFromFile(InFile);
InFile.SetReadByteLimit(DataBlockHeader.compressed_size);
AriDecode(Infile);
MTFDecode(DataBlockHeader.virtual_char_index);
RecoverSortedBlock(DataBlockHeader.first_sym_index, DataBlockHeader.virtual_char_index);
{RLEDecode;}
// check crc
CalculateCRC32(in_block, block_length, crc);
if (DataBlockHeader.crc32 <> crc) then
begin
ShowMessage('CRC does not match!');
FLastCRC32Result := false;
end
else
begin
FLastCRC32Result := true;
end;
// Write to OutFile
OutFile.Write(in_block[0], block_length);
//FreeStructs;
end;
*)
{-------------------------------------------------------------------------------
AriDecode
OUT Assertion:
Sets block_length
-------------------------------------------------------------------------------}
procedure TExpander.AriDecode(InFile: TArchiveFile);
begin
// FileStrucAriDecoder := TFileStrucAriDecoder.Create;
FileStrucAriDecoder.DecodeBlock(InFile, out_block, block_length);
SwapBlocks;
end;
{-------------------------------------------------------------------------------
Move To Front Decode and count
-------------------------------------------------------------------------------}
procedure TExpander.MTFDecode(const virtual_char_index: longint);
var
i, j: integer;
b: byte;
begin
MTFDecoder.Init;
// Reset counts to 0
for i := 0 to 255 do
count[i] := 0;
// Count[-1] = 1 since it is the virtual smallest char
// -1 is the virtual character
count[-1] := 1;
// i: outblock index
// j: inblock index
i := 0;
j := 0;
// the decode/count loop is unrolled to 2 parts to ignore the virtual char
while (i < virtual_char_index) do
begin
b := MTFDecoder.Decode(in_block[j]);
out_block[i] := b;
inc(count[b]);
inc(i);
inc(j);
end;
inc(i); // leave one char in outblock for virtual char
while (j < block_length) do // 2nd time
begin
b := MTFDecoder.Decode(in_block[j]);
out_block[i] := b;
inc(count[b]);
inc(i);
inc(j);
end;
// add one to the block length because the virtual char was added
// outblock is now 1 char greater
inc(block_length);
SwapBlocks;
end;
{-------------------------------------------------------------------------------
RecoverSortedBlock
Processes in_block to produce out_block.
Reverses the process of Sort + Transform
IN Assertion: Memory has been allocated for out_block and transformation_block
first_sym_index has been set
-------------------------------------------------------------------------------}
procedure TExpander.RecoverSortedBlock(const first_sym_index, virtual_char_index: longint);
var
i, j, sum, idx: longint;
begin
{Map the symbols from the last column to the first column}
sum := 0;
for i := -1 to 255 do
begin
running_total[i] := sum;
sum := sum + count[i];
count[i] := 0;
end;
// the loop is unrolled to 2 parts to account for the virtual char
for i := 0 to virtual_char_index-1 do
begin
idx := in_block[i];
transformation_block[count[idx] + running_total[idx]] := i;
inc(count[idx]);
end;
// i = virtual_char_index
// we assign manually since -1 cannot be represented in a byte}
transformation_block[count[-1] + running_total[-1]] := virtual_char_index;
for i := virtual_char_index+1 to block_length-1 do
begin
idx := in_block[i];
transformation_block[count[idx] + running_total[idx]] := i;
inc(count[idx]);
end;
// Recover
i := first_sym_index;
for j := 0 to block_length-1 do
begin
out_block[j] := in_block[i];
i := transformation_block[i];
end;
// cut the virtual char. outblock less one char.
dec(block_length);
SwapBlocks;
end;
{-------------------------------------------------------------------------------
Run Length Decode
-------------------------------------------------------------------------------}
{procedure TExpander.RLEDecode;
var
RunLengthDecoder: TRunLengthDecoder;
begin
RunLengthDecoder := TRunLengthDecoder.Create;
RunLengthDecoder.DecodeBlock(in_block, out_block, block_length, block_length);
RunLengthDecoder.Free;
SwapBlocks;
end;}
function TExpander.GetLastCRC32Result: boolean;
begin
result := FLastCRC32Result;
end;
end.

249
Component/BitStreamUnit.pas Normal file
View File

@ -0,0 +1,249 @@
unit BitStreamUnit;
{-------------------------------------------------------------------------------
Bit Access for Streams
----------------------
revision 1.0
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
Acts as a Bit access interface and buffer for a TStream.
Any Stream (TMemoryStream, TFileStream) can be assigned.
Usage Note:
Call BeginBitAccess and EndBitAccess to start and end bit access.
Failure to call any of which may lead to data corruption.
Specially tailored procedures:
SetReadByteLimit
This checks that the bits read fall within the limit. It allows a maximum
of NUM_FAKED_BYTES bytes more read (which the decoder uses) after which data corruption
has most likely occured.
Set to MaxLongInt if the limit is not to be used (default).
version
1.0: First release
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, SysUtils;
const
NUM_FAKED_BYTES = 20;
type
TBitStream = class
private
Stream: TStream;
mask: byte;
rack: byte;
IsOpenInput: boolean;
read_byte_limit: integer;
bytes_read: integer;
//extra_bytes_read: integer; // bytes read past the limit
procedure BitGetNextByte(var b: byte);
procedure GetNextByte(var b: byte);
procedure WriteByte(b: byte);
public
constructor Create(_Stream: TStream; IsRead: boolean);
destructor Destroy; override;
procedure SetReadByteLimit(const limit: integer);
procedure BeginBitReadAccess;
procedure EndBitReadAccess;
procedure BeginBitWriteAccess;
procedure EndBitWriteAccess;
procedure OutputBit(bit: byte);
procedure OutputBits(code: longint; count: byte);
function InputBit: byte;
function InputBits( count: byte ): longint;
end;
(**) implementation (**)
uses ErrorUnit;
constructor TBitStream.Create(_Stream: TStream; IsRead: boolean);
begin
inherited Create;
IsOpenInput := IsRead;
rack := 0;
mask := $80;
SetReadByteLimit(MaxLongInt);
Stream := _Stream;
end;
destructor TBitStream.Destroy;
begin
if (not IsOpenInput) and (Mask <> $80) then WriteByte(rack);
inherited Destroy;
end;
procedure TBitStream.SetReadByteLimit(const limit: integer);
begin
bytes_read := 0;
read_byte_limit := limit;
//extra_bytes_read := 0;
end;
procedure TBitStream.BitGetNextByte(var b: byte);
begin
if (bytes_read >= read_byte_limit) then {If limit number of bytes already read}
begin
if (bytes_read - read_byte_limit >= NUM_FAKED_BYTES) then
begin
ShowError('Too many bytes read in bit mode.');
halt(1);
end
else
begin
b := 0;
inc(bytes_read);
end;
end
else
begin
GetNextByte(b);
inc(bytes_read);
end;
end;
procedure TBitStream.BeginBitReadAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitStream.EndBitReadAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitStream.BeginBitWriteAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitStream.EndBitWriteAccess;
begin
if (not IsOpenInput) and (Mask <> $80) then
begin
WriteByte(rack);
end;
Mask := $80;
rack := 0;
end;
procedure TBitStream.OutputBit(bit: byte);
begin
if (bit <> 0) then
rack := rack or mask;
mask := mask shr 1;
if mask = 0 then
begin
WriteByte(rack);
rack := 0;
mask := $80;
end;
end;
procedure TBitStream.OutputBits(code: longint; count: byte);
var
TempMask: longint;
begin
TempMask := 1 Shl (Count-1);
while TempMask <> 0 do
begin
if (TempMask and Code <> 0) then
Rack := Rack or Mask;
Mask := Mask shr 1;
if Mask = 0 then
begin
WriteByte(Rack);
Rack := 0;
Mask := $80;
end;
TempMask := TempMask shr 1;
end;
end;
function TBitStream.InputBit: byte;
var
value: byte;
begin
if (mask = $80) then
BitGetNextByte(rack);
value := Rack and Mask;
Mask := Mask shr 1;
if Mask = 0 then Mask := $80;
if value = 0 then
result := 0
else
result := 1;
end;
function TBitStream.InputBits( count: byte ): longint;
var
TempMask: longint;
value: longint;
begin
TempMask := 1 shl (count-1);
value := 0;
while TempMask <> 0 do
begin
if (Mask = $80) then
BitGetNextByte(Rack);
if (Rack and Mask <> 0) then
value := (value or TempMask);
TempMask := TempMask shr 1;
Mask := Mask shr 1;
if Mask = 0 then Mask := $80;
end;
result := value;
end;
procedure TBitStream.GetNextByte(var b: byte);
begin
{Interface to Stream}
Stream.ReadBuffer(b, 1);
end;
procedure TBitStream.WriteByte(b: byte);
begin
Stream.WriteBuffer(b, 1);
end;
end.

152
Component/CRC32Unit.pas Normal file
View File

@ -0,0 +1,152 @@
unit CRC32Unit;
{-------------------------------------------------------------------------------
CRC32 Unit
----------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Taken from Swag:
"Copyright (C) 1986 Gary S. Brown"
"File verification using CRC" by Mark R. Nelson in Dr. Dobbs' Journal, May 1992.
Delphi/Class conversion by Victor K / 1998
Desc:
Fast CRC-32 implementation using a table lookup.
The table is generated by another program.
Should be compatible or similar to the PKZip version.
To use:
1) Create the class
2) Run through the buffer passing each byte to Update
3) Get the crc-32
Algo:
crc_val: CRC value
1) Seeds crc_val
2) Uses a formula to update the crc_val
3) Returns the current value of crc_val
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, StructsUnit;
type
TCRC32 = class
private
crc_val: Longword;
public
constructor Create;
procedure Update(b: byte);
function Get: Longword;
end;
procedure CalculateCRC32(block: PBlock; block_length: integer; var crc: longword);
procedure CalculateCRC32Stream(Stream: TStream; len: integer; var crc: longword);
(**) implementation (**)
procedure CalculateCRC32(block: PBlock; block_length: integer; var crc: longword);
var
i: integer;
CRC32: TCRC32;
begin
CRC32 := TCRC32.Create;
for i := 0 to block_length-1 do
CRC32.Update(block^[i]);
crc := CRC32.Get;
CRC32.Free;
end;
procedure CalculateCRC32Stream(Stream: TStream; len: integer; var crc: longword);
var
i: integer;
CRC32: TCRC32;
b: byte;
begin
CRC32 := TCRC32.Create;
for i := 0 to len-1 do
begin
Stream.ReadBuffer(b, 1);
CRC32.Update(b);
end;
crc := CRC32.Get;
CRC32.Free;
end;
{-------------------------------------------------------------------------------
CRC32 Class
-------------------------------------------------------------------------------}
Const
CRCSeed = $ffffffff;
CRC32tab : Array[0..255] of Longword = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
$e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
$09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
$f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
$fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
$3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
$dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
$26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
$cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
$2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
$98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
$7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
$91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
$6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
$8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
$a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
$44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
$be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
$b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
$ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
$0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
$f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
$196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
$f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
$38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
$316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
$cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
$2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
$9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
$72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
$92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
$88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
$616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
$a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
$40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
$54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
$b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d );
constructor TCRC32.Create;
begin
inherited Create;
crc_val := CRCSeed;
end;
procedure TCRC32.Update(b: byte);
begin
crc_val := CRC32tab[Byte(crc_val xor Longword(b))] xor ((crc_val shr 8) and $00ffffff);
end;
function TCRC32.Get: Longword;
begin
result := (crc_val xor CRCSeed)
end;
end.

665
Component/EDosUnit.pas Normal file
View File

@ -0,0 +1,665 @@
unit EDosUnit;
{-------------------------------------------------------------------------------
Supporting Dos Unit.
-------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
revision 2.1
Delphi version: 4.0
Purpose: Provide encapsulation and better error handling for delphi's
file/system functions.
Notes: This unit started out a long time ago to add to the Dos unit.
Delphi adds alot of system functionality that makes many of these procedures
redundant. Using this or Delphi's one should be similar.
Many procedures have been commented out, deleted or lost because they
were either too old or were lost in one of those h/d crash.
Conventions :
- S is used to represent "DirectoryString" or generally, string.
Rules to follow :
Directory paths:
- All directories end with a '\'
AddSlash appends the '\' if necessary.
DelSlash removes the '\' if there is one
File names/paths:
- file names may contain no extension.
- File seperators are '\'
- All file names are in 'string' type.
TDriveList
----------
Used for enumerating drives
DEFUNCT: TEnSearchRec
---------------------
The TEnhSearchRec (Enhanced Search Record) is a customized search
record object.
notes:
The fileTime used here is an integer. See FileDateToDateTime.
methods :
- constructor CreateFrom(const f: TSearchRec);
Creates a new object from f
- procedure CopySearchRec(const f: TSearchRec);
Copies data from f
EDosType
--------
Extra Dos functions type.
This object provides additional dos functions.
- GetWindowsDirectory: string;
Wrapper for the win32 API function, GetWindowsDirectory.
returns the string.
- function GetPathFromTree(const TreeView : TTreeView; const TreeNode : TTreeNode) : string;
Constructs a directory path to Tree Node, seperated by '\'
Note: If there is a customised one, (eg. DirTreeForm) don't use this.
- function HasSubDir(var S : string) : boolean;
True if the directory, S, has a sub directory.
- FileExists (Under SysUtils)
- Path exists (Use DirectoryExists Delphi 4)
true if a file/drive/directry exists.
To check for a drive, use 'c:'. Do not append a slash.
- ForceDirectories
ripped from FileCtrl
will raise EInOutError if dir cannot be created e.g. drive not ready
- function ShowErrorMessageBox(const ErrorCode: integer): integer;
Shows a meaningful message (if available) for the ErrorCode.
Check help for "Error Codes". Returns the user's reponse from the
message box eg. IDRETRY, IDCANCEL.
Note: The message will not be shown if there is no error ie. ErrorCode = 0.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ComCtrls, ShellAPI,
FileCtrl,
// for SCannotCreateDir
Consts;
type
TFilePos = Longint;
TDriveList = class
private
CurrPos: integer; // current position in DriveStr
EndOfList: boolean; // true when end of list is reached.
public
DriveStr: PChar; // string of drive letters gotten from GetLogicalDrivesString
constructor Create;
destructor destroy; override;
function Next: string;
{Returns the next drive string, returns a null string when the
end of the list is reached}
procedure Reset;
{restart}
end;
(* TEnhSearchRec = class
public
constructor CreateFrom(const f: TSearchRec);
procedure CopySearchRec(const f: TSearchRec);
function IsArchive: boolean;
function IsReadOnly: boolean;
function IsSysFile: boolean;
function IsHidden: boolean;
function IsFolder: boolean;
private
FCreationTime,
FLastAccessTime,
FLastWriteTime: TDateTime;
FSize: Integer;
FAttr: Integer;
FName: TFileName;
{Time functions}
function Win32FileTimeToDosDateTime(const ftime: TFileTime): integer;
published
property Size: Integer read FSize;
property Attr: Integer read FAttr;
property Name: TFileName read FName;
property CreationTime: TDateTime read FCreationTime;
property LastAccessTime: TDateTime read FLastAccessTime;
property LastWriteTime: TDateTime read FLastWriteTime;
end; *)
EDosType = class
public
{defunct}
{function GetPathFromTree(const TreeNode: TTreeNode) : string;}
{Directory related functions}
function GetWindowsDirectory: string;
function HasSubDir(const S: string): boolean;
procedure AddSlash(var s: string);
procedure DelSlash(var s: string);
procedure DelTree(dir: string);
procedure ForceDirectories(Dir: string);
function PathExists(const s: string): boolean;
function ExtractFolders(s: string): string;
{function FileExists(const S: string): boolean;
procedure CreatePath(const s: string);}
{FindFirst/FindNext}
function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
function FindNext(var F: TSearchRec): Integer;
procedure FindClose(var F: TSearchRec);
function GetSysImageList: TImageList;
{Error support}
function TestIO(const val: integer): boolean;
end;
var
EDos : EDosType;
(**) implementation (**)
////////////////////////////////////////////////////////////////////////////////
// TDriveList
////////////////////////////////////////////////////////////////////////////////
const
DriveStrSize = 1000; // size of the DriveStr variable
constructor TDriveList.create;
begin
GetMem(DriveStr, DriveStrSize);
GetLogicalDriveStrings(DriveStrSize, DriveStr);
CurrPos := 0;
EndOfList := false;
end;
destructor TDriveList.destroy;
begin
FreeMem(DriveStr);
end;
function TDriveList.Next: string;
begin
result := '';
if (ord(DriveStr[CurrPos]) = 0) or EndOfList then
begin
EndOfList := true;
exit;
end;
while (ord(DriveStr[CurrPos]) <> 0) do
begin
result := result + DriveStr[CurrPos];
inc(CurrPos);
end;
inc(CurrPos); {Next position to start reading from}
end;
procedure TDriveList.Reset;
begin
CurrPos := 0;
EndOfList := false;
end;
////////////////////////////////////////////////////////////////////////////////
// TEnhSearchRec
////////////////////////////////////////////////////////////////////////////////
(* constructor TEnhSearchRec.CreateFrom(const f: TSearchRec);
begin
inherited create;
CopySearchRec(f);
end;
procedure TEnhSearchRec.CopySearchRec(const f: TSearchRec);
begin
FSize := f.Size;
FAttr := f.Attr;
FName := f.Name;
FLastWriteTime := FileDateToDateTime(f.Time);
// FCreationTime := FileDateToDateTime(Win32FileTimeToDosDateTime(f.FindData.ftCreationTime));
// FLastAccessTime := FileDateToDateTime(Win32FileTimeToDosDateTime(f.FindData.ftLastAccessTime));
end;
function TEnhSearchRec.IsFolder: boolean;
begin
result := (Attr and faDirectory <> 0);
end;
function TEnhSearchRec.IsArchive: boolean;
begin
result := (Attr and faArchive <> 0);
end;
function TEnhSearchRec.IsReadOnly: boolean;
begin
result := (Attr and faReadOnly <> 0);
end;
function TEnhSearchRec.IsSysFile: boolean;
begin
result := (Attr and faSysFile <> 0);
end;
function TEnhSearchRec.IsHidden: boolean;
begin
result := (Attr and faHidden <> 0);
end;
function TEnhSearchRec.Win32FileTimeToDosDateTime(const ftime: TFileTime): integer;
var
LocalFileTime: TFileTime;
Time: integer;
begin
FileTimeToLocalFileTime(ftime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi,
LongRec(Time).Lo);
result := Time;
end;
*)
////////////////////////////////////////////////////////////////////////////////
// EDosType
////////////////////////////////////////////////////////////////////////////////
function EDosType.GetWindowsDirectory: string;
var
c: PChar; {PChar to get the directory}
const
cLength = MAX_PATH; {Length of c}
begin
c := StrAlloc(cLength + 1);
windows.GetWindowsDirectory(c, cLength);
result := c;
StrDispose(c);
end;
procedure EDosType.AddSlash(var s: string);
var
len: integer;
begin
len := length(s);
if (len > 0) and (s[len] <> '\') then
s := s + '\';
end;
procedure EDosType.DelSlash(var s: string);
var
len: integer;
begin
len := Length(s);
if (len > 0) and (s[len] = '\') then
delete(S, len, 1);
end;
function EDosType.HasSubDir(const S : string) : boolean;
var
F : TSearchRec;
rc : integer;
found : boolean;
begin
found := false;
rc := FindFirst(S + '*.*', faDirectory, F);
while (rc = 0) do begin
if (F.Attr and faDirectory <> 0) and (F.Name[1] <> '.') then begin
found := True;
break;
end;
rc := FindNext(F);
end;
FindClose(F);
result := found;
end;
(*
function EDosType.GetPathFromTree(const TreeNode : TTreeNode) : string;
var
rs : string;
WorkNode : TTreeNode;
begin
rs := '';
WorkNode := TreeNode;
while (WorkNode <> nil) do begin
rs := rCheckDirStr(WorkNode.Text) {+ '\'} + rs;
WorkNode := WorkNode.Parent;
end;
result := rs;
end;
*)
{$I-}
{Path exists checks for drive, file or directory}
function EDosType.PathExists(const s: string): boolean;
var
F: TSearchRec;
ws: string;
curDir: string;
begin
// create a working copy
ws := s;
DelSlash(ws);
// test for eg 'c:', 'z:', 'x:'
if (ws[2] = ':') and (length(ws) <= 2) then
begin
//drive
GetDir(0, curDir);
CHDir(ws);
result := (ioResult = 0);
CHDir(curDir);
end
else
begin
// File or dir
result := (FindFirst(ws, faAnyFile, F) = 0);
FindClose(F);
end;
end;
procedure EDosType.DelTree(dir: string);
var
F: TSearchRec;
r: integer;
CurFileStr: string;
begin
r := FindFirst(dir + '\*.*', faAnyFile - faVolumeID, F);
while (r = 0) do
begin
with F do
begin
CurFileStr := dir + '\' + Name;
// test if it is a directory
if (Attr and faDirectory <> 0) then
begin
// if it is a directory we rescurse into it
if (Name[1] <> '.') then
DelTree(CurFileStr);
end
else
begin
// test if it has a read only or system attribute which
// may hinder deletion. clear it.
// DO: IMPLEMENT EXCEPTION CHECKING FILESETATTR and DELETEFILE
if (Attr and faReadOnly <> 0) or
(Attr and faHidden <> 0) or
(Attr and faSysFile <> 0) then
FileSetAttr(CurFileStr, 0);
DeleteFile(CurFileStr);
end;
end;
r := FindNext(F);
end;
// remove the empty dir
RmDir(dir);
FindClose(F);
end;
procedure EDosType.ForceDirectories(Dir: string);
begin
FileCtrl.ForceDirectories(Dir);
if not DirectoryExists(Dir) then
raise EInOutError.Create('Cannot force directory');
{if Length(Dir) = 0 then
raise Exception.Create(SCannotCreateDir);
if (AnsiLastChar(Dir) <> nil) and (AnsiLastChar(Dir)^ = '\') then
Delete(Dir, Length(Dir), 1);
if (Length(Dir) < 3) or DirectoryExists(Dir)
or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
ForceDirectories(ExtractFilePath(Dir));
if not CreateDir(Dir) then
raise EInOutError.Create('Cannot force directory');}
end;
function EDosType.GetSysImageList: TImageList;
var
SysImageList: TImageList;
FileInfo: TSHFileInfo;
begin
SysImageList := TImageList.create(Application);
with SysImageList do
begin
handle := SHGetFileInfo(PChar(EDos.GetWindowsDirectory), 0, FileInfo, sizeof(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
ShareImages := true;
end;
result := SysImageList;
end;
function EDosType.FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
begin
repeat
result := SysUtils.FindFirst(Path, Attr, F);
until TestIO(result);
end;
function EDosType.FindNext(var F: TSearchRec): Integer;
begin
repeat
result := SysUtils.FindNext(F);
until TestIO(result);
end;
procedure FileSetAttr(const FileName: string; Attr: Integer);
var
retval: integer;
begin
retval := SysUtils.FileSetAttr(FileName, Attr);
if (retval <> 0) then
raise EInOutError.Create('FileSetAttr error');
end;
procedure DeleteFile(const FileName: string);
begin
if (SysUtils.DeleteFile(FileName) = false) then
raise EInOutError.Create('DeleteFile error');
end;
procedure EDosType.FindClose(var F: TSearchRec);
begin
SysUtils.FindClose(F);
end;
{-------------------------------------------------------------------------------
TestIO
Desc: Will test the IO return value val for error.
Returns True if IO is OK.
False means the operation should retry
If the user cancelled, then EInOutError will be raised with the error description
-------------------------------------------------------------------------------}
function EDosType.TestIO(const val: integer): boolean;
var
Caption: string;
ErrorDesc: string;
HelpStr: string;
flags : integer;
begin
if (val = 0) OR
(val = ERROR_NO_MORE_FILES) then
result := true
else
begin
// give user choice of retrying
// the function will return a false indicating a retry
// otherwise if the user cancelled, then an EInOutError will be returned
Caption := 'Error';
ErrorDesc := '';
HelpStr := '';
case val of
// the error consts are taken from the Windows unit
ERROR_PATH_NOT_FOUND:
begin
ErrorDesc := 'Path not found.';
//HelpStr := 'Try re-reading the directory.';
end;
ERROR_NOT_READY: {21: drive not ready}
begin
ErrorDesc := 'Drive not ready.';
HelpStr := 'Make sure the disk is properly inserted.';
end;
else
begin
ErrorDesc := 'No error description available.';
HelpStr := 'Choose ''Retry'' to retry the last operation.';
end;
end;
{Display the error code also}
flags := MB_ICONERROR or MB_RETRYCANCEL;
if (Application.MessageBox(PChar(ErrorDesc + #13 + HelpStr + ' (Error code: ' + IntToStr(val) + ')'),
PChar(Caption), flags) = IDRetry) then
result := false
else
raise EInOutError.Create(Caption);
end;
end;
{File exists checks if a file exists. Dirs and drives are not counted.
Now defunct. exists in SysUtils.}
{function EDosType.FileExists(const s: string): boolean;
var
F: TSearchRec;
ws: string;
r: integer;
begin
// create a working copy
ws := s;
DelSlash(ws);
r := FindFirst(ws, faAnyFile, F);
while (r = 0) do
begin
if (F.Attr and faDirectory = 0) then
begin
result := true;
FindClose(F);
exit;
end;
r := FindNext(F);
end;
result := false;
FindClose(F);
end;}
(* CreatePath
Don't think this works. Use ForceDirectories
{$I+}
procedure EDosType.CreatePath(const s: string);
var
i, path_length: integer;
next_dir: string;
function GetNextDir: string;
begin
next_dir := '';
while (i < path_length) and (s[i] <> '\') do
begin
next_dir := next_dir + s[i];
inc(i);
end;
// skip the '\'
inc(i);
end;
begin
i := 1;
path_length := length(s);
{$I-}
GetNextDir;
// make sure the drive is passed
Assert(next_dir[2] = ':', 'CreatePath: Drive not passed.');
// change to drive first. '\' added to change to root.
CHDir(next_dir + '\');
if (IOResult <> 0) then raise EInOutError.Create('CreatePath: Cannot change to drive');
GetNextDir;
while (next_dir <> '') do
begin
CHDir(next_dir);
if (IOResult <> 0) then
begin
// directory does not exist.
// try to create it.
MKDir(next_dir);
if (IOResult <> 0) then raise EInOutError.Create('CreatePath: Cannot create directory');
end
else
GetNextDir;
end;
{$I+}
end; *)
function EDosType.ExtractFolders(s: string): string;
begin
// returns the folders only
// same as ExtractPath but without the drive
s := ExtractFilePath(s);
if (s[2] = ':') then delete(s, 1, 2);
if s[1] = '\' then delete(s, 1, 1);
result := s;
end;
initialization
EDos := EDosType.Create;
finalization
EDos.free;
end.

38
Component/ErrorUnit.pas Normal file
View File

@ -0,0 +1,38 @@
unit ErrorUnit;
{-------------------------------------------------------------------------------
Error management unit
---------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
Used for debugging and showing of error messages quickly.
-------------------------------------------------------------------------------}
(**) interface (**)
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
{Displays a messagebox with the error description s}
procedure ShowError(const s: string);
procedure ShowFatal(const s: string);
(**) implementation (**)
procedure ShowError(const s: string);
begin
Application.MessageBox(PChar(s), 'Error', 0);
end;
procedure ShowFatal(const s: string);
begin
Application.MessageBox(PChar(s), 'Fatal', 0);
halt(1);
end;
end.

653
Component/FSortUnit.pas Normal file
View File

@ -0,0 +1,653 @@
unit FSortUnit;
{-------------------------------------------------------------------------------
Fast sorter unit
----------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Fast sort unit.
Algos:
DJ Wheeler from his June 1989 report and
Kunihiko Sadakane's Suffix sort.
coded by gruv
Notes:
Sort the index, not the block.
SadaSort compares group indexes not block.
Sort rev 4:
Radix on symbol pairs.
Sadakane's Suffix sort.
------------------------------------------------------------------------------}
(**) interface (**)
uses SysUtils, Forms, dialogs, StructsUnit;
const
STRIDE = 4;
MAXDEPTH = 20;
NUMOVERSHOOT = MAXDEPTH + 100;
type
{THead = array[0..65535] of Longint;
PHead = ^THead;}
TFastSorter = class
private
block: PBlock; // block to sort
index: PLongintBlock; // index to the block to sort. each index pos is a string
block_length: longint; // length of the block
last_index: integer;
head: P64kBlock; // head of the linked list
link: PLongintBlock; // links in the linked list
//link_count: PHead; // Number of links in each head
//index_head: PHead; // start of each group in index
group: PLongintBlock; // group of suffix s
size: PLongintBlock;
{For SadaSort: from the paper
I -> index
V -> group
S -> size}
procedure RadixSortOnSymbolPairs;
procedure InitIndexFromLink;
procedure SadaSort;
procedure SortGroup(const stlo, sthi, depth: integer);
public
constructor Create;
destructor Destroy; override;
procedure SortBlock(const _block: PBlock; const _index: PLongintBlock; const _block_length: longint);
end;
(**) implementation (**)
uses ErrorUnit;
{-------------------------------------------------------------------------------
Create/Destroy
--------------
Allocates and frees the memory structures used for sorting.
-------------------------------------------------------------------------------}
constructor TFastSorter.Create;
begin
inherited Create;
{New(head);
New(link);
//New(link_count);
//New(index_head);
New(group);
New(size);}
end;
destructor TFastSorter.Destroy;
begin
{Dispose(size);
Dispose(group);
//Dispose(index_head);
//Dispose(link_count);
Dispose(link);
Dispose(head);}
inherited Destroy;
end;
{-------------------------------------------------------------------------------
SortBlock
---------
Main procedure to call.
Initializes the block then calls the respective procedures to sort the block.
-------------------------------------------------------------------------------}
procedure TFastSorter.SortBlock(const _block: PBlock; const _index: PLongintBlock; const _block_length: longint);
procedure Initialize;
var
i: integer;
begin
{Initialize}
block := _block;
index := _index;
block_length := _block_length;
last_index := block_length-1;
// sizes array need not be cleared. it will be init.
// assign block memory
// index -> longintblock1
head := BlockMan.k64Block;
link := BlockMan.longintblock2;
group := BlockMan.longintblock2;
size := BlockMan.longintblock3;
{Clear Arrays}
for i := 0 to 65535 do
head[i] := -1;
end;
//var
//head_idx, cur_head: longword;
//first_char: byte;
//i, numkeys, first_head: integer; // numkeys: total number of keys with first_char
//t: longword;
//totalbytes: integer; // for progress bar
begin
//totalbytes := 0;
Initialize;
RadixSortOnSymbolPairs; // fill up head and link
InitIndexFromLink; // get index in semi sorted order and index_head
SadaSort;
end;
{-------------------------------------------------------------------------------
RadixSortOnSymbolPairs
----------------------
Radix sort: Run through the block array in words to get the buckets and dump
the indexes into their respective bucket.
Initializes long_block with each long integer straddling 4 bytes.
OUT Assertion:
head/link are linked lists to the sort.
long_block is initialized
-------------------------------------------------------------------------------}
procedure TFastSorter.RadixSortOnSymbolPairs;
var
i: integer;
w: word;
begin
{Init w with the first character}
w := block^[0];
for i := 0 to last_index-1 do
begin
w := word(w shl 8) or block^[i+1];
{if there is no entry in head then set the pos as the head.
Otherwise link the pos in by making it the head and setting its link}
if (head^[w] = -1) then
begin
head^[w] := i;
link^[i] := -1;
{Set link^[i] to -1 as the terminator}
end
else
begin
link^[i] := head^[w];
head^[w] := i;
end;
end; {for}
end;
{-------------------------------------------------------------------------------
InitIndexFromLink
-----------------
Out Assertion:
Inits index, index_head and link_count.
index_head will point to the head of each symbol pair in index.
link_count is the count for each symbol pair corresponding in head.
index will contain a continuous list of indexes. These indexes are in groups
with their head pointed to by index_head and counts in link_count.
Quicksort will sort the index.
head no more used.
Desc:
This will run through the head array.
It will fill in the index_head with all valid entries from head.
It is therefore possible that index_head be smaller than head, because all
-1 entries are removed.
The current index position is then filled with the head value.
If there is a head, there may be links. So the links are filled in trailing
after the head value until a -1 terminator is reached.
Note:
link_count includes the head node and all other link nodes.
link_count corresponds to the new def. of head, NOT the old one.
link_count[i] is the count for index_head[i].
All -1 or 'no entries' in index_head have been removed. index_head is a continuous list
of heads in index.
The end of index_head is marked by a -1.
New:
use link and head to init index, index_head, link_count, size
index_pos walks through to fill in index with the semi sorted indexes.
after this, link and head are no more used.
link and group share the same memory location
-------------------------------------------------------------------------------}
procedure TFastSorter.InitIndexFromLink;
var
i, index_pos, {head_pos,} cur_node, t: longint;
group_num: integer;
//group_first_index: integer;
group_size: integer;
w: word;
begin
index_pos := 1; // start from 1 for virtual smallest character. for circular start from 0
//head_pos := 0;
// due to the last char being the smallest char, we must fill in manually
// link for that one.
// if actual last is 'e', then we get 'e$00' and we add to the head.
w := word(block[last_index] shl 8);
{if there is no entry in head then set the pos as the head.
Otherwise link the pos in by making it the head and setting its link}
if (head^[w] = -1) then
begin
head^[w] := last_index;
link^[last_index] := -1;
// Set link[i] to -1 as the terminator
end
else
begin
link^[last_index] := head^[w];
head^[w] := last_index;
end;
{go through each radix bucket}
for i := 0 to 65535 do
begin
cur_node := head^[i];
if (i = w) then
begin
// the link with the virtual smallest char is the first one
// we give it it's own group number, remove it from the linked list
// and continue as if this never happened
// cur_node is the index
// index_pos is the group number
Assert(cur_node = last_index);
index[index_pos] := cur_node;
size[index_pos] := 1;
// link and group share the same memory location. update cur_node then
// assign the group number because we'll never access that link again.
cur_node := link[cur_node]; // take out the memory contents
group[last_index] := index_pos; // override it
inc(index_pos);
end;
if (cur_node <> -1) then
begin
{Head now points to the head of a symbol pair linked list in index}
//index_head^[head_pos] := index_pos;
//link_count^[head_pos] := 0;
// walk the linked list
group_num := index_pos; // group_num is i
//group_first_index := cur_node;
group_size := 0;
repeat
// collate the nodes in index
index[index_pos] := cur_node;
t := cur_node; // save the cur_node
cur_node := link[cur_node];
// fill in the group number for index_pos
// override previous memory location in link with the group_num
group[t] := group_num; // group[index[index[pos]] or V[I[i]]
inc(index_pos);
inc(group_size); // inc(link_count[head_pos]);
until (cur_node = -1);
// fill in the group size in size[group_num]
size[group_num] := group_size;
//size[group_num] := link_count[head_pos];
//inc(head_pos);
end;
end;
//index_head^[head_pos] := -1;
// init the virtual smallest character
block[block_length] := 0;
index[0] := block_length;
size[0] := -1; // sorted, 1 char only
group[index[0]] := 0; // first group}
end;
{Notes:
group and index init from 1 to block_size
0 is the virtual smallest char. compare with index[0]=block_size should
be greater. note that index[0] may not contain block_size}
procedure TFastSorter.SortGroup(const stlo, sthi, depth: integer);
{Swap - swaps 2 values v1 and v2 }
procedure Swap(var v1, v2: longword); overload;
var
t: longword;
begin
t := v1;
v1 := v2;
v2 := t;
end;
{Swap - swaps 2 values v1 and v2 }
procedure Swap(var v1, v2: longint); overload;
var
t: longword;
begin
t := v1;
v1 := v2;
v2 := t;
end;
{Vector swap}
procedure VecSwap(p1, p2, n: longword);
{var
t: longword;}
begin
while (n > 0) do
begin
{Swap p1, p2}
{t := p1;
p1 := p2;
p2 := t;}
Swap(index[p1], index[p2]);
inc(p1); inc(p2); dec(n);
end;
end;
{Median of 3}
function Med3(a, b, c: byte): byte; overload;
var
t: byte;
begin
if (a > b) then
begin
{Swap a, b}
t := a; a := b; b := t;
end;
if (b > c) then
begin
{Swap b, c}
t := b;
b := c;
c := t;
end;
if (a > b) then b := a;
result := b;
end;
function Min(a, b: integer): integer;
begin
if (a < b) then
result := a
else
result := b;
end;
function Med3(a, b, c: longword): longword; overload;
var
t: longword;
begin
if (a > b) then
begin
{Swap a, b}
t := a; a := b; b := t;
end;
if (b > c) then
begin
{Swap b, c}
t := b;
b := c;
c := t;
end;
if (a > b) then b := a;
result := b;
end;
function Med3(a, b, c: integer): integer; overload;
var
t: integer;
begin
if (a > b) then
begin
{Swap a, b}
t := a; a := b; b := t;
end;
if (b > c) then
begin
{Swap b, c}
t := b;
b := c;
c := t;
end;
if (a > b) then b := a;
result := b;
end;
{function NormIdx(idx: integer): integer;
begin
repeat
if (idx > last_index) then
dec(idx, last_index)
else
begin
result := idx;
exit;
end;
until false;
end;}
procedure QSort3(lo, hi: integer);
{lo, hi: first and last element
Note: we will compare group numbers
the depth of comparison is constant througout the recursion}
var
a, b, c, d: integer; // may become negative?
r: integer;
med: integer; // byte
i, group_num: integer;
begin
if (hi-lo < 1) then
begin
// 1 item only. assign it a group
if (hi = lo) then
begin
group[index[hi]] := hi;
size[hi] := 1;
end;
exit;
end;
med := Med3(group[index[lo] + depth],
group[index[hi] + depth],
group[index[(lo + hi) shr 1] + depth]);
a := lo;
b := lo;
c := hi;
d := hi;
while true do
begin
{ = < }
{ find item greater than med, while swapping equal items to the left }
while (b <= c) and (group[index[b] + depth] <= med) do
begin
if (group[index[b] + depth] = med) then
begin
Swap(index[a], index[b]);
inc(a);
end;
inc(b);
end;
{ > = }
{ find item smaller than med, while swapping equal items to the right }
while (b <= c) and (group[index[c] + depth] >= med) do
begin
if (group[index[c] + depth] = med) then
begin
Swap(index[c], index[d]);
dec(d);
end;
dec(c);
end;
if (b > c) then break;
// swap b and c
Swap(index[b], index[c]);
inc(b);
dec(c);
end;
{b = c+1 once we are out}
Assert(b = c+1);
//if b <> (c+1) then ShowMessage('bc');
{final arrangment:
lo a c b d hi
d is next avail pos. d+1 to hi: = items
a is next avail pos. lo to a-1: = items}
{left centre right}
{swap enough to get left from '= <' to '< ='
a-lo: num of = items
b-a: num of < items
r gives the min items to swap}
r := min(a-lo, b-a);
VecSwap(lo, b-r, r);
{swap enough to get right from '> =' to '= >'
d-c: num of > items
hi-d: num of = items}
r := min(d-c, hi-d);
VecSwap(b, hi-r+1, r);
// sort from higher to lower
// for equal items update their group numbers to the same group
r := d-c; // num of '>' items
QSort3(hi-r+1, hi); // sort right
r := (a-lo) + (hi-d);
{QSort3(lo+b-a, lo+b-a+r-1); // sort middle}
group_num := lo+b-a;
for i := lo+b-a to lo+b-a+r-1 do // give the '=' items the same group number
group[index[i]] := group_num;
size[group_num] := r;
r := b-a; // size of '<' items
QSort3(lo, lo + r - 1); // sort left
end; {QSort3}
begin
QSort3(stlo, sthi);
end;
procedure TFastSorter.SadaSort;
var
i, k: integer;
first_i: integer;
group_size: integer;
begin
// sort unsorted groups
// go through the size array. anything with size 1 we ignore and add to the
// previous group size
// if first_i = -1 that means first_i not avail and next sorted group can
// be first_i
// blocksize has increased by 1 because of the vitual char
inc(block_length);
// keep sorting until all has been sorted
k := 2;
while (abs(size[0]) < (block_length-1)) do
begin
i := 0;//i := abs(size[0]);
first_i := -1;
repeat
if (size[i] < 0) then
begin
if (first_i = -1) then
begin
first_i := i; // we can add further sorted groups to this group
inc(i, abs(size[i])); // skip this group
end
else
begin
Assert(size[first_i] < 0);
inc(size[first_i], size[i]); // add to the first_i
inc(i, abs(size[i])); // skip, because it is sorted and group has been combined
end;
end
else if (size[i] = 1) then
begin
if (first_i = -1) then
begin
first_i := i; // we can add further sorted groups to this group
size[first_i] := -1; // make this the head sorted group
end
else
begin
Assert(size[first_i] < 0);
dec(size[first_i]); // add this group to the first_i
end;
inc(i);
end
else
begin
// group size > 1 sort it
group_size := size[i];
SortGroup(i, i + size[i]-1, k);
inc(i, group_size); // size[i] may change after sort group
first_i := -1;
end;
until (i >= block_length); // while (i < block_length-1)
k := k * 2;
end;
end;
end.

View File

@ -0,0 +1,149 @@
unit FileStrucAriDecoderUnit;
{-------------------------------------------------------------------------------
File Structured Arithmetic Decoder Unit
---------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
Derives from Structured arithmetic decoder to allow it to write to files.
Handles the input from the archive file by implementing InputBit/InputBits.
To use:
Create the class.
Call DecodeBlock.
Free.
DecodeBlock
Wrapper proc.
Decode from file to block. returns the block length in block_length.
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes,
StructsUnit,
StrucAriDecoderUnit, GroupAriModelUnit, ArchiveFileUnit;
type
TFileStrucAriDecoder = class(TStrucAriDecoder)
protected
ArchiveFile: TArchiveFile;
function InputBit: byte; override;
function InputBits( count: byte ): longint; override;
public
constructor Create;
destructor Destroy; override;
procedure DecodeBlock(_ArchiveFile: TArchiveFile; block: PBlock; var block_length: integer);
end;
(**) implementation (**)
constructor TFileStrucAriDecoder.Create;
begin
inherited Create;
end;
destructor TFileStrucAriDecoder.Destroy;
begin
inherited Destroy;
end;
function TFileStrucAriDecoder.InputBit: byte;
begin
result := ArchiveFile.InputBit;
end;
function TFileStrucAriDecoder.InputBits( count: byte ): longint;
begin
result := ArchiveFile.InputBits(count);
end;
procedure TFileStrucAriDecoder.DecodeBlock(_ArchiveFile: TArchiveFile; block: PBlock; var block_length: integer);
var
i, j: longint;
symbol: integer;
mask: integer;
run_length: integer;
begin
ArchiveFile := _ArchiveFile;
ArchiveFile.BeginBitReadAccess;
StartDecoding;
i := 0;
DecodeSymbol(symbol);
while (symbol <> EOF_SYMBOL) do
begin
{Convert the symbols to ascii
symbols 0 and 1 represent runs of 0s.
symbols 2 - 256 represent ascii 1-255 repectively.
symbol 257 is the EOB}
if (symbol <= 1) then
begin
{expand runs}
{successive 0s have weights 1, 2, 4, 8, 16, ..., while
successive 1s have weights 2, 4, 8, 16, 32, ... .}
{read in symbols and get run length.
start off with the currently read symbol}
run_length := 0;
mask := 1;
repeat
if (symbol = 0) then
inc(run_length, mask)
else
inc(run_length, (mask shl 1));
mask := mask shl 1;
DecodeSymbol(symbol);
until (symbol > 1) or (symbol = EOF_SYMBOL);
{expand run and update i}
for j := 1 to run_length do
begin
block^[i] := 0;
inc(i);
end;
{DEBUG: Test no run expansion.
1 should not appear because MTF_1 is symbol_2}
{Assert(symbol <> 1, 'No run expansion but symbol_1 appeared.');
block^[i] := 0;
DecodeSymbol(symbol);
inc(i);}
{symbol has been filled with a value greater than 1 or it is EOF_SYMBOL
i is positioned to the next pos to fill}
end
else
begin
{decrement symbol value by 1 to get the ascii}
block^[i] := byte(symbol-1);
inc(i);
DecodeSymbol(symbol);
end;
end;
block_length := i;
{DEBUG: If there is no run_length compression, then the block_length should be
blocksize for all except the last block.}
//Assert(block_length = BLOCKSIZE, 'block_length <> BlockSize');
DoneDecoding;
ArchiveFile.EndBitReadAccess;
end;
end.

View File

@ -0,0 +1,165 @@
unit FileStrucAriEncoderUnit;
{-------------------------------------------------------------------------------
File Structured Arithmetic Encoder Unit
---------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
Derives from Structured arithmetic encoder to allow it to write to files.
Handles the output to the archive file by implementing OutputBit/OutputBits.
procedure EncodeBlock(block: PBlock; block_length: integer);
Encodes the block with block length block_length.
Will encode the block with an EOF symbol trailing.
To Use:
Create it.
Call EncodeBlock
Free.
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, dialogs,
// general
StructsUnit,
// base class
StrucAriEncoderUnit, GroupAriModelUnit, ArchiveFileUnit, BitStreamUnit;
type
TFileStrucAriEncoder = class(TStrucAriEncoder)
protected
ArchiveFile: TArchiveFile; // required by OutputBit
procedure OutputBit(bit: byte); override;
procedure OutputBits(code: longint; count: byte); override;
public
constructor Create;
destructor Destroy; override;
procedure EncodeBlock(_ArchiveFile: TArchiveFile; block: PBlock; block_length: integer);
end;
(**) implementation (**)
constructor TFileStrucAriEncoder.Create;
begin
inherited Create;
//ArchiveFile := _ArchiveFile;
end;
destructor TFileStrucAriEncoder.Destroy;
begin
//ArchiveFile.ResetBuffer;
inherited Destroy;
end;
procedure TFileStrucAriEncoder.OutputBit(bit: byte);
begin
ArchiveFile.OutputBit(bit);
end;
procedure TFileStrucAriEncoder.OutputBits(code: longint; count: byte);
begin
ArchiveFile.OutputBits(code, count);
end;
procedure TFileStrucAriEncoder.EncodeBlock(_ArchiveFile: TArchiveFile; block: PBlock; block_length: integer);
var
i, j: longint;
run_length: integer;
mask, num_bits: integer;
begin
ArchiveFile := _ArchiveFile;
ArchiveFile.BeginBitWriteAccess;
StartEncoding;
i := 0;
while (i < block_length) do
begin
{DEBUG panick case: plain encode}
//EncodeSymbol(block^[i]);
{Convert the ascii to symbols.
symbols 0 and 1 represent runs of 0s.
symbols 2 - 256 represent ascii 1-255 repectively.
symbol 257 is the EOB}
if (block^[i] = 0) then
begin
{Wheeler's run length coding.
convert to runs of 0s
Algo: Count run_length, or number of 0s (run length includes init byte
Increment run_length by one
Ignore most significant one bit and encode run_length
as ordinary binary number}
{count run length and inc i. min run_length will be 1}
run_length := 0;
repeat
inc(i);
inc(run_length);
until (i >= block_length) or (block^[i] <> 0);
//if (i > block_length) then ShowMessage('Hello');
{increment by 1}
inc(run_length);
{find the most significant 1 bit and count the number of bits
to output in num_bits}
num_bits := 32;
mask := 1 shl 31;
while (run_length and mask = 0) do
begin
mask := mask shr 1;
dec(num_bits);
end;
{ignore most significant 1 bit}
dec(num_bits);
{output the number as an ordinary binary number from the lsb}
mask := 1;
for j := 1 to num_bits do
begin
if (run_length and mask <> 0) then
EncodeSymbol(1)
else
EncodeSymbol(0);
mask := mask shl 1;
end;
{DEBUG: Test no run length coding. code 0s directly.
The value 1 should not appear at all}
{EncodeSymbol(0);
inc(i);}
{i will have been set to the next character during the run_length count}
end
else
begin
{increment the ascii by 1 to get the symbol}
EncodeSymbol(block^[i]+1);
inc(i);
end;
end; {While}
EncodeSymbol(EOF_SYMBOL);
DoneEncoding;
ArchiveFile.EndBitWriteAccess;
end;
end.

View File

@ -0,0 +1,352 @@
unit GroupAriModelUnit;
{-------------------------------------------------------------------------------
Group Arithmetic Model Unit
---------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
The Arithmetic model for the structured arithmetic encoder and decoder.
Desc:
There are 9 groups.
Each group handles a group of characters. Each group size is different.
The EOF symbol is in the last group.
Each group is a TGroupAriModel and handles a range of characters.
The range is between ch_lo and ch_hi inclusive.
Within each group the symbol may be mapped to another value. This value
is called the group symbol.
The main group handles the probability that each group would appear. It is
also a TGroupAriModel class.
There are therefore 3 levels of symbols:
symbol, group number, group symbol
-------------------------------------------------------------------------------}
(**) interface (**)
const
NUM_GROUPS = 9;
type
TGroupIntArray = array[0..NUM_GROUPS-1] of integer;
const
ROOT_LIMIT = 4096;
ROOT_INCREMENT = 32;
GROUP_INCREMENT = 1;
// leaf group info
{0 1 2-3 4-7 8-15 16-31 32-63 64-127 128-256}
grpStart: TGroupIntArray = (0, 1, 2, 4, 8, 16, 32, 64, 128);
grpLast : TGroupIntArray = (0, 1, 3, 7, 15, 31, 63, 127, 257);
grpLimit: TGroupIntArray = (0, 0, 256,256, 128, 1024, 2048, 4096, 8192);
{0: Run MTF_0
1: Run MTF_0
2: MTF_1
3: MTF_2
...
256: MTF_255
257: EOF
}
{grpStart: TGroupIntArray = (0, 1, 2, 4, 6, 8, 76, 136, 196);
grpLast : TGroupIntArray = (0, 1, 3, 5, 7, 75, 135, 195, 257);
grpLimit: TGroupIntArray = (0, 0, 256,256, 256, 1024, 1024, 1024, 1024);}
const
EOF_SYMBOL = 257;
MAX_SYMBOL_COUNT = 300;
// constants used for encoding/decoding
CODE_VALUE_BITS = 16;
TOP_VALUE = (1 SHL CODE_VALUE_BITS) -1;
FIRST_QTR = (TOP_VALUE DIV 4) + 1;
HALF = 2 * FIRST_QTR;
THIRD_QTR = 3 * FIRST_QTR;
type
TCumFreq = array[0..MAX_SYMBOL_COUNT] of integer;
TGroupAriModel = class
private
protected
num_chars, num_symbols: integer; // number of members and symbols in the group
max_freq: integer; // max count before scaling
increment: integer; // increment the frequancy for each occurence
char_to_index: array[0..MAX_SYMBOL_COUNT] of integer;
index_to_char: array[0..MAX_SYMBOL_COUNT] of integer;
procedure StartModel;
public
ch_lo, ch_hi: integer; // range of chars the group handles
freq: array[0..MAX_SYMBOL_COUNT] of integer;
cum_freq: TCumFreq;
constructor Create(new_ch_lo, new_ch_hi, new_max_freq, new_increment: integer);
procedure UpdateModel(Symbol: integer);
function SymbolToIndex(const symbol: integer): integer;
function IndexToSymbol(const index: integer): integer;
function IndexToChar(const index: integer): byte;
end;
THeadAriModel = class
private
symbol_to_group_num: array[0..MAX_SYMBOL_COUNT] of integer;
public
MainAriModel: TGroupAriModel; // main AriModel
AriModelList: array[0..NUM_GROUPS-1] of TGroupAriModel; // AriModel for each group
constructor Create;
destructor Destroy; override;
function GetGroupNum(const symbol: integer): integer;
procedure GetSymbolInfo(const symbol: integer;
var AriModel: TGroupAriModel;
var symbol_index: integer);
procedure GetGroupSymbolInfo(const group_symbol, group_num: integer;
var AriModel: TGroupAriModel;
var symbol_index: integer);
function HasResidue(group_num: integer): boolean;
function SymbolToGroupSymbol(symbol: integer; group_num: integer): integer;
function GroupSymbolToSymbol(group_symbol: integer; group_num: integer): integer;
end;
(**) implementation (**)
(*******************************************************************************
THeadAriModel
*******************************************************************************)
constructor THeadAriModel.Create;
var
i, j: integer;
begin
inherited Create;
// create the main group that handles the frequancies of the groups appearing
MainAriModel := TGroupAriModel.Create(0, NUM_GROUPS-1, ROOT_LIMIT, ROOT_INCREMENT);
// create the arithmetic model for the various groups
AriModelList[0] := nil;
AriModelList[1] := nil;
for i := 2 to 8 do
AriModelList[i] := TGroupAriModel.Create(grpStart[i], grpLast[i], grpLimit[i], GROUP_INCREMENT);
// init the symbol_to_group_num mapping array
for i := 0 to 8 do
for j := grpStart[i] to grpLast[i] do
symbol_to_group_num[j] := i;
end;
destructor THeadAriModel.Destroy;
var
i: integer;
begin
for i := 2 to 8 do
AriModelList[i].Free;
inherited Destroy;
end;
{-------------------------------------------------------------------------------
GetGroupNum
-----------
returns a group number/root symbol
Get the root symbol's info using GetRootSymbolInfo
-------------------------------------------------------------------------------}
function THeadAriModel.GetGroupNum(const symbol: integer): integer;
begin
result := symbol_to_group_num[symbol];
end;
{-------------------------------------------------------------------------------
GetRootSymbolInfo
-----------------
returns the root symbol information
-------------------------------------------------------------------------------}
procedure THeadAriModel.GetSymbolInfo(const symbol: integer;
var AriModel: TGroupAriModel;
var symbol_index: integer);
begin
AriModel := MainAriModel;
symbol_index := AriModel.SymbolToIndex(symbol);
end;
{-------------------------------------------------------------------------------
GetGroupSymbolInfo
-----------------
returns the leaf symbol info from a leaf symbol
Obtain leaf_symbol using SymbolToGroupSymbol
-------------------------------------------------------------------------------}
procedure THeadAriModel.GetGroupSymbolInfo(const group_symbol, group_num: integer;
var AriModel: TGroupAriModel;
var symbol_index: integer);
begin
AriModel := AriModelList[group_num];
symbol_index := AriModel.SymbolToIndex(group_symbol);
end;
{-------------------------------------------------------------------------------
HasResidue
----------
returns true if the group has members.
-------------------------------------------------------------------------------}
function THeadAriModel.HasResidue(group_num: integer): boolean;
begin
HasResidue := (group_num > 1);
end;
function THeadAriModel.SymbolToGroupSymbol(symbol: integer; group_num: integer): integer;
begin
result := symbol - AriModelList[group_num].ch_lo;
end;
function THeadAriModel.GroupSymbolToSymbol(group_symbol: integer; group_num: integer): integer;
begin
result := AriModelList[group_num].ch_lo + group_symbol;
end;
(*******************************************************************************
TGroupAriModel
*******************************************************************************)
Constructor TGroupAriModel.Create;
begin
inherited Create;
ch_lo := new_ch_lo;
ch_hi := new_ch_hi;
num_chars := ch_hi - ch_lo + 1;
num_symbols := num_chars + 1;
max_freq := new_max_freq;
increment := new_increment;
StartModel;
end;
function TGroupAriModel.SymbolToIndex(const symbol: integer): integer;
begin
result := char_to_index[symbol];
end;
function TGroupAriModel.IndexToSymbol(const index: integer): integer;
begin
result := index_to_char[index];
end;
function TGroupAriModel.IndexToChar(const index: integer): byte;
var
r: integer;
begin
r := IndexToSymbol(index);
if (r <= 255) then
result := r
else
result := 0;
end;
{-------------------------------------------------------------------------------
StartModel
----------
initialises variables
Notes:
The index corresponds to the frequancy. They start from 1.
freq[0] is just a dummy value.
-------------------------------------------------------------------------------}
procedure TGroupAriModel.StartModel;
var
i: integer;
begin
for i := 0 to num_chars-1 do
begin
char_to_index[i] := i + 1;
index_to_char[i+1] := i;
end;
// initialise frequancies and the cum_freq
for i := 0 to num_symbols do
begin
freq[i] := 1;
cum_freq[i] := num_symbols-i;
end;
// the frequancy for 0 and 1 cannot be equal (see UpdateModel)
freq[0] := 0;
end;
{-------------------------------------------------------------------------------
UpdateModel
-----------
updates the model for the Symbol
Desc:
Keeps the symbols in sorted order according to frequancy. This allows
the more frequantly appearing symbols to be found and encoded faster.
Notes:
The cumulative frequancy is stored upside down. The total is in cum_freq[0].
The moost frequantly upated symbols are stored to the front.
-------------------------------------------------------------------------------}
procedure TGroupAriModel.UpdateModel(Symbol: integer);
var
i, cum: integer;
ch_i, ch_symbol: integer;
begin
// scale down if over the max_freq count
if (cum_freq[0] >= max_freq) then
begin
cum := 0;
for i := num_symbols downto 0 do
begin
freq[i] := (freq[i] + 1) div 2;
cum_freq[i] := cum;
inc(cum, freq[i]);
end;
end;
// search for the next position to place the symbol
// the next position is the position where freq[i-1] > freq[i]
i := symbol;
while (freq[i] = freq[i-1]) do dec(i);
// update the translation tables if the symbol has moved
if (i < symbol) then
begin
ch_i := index_to_char[i];
ch_symbol := index_to_char[symbol];
index_to_char[i] := ch_symbol;
index_to_char[symbol] := ch_i;
char_to_index[ch_i] := symbol;
char_to_index[ch_symbol] := i;
end;
// increment the frequancy count for the symbol
// update the cumulative frequancy for the other symbols in front of it
inc(freq[i], increment);
while (i > 0) do
begin
dec(i);
inc(cum_freq[i], increment);
end;
end;
end.

94
Component/MTFBaseUnit.pas Normal file
View File

@ -0,0 +1,94 @@
unit MTFBaseUnit;
{-------------------------------------------------------------------------------
Move To Front Base Class
------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
The MTF is derived from Peter Fenwick's implementation.
Desc:
We work with two arrays --
image contains an image of the MTF list, most recent in posn 0
map contains the position of the chars in image.
MTFDest has been removed.
This is done so that searching for the character is faster.
e.g. search for 'c', look up index 2 in map to get its position.
Then move it to the front by shifting all chars before it in the image
one step up. Update the map accordingly.
-------------------------------------------------------------------------------}
(**) interface (**)
uses StructsUnit;
const
NumSym = 256;
type
TMTFBase = class
protected
map: array[0..NumSym-1] of byte; // index of a character
image: array[0..NumSym-1] of byte; // chars in MTF order
procedure MoveToFront(const s:byte);
public
constructor Create;
procedure Init;
end;
(**) implementation (**)
(*******************************************************************************
TMTFBase
*******************************************************************************)
constructor TMTFBase.Create;
begin
inherited Create;
end;
procedure TMTFBase.Init;
var
i: byte;
begin
for i := 0 to NumSym-1 do
begin
image[i] := i;
map[i] := i;
end;
end;
{-------------------------------------------------------------------------------
MoveToFront
-----------
Move symbol s to the front
-------------------------------------------------------------------------------}
procedure TMTFBase.MoveToFront(const s:byte);
var
i: byte;
begin
if (map[s] <> 0) then
begin
{Move everything before s in image up one step.
update the maps accordingly}
for i := map[s] downto 1 do
begin
image[i] := image[i-1];
map[image[i]] := i;
end;
{s is moved to the front}
image[0] := s;
map[s] := 0;
end;
end;
end.

View File

@ -0,0 +1,93 @@
unit MTFDecoderUnit;
{-------------------------------------------------------------------------------
Move To Front Decoder
---------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Notes: For manual decoding, call init then decode.
-------------------------------------------------------------------------------}
(**) interface (**)
uses StructsUnit, MTFBaseUnit;
type
TMTFDecoder = class(TMTFBase)
public
function Decode(const posn: byte): byte;
{procedure DecodeBlock(const inblock, outblock: PBlock; const block_length: longint);
procedure DecodeBlockWithVirtualChar(const inblock, outblock: PBlock; var block_length: longint; const virtual_char_index: longint);}
private
end;
(**) implementation (**)
uses ErrorUnit;
////////////////////////////////////////////////////////////////////////////////
// TMTFDecoder
////////////////////////////////////////////////////////////////////////////////
{-------------------------------------------------------------------------------
Decode
------
given its position posn, return a symbol and update the decoder
-------------------------------------------------------------------------------}
function TMTFDecoder.Decode(const posn: byte): byte;
begin
result := image[posn];
MoveToFront(result);
end;
(*
procedure TMTFDecoder.DecodeBlock;
var
i: longint;
begin
for i := 0 to block_length-1 do
outblock^[i] := Decode(inblock^[i]);
end;
procedure TMTFDecoder.DecodeBlockWithVirtualChar(const inblock, outblock: PBlock; var block_length: longint; const virtual_char_index: longint);
var
i, j: longint;
begin
// Error Check. virtual_char_index < block_length
if (virtual_char_index > block_length) then
begin
ShowError('Warning: Virtual char index wrong.');
exit;
end;
// i: outblock index
// j: inblock index
i := 0;
j := 0;
while (i < virtual_char_index) do
begin
outblock[i] := Decode(inblock[j]);
inc(i);
inc(j);
end;
inc(i); // leave one char in outblock for virtual char
while (j < block_length) do
begin
outblock[i] := Decode(inblock[j]);
inc(i);
inc(j);
end;
// add one to the block length because the virtual char was added
// outblock is now 1 char greater
inc(block_length);
end;
*)
end.

View File

@ -0,0 +1,50 @@
unit MTFEncoderUnit;
{-------------------------------------------------------------------------------
Move To Front Encoder
---------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
-------------------------------------------------------------------------------}
(**) interface (**)
uses StructsUnit, MTFBaseUnit;
type
TMTFEncoder = class(TMTFBase)
public
procedure EncodeBlock(const inblock, outblock: PBlock; const block_length: longint);
function Encode(const s: byte): byte;
private
end;
(**) implementation (**)
////////////////////////////////////////////////////////////////////////////////
// TMTFEncoder
////////////////////////////////////////////////////////////////////////////////
{-------------------------------------------------------------------------------
Encode
------
Return symbol's current position then move it to the front
-------------------------------------------------------------------------------}
function TMTFEncoder.Encode(const s: byte): byte;
begin
result := map[s];
MoveToFront(s);
end;
procedure TMTFEncoder.EncodeBlock;
var
i: longint;
begin
for i := 0 to block_length-1 do
outblock^[i] := Encode(inblock^[i]);
end;
end.

325
Component/RLEUnit.pas Normal file
View File

@ -0,0 +1,325 @@
unit RLEUnit;
{-------------------------------------------------------------------------------
Run Length Encoder Unit
-----------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
This is the run length encoder for preprocessing the file before the sorting
phase.
Naming convention notes:
ix: input index
oix: output index
-------------------------------------------------------------------------------}
(**) interface (**)
uses StructsUnit;
const
{RunThreshold number of bytes signifies the start of a run.
4 = 4 + 0
5 = 4 + 1
6 = 4 + 1 bytes
4 will expand to 5 bytes, 5 will retain, 6 will compress to 5 bytes}
RUN_THRESHOLD = 100;
type
TRunLengthEncoder = class
private
in_block, out_block: PBlock;
block_length: longint; // in_block length
oix: longint; // index into out_block
run_length: longint; // current run count
last_symbol: byte; // the symbol that has a run
procedure PutByte(const b: byte);
procedure PutRunCount;
public
procedure EncodeBlock(_in_block, _out_block: PBlock; _block_length: longint;
var out_block_length: longint);
end;
TRunLengthDecoder = class
in_block, out_block: PBlock;
block_length: longint; // length of in_block
ix, oix: longint; // index into input and output block
function GetRunCount: longint;
procedure ExpandRun;
public
procedure DecodeBlock(_in_block, _out_block: PBlock; _block_length: longint;
var out_block_length: longint);
end;
(**) implementation (**)
////////////////////////////////////////////////////////////////////////////////
// Run Length Encoder
////////////////////////////////////////////////////////////////////////////////
{-------------------------------------------------------------------------------
PutByte
-------
output a byte to out_block and increment the output index (oix)
-------------------------------------------------------------------------------}
procedure TRunLengthEncoder.PutByte(const b: byte);
begin
out_block^[oix] := b;
inc(oix);
end;
{-------------------------------------------------------------------------------
PutRunCount
-----------
Desc:
The count is encoded in as many 6 bit codes as needed, up to a max of 30 bits.
The 7th bit is set if more codes follow.
The most significant 6 bits are transmitted first.
-------------------------------------------------------------------------------}
procedure TRunLengthEncoder.PutRunCount;
var
d: byte;
bits_shift: shortint;
must_put: boolean;
begin
// Start by getting bits 25-30, then 19-24, 13-19 etc.
// if a bigger value was set eg. 25-30, then the rest of the values must be
// put although they may be 0
dec(run_length, RUN_THRESHOLD);
bits_shift := 24;
must_put := false;
repeat
d := ((run_length shr bits_shift) and $3F);
if (d > 0) or must_put then
begin
d := d or $40;
PutByte(d);
must_put := true;
end;
dec(bits_shift, 6);
until (bits_shift = 0);
// Put last byte (terminator) without the 7th bit set
d := (run_length and $3F);
PutByte(d);
end;
{-------------------------------------------------------------------------------
EncodeBlock
-----------
Algo:
Maintain 2 index, ix and oix into the input and output block respectively.
curr_symbol: current symbol
1) Read curr_symbol from the block
2) If curr_symbol equals the previous symbol then
a) increase run count
ELSE
a) If it is the end of a run (run count > run threshold) then
i) output the run length
ii) reset run length
3) Only output the curr_symbol if the run length is below run threshold
4) Repeat (1)
Notes:
If the run goes all the way to the end of the block, we must output the
run length in the end.
-------------------------------------------------------------------------------}
procedure TRunLengthEncoder.EncodeBlock(_in_block, _out_block: PBlock; _block_length: longint;
var out_block_length: longint);
{
Initialize resets the variables to process a new block
}
procedure Initialize;
begin
out_block := _out_block;
in_block := _in_block;
block_length := _block_length;
oix := 0;
end;
var
curr_symbol: byte;
ix: longint;
begin
Initialize;
{Init out_block with the first byte in in_block}
run_length := 1;
last_symbol := in_block^[0];
PutByte(last_symbol);
for ix := 1 to block_length-1 do
begin
curr_symbol := in_block^[ix];
if (curr_symbol = last_symbol) then
inc(run_length)
else
begin
{A different symbol indicates an end of run}
if (run_length >= RUN_THRESHOLD) then
PutRunCount;
run_length := 1;
end;
if (run_length <= RUN_THRESHOLD) then
PutByte(curr_symbol);
last_symbol := curr_symbol;
end;
{If there were more than RunThreshold bytes at the end of the block,
then we must terminate the run at the end}
if (run_length >= RUN_THRESHOLD) then PutRunCount;
out_block_length := oix;
end;
////////////////////////////////////////////////////////////////////////////////
// Run Length Decoder
////////////////////////////////////////////////////////////////////////////////
{-------------------------------------------------------------------------------
DecodeBlock
-----------
Decode a block.
Algo:
Maintain 2 indexes, ix and oix into the input and output block.
1) Read in a character
2) If the character is repeated, then increase run length
3) If run length hits run threshold, (a run length follows)
a) decode the run length
b) expand the run (fill output block with run length number of thbe char curr_symbol)
b) reset run length to zero
4) Repeat (1)
Notes:
We start counting from index 1 so that previous char is init to the char at
index 0.
-------------------------------------------------------------------------------}
procedure TRunLengthDecoder.DecodeBlock(_in_block, _out_block: PBlock; _block_length: longint;
var out_block_length: longint);
procedure Initialize;
begin
out_block := _out_block;
in_block := _in_block;
block_length := _block_length;
end;
var
run_length: byte;
curr_symbol, last_symbol: byte;
begin
Initialize;
run_length := 1;
last_symbol := in_block^[0];
out_block^[0] := last_symbol;
oix := 1;
ix := 1;
while (ix < block_length) do
begin
curr_symbol := in_block^[ix];
out_block^[oix] := curr_symbol;
inc(ix); {The next index could point to a run length or another char}
inc(oix);
if (curr_symbol = last_symbol) then
begin
inc(run_length);
if (run_length = RUN_THRESHOLD) then
begin
ExpandRun;
run_length := 1;
end;
end
else
run_length := 1;
last_symbol := curr_symbol;
end; {while}
out_block_length := oix;
end;
{-------------------------------------------------------------------------------
GetRunCount
-----------
gets the run count by reading as many bits as necessary that represent the
run length. The run length is represented in 7 bits per byte.
-------------------------------------------------------------------------------}
function TRunLengthDecoder.GetRunCount: longint;
var
count: longint;
b: byte;
begin
count := 0;
repeat
b := in_block^[ix];
count := (count shl 6) or (b and $3F); // extract last 6 bits from b
inc(ix);
until ((b and $40) = 0); // continue if 7th bit set
result := count;
end;
{-------------------------------------------------------------------------------
ExpandRun
---------
Expand the run with length pointed to by ix.
ix-1 is the symbol used to expand.
GetRunCount will inc ix to get the run count.
ExpandRun itself will inc oix accordingly.
IN and OUT assertion:
ix and oix point to the next pos to input and output respectively.
-------------------------------------------------------------------------------}
procedure TRunLengthDecoder.ExpandRun;
var
run_symbol: byte;
expand_count: longint;
expand_limit: longint;
begin
run_symbol := in_block^[ix-1];
expand_count := GetRunCount;
expand_limit := oix + expand_count;
while (oix < expand_limit) do
begin
out_block^[oix] := run_symbol;
inc(oix);
end;
end;
end.

Binary file not shown.

View File

@ -0,0 +1,317 @@
unit ResourceCompUnit;
{reSource Component Unit
Component Front End for reSource Compression Engine
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
USAGE:
Drop the component onto the form to use it.
Default name will be Resource1.
To perform any action on the archive, use Resource1.ArchiveMan (Archive Manager)
There are 2 ways to perform actions on archives:
Type 1: To deal directly with ArchiveMan.
This is the most efficient type and allows the fastest way to add/extract
multiple files from archive.
Type 2: Call CompressToFile, DecompressFromFile.
This wraps ArchiveMan and is simple to use if only dealing with one file.
ACTIONS: (Type 1)
Before doing any action, set the parameters for ArchiveMan
Resource1.ArchiveMan.TempDir := 'c:\temp'; // Set the Temporary Directory
To Open an Archive:
Resource1.ArchiveMan.OpenArchive(<ArchiveName>);
To Close the Archive:
Resource1.ArchiveMan.CloseArchive;
To Add files:
Resource1.ArchiveMan.AddFiles(FileList: TStrings; const infile_dir: string)
There are 2 ways to send the FileList
- If each entry in FileList has the full Path+Name, then infile_dir can be ''.
- If each entry in FileList is only the name, then infile_dir must contain
the path the files are in.
To Extract the file:
Before calling ExtractList, set the parameters for file extract:
Resource1.ArchiveMan.dest_dir := 'c:\mydir'; // destination dir for extract
Resource1.ArchiveMan.ExtractList(List: TList; var files_extracted, extracted_size: integer);
List is a TList of TCentralFileHeader.
The CentralFileHeader is gotten from Resource1.ArchiveMan.ArchiveFile.CentralDir[i],
where i is the index of the file.
So to add file index 2 to the extract list, call
List.Add(Resource1.ArchiveMan.ArchiveFile.CentralDir[2]);
Then call ExtractList(List, a, b)
The files_extracted and extracted_size are returned values.
To Delete files:
Resource1.ArchiveMan.DeleteFiles
All files that are flagged for deletion are removed.
To flag a file for delete, set the Delete property in its CentralFileHeader entry.
e.g. to delete file of index 2 and 5,
Resource1.ArchiveMan.ArchiveFile.CentralDir[2].Deleted := true; // flag
Resource1.ArchiveMan.ArchiveFile.CentralDir[5].Deleted := true; // flag
Resource1.ArchiveMan.DeleteFiles; // actual process
EVENTS:
OnCentralDirChange
- called when Resource1.ArchiveMan.ArchiveFile.CentralDir changes.
use it to update the list of files in the archive.
OnAddLog (for debugging)
- called when ArchiveMan outputs verbose information on what it is doing.
mainly used for debugging.
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{CG}
ArchiveManagerUnit, ArchiveHeadersUnit, StructsUnit;
type
TResource = class(TComponent)
private
{function GetOnShowStatusMsg: TStrEvent;
procedure SetOnShowStatusMsg(const Value: TStrEvent);}
function GetOnCentralDirChange: TNotifyEvent;
procedure SetOnCentralDirChange(const Value: TNotifyEvent);
function GetOnAddLog: TStrEvent;
procedure SetOnAddLog(const Value: TStrEvent);
protected
FArchiveMan: TArchiveManager;
public
property ArchiveMan: TArchiveManager read FArchiveMan;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{Wrapper for ArchiveMan.
To work on one file in one archive
NOTE:
- These do not require an archive to be opened. They can be called
'immediately'.
- Do not call ArchiveMan.OpenArchive when you use these procedures.
See Help above for description.
CompressToArchive:
SourceFileNamePath - File to compress
ArchiveNamePath - Archive to add to.
If it exists, the file will be Added to the existing archive.
DecompressFromArchive:
ArchiveNamePath - Full path to archive file
DestPath - Destination dir to extract files to
FileName - the name of the file to extract. Leave blank to extract all files (Default)
}
procedure CompressToArchive(SourceFileNamePath, ArchiveNamePath: string);
procedure DecompressFromArchive(ArchiveNamePath, DestPath: string; ExtractFileName: string = '');
published
property OnCentralDirChange: TNotifyEvent read GetOnCentralDirChange write SetOnCentralDirChange;
//property OnShowStatusMsg: TStrEvent read GetOnShowStatusMsg write SetOnShowStatusMsg;
property OnAddLog: TStrEvent read GetOnAddLog write SetOnAddLog;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Compression', [TResource]);
end;
{ TResource }
constructor TResource.Create(AOwner: TComponent);
begin
inherited;
{if not (csDesigning in ComponentState) then
begin}
FArchiveMan := TArchiveManager.Create;
{end;}
end;
destructor TResource.Destroy;
begin
if Assigned(FArchiveMan) then FArchiveMan.Free;
inherited;
end;
function TResource.GetOnAddLog: TStrEvent;
begin
result := FArchiveMan.OnAddLog;
end;
function TResource.GetOnCentralDirChange: TNotifyEvent;
begin
result := FArchiveMan.OnCentralDirChange;
end;
{function TResource.GetOnShowStatusMsg: TStrEvent;
begin
result := FArchiveMan.OnShowStatusMsg;
end;}
procedure TResource.SetOnAddLog(const Value: TStrEvent);
begin
FArchiveMan.OnAddLog := Value;
end;
procedure TResource.SetOnCentralDirChange(const Value: TNotifyEvent);
begin
FArchiveMan.OnCentralDirChange := Value;
end;
{procedure TResource.SetOnShowStatusMsg(const Value: TStrEvent);
begin
FArchiveMan.OnShowStatusMsg := Value;
end;}
{-------------------------------------------------------------------------------
CompressToArchive
-------------------------------------------------------------------------------}
procedure TResource.CompressToArchive(SourceFileNamePath,
ArchiveNamePath: string);
var
FilesAdded: integer;
list: TStringList;
begin
{Algorithm:
Open Archive
Add the file
Close Archive}
if ArchiveMan.IsArchiveOpen then
begin
{Error Check: Cannot use when Archive is opened.
We will open and close the Archive ourselves}
Application.MessageBox('reSource: ArchiveMan cannot be opened to use CompressToArchive',
'Error', MB_OK);
exit;
end;
{ Step 1: Open Archive }
ArchiveMan.OpenArchive(ArchiveNamePath, false);
Screen.Cursor := crHourGlass;
try
{ Step 2: Add the file }
// Construct a TStringList of files to add
// We pass a nil in the folder because the full path is in list
list := TStringList.Create;
list.Add(SourceFileNamePath);
FilesAdded := ArchiveMan.AddFiles(list, '');
if (FilesAdded = 0) then
begin
Application.MessageBox('reSource.CompressToArchive: Error No Files Added',
'Error', MB_OK);
exit;
end
else
begin
Application.MessageBox('reSource.CompressToArchive: One file added to archive.',
'Error', MB_OK);
exit;
end;
finally
{ Step 3: Close the archive }
if ArchiveMan.IsArchiveOpen then
ArchiveMan.CloseArchive;
Screen.Cursor := crDefault;
end;
end;
{-------------------------------------------------------------------------------
DecompressFromArchive
-------------------------------------------------------------------------------}
procedure TResource.DecompressFromArchive(ArchiveNamePath, DestPath: string;
ExtractFileName: string='');
var
CFH: TCentralFileHeader;
i, FilesExtracted, ExtractedSize: integer;
CFHList: TList;
begin
{Algorithm
Check that the Archive exists before calling this.
Open Archive
if FileName <> '' then
search for FileName and extract one file
else
extract all files in archive
Close Archive
}
FilesExtracted := 0;
ExtractedSize := 0;
if not FileExists(ArchiveNamePath) then
begin
Application.MessageBox('reSource.DecompressFromArchive: Archive file does not exist.',
'Error', MB_OK);
exit;
end;
ArchiveMan.OpenArchive(ArchiveNamePath, true);
Screen.Cursor := crHourGlass;
try
with ArchiveMan.ArchiveFile do
begin
ArchiveMan.dest_dir := IncludeTrailingBackslash(DestPath);
{Search for file name in CentralFileHeader}
if ExtractFileName <> '' then
begin
for i := 0 to CentralDir.Count-1 do
begin
CFH := TCentralFileHeader(CentralDir[i]);
if CompareText(CFH.filename, ExtractFileName) = 0 then
begin
{Construct a CFHList with one CentralFileHeader (CFH) }
CFHList := TList.Create;
CFHList.Add(CFH);
ArchiveMan.ExtractList(CFHList, FilesExtracted, ExtractedSize);
CFHList.Free;
break;
end;
end;
end
else
begin
{extract all files in archive.
Add all the CentralDir CFH into CFHList}
CFHList := TList.Create;
for i := 0 to CentralDir.Count-1 do
CFHList.Add(TCentralFileHeader(CentralDir[i]));
ArchiveMan.ExtractList(CFHList, FilesExtracted, ExtractedSize);
CFHList.Free;
end;
end;
if FilesExtracted = 0 then
ShowMessage('Error: No files extracted')
else
ShowMessage(IntToStr(FilesExtracted)+' file(s) extracted');
finally
if ArchiveMan.IsArchiveOpen then
ArchiveMan.CloseArchive;
Screen.Cursor := crDefault;
end;
end;
end.

View File

@ -0,0 +1,37 @@
-$A+
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J+
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q+
-$R+
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-E"c:\temp\cg"
-LE"c:\borland\delphi5\Projects\Bpl"
-LN"c:\borland\delphi5\Projects\Bpl"
-Z

109
Component/ResourcePack.dof Normal file
View File

@ -0,0 +1,109 @@
[Compiler]
A=1
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=1
R=1
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=reSource Compression Component
[Directories]
OutputDir=c:\temp\cg
UnitOutputDir=
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=
Packages=VCL50;VCLX50;VCLSMP50;VCLDB50;VCLADO50;ibevnt50;VCLBDE50;VCLDBX50;QRPT50;TEEUI50;TEEDB50;TEE50;DSS50;TEEQR50;VCLIB50;VCLMID50;VCLIE50;INETDB50;INET50;NMFAST50;WEBMID50;dclocx50;dclaxserver50;DragDropD5;ColorPicker;preview;Icsdel50;galoled
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
[Language]
ActiveLang=
ProjectLang=$00000409
RootDir=
[Version Info]
IncludeVerInfo=1
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=0
Build=0
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1033
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=
FileVersion=1.0.0.0
InternalName=
LegalCopyright=
LegalTrademarks=
OriginalFilename=
ProductName=
ProductVersion=1.0.0.0
Comments=
[HistoryLists\hlUnitAliases]
Count=1
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[HistoryLists\hlSearchPath]
Count=1
Item0=C:\Save\Delphi\resource\Component
[HistoryLists\hlUnitOutputDirectory]
Count=1
Item0=C:\temp\rs
[HistoryLists\hlOutputDirectorry]
Count=2
Item0=c:\temp\cg
Item1=C:\temp\rs
[HistoryLists\hlBPLOutput]
Count=1
Item0=c:\temp\rs

View File

@ -0,0 +1,62 @@
package ResourcePack;
{$R *.RES}
{$R 'ResourceCompUnit.dcr'}
{$ALIGN ON}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS ON}
{$RANGECHECKS ON}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'reSource Compression Component'}
{$IMPLICITBUILD OFF}
requires
vcl50,
VCLX50,
VCLSMP50;
contains
ArchiveManagerUnit in 'ArchiveManagerUnit.pas',
EDosUnit in 'EDosUnit.pas',
ArchiveHeadersUnit in 'ArchiveHeadersUnit.pas',
ArchiveFileUnit in 'ArchiveFileUnit.pas',
bit_file_unit in 'bit_file_unit.pas',
BWTBaseUnit in 'BWTBaseUnit.pas',
BWTCompressUnit in 'BWTCompressUnit.pas',
BWTExpandUnit in 'BWTExpandUnit.pas',
CRC32Unit in 'CRC32Unit.pas',
ErrorUnit in 'ErrorUnit.pas',
FileStrucAriDecoderUnit in 'FileStrucAriDecoderUnit.pas',
FileStrucAriEncoderUnit in 'FileStrucAriEncoderUnit.pas',
FSortUnit in 'FSortUnit.pas',
GroupAriModelUnit in 'GroupAriModelUnit.pas',
MTFBaseUnit in 'MTFBaseUnit.pas',
MTFDecoderUnit in 'MTFDecoderUnit.pas',
MTFEncoderUnit in 'MTFEncoderUnit.pas',
Ofile in 'ofile.pas',
RLEUnit in 'RLEUnit.pas',
smart_buf_filestream_unit in 'smart_buf_filestream_unit.pas',
StrucAriDecoderUnit in 'StrucAriDecoderUnit.pas',
StrucAriEncoderUnit in 'StrucAriEncoderUnit.pas',
StructsUnit in 'StructsUnit.pas',
ResourceCompUnit in 'ResourceCompUnit.pas',
BitStreamUnit in 'BitStreamUnit.pas',
StreamStrucAriEncoderUnit in 'StreamStrucAriEncoderUnit.pas';
end.

304
Component/ResourcePack.dsk Normal file
View File

@ -0,0 +1,304 @@
[Closed Files]
File_0=SourceModule,'C:\Save\Delphi\resource\Component\StructsUnit.pas',0,1,1,1,9,0,0
File_1=SourceModule,'C:\Save\Delphi\resource\Component\StrucAriEncoderUnit.pas',0,1,1,1,9,0,0
File_2=SourceModule,'C:\Save\Delphi\resource\Component\StrucAriDecoderUnit.pas',0,1,1,1,9,0,0
File_3=SourceModule,'C:\Save\Delphi\resource\Component\StreamStrucAriEncoderUnit.pas',0,1,1,1,11,0,0
File_4=SourceModule,'C:\Save\Delphi\resource\Component\smart_buf_filestream_unit.pas',0,1,1,1,10,0,0
File_5=SourceModule,'C:\Save\Delphi\resource\Component\RLEUnit.pas',0,1,1,1,9,0,0
File_6=SourceModule,'C:\Save\Delphi\resource\Component\ResourceCompUnit.pas',0,1,1,1,9,0,0
File_7=SourceModule,'C:\Save\Delphi\resource\Component\ofile.pas',0,1,1,1,1,0,0
File_8=SourceModule,'C:\Save\Delphi\resource\Component\MTFEncoderUnit.pas',0,1,1,1,9,0,0
File_9=SourceModule,'C:\Save\Delphi\resource\Component\MTFDecoderUnit.pas',0,1,1,1,9,0,0
[Modules]
Module0=C:\Save\Delphi\resource\Component\ResourcePack.dpk
Count=1
EditWindowCount=1
PackageWindowCount=1
[C:\Save\Delphi\resource\Component\ResourcePack.dpk]
ModuleType=PackageEditModule
FormState=0
FormOnTop=0
[C:\Save\Delphi\resource\Component\ProjectGroup1.bpg]
FormState=0
FormOnTop=0
[EditWindow0]
ViewCount=1
CurrentView=0
View0=0
CodeExplorer=CodeExplorer@EditWindow0
MessageView=MessageView@EditWindow0
Create=1
Visible=1
State=2
Left=229
Top=232
Width=564
Height=334
MaxLeft=-4
MaxTop=97
MaxWidth=808
MaxHeight=479
ClientWidth=800
ClientHeight=452
LeftPanelSize=0
LeftPanelClients=CodeExplorer@EditWindow0
LeftPanelData=00000400010000000C000000436F64654578706C6F7265720000000000000000000000000000000000FFFFFFFF
RightPanelSize=0
BottomPanelSize=0
BottomPanelClients=CallStackWindow,WatchWindow,MessageView@EditWindow0
BottomPanelData=00000400030000000F00000043616C6C537461636B57696E646F770B000000576174636857696E646F770B0000004D657373616765566965772003000000000000004D00000000000000FFFFFFFF
[View0]
Module=C:\Save\Delphi\resource\Component\ResourcePack.dpk
CursorX=1
CursorY=1
TopLine=1
LeftCol=1
[PackageWindow0]
Create=1
Visible=0
State=0
Left=202
Top=147
Width=422
Height=398
MaxLeft=-1
MaxTop=-1
ClientWidth=414
ClientHeight=376
TBDockHeight=284
LRDockWidth=421
Dockable=1
StatusBar=0
TextLabels=1
Toolbar=1
SectionWidth0=186
SectionWidth1=228
Module=C:\Save\Delphi\resource\Component\ResourcePack.dpk
[Watches]
Count=0
[Breakpoints]
Count=0
[AddressBreakpoints]
Count=0
[Main Window]
Create=1
Visible=1
State=2
Left=0
Top=28
Width=777
Height=105
MaxLeft=-1
MaxTop=-1
MaxWidth=808
MaxHeight=105
ClientWidth=800
ClientHeight=78
[ProjectManager]
Create=1
Visible=0
State=0
Left=155
Top=124
Width=448
Height=413
MaxLeft=-1
MaxTop=-1
ClientWidth=440
ClientHeight=391
TBDockHeight=303
LRDockWidth=510
Dockable=1
[CPUWindow]
Create=1
Visible=0
State=0
Left=10
Top=108
Width=732
Height=433
MaxLeft=-1
MaxTop=-1
ClientWidth=724
ClientHeight=406
DumpPane=79
DisassemblyPane=349
RegisterPane=231
FlagPane=64
[AlignmentPalette]
Create=1
Visible=0
State=0
Left=50
Top=119
Width=156
Height=80
MaxLeft=-1
MaxTop=-1
ClientWidth=150
ClientHeight=60
[PropertyInspector]
Create=1
Visible=1
State=0
Left=304
Top=200
Width=236
Height=303
MaxLeft=-1
MaxTop=-1
ClientWidth=226
ClientHeight=279
TBDockHeight=494
LRDockWidth=164
Dockable=0
SplitPos=108
ArrangeBy=Name
SelectedItem=
ExpandedItems=BorderIcons,Brush,Dragtypes,Font.Style,Options,Pen
HiddenCategories=Legacy
ShowStatusBar=1
[WatchWindow]
Create=1
Visible=0
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=421
Dockable=1
[BreakpointWindow]
Create=1
Visible=0
State=0
Left=181
Top=255
Width=453
Height=197
MaxLeft=-1
MaxTop=-1
ClientWidth=445
ClientHeight=175
TBDockHeight=197
LRDockWidth=453
Dockable=1
Column0Width=100
Column1Width=75
Column2Width=225
Column3Width=40
Column4Width=75
Column5Width=75
[CallStackWindow]
Create=1
Visible=0
State=0
Left=412
Top=0
Width=388
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=388
ClientHeight=77
TBDockHeight=77
LRDockWidth=379
Dockable=1
[LocalVarsWindow]
Create=1
Visible=0
State=0
Left=273
Top=197
Width=421
Height=192
MaxLeft=-1
MaxTop=-1
ClientWidth=413
ClientHeight=170
TBDockHeight=192
LRDockWidth=421
Dockable=1
[ToDo List]
Create=1
Visible=0
State=0
Left=154
Top=175
Width=470
Height=250
MaxLeft=-1
MaxTop=-1
ClientWidth=462
ClientHeight=228
TBDockHeight=250
LRDockWidth=470
Dockable=1
Column0Width=260
Column1Width=30
Column2Width=100
Column3Width=70
Column4Width=70
SortOrder=4
ShowHints=1
ShowChecked=1
[CodeExplorer@EditWindow0]
Create=1
Visible=0
State=0
Left=0
Top=12
Width=200
Height=348
MaxLeft=-1
MaxTop=-1
ClientWidth=200
ClientHeight=348
TBDockHeight=305
LRDockWidth=200
Dockable=1
[MessageView@EditWindow0]
Create=1
Visible=0
State=0
Left=12
Top=0
Width=788
Height=77
MaxLeft=-1
MaxTop=-1
ClientWidth=788
ClientHeight=77
TBDockHeight=77
LRDockWidth=443
Dockable=1
[DockHosts]
DockHostCount=0

BIN
Component/ResourcePack.res Normal file

Binary file not shown.

View File

@ -0,0 +1,169 @@
unit StreamStrucAriEncoderUnit;
{-------------------------------------------------------------------------------
Stream Structured Arithmetic Encoder Unit
---------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Desc:
Derives from Structured arithmetic encoder to allow it to write to Stream.
Handles the output to the Stream by implementing OutputBit/OutputBits.
Very similar to FileStrucAriEncoder because it's ported from there.
procedure EncodeBlock(_Stream: TStream; block: PBlock; block_length: integer);
Encodes the block with block length block_length.
Will encode the block with an EOF symbol trailing.
To Use:
Create it.
Call EncodeBlock
Free.
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, dialogs,
// general
StructsUnit,
// base class
StrucAriEncoderUnit, GroupAriModelUnit, BitStreamUnit;
type
{For Stream out, must implement Bit Buffer }
TStreamAriEncoder = class(TStrucAriEncoder)
protected
BitStream: TBitStream;
procedure OutputBit(bit: byte); override;
procedure OutputBits(code: longint; count: byte); override;
public
constructor Create;
destructor Destroy; override;
procedure EncodeBlock(_Stream: TStream; block: PBlock; block_length: integer;
var OutSize: integer);
end;
(**) implementation (**)
{ TStreamAriEncoder }
constructor TStreamAriEncoder.Create;
begin
inherited Create;
end;
destructor TStreamAriEncoder.Destroy;
begin
inherited;
end;
procedure TStreamAriEncoder.EncodeBlock(_Stream: TStream; block: PBlock;
block_length: integer; var OutSize: integer);
var
i, j: longint;
run_length: integer;
mask, num_bits: integer;
StartPos: integer;
begin
StartPos := _Stream.Position;
BitStream := TBitStream.Create(_Stream, false);
BitStream.BeginBitWriteAccess;
StartEncoding;
i := 0;
while (i < block_length) do
begin
{Convert the ascii to symbols.
symbols 0 and 1 represent runs of 0s.
symbols 2 - 256 represent ascii 1-255 repectively.
symbol 257 is the EOB}
if (block^[i] = 0) then
begin
{Wheeler's run length coding.
convert to runs of 0s
Algo: Count run_length, or number of 0s (run length includes init byte
Increment run_length by one
Ignore most significant one bit and encode run_length
as ordinary binary number}
{count run length and inc i. min run_length will be 1}
run_length := 0;
repeat
inc(i);
inc(run_length);
until (i >= block_length) or (block^[i] <> 0);
//if (i > block_length) then ShowMessage('Hello');
{increment by 1}
inc(run_length);
{find the most significant 1 bit and count the number of bits
to output in num_bits}
num_bits := 32;
mask := 1 shl 31;
while (run_length and mask = 0) do
begin
mask := mask shr 1;
dec(num_bits);
end;
{ignore most significant 1 bit}
dec(num_bits);
{output the number as an ordinary binary number from the lsb}
mask := 1;
for j := 1 to num_bits do
begin
if (run_length and mask <> 0) then
EncodeSymbol(1)
else
EncodeSymbol(0);
mask := mask shl 1;
end;
{DEBUG: Test no run length coding. code 0s directly.
The value 1 should not appear at all}
{EncodeSymbol(0);
inc(i);}
{i will have been set to the next character during the run_length count}
end
else
begin
{increment the ascii by 1 to get the symbol}
EncodeSymbol(block^[i]+1);
inc(i);
end;
end; {While}
EncodeSymbol(EOF_SYMBOL);
DoneEncoding;
BitStream.EndBitWriteAccess;
OutSize := _Stream.Position - StartPos;
end;
procedure TStreamAriEncoder.OutputBit(bit: byte);
begin
BitStream.OutputBit(bit);
//ShowMessage('asdf');
end;
procedure TStreamAriEncoder.OutputBits(code: Integer; count: byte);
begin
{ Not Implemented }
end;
end.

View File

@ -0,0 +1,165 @@
unit StrucAriDecoderUnit;
{-------------------------------------------------------------------------------
Structured Arithmetic Decoder Unit
----------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
uses the Group Arithmetic Model to decode the symbols
-------------------------------------------------------------------------------}
(**) interface (**)
uses
GroupAriModelUnit;
type
TStrucAriDecoder = class
private
low, high, value: longint;
HeadAriModel: THeadAriModel;
protected
function InputBit: byte; virtual; abstract;
function InputBits( count: byte ): longint; virtual; abstract;
public
constructor Create;
destructor Destroy; override;
// for decoding
procedure DecodeSymbol(var symbol: integer);
procedure StartDecoding;
procedure DoneDecoding;
end;
(**) implementation (**)
constructor TStrucAriDecoder.Create;
begin
inherited Create;
end;
destructor TStrucAriDecoder.Destroy;
begin
inherited Destroy;
end;
procedure TStrucAriDecoder.StartDecoding;
var
i: longint;
begin
HeadAriModel := THeadAriModel.Create;
value := 0; // input bits to fill the
for i := 1 to CODE_VALUE_BITS do // code value
value := 2 * value + InputBit;
low := 0; // full code range
high := TOP_VALUE;
end;
procedure TStrucAriDecoder.DoneDecoding;
begin
HeadAriModel.Free;
end;
{-------------------------------------------------------------------------------
DecodeSymbol
------------
decodes the next symbol in the stream and returns the symbol in symbol.
Algo:
The decoding process is either 1 or 2 steps, depending on whether the group
has one or more members.
The design of the algo is such that the unique groups are zero and one.
The symbols correspond to the unique group values.
1) Decode the group number (step 1)
2) If the group has several members, then
a) decode the residue to obtain the member symbol (step 2)
b) convert the member symbol to the corresponding symbol and return this.
ELSE
Otherwise, the symbol is unique in the group and the group_num is the symbol.
return this.
-------------------------------------------------------------------------------}
procedure TStrucAriDecoder.DecodeSymbol(var symbol: integer);
procedure DoDecodeSymbol(var symbol: integer; AriModel: TGroupAriModel);
var
range: longint; // size of current code region
cum: integer; // cumulative frequancy calculated
index: integer; // index of the symbol
begin
range := high - low + 1;
// find cum freq for value
cum := ((value-low+1) * AriModel.cum_freq[0] -1) div range;
// find the symbol that straddles the range
index := 1;
while (AriModel.cum_freq[index] > cum) do inc(index);
// return the symbol
symbol := AriModel.IndexToSymbol(index);
// narrow the code region to that allooted to this symbol
high := low + (range * AriModel.cum_freq[index-1]) div AriModel.cum_freq[0] -1;
low := low + (range * AriModel.cum_freq[index]) div AriModel.cum_freq[0];
// remove the bits that represent the current symbol to get the next symbol's
// range
repeat
if (high < HALF) then
begin
{nothing} // expand low half
end
else if (low >= HALF) then // expand high half
begin
dec(value, HALF);
dec(low, HALF); // substract offset to top
dec(high, HALF);
end else if ((low >= FIRST_QTR) and // expand middle half
(high < THIRD_QTR)) then
begin
dec(value, FIRST_QTR);
dec(low, FIRST_QTR);
dec(high, FIRST_QTR); // substract offset to middle
end else break; // otherwise exit loop
low := 2 * low;
high := 2 * high + 1; // scale up code range
value := 2 * value + InputBit; // move in next input bit
until false;
// update the model with the new symbol found
AriModel.UpdateModel(index);
end;
var
group_num: integer; // group number for the symbol
group_symbol: integer; // the group symbol in the respective group (group_num)
begin
DoDecodeSymbol(group_num, HeadAriModel.MainAriModel);
if HeadAriModel.HasResidue(group_num) then
begin
// decode the group_symbol using the respetive AriModel
DoDecodeSymbol(group_symbol, HeadAriModel.AriModelList[group_num]);
// convert the group_symbol to its corresponding symbol using the group_num
symbol := HeadAriModel.GroupSymbolToSymbol(group_symbol, group_num);
end
else
begin
// the group has only one character
// therefore the symbol is the group_num
symbol := group_num;
end;
end;
end.

View File

@ -0,0 +1,187 @@
unit StrucAriEncoderUnit;
{-------------------------------------------------------------------------------
Structured Arithmetic Encoder Unit
----------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
uses the Group Arithmetic Model to encode the symbols
first_level_symbol: 0-9
second_level_symbol: 0 - (NumberOfEntries-1)
Each entry in the AriModelList corresponds to the AriModel for the first_level_symbol.
-------------------------------------------------------------------------------}
(**) interface (**)
uses GroupAriModelUnit;
type
TStrucAriEncoder = class
private
high, low: integer; // ends of current code region
bits_to_follow: integer;
procedure BitPlusFollow(bit: byte);
protected
HeadAriModel: THeadAriModel;
procedure OutputBit(bit: byte); virtual; abstract;
procedure OutputBits(code: longint; count: byte); virtual; abstract;
procedure StartEncoding;
procedure DoneEncoding;
public
constructor Create;
destructor Destroy; override;
{procedure EncodeByte(a: byte);}
procedure EncodeSymbol(symbol: integer);
end;
(**) implementation (**)
constructor TStrucAriEncoder.Create;
begin
inherited Create;
end;
destructor TStrucAriEncoder.Destroy;
begin
inherited Destroy;
end;
{ At the end of the encoding process, there are still significant bits left
in the high and low registers. We output two bits, plus as many underflow
bits as are necessary }
procedure TStrucAriEncoder.BitPlusFollow(bit: byte);
begin
OutputBit(bit);
// output bits_to_follow opposite bits. Set bits_to_follow to zero.
while (bits_to_follow > 0) do
begin
if bit = 0 then
OutputBit(1)
else
OutputBit(0);
dec(bits_to_follow);
end;
end;
procedure TStrucAriEncoder.StartEncoding;
begin
low := 0; // full code region
high := TOP_VALUE;
bits_to_follow := 0; // no bits to follow next
HeadAriModel := THeadAriModel.Create;
end;
procedure TStrucAriEncoder.DoneEncoding;
begin
// output two bits that select the quarter that the
// current code range contains
inc(bits_to_follow);
if (low < FIRST_QTR) then
BitPlusFollow(0)
else
BitPlusFollow(1);
//OutputBits(0, 15); //16 or 15 or none?
HeadAriModel.Free;
end;
{-------------------------------------------------------------------------------
EncodeSymbol
------------
encodes the symbol 'symbol'.
Algo:
The encoding process is either 1 or 2 steps, depending on whether the group
has several members.
The design of the algo is such that the unique groups are zero and one.
The symbols correspond to the unique group values.
1) Get the group number for the symbol
2) Encode the group number (step 1)
3) If the group has residue, then
a) Get the group symbol for the corresponding symbol in its group
b) Encode the group symbol (step 2)
-------------------------------------------------------------------------------}
procedure TStrucAriEncoder.EncodeSymbol(symbol: integer);
procedure DoEncodeSymbol(symbol_index: integer; AriModel: TGroupAriModel);
var
range: integer;
begin
// narrow the code region to that alloted to this symbol
range := high-low + 1;
high := low + (((range * AriModel.cum_freq[symbol_index-1]) div AriModel.cum_freq[0]) -1);
low := low + ((range * AriModel.cum_freq[symbol_index]) div AriModel.cum_freq[0]);
// loop to output bits
repeat
if (high < HALF) then
BitPlusFollow(0) // output 0 if in low half (MSB=0)
else if (low >= HALF) then
begin
BitPlusFollow(1); // output 1 if in high half (MSB=1)
dec(low, HALF); // set MSB to 0 for both low and high
dec(high, HALF);
end
else if ((low >= FIRST_QTR) and (high < THIRD_QTR)) then
begin
inc(bits_to_follow); // output an opposite bit later if in middle half
dec(low, FIRST_QTR); // substract offset to middle
dec(high, FIRST_QTR);
end
else break;
low := 2 * low; // scale up code region
high := 2 * high + 1;
until false;
AriModel.UpdateModel(symbol_index); // update the model with the symbol
end;
var
AriModel: TGroupAriModel; // AriModel. reused through the levels
symbol_index: integer; // index for symbols. reused through the levels
group_num, group_symbol: integer; // 2nd and 3rd level symbols
begin
// get the group number from the HeadAriModel
group_num := HeadAriModel.GetGroupNum(symbol);
// retrieve the AriModel and symbol_index for group_num
HeadAriModel.GetSymbolInfo(group_num, AriModel, symbol_index);
// encode the group number
DoEncodeSymbol(symbol_index, AriModel);
// encode any residue
if HeadAriModel.HasResidue(group_num) then
begin
// convert the symbol to a group symbol in its respective group (group_num)
group_symbol := HeadAriModel.SymbolToGroupSymbol(symbol, group_num);
// get the AriModel and symbol_index for the group_symbol
HeadAriModel.GetGroupSymbolInfo(group_symbol, group_num, AriModel, symbol_index);
Assert(AriModel <> nil);
// encode the group_symbol or residue
DoEncodeSymbol(symbol_index, AriModel);
end;
end;
end.

120
Component/StructsUnit.pas Normal file
View File

@ -0,0 +1,120 @@
unit StructsUnit;
{-------------------------------------------------------------------------------
Structures Unit
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Contains:
Common data structures used across the compressor and related test files.
-------------------------------------------------------------------------------}
(**) interface (**)
var
reSourceIDStr: string = 'reSource - BWT Compressor';
reSourceVerStr: string = 'reSource v2.6';
reSourceCopyrightStr: string = 'Copyright (C) 1998-2000 Victor Kasenda / gruv';
type
{Event types for ArchiveManager}
TIntEvent = procedure(Sender: TObject; a: integer) of object;
TStrEvent = procedure(Sender: TObject; s: string) of object;
const
//BlockSize = 500; {bytes}
BlockSize = 400 * 1024; {kilobytes}
//BlockSize = 2 * 1024 * 1000; {megabytes}
GHOST_BUFFER = 2000; // for overshoot, only for block (see FSortUnit)
{Run Length encoding may expand the block by a few bytes.
If run length encoding before sorting is not performed, this can be set to 0}
RLE_EXPAND_EXTRA_BYTES = 0; {BLOCKSIZE * 20 DIV 100; {20% of BlockSize}
//RLE_EXPAND_EXTRA_BYTES = 10000; {20% of BlockSize}
MaxLongword = high(Longword);
{String constants}
SRESOURCE_EXT = 'rs';
type
{Block with ghost buffers at the front (1 byte) and back (5 bytes)
Extra 1000 bytes in case RLEncoder expands the block}
TBlock = array[-1..BlockSize*2 + GHOST_BUFFER + RLE_EXPAND_EXTRA_BYTES] of byte;
PBlock = ^TBlock;
TLongintBlock = array[0..BlockSize-1 + 1000 + RLE_EXPAND_EXTRA_BYTES] of longint;
PLongintBlock = ^TLongintBlock;
TLongWordBlock = array[0..BlockSize * 2 + GHOST_BUFFER + RLE_EXPAND_EXTRA_BYTES] of Longword;
PLongWordBlock = ^TLongwordBlock;
PWord = ^Word;
T64kBlock = array[0..65535] of longint;
P64kBlock = ^T64kBlock;
TBlockMan = class
public
// common blocks. shared memory blocks between compressor and expander
// call InitBlocks, FreeBlocks to use
longintblock1, longintblock2, longintblock3: PLongintblock;
block1, block2: PBlock;
k64Block: P64kBlock;
constructor Create;
destructor Destroy; override;
end;
procedure CompareBlocks(const block1, block2: PBlock; const block_length: longint;
error_msg: string);
var
BlockMan: TBlockMan;
(**) implementation (**)
uses ErrorUnit, SysUtils;
constructor TBlockMan.Create;
begin
inherited Create;
New(longintblock1);
New(longintblock2);
New(longintblock3);
New(block1);
New(block2);
New(k64Block);
end;
destructor TBlockMan.Destroy;
begin
inherited Destroy;
end;
procedure CompareBlocks(const block1, block2: PBlock; const block_length: longint;
error_msg: string);
var
i: longint;
begin
for i := 0 to block_length-1 do
if block1^[i] <> block2^[i] then
begin
if error_msg = '' then error_msg := 'block1 differs from block2 at ';
ShowError(error_msg + ' position: ' + IntToStr(i));
break;
end;
end;
initialization
BlockMan := TBlockMan.Create;
finalization
BlockMan.Free;
end.

237
Component/bit_file_unit.pas Normal file
View File

@ -0,0 +1,237 @@
unit bit_file_unit;
{-------------------------------------------------------------------------------
Bit Access for Files
--------------------
revision 1.3
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Usage Note:
Call BeginBitAccess and EndBitAccess to start and end bit access.
Failure to call any of which may lead to data corruption.
Specially tailored procedures:
SetReadByteLimit
This checks that the bits read fall within the limit. It allows a maximum
of NUM_FAKED_BYTES bytes more read (which the decoder uses) afther which data corruption
has most likely occured.
Set to MaxLongInt if the limit is not to be used (default).
version
1.1: Added SetReadByteLimit
1.2: Added BeginBitAccess and EndBitAccess
1.3: Fixed read_byte_limit. off by one.
-------------------------------------------------------------------------------}
(**) interface (**)
uses smart_buf_filestream_unit, SysUtils;
const
NUM_FAKED_BYTES = 20;
type
TBitFile = class(TBufferedFileStream)
private
mask: byte;
rack: byte;
IsOpenInput: boolean;
read_byte_limit: integer;
bytes_read: integer;
//extra_bytes_read: integer; // bytes read past the limit
procedure BitGetNextByte(var b: byte);
public
constructor Create(const FileName: string; Mode: Word);
destructor Destroy; override;
procedure SetReadByteLimit(const limit: integer);
procedure BeginBitReadAccess;
procedure EndBitReadAccess;
procedure BeginBitWriteAccess;
procedure EndBitWriteAccess;
procedure OutputBit(bit: byte);
procedure OutputBits(code: longint; count: byte);
function InputBit: byte;
function InputBits( count: byte ): longint;
end;
(**) implementation (**)
uses ErrorUnit;
constructor TBitFile.Create(const FileName: string; Mode: Word);
begin
inherited Create(FileName, Mode, 64*1024);
IsOpenInput := (Mode = fmOpenRead);
rack := 0;
mask := $80;
SetReadByteLimit(MaxLongInt);
end;
destructor TBitFile.Destroy;
begin
if (not IsOpenInput) and (Mask <> $80) then WriteByte(rack);
inherited Destroy;
end;
procedure TBitFile.SetReadByteLimit(const limit: integer);
begin
bytes_read := 0;
read_byte_limit := limit;
//extra_bytes_read := 0;
end;
procedure TBitFile.BitGetNextByte(var b: byte);
begin
if (bytes_read >= read_byte_limit) then {If limit number of bytes already read}
begin
if (bytes_read - read_byte_limit >= NUM_FAKED_BYTES) then
begin
ShowError('Too many bytes read in bit mode.');
halt(1);
end
else
begin
b := 0;
inc(bytes_read);
end;
end
else
begin
inherited GetNextByte(b);
inc(bytes_read);
end;
end;
procedure TBitFile.BeginBitReadAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitFile.EndBitReadAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitFile.BeginBitWriteAccess;
begin
mask := $80;
rack := 0;
end;
procedure TBitFile.EndBitWriteAccess;
begin
if (not IsOpenInput) and (Mask <> $80) then
begin
WriteByte(rack);
end;
Mask := $80;
rack := 0;
end;
procedure TBitFile.OutputBit(bit: byte);
begin
if (bit <> 0) then
rack := rack or mask;
{if bit = 1 then
rack := rack or mask;}
mask := mask shr 1;
if mask = 0 then
begin
WriteByte(rack);
rack := 0;
mask := $80;
end;
end;
procedure TBitFile.OutputBits(code: longint; count: byte);
var
TempMask: longint;
begin
TempMask := 1 Shl (Count-1);
while TempMask <> 0 do
begin
if (TempMask and Code <> 0) then
Rack := Rack or Mask;
Mask := Mask shr 1;
if Mask = 0 then
begin
WriteByte(Rack);
Rack := 0;
Mask := $80;
end;
TempMask := TempMask shr 1;
end;
end;
function TBitFile.InputBit: byte;
var
value: byte;
begin
if (mask = $80) then
BitGetNextByte(rack);
value := Rack and Mask;
Mask := Mask shr 1;
if Mask = 0 then Mask := $80;
if value = 0 then
result := 0
else
result := 1;
end;
function TBitFile.InputBits( count: byte ): longint;
var
TempMask: longint;
value: longint;
begin
TempMask := 1 shl (count-1);
value := 0;
while TempMask <> 0 do
begin
if (Mask = $80) then
BitGetNextByte(Rack);
if (Rack and Mask <> 0) then
value := (value or TempMask);
TempMask := TempMask shr 1;
Mask := Mask shr 1;
if Mask = 0 then Mask := $80;
end;
result := value;
end;
end.

351
Component/ofile.pas Normal file
View File

@ -0,0 +1,351 @@
unit Ofile;
{$I-}
{Object file unit.
Copyright (C) 1995 F-inc.
rev 2.1 5/July/1996
Borland Delphi Object Pascal compatible.
Do not use with BP7.
}
(**) interface (**)
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons;
(***************************************************************************
General Notes:
If you want to override any of the functions, only do so
for those that are virtual.
Do not override non virtual methods!
Notes v2.0:
- Many virtual methods have been taken out for faster execution.
For faster, buffered saving of delphi data types, use TWriter or TBufferedFileStream.
See unit buffered_file_stream_unit (F-inc).
- To check for errors, use the Error function (this calls IOResult) or IOResult method.
v2.1:
- Took out AssignFile. Directly pass the file name in create. This is more inline
with Borland's own TStreamFile creation procedure and is less confusing.
***************************************************************************)
Type
PFile = ^File;
TErrorFlag = Integer;
TOFile = Class
private
procedure AssignFile(const AFilePath : string); {Accepts : A file path. The path to the file}
public
Constructor Create(const file_path: string);
Destructor Destroy; Override;
function Error: Boolean; {Returns true if there is an error}
function IOResult: integer; {wraps the system's IOResult}
{Wrapper methods}
procedure Reset(Const aSize : Word);
procedure ResetReadOnly(Const aSize : Word);
procedure Rewrite(Const aSize : Word); //virtual;
procedure Close; //virtual;
function FilePos : LongInt; //virtual;
procedure Seek(Const aPos : LongInt); //virtual;
procedure SeekEOF; {Seeks to the end of file}
{Block read/write support
Returns number of bytes read/written}
function BlockRead(Var Buf; Const Count : longint): longint; {virtual;}
function BlockWrite(Var Buf; Const Count : longint): longint; {virtual;}
{Writes/reads a string
String is stored in the format [StringLength][...String...]}
procedure ReadString(Var rString : String);
procedure WriteString(aString : String);
function GetString : string;
{Writes/reads a byte}
procedure ReadByte(Var rByte : Byte);
procedure WriteByte(aByte : Byte);
function GetByte : byte;
{Writes/reads a integer}
procedure ReadInteger(Var rInteger : Integer);
procedure WriteInteger(aInteger : Integer);
function GetInteger : Integer;
{Writes/reads a integer}
procedure ReadLongint(Var rLongint : Longint);
procedure WriteLongint(aLongint : Longint);
function GetLongint : Longint;
function EOF : Boolean; {True if end of file reached}
function Exists : Boolean; {True if file exists}
function FileSize : LongInt;
protected
F : File; {The actual file variable}
FName : String; {The actual file name}
FPath : String; {The actual file path}
FOpen : Boolean; {True if file is open}
//BlockResult : longint; {BlockRead/Write result stored here}
//ErrorFlag : TErrorFlag; {The error flag. 0 - no error.}
//procedure UpdateErrorFlag; {Assigns IOError to ErrorFlag}
//function GetErrorFlag : TErrorFlag; {Returns the value of the error flag}
procedure _Reset(Const aSize : Word); virtual; {Real reset}
//procedure _BlockRead(Var Buf; Const Count : word); {Default BlockRead procedure}
//procedure _BlockWrite(Var Buf; Const Count : word); {Default BlockWrite prrocedure}
published
property Handle: File read F; {Returns a pointer to the file handle}
property IsOpen: boolean read FOpen; {True if file is open}
property FileName: string read FName;
property FilePath: string read FPath;
end;
(**) implementation (**)
//Uses EDosu;
{/////////////////////////////////////////////////////////////}
{Constructor/Destructor}
{/////////////////////////////////////////////////////////////}
Constructor TOFile.Create(const file_path: string);
//Constructor TOFile.Create;
begin
Inherited Create;
FOpen := False;
AssignFile(file_path);
end;
Destructor TOFile.Destroy;
begin
Close;
Inherited Destroy;
end;
{/////////////////////////////////////////////////////////////}
{Misc functions}
{/////////////////////////////////////////////////////////////}
{function TOFile.GetHandle: PFile;
begin
result := @F;
end;}
{/////////////////////////////////////////////////////////////}
{Wrapper functions}
{/////////////////////////////////////////////////////////////}
procedure TOFile.AssignFile(const AFilePath : String);
begin
Close;
{Init fields}
FName := ExtractFileName(AFilePath);
FPath := ExtractFilePath(AFilePath);
Assign(f, AFilePath);
end;
procedure TOFile.Reset;
begin
FileMode := 2;
_Reset(aSize);
end;
procedure TOFile.ResetReadOnly;
begin
FileMode := 0;
_Reset(aSize);
end;
procedure TOFile._Reset;
begin
Close;
System.Reset(f, aSize);
FOpen := True;
end;
procedure TOFile.Rewrite;
begin
Close;
System.Rewrite(f, aSize);
FOpen := True;
end;
procedure TOFile.Close;
begin
If IsOpen then
begin
System.Close(f);
FOpen := False;
end;
end;
function TOFile.FilePos : LongInt;
begin
FilePos := System.FilePos(f);
end;
procedure TOFile.Seek;
begin
System.Seek(f, aPos);
end;
procedure TOFile.SeekEOF;
begin
Seek(FileSize);
end;
function TOFile.EOF;
begin
Result := System.EOF(f);
end;
function TOFile.Exists;
begin
Result := FileExists(FPath + FName);
end;
Function TOFile.FileSize;
begin
Result := System.FileSize(f);
end;
{/////////////////////////////////////////////////////////////}
{BlockRead / BlockWrite wrappers}
{/////////////////////////////////////////////////////////////}
{The procedurers call the virtual BlockRead and BlockWrite.
These can be overriden. _BlockRead and _BlockWrite cannot.}
function TOFile.BlockRead(Var Buf; Const Count: longint): longint;
begin
System.BlockRead(f, Buf, Count, result);
end;
function TOFile.BlockWrite(Var Buf; Const Count: longint): longint;
begin
System.BlockWrite(f, Buf, Count, result);
end;
{/////////////////////////////////////////////////////////////}
{Write data types support}
{/////////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////////}
{String support}
{/////////////////////////////////////////////////////////////}
procedure TOFile.WriteString(aString : String);
begin
{Write Length + 1 bytes because the length byte is also written}
BlockWrite(aString, Length(aString));
end;
procedure TOFile.ReadString(Var rString : String);
begin
{Read length,
Read string data if length is > 0}
If length(rString) > 0 then
BlockRead(rString, length(rString));
end;
function TOFile.GetString : string;
var
s : string;
begin
ReadString(s);
GetString := s;
end;
{/////////////////////////////////////////////////////////////}
{Byte support}
{/////////////////////////////////////////////////////////////}
procedure TOFile.WriteByte(aByte : Byte);
begin
BlockWrite(aByte, SizeOf(Byte));
end;
procedure TOFile.ReadByte(Var rByte : Byte);
begin
BlockRead(rByte, SizeOf(Byte));
end;
function TOFile.GetByte : byte;
var
b : byte;
begin
ReadByte(b);
GetByte := b;
end;
{/////////////////////////////////////////////////////////////}
{Integer support}
{/////////////////////////////////////////////////////////////}
procedure TOFile.WriteInteger(aInteger : Integer);
begin
BlockWrite(aInteger, SizeOf(Integer));
end;
procedure TOFile.ReadInteger(Var rInteger : Integer);
begin
BlockRead(rInteger, SizeOf(Integer));
end;
function TOFile.GetInteger : Integer;
var
i : Integer;
begin
ReadInteger(i);
GetInteger := i;
end;
{/////////////////////////////////////////////////////////////}
{Long Integer support}
{/////////////////////////////////////////////////////////////}
procedure TOFile.WriteLongInt(aLongint : Longint);
begin
BlockWrite(aLongint, SizeOf(Longint));
end;
procedure TOFile.ReadLongint(Var rLongint : Longint);
begin
BlockRead(rLongint, SizeOf(Longint));
end;
function TOFile.GetLongint : Longint;
var
i : Longint;
begin
ReadLongint(i);
GetLongint := i;
end;
{/////////////////////////////////////////////////////////////}
{Error support}
{/////////////////////////////////////////////////////////////}
function TOFile.Error;
begin
Result := (IOResult = 0);
end;
function TOFile.IOResult: integer;
begin
result := system.IOResult;
end;
end.

View File

@ -0,0 +1,352 @@
unit smart_buf_filestream_unit;
{-------------------------------------------------------------------------------
Smart Buffered file stream input/output
rev 2.1
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
Features:
Enable/Disable buffering.
efficient in-buffer seeks.
Notes:
Buffering is enabled by default.
To enable/disable buffering, call EnableBuf/DisableBuf.
Procedures allowed when buffering is on or off.
When Buffering is on:
GetNextByte
WriteByte
ReadBuf
WriteBuf
When buffering is off:
Read
Write
Seek
Buffering on/off:
SmartSeek
Assertions are used to check if they are used correctly.
Be warned that not all procedures are protected.
Warning:
Do not call seek when buffering is used. Try not to use it at all.
Call SmartSeek all the time.
Notes:
For GetNextByte
EOF is assumed when bytes_read is smaller than bufsize. Therefore to force
a buffer reread set bytes_read to bufsize. (ResetBuffer)
Version
2.1: Fixed buffer reread and rewrite on GetByte and WriteByte
-------------------------------------------------------------------------------}
(**) interface (**)
uses Classes, Sysutils;
type
ESeekError = class(Exception);
{public
constructor Create;
end;}
TBuf = array[0..MaxLongInt-1] of byte;
PBuf = ^TBuf;
TBufferedFileStream = class( TFileStream )
private
buf: PBuf;
bufsize: integer; // actual size of the buffer
bytes_read: integer; // number of bytes read into the buffer
bufpos: integer;
bufoffset: integer; // actual buffer offset in file
dirty: Boolean;
buf_enabled: boolean;
FFileName: string;
write_mode: boolean;
reread_buffer: boolean;
function GetBufFilePos: integer;
public
property Position: integer read GetBufFilePos;
property FileName: string read FFileName;
constructor Create(const FileName: string; Mode: Word; _bufsize: Cardinal);
destructor Destroy; override;
function SmartSeek(offset: Longint; origin: Word): Longint;
procedure ResetBuffer;
function GetNextByte(var c: byte): Boolean; virtual;
procedure WriteByte(b: byte); virtual;
function ReadBuf(var Buffer; Count: Longint): Longint;
function WriteBuf(const Buffer; Count: Longint): Longint;
procedure EnableBuf;
procedure DisableBuf;
end;
(**) implementation (**)
uses ErrorUnit;
{constructor ESeekError.Create;
begin
inherited Create('Gruv: Fatal Seek Error');
end;}
////////////////////////////////////////////////////////////////////////////////
// Create
// ------
// Only resets the buffer after object is constructed.
////////////////////////////////////////////////////////////////////////////////
constructor TBufferedFileStream.Create( const FileName : string; Mode : Word; _bufsize: Cardinal);
begin
inherited Create(FileName, Mode);
bufsize := _bufsize;
bytes_read := 0;
bufoffset := 0;
dirty := False;
buf_enabled := true;
FFileName := FileName;
write_mode := (Mode and fmOpenWrite <> 0) or (Mode and fmOpenReadWrite <> 0);
GetMem(buf, bufsize);
ResetBuffer;
end;
////////////////////////////////////////////////////////////////////////////////
// Destroy
// -------
// Commits any data and destroys object.
////////////////////////////////////////////////////////////////////////////////
destructor TBufferedFileStream.Destroy;
begin
ResetBuffer;
Freemem(buf);
inherited Destroy;
end;
function TBufferedFileStream.GetBufFilePos: integer;
begin
if (bufpos = 0) and (bytes_read = 0) then
begin
// buffer could be just reset. get the actual physical position
result := inherited Position;
end
else
result := bufoffset + bufpos;
end;
(*------------------------------------------------------------------------------
ResetBuffer
-----------
Writes any information that has not been committed.
Will set BufferPos and BytesRead to values that will force a file read the
next time GetNextChar is called *)
procedure TBufferedFileStream.ResetBuffer;
begin
if dirty then
begin
Write(buf^, bufpos); {bufpos already incremented by 1}
dirty := False;
bufoffset := inherited Position;
end;
bufpos := 0;
bytes_read := 0;
reread_buffer := true;
end;
////////////////////////////////////////////////////////////////////////////////
// SmartSeek
//
// Will attempt to do an in buffer seek.
////////////////////////////////////////////////////////////////////////////////
function TBufferedFileStream.SmartSeek(offset: Longint; origin: Word) : Longint;
var
abs_offset: integer; // absolute offset
new_relative_offset: integer; // new pos in buffer if seek in buffer possible
begin
if write_mode then
begin
// write out data if buffer is dirty then do the seek
ResetBuffer;
Result := Seek(Offset, Origin);
bufoffset := inherited Position;
end
else
begin
// Attempt to do a seek in buffer if buf_enabled
if buf_enabled then
begin
// Convert offset to absolute offset
case origin of
soFromBeginning: abs_offset := offset;
soFromCurrent: abs_offset := GetBufFilePos + offset;
soFromEnd: abs_offset := Size - 1 + offset; { - 1 to convert to zero base }
else
begin
ShowError('abs_offset not initialized');
abs_offset := offset; {this line to remove the warning}
end;
end; {Case Origin}
// Test if seek in buffer is possible
new_relative_offset := abs_offset - bufoffset;
if (new_relative_offset > 0) and (new_relative_offset < bytes_read-1) then
begin
bufpos := new_relative_offset;
Result := GetBufFilePos;
end
else
begin
Result := Seek(Offset, Origin);
ResetBuffer;
end;
end
else
Result := Seek(Offset, Origin);
end; // write_mode
if (Result < 0) then raise ESeekError.Create('SmartSeek General error');
end;
(*------------------------------------------------------------------------------
GetNextByte
-----------
Reads the next byte in the stream.
bufsize characters are read from disk at a time, and when the buffer
runs out, a new buffer is automatically read.
Making BufferSize larger will reduce the number of reads and thus
increase speed, but will ( of course ) consume more memory. *)
function TBufferedFileStream.GetNextByte(var c: byte): Boolean;
begin
Assert(buf_enabled = true);
// If the bufpos is over the bytes_read, then must fill buffer with new characters
if (bufpos >= bytes_read) or reread_buffer then
begin
// bytes_read = bufsize implies the file has not reached eof yet
// the file is read in bufsize chunks. smaller than that implies no more data.
if (bytes_read = bufsize) or reread_buffer then
begin
reread_buffer := false;
bufoffset := inherited Position;
bytes_read := Read(buf^, bufsize);
bufpos := 0;
result := GetNextByte(c)
end
else
begin
c := 0;
// return EOF reached
result := false;
end;
end
else
begin
c := buf^[bufpos];
inc(bufpos);
result := True;
end;
end;
(*-----------------------------------------------------------------------------
PutChar
-------
If the buffer is full and dirty, it will be written to disk and restarted. *)
procedure TBufferedFileStream.WriteByte(b: byte);
begin
Assert(buf_enabled = true);
if (bufpos >= bufsize) then
begin
ResetBuffer;
end;
buf^[bufpos] := b;
inc(bufpos);
dirty := True;
end;
procedure TBufferedFileStream.EnableBuf;
begin
buf_enabled := true;
ResetBuffer;
{All changes were made directly to the file. No buffer flushing needed.
Resume normal buffer operation as usual.}
end;
procedure TBufferedFileStream.DisableBuf;
begin
buf_enabled := false;
ResetBuffer;
end;
function TBufferedFileStream.ReadBuf(var Buffer; Count: Longint): Longint;
var
b: PBuf;
c: byte;
i: integer;
begin
Assert(buf_enabled = true);
b := PBuf(@Buffer);
for i := 0 to Count-1 do
begin
GetNextByte(c);
b^[i] := c;
end;
result := Count; // return number of bytes read
end;
function TBufferedFileStream.WriteBuf(const Buffer; Count: Longint): Longint;
var
b: PBuf;
i: integer;
begin
Assert(buf_enabled = true);
b := PBuf(@Buffer);
for i := 0 to Count-1 do
WriteByte(b^[i]);
result := Count;
end;
end.

139
Xtra/QSortUnit.pas Normal file
View File

@ -0,0 +1,139 @@
unit QSortUnit;
{-------------------------------------------------------------------------------
Quick Sort unit
---------------
reSource (C) 1998 Victor K /97S66
Desc:
Sorts the index of a block.
This is the classic quick sort. Idiot proof, gueranteed to sort everytime.
Used for debugging. To confirm that any corrupted data is not the fault of
the sort.
Notes:
Uses a custom CompareStr routine that wraps around the end of the block.
-------------------------------------------------------------------------------}
(**) interface (**)
uses BWTCompressUnit, StructsUnit;
type
TQSortBlock = class
private
block: PBlock; // block that contains the data
index: PLongintBlock; // index to sort
block_length: longint; // data size in block
last_index: longint; // the index to the last piece of data in the block
public
constructor Create(const _block: PBlock; const _index: PLongintBlock; const _block_length: longint);
procedure Run;
end;
(**) implementation (**)
constructor TQSortBlock.Create(const _block: PBlock; const _index: PLongintBlock; const _block_length: longint);
begin
block := _block;
index := _index;
block_length := _block_length;
last_index := block_length-1;
end;
procedure TQSortBlock.Run;
function CompareStr(a, b: integer): integer;
var
times: byte;
first, index: longint;
begin
if (a <> b) then
begin
for times := 1 to 3 do
begin
{Take the later index to be the counter so that we know when we reach
the end}
if (a > b) then
first := a
else
first := b;
for index := first to last_index do
begin
if block^[a] < block^[b] then
begin
result := -1;
exit;
end
else
if block^[a] > block^[b] then
begin
result := 1;
exit;
end;
inc(a);
inc(b);
end;
{wrap indices around}
if (a = last_index+1) then
a := 0;
if (b = last_index+1) then
b := 0;
end;
{Equal comparison right to the end.
Shorter string, or the index closer to the end is greater}
if (a < b) then
result := -1
else
result := 1;
end
else
result := 0;
end; {Compare Str}
procedure QuickSort(const iLo, iHi: Integer);
var
Lo, Hi, Mid, T: Integer;
begin
Lo := iLo;
Hi := iHi;
Mid := index[(Lo + Hi) div 2];
repeat
while (CompareStr(index^[Lo], Mid) < 0) do inc(Lo);
while (CompareStr(index^[Hi], Mid) > 0) do dec(Hi);
{Swap}
if (Lo <= Hi) then
begin
T := index^[Lo];
index^[Lo] := index^[Hi];
index^[Hi] := T;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(iLo, Hi);
if Lo < iHi then QuickSort(Lo, iHi);
end;
begin
QuickSort(0, last_index);
end;
end.

101
arcstruc.txt Normal file
View File

@ -0,0 +1,101 @@
--------------------------------------------------------------------------------
Archive Structure Text file.
revision 1.0
Applicable for reSource v2.1 and above.
Last Modified: 11/December/2000
reSource (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
revisions:
1.0: Final revision. Added more comments.
0.3: Added archive signature
0.2: Cleaned up and added several data
0.1: Initial version
--------------------------------------------------------------------------------
Data types and definition:
--------------------------
byte - basic unit.
longint - 4 bytes. (Long Integer. Can take a negative value.)
string - variable length + null termination
... - variable size. Also used to indicate the data can be repeated as
many times as wanted.
General Format of a reSource Archive
------------------------------------
The extension for a reSource archive is 'rS'. All archives have a signature to
confirm that it is a reSource archive.
An empty archive is one that has no files. It must have a valid signature and
a central directory end header.
A zero byte file is not a valid archive.
Generally, the reSource archive will have an archive header, as many data
blocks as needed, a central directory and a central directory end record.
Signatures:
-----------
Long integers are stored in groups of 4 bytes. The byte with the lsb goes
first. So the signatures values had to be reversed to allow them to be seen by
a hex editor.
The signatures are stored in ArchiveHeadersUnit.
Headers
-------
Each header has a corresponding class.
For some headers, the actual size in bytes is required so it is stored in
a constant e.g. DATA_HEADER_SIZE is the size of a data header.
Data Header
-----------
Each data block has a data header.
first similarity index - first char to start with when restoring the block
virtual smallest char - it does not exist, so it is not output to the block.
when restoring, leave a space at this index to pretend it's there. used in
sada sort.
Overall reSource format:
[archive header]
[data header + data block] . . .
[central directory] end of central directory record
A. Archive Header
reSource Archive signature 4 bytes ('RSVK')
B. Data Header
Data header signature 4 bytes ('DATA')
crc 32 4 bytes
compressed size 4 bytes
first similarity index 4 bytes
virtual smallest char index 4 bytes
C. Central Director Structure:
[file header] . . . + end of central directory record
File Header:
Central file header signature 4 bytes ('CFHS')
compressed size 4 bytes
uncompressed size 4 bytes
number of blocks 4 bytes
offset of first local data header 4 bytes
(attributes)
time (dos date + time) 4 bytes
attr 4 bytes
file name string
End Of Central Directory Record:
Signature 4 bytes ('ECDR') End of Central Directory Record
Block Size 4 bytes
offset of first Central File Header 4 bytes

8
bugs.txt Normal file
View File

@ -0,0 +1,8 @@
--------------------------------------------------------------------------------
Known bugs
reSource (C) 1998-2000 Victor Kasenda / gruv
contains a list of bugs that are still around.
--------------------------------------------------------------------------------
(Please email all bugs or quirks to vickas@singnet.com.sg)

65
install.txt Normal file
View File

@ -0,0 +1,65 @@
-------------------------------------------------------
reSource
installation/getting to know/compiling and running
---------------------------------------------
reSource v2.6
Copyright (C) 1998-2001 Victor Kasenda / gruv
reSource support site: http://go.to/gruv
email: vickas@singnet.com.sg
---------------------------------------------
This file last updated on 08 May 2001
reSource version 2.6
-------------------------------------------------------
INSTALLATION:
unzip everything, including subdirectories into a directory.
The following directories will be created:
\Archiver Demo (Full featured Archiver demo that uses the TResource Component)
\Archiver Demo2 (demo for compressing/decompressing one file at a time)
\Component (The TResource component)
\manuals (System Doc and other txt files)
\Xtra (extra sources)
INSTALLING TRESOURCE COMPONENT
In Delphi, Open ResourcePack.dpk under \Components and press 'Install'.
The Component Package will be installed.
You should be able to see the TResource component under the 'Compression' tab in the component list.
RUNNING THE DEMO APP
make sure TResource component has been installed. Just Build and Run the Project.
TXT FILES INCLUDED IN THE PROJECT
---------------------------------
readme.txt - first file you should have read.
arcstruc.txt - the archive structure
install.txt - This file. Getting to know and using the component.
notes.txt - some notes I wrote about the implementation.
version.txt - The version of reSource and History.
UNDERSTANDING RESOURCE
----------------------
On the top of every unit there is a small description of what the unit does, how it works and maybe a brief description of the algorithm.
Also, before some procedures there is a detailed description of what the procedure does and how it does the work.
The main unit for the component is Component\ResourceCompUnit.pas. At the top of the unit is a detailed explanation of how to use it in code.
the following documents are in word 97 format, they are in the \manuals directory:
system doc.doc -
system documentation. about the archiver, how it works and organisation of the classes. may be quite outdated. the major change in version 2.1 is the sadakane suffix sort, which is much more efficient than the one described in the doc. this doc was written for the project, and as such has a lot of credits, names and references which you may not understand. but for completeness and originality's sake, i left them all in.
...carry on, compile/run/go/copy/paste/learn/code/delphirulez...

7
manuals/Readme.txt Normal file
View File

@ -0,0 +1,7 @@
WARNING:
SYSTEM DOC.DOC
The System Doc is semi-outdated.
It refers to Version 1.0 of reSource which did not have the more advanced sorting algorithm.
But the design and structure still remains the same, so it should provide a reasonable explanation as to how reSource works. It also explains a little the concept behind block sorting.

BIN
manuals/System Doc.doc Normal file

Binary file not shown.

144
notes.txt Normal file
View File

@ -0,0 +1,144 @@
--------------------------------------------------------------------------------
Notes file
reSource (C) 1998-2001 Victor Kasenda / gruv
--------------------------------------------------------------------------------
This file contains important information that should be reviewed before the
software, reSource, is released.
Pre Release Check list
----------------------
+ Check that all 'debug' statements are removed. All statements preceded by
a comment with the word 'debug' should be checked and removed if necessary.
+ remove debug columns from file list
If there are errors:
--------------------
- SendMessage in MainForm, parameter typecasted to longint to prevent range
check error.
- Block has indexes -1 to over the block size. When doing memory compares or
passing compares, make sure the same type is passed and memory is accessed
correctly i.e. From 0.
- if manually decoding then init may be necessary e.g. mtfEncode/Decode
if wrapper is called then may not need. ariEncodeBlock/DecodeBlock
Design Notes:
Archive Manager -> Block compressor -> Output file.
The archive manager chops the file into blocks.
Each block is passed to the block compressor
The block compressor compresses each block and writes it to the output file.
reSource probably cannot be used on tape backup systems due to its file
structure. Decompressing requires several random seeks to be done. If support
was to be added, then local file headers at the start of each data block would
have to be added which add to the archive size.
Drag and drop Notes:
During drag and drop, the path of the file is ignored. All files are dumped
in the drop directory. Duplicate names are handled by decompressing everything
into a common temp directory. User will be asked whether he wants to overwrite
the file. This behaviour is similar to Winzip.
Variable Type Selection:
Longint and Longword
--------------------
Longint should be enough for storing sizes, index etc. 2 gigs.
Only if unsigned or 4 gigs is necessary then longword should be used.
Buffer sizes
------------
It seems RLEncoder may expand the block (UC.EXE)
Therefore 10% of BlockSize have been added as overflow areas.
Deleting files
--------------
The interface will confirm the deletion of every file first before actually
calling archive manager to delete the files.
Therefore, cancel aborts the whole operation and nothing is changed in the
archive.
Adding files
------------
Shared files
------------
Adding of shared files is allowed. Files that are currently being added
are also allowed to be read. The file mode is fmShareDenyWrite, where
only writing is denied. An exe that is currently running can be added.
Input file cannot be opened
---------------------------
If the disk is not ready, or the input file cannot be opened, EFOpenError
is raised and captured in ArchiveManager.AddFiles. The file will not be
added. The user can add it himself later on when the problem is fixed.
Adding the archive file itself
------------------------------
This is checked for and the archive will be deselected upon pressing the
ok button in the add dialog.
File names
----------
Duplicate file names can be added to the archive.
The files can be differentiated by their dates and times.
The user will be alerted if a file of duplicate name is added to the archive.
He will be given a choice whether he wants to add it or not.
Zero length files
-----------------
It is possible to add zero length files.
Drag and Drop
-------------
If only one file is dropped and this file is a reSource archive, then
it is opened instead of being added. To add reSource archives, use Add.
Valid Archives
--------------
A valid archive contains at least a signature and an EndOfCentralDir header.
A 0 byte file is not a valid archive.
Opening Archives
----------------
EWrongSignature will be raised if the archive to be opened is corrupted.
An extension is compulsary. Due to a bug in the TFileStream.Create routine,
if a directory 'z' exists and you try to open a file called 'z', an EFCreateError
will occur. reSource currently overcomes this by forcing an extension.
e.g. 'z' --> 'z.rs'
'z.' -> 'z.rs'
'z.rs > 'z.rs'
The logic and algo can be found in ArchiveManager.OpenArchive. A dot is
first checed for then the extension is checked and added if needed.
Interface
---------
The interface may be slow in updating, especially during adding and extraction
of files. This is because the compressor and decompressor operates on blocks
of data and should not be interrupted half way. Adding of
Application.ProcessMessages throughout the operations may slow things down
greatly.
Therefore ProcessMessages is called after adding/extraction of every block.
Archive file name
-----------------
The archive file name will be displayed on the title bar.

142
readme.txt Normal file
View File

@ -0,0 +1,142 @@
---------------------------------
resource readme
version 2.6 full source code
08 May 2001
---------------------------------
Copyright (C) 1998-2001 Victor Kasenda / gruv
http://go.to/gruv
email: vickas@singnet.com.sg
icq me at: 6505245
...resource...
" compression ratios approaching that of PPM, speeds closer to LZ77 compressors"
only for delphi 5.0
later versions of delphi may work, earlier versions may need minor code modifications.
reSource features
- Burrows Wheeler Transformation (BWT) compression technology with efficient implementation
- addition
- extraction
- deletion
- modification of file attributes. The filename or attribute can be changed.
- compression statistics viewer
- compression ratios are close to PPM and speeds close to LZ77 (zip,arj) archivers.
Implementation features
- Kunihiko Sadakane's Suffix Sort
- Peter Fenwick's Structured Arithmetic Encoder Model
- Standard 1989 CACM Arithmetic Encoder (Patent Free)
- CRC 32 file extraction integrity check
- dual layer file read/write buffering - bit buffer (8 bits) and byte buffer (64kbytes)
- efficient block memory manager that shares and reuses blocks between classes
- full object oriented design
- pure pascal/delphi 4.0
the ideas came from:
- mark nelson: 1989 CACM arithmetic encoder 'c' source
- dj wheeler : 1989 report on the block sorting algorithm for DES
- peter fenwick: structured arithmetic encoder/model from his final report on the block sorting algorithm
- kunihiko sadakane: suffix sort algorithm
- julian seward: bzip, BWT implementation
this is my contribution to the delphi community.
don't you just hate it when you see 'pay $10 for full source'?
...copyright...
the source code to the program is free for non-commercial and educational use. It can be incorporated
freely into programs that are 'freeware' or public domain'.
please do at least drop me a note at gruv@bigfoot.com, mention where you got the code from in the credits and acknowledge the people as listed at the end of the document.
in no way is any of the code to be used in a shareware, commercial software, or commercial environments
without the permission or consent from the author, and also the people where the ideas came from.
Please note that this is not entirely my work, and is actually also based on the work, ideas of several people as mentioned at the end of this document.
...disclaimer...
regarding patents and licenses, i will not be held responsible if any of this code violates patent or legal legislations in your country.
this code is provided as is. i will not be held responsible for any damage done to your computer, or your brain.
to the best of my knowledge, resource does not violate any patent legislations. the arithmetic encoder is a standard CACM 1989 implementation and the rest of the algorithms are fairly new.
...for the impatient...
read install.txt to get familier with the files, how to install, compile and run resource.
...background...
this was intended to be an industrial strength archiver, comparable
to zip and other more established formats, but i got tired.... and there
are always buts...
it was released in 1998 as a school project, complete with system docs and user manual.
maybe if inspiration strikes again i'll dig everything out of the grave and rejuvenate the project.
...differences between bzip and resource...
resource bzip
Graphical interface implemented -
encoder type 1989 CACM arithmetic huffman
sort method sadakane's suffix sort
speed differences in speed due to different encoding and sort methods. bzip may be faster because huffman encoding is much faster than arithmetic encoding
...hopes...
so i hope all this code, which i have written for more than a year, will
come in handy to someone, be it the sorting routine, arithmetic coding
routine, or even the file list that can display shell icons!
...credits...
everything here was coded entirely in pascal/delphi by me, and
ideas/references came from many people, all of them i have
referred to in the respective files and also at the end of this document.
it was lotsa sweat and pain, and this is in the end released to the
public, free for non-commercial use.
i would like to thank (and also shout out a big hello! to):
Mark Nelson, who with his wonderful book,
Michael Burrows and David J. Wheeler for the block sorting algorithm.
Peter Fenwick's for his tuned structured arithmetic encoder
Kunihiko Sadakane's Suffix sort, which rocks, and imho is the best
general purpose sorter for the block sorting algorithm.
Angus Johnson, Anders Melander & Graham Wideman for their wonderful, totally incredible drag and drop package. I had managed to incorporate the older version of their package into resource and it turned instantly totally drag and drop to and from explorer.. simply amazing.
Julian Seward, author of BZip. BZip really inspired me to write on, although i didn't really understand much of the 'c' implementation of the BWT algorithm... ;-)
the author(s) of the delphi superpage and delphi deli, without which i may not even have been able to have finished.
and of course Inprise for creating Delphi, which is totally radical!
(and Inprise: when are we gonna have inline functions? it will surely speed up delphi apps alot!)
... a bit about the author ...
the author, Victor Kasenda (born 1980), lives on a small island of Singapore (check your atlas).
He treks neighbouring mountains, and enjoys a mountain biking.
programming is his life, his source of energy and motivation. he loves delphi, hates basic, and befriends java more than c, shys away from assembly because it's too much of a fuss. totally normal, partially insane, a little disturbed and totally lost his marbles when he released this source code.... hmmm....
...end of document, now go to sleep...

25
version.txt Normal file
View File

@ -0,0 +1,25 @@
reSource version 2.6 public release full source
copyright (C) 1998-2001 Victor Kasenda / gruv
email: vickas@singnet.com.sg
icq: 6505245
HISTORY
-------
Version 2.6
- Fixed ShellTypeName and ShellSmallImageIndex in TCentralFileHeader. Now implemented as properties and it will read itself when data is requested.
- Added 2 new functions: TResource.CompressToArchive and TResource.DecompressFromArchive
- Added Archiver Demo2 to demonstrate use of reSource to compress/decompress one file at a time.
Version 2.5 BETA
- Removed inter unit dependencies with the Component. TResource is now a stand alone component and you can integrate it easily with your application to provide Block Sorting compression.
- Cleaned up source code, and reorganized units into seperate dirs.
- The demo app now looks much better, and also has verbose output of what the engine is doing.
Version 2.1
First public release of source code.
Probably the only full Object Pascal/Delphi implementation of the Block Sorting Compression Algorithm + Arithmetic Encoding.
The first full source code release for a full featured archiver that has add/extract/delete and CRC32 Error checks.