pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

clean

Browse Source 
git-svn-id: https://svn.code.sf.net/p/kolmck/code@117 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2014-12-03 08:36:02 +00:00
parent 5e290f946e
commit b47333c67b
21 changed files with 0 additions and 6903 deletions
Download Patch File Download Diff File Expand all files Collapse all files

122
Addons/HeapMM.pas
View File

@ -1,122 +0,0 @@
{
Alternative memory manager. To use it, just place a reference to this
unit *FIRST* in the uses clause of your project (dpr-file). It is a good idea
to use this memory manager with system dcu replacement by Vladimir Kladov.
Heap API used, which is fast and very effective (allocated block granularity
is 16 bytes). One additional benefit is that some proofing tools (MemProof)
do not detect API failures, which those can find when standard Delphi memory
manager used.
=====================================================================
Copyright (C) by Vladimir Kladov, 2001
---------------------------------------------------------------------
http://xcl.cjb.net
mailto: bonanzas@xcl.cjb.net
}
unit HeapMM;
interface
uses windows;
const
HEAP_NO_SERIALIZE = $00001;
HEAP_GROWABLE = $00002;
HEAP_GENERATE_EXCEPTIONS = $00004;
HEAP_ZERO_MEMORY = $00008;
HEAP_REALLOC_IN_PLACE_ONLY = $00010;
HEAP_TAIL_CHECKING_ENABLED = $00020;
HEAP_FREE_CHECKING_ENABLED = $00040;
HEAP_DISABLE_COALESCE_ON_FREE = $00080;
HEAP_CREATE_ALIGN_16 = $10000;
HEAP_CREATE_ENABLE_TRACING = $20000;
HEAP_MAXIMUM_TAG = $00FFF;
HEAP_PSEUDO_TAG_FLAG = $08000;
HEAP_TAG_SHIFT = 16 ;
{$DEFINE USE_PROCESS_HEAP}
var
HeapHandle: THandle;
{* Global handle to the heap. Do not change it! }
HeapFlags: DWORD = 0;
{* Possible flags are:
HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a
function failure, such as an out-of-memory
condition, instead of returning NULL.
HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc
function is accessing the heap. Be careful!
Not recommended for multi-thread applications.
But faster.
HEAP_ZERO_MEMORY - obviously. (Slower!)
}
{ Note from MSDN:
The granularity of heap allocations in Win32 is 16 bytes. So if you
request a global memory allocation of 1 byte, the heap returns a pointer
to a chunk of memory, guaranteeing that the 1 byte is available. Chances
are, 16 bytes will actually be available because the heap cannot allocate
less than 16 bytes at a time.
}
implementation
function HeapGetMem(size: Integer): Pointer;
// Allocate memory block.
begin
Result := HeapAlloc( HeapHandle, HeapFlags, size );
end;
function HeapFreeMem(p: Pointer): Integer;
// Deallocate memory block.
begin
Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE,
p ) );
end;
function HeapReallocMem(p: Pointer; size: Integer): Pointer;
// Resize memory block.
begin
Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and
HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY),
// (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow
// system to move the block if necessary).
p, size );
end;
{function HeapMemoryManagerSet: Boolean;
begin
Result := TRUE;
end;}
const
HeapMemoryManager: TMemoryManager = (
GetMem: HeapGetMem;
FreeMem: HeapFreeMem;
ReallocMem: HeapReallocMem);
var OldMM: TMemoryManager;
//OldIsMMset: function : Boolean;
initialization
{$IFDEF USE_PROCESS_HEAP}
HeapHandle := GetProcessHeap;
{$ELSE}
HeapHandle := HeapCreate( 0, 0, 0 );
{$ENDIF}
GetMemoryManager( OldMM );
//OldIsMMset := IsMemoryManagerSet;
//IsMemoryManagerSet := HeapMemoryManagerSet;
SetMemoryManager( HeapMemoryManager );
finalization
SetMemoryManager( OldMM );
//IsMemoryManagerSet := OldIsMMset;
{$IFNDEF USE_PROCESS_HEAP}
HeapDestroy( HeapHandle );
{$ENDIF}
end.

1960
Addons/KolZLibBzip.pas
View File

File diff suppressed because it is too large Load Diff

260
Addons/Objects.pas
View File

@ -1,260 +0,0 @@
unit objects;
interface
uses
KOL, Windows, Messages;
type
TWndMethod = procedure(var Message: TMessage) of object;
function MakeObjectInstance(Method: TWndMethod): Pointer;
procedure FreeObjectInstance(ObjectInstance: Pointer);
function AllocateHWnd(Method: TWndMethod): HWND;
procedure DeallocateHWnd(Wnd: HWND);
function IncColor(C: TColor; D: integer): TColor;
procedure AjustBitmap(const M: KOL.PBitmap; S, C: TColor);
implementation
type
PObjectInstance = ^TObjectInstance;
TObjectInstance = packed record
Code: Byte;
Offset: Integer;
case Integer of
0: (Next: PObjectInstance);
1: (Method: TWndMethod);
end;
type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
Next: PInstanceBlock;
Code: array[1..2] of Byte;
WndProcPtr: Pointer;
Instances: array[0..100] of TObjectInstance;
end;
var
InstBlockList: PInstanceBlock;
InstBlockCount: integer;
InstFreeList: PObjectInstance;
{ Standard window procedure }
{ In ECX = Address of method pointer }
{ Out EAX = Result }
function StdWndProc(Window: HWND; Message, WParam: Longint;
LParam: Longint): Longint; stdcall; assembler;
asm
XOR EAX,EAX
PUSH EAX
PUSH LParam
PUSH WParam
PUSH Message
MOV EDX,ESP
MOV EAX,[ECX].Longint[4]
CALL [ECX].Pointer
ADD ESP,12
POP EAX
end;
{ Allocate an object instance }
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;
function MakeObjectInstance(Method: TWndMethod): Pointer;
const
BlockCode: array[1..2] of Byte = (
$59, { POP ECX }
$E9); { JMP StdWndProc }
PageSize = 4096;
var
Block: PInstanceBlock;
Instance: PObjectInstance;
begin
if InstFreeList = nil then
begin
Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
Block^.Next := InstBlockList;
Move(BlockCode, Block^.Code, SizeOf(BlockCode));
Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
Instance := @Block^.Instances;
repeat
Instance^.Code := $E8; { CALL NEAR PTR Offset }
Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
Instance^.Next := InstFreeList;
InstFreeList := Instance;
Inc(Longint(Instance), SizeOf(TObjectInstance));
until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
InstBlockList := Block;
end;
Result := InstFreeList;
Instance := InstFreeList;
InstFreeList := Instance^.Next;
Instance^.Method := Method;
inc(InstBlockCount);
end;
{ Free an object instance }
procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
if (ObjectInstance <> nil) and (InstBlockCount > 0) then
begin
PObjectInstance(ObjectInstance)^.Next := InstFreeList;
InstFreeList := ObjectInstance;
Dec(InstBlockCount);
if InstBlockCount = 0 then begin
VirtualFree(InstBlockList, 0, MEM_RELEASE);
InstBlockList := nil;
// ObjectInstance := nil;
end;
end;
end;
var
UtilWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @DefWindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'KOLFakeUtilWindow');
function AllocateHWnd(Method: TWndMethod): HWND;
var
TempClass: TWndClass;
ClassRegistered: Boolean;
begin
UtilWindowClass.hInstance := HInstance;
ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
TempClass);
if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
begin
if ClassRegistered then
Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
Windows.RegisterClass(UtilWindowClass);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
'', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if Assigned(Method) then
SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;
procedure DeallocateHWnd(Wnd: HWND);
var
Instance: Pointer;
begin
Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
DestroyWindow(Wnd);
if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
end;
procedure SplitColor(C: TColor; var r, g, b: integer);
begin
b := (c and $FF0000) shr 16;
g := (c and $00FF00) shr 08;
r := (c and $0000FF) shr 00;
end;
procedure AjustBitmap;
var i, j: integer;
t: KOL.PBitmap;
r,
g,
b,
r2,
g2,
b2: integer;
p: PRGBTriple;
function CalcColor(c1, c2, c3: integer): integer;
begin
if c1 = c3 then begin
Result := c2;
exit;
end;
if c1 = 0 then begin
Result := 0;
exit;
end;
{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
exit;}
Result := c1 * c2 div c3;
if c2 = 0 then Result := c1 * 150 div 255;
if Result > 255 then Result := 255;
if Result < 50 then Result := Result + 50;
{ exit;
a := trunc(x1 * 3);
a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
a := 255 * 255 - 4 * a;
try
x1 := Trunc((255 - sqrt(a)) / 2);
x2 := Trunc((255 + sqrt(a)) / 2);
if x1 > x2 then Result := Trunc(x1)
else Result := Trunc(x2);
except
Result := 0;
end;}
end;
begin
if s = c then exit;
if m.Width = 0 then exit;
if m.Height = 0 then exit;
t := NewBitmap(m.Width, m.Height);
m.PixelFormat := pf24bit;
t.Assign(m);
SplitColor(Color2RGB(s), r, g, b);
if r = 0 then r := 1;
if g = 0 then g := 1;
if b = 0 then b := 1;
SplitColor(Color2RGB(c), r2, g2, b2);
for j := 0 to t.Height - 1 do begin
p := t.scanline[j];
for i := 0 to t.Width - 1 do begin
p.rgbtRed := CalcColor(p.rgbtRed, r2, r);
p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b);
inc(p);
end;
end;
m.Assign(t);
t.Free;
end;
function IncColor;
var T: TColor;
P: PRGBTriple;
begin
T := Color2RGB(C);
p := @T;
if D > 0 then begin
if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255;
if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255;
if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
end else begin
if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000;
if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000;
if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
end;
Result := T;
end;
begin
InstBlockList := nil;
InstBlockCount := 0;
InstFreeList := nil;
end.

74
Addons/UBitTreeDecoder.pas
View File

@ -1,74 +0,0 @@
unit UBitTreeDecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL, URangeDecoder;
type PBitTreeDecoder = ^TBitTreeDecoder;
TBitTreeDecoder=object(TObj)
public
Models: array of smallint;
NumBitLevels:integer;
constructor Create(const AnumBitLevels:integer);
procedure _Init;
function Decode(const ArangeDecoder:PRangeDecoder):integer;
function ReverseDecode(const ArangeDecoder:PRangeDecoder):integer;overload;
end;
function ReverseDecode(var AModels: array of smallint; const AstartIndex:integer;const ArangeDecoder:PRangeDecoder; const ANumBitLevels:integer):integer;overload;
implementation
constructor TBitTreeDecoder.Create(const AnumBitLevels:integer);
begin
self.NumBitLevels := AnumBitLevels;
setlength(Models,1 shl AnumBitLevels);
end;
procedure TBitTreeDecoder._Init;
begin
urangedecoder.InitBitModels(Models);
end;
function TBitTreeDecoder.Decode(const ArangeDecoder:PRangeDecoder):integer;
var m,bitIndex:integer;
begin
m:=1;
for bitIndex := NumBitLevels downto 1 do begin
m:=m shl 1 + ArangeDecoder.DecodeBit(Models, m);
end;
result:=m - (1 shl NumBitLevels);
end;
function TBitTreeDecoder.ReverseDecode(const ArangeDecoder:PRangeDecoder):integer;
var m,symbol,bitindex,bit:integer;
begin
m:=1;
symbol:=0;
for bitindex:=0 to numbitlevels-1 do begin
bit:=ArangeDecoder.DecodeBit(Models, m);
m:=(m shl 1) + bit;
symbol:=symbol or (bit shl bitIndex);
end;
result:=symbol;
end;
function ReverseDecode(var AModels: array of smallint;const AstartIndex:integer;
const ArangeDecoder:PRangeDecoder;const ANumBitLevels:integer):integer;
var m,symbol,bitindex,bit:integer;
begin
m:=1;
symbol:=0;
for bitindex:=0 to ANumBitLevels -1 do begin
bit := ArangeDecoder.DecodeBit(AModels, AstartIndex + m);
m := (m shl 1) + bit;
symbol := symbol or bit shl bitindex;
end;
result:=symbol;
end;
end.

116
Addons/UBitTreeEncoder.pas
View File

@ -1,116 +0,0 @@
unit UBitTreeEncoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL, URangeDecoder,URangeEncoder;
type PBitTreeEncoder =^TBitTreeEncoder;
TBitTreeEncoder=object(TObj)
public
Models: array of smallint;
NumBitLevels:integer;
constructor Create(const AnumBitLevels:integer);
procedure _Init;
procedure Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer);
procedure ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer);
function GetPrice(const Asymbol:integer):integer;
function ReverseGetPrice(Asymbol:integer):integer;overload;
end;
procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer; Asymbol:integer);
function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer; Asymbol:integer):integer;
implementation
constructor TBitTreeEncoder.Create(const AnumBitLevels:integer);
begin
self.NumBitLevels:=AnumBitLevels;
setlength(Models,1 shl AnumBitLevels);
end;
procedure TBitTreeEncoder._Init;
begin
URangeDecoder.InitBitModels(Models);
end;
procedure TBitTreeEncoder.Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer);
var m,bitindex,bit:integer;
begin
m := 1;
for bitIndex := NumBitLevels -1 downto 0 do begin
bit := (Asymbol shr bitIndex) and 1;
ArangeEncoder.Encode(Models, m, bit);
m := (m shl 1) or bit;
end;
end;
procedure TBitTreeEncoder.ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer);
var m,i,bit:integer;
begin
m:=1;
for i:= 0 to NumBitLevels -1 do begin
bit := Asymbol and 1;
ArangeEncoder.Encode(Models, m, bit);
m := (m shl 1) or bit;
Asymbol := Asymbol shr 1;
end;
end;
function TBitTreeEncoder.GetPrice(const Asymbol:integer):integer;
var price,m,bitindex,bit:integer;
begin
price := 0;
m := 1;
for bitIndex := NumBitLevels - 1 downto 0 do begin
bit := (Asymbol shr bitIndex) and 1;
price := price + RangeEncoder.GetPrice(Models[m], bit);
m := (m shl 1) + bit;
end;
result:=price;
end;
function TBitTreeEncoder.ReverseGetPrice(Asymbol:integer):integer;
var price,m,i,bit:integer;
begin
price := 0;
m := 1;
for i:= NumBitLevels downto 1 do begin
bit := Asymbol and 1;
Asymbol := Asymbol shr 1;
price :=price + RangeEncoder.GetPrice(Models[m], bit);
m := (m shl 1) or bit;
end;
result:=price;
end;
function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer;Asymbol:integer):integer;
var price,m,i,bit:integer;
begin
price := 0;
m := 1;
for i := ANumBitLevels downto 1 do begin
bit := Asymbol and 1;
Asymbol := Asymbol shr 1;
price := price + RangeEncoder.GetPrice(AModels[AstartIndex + m], bit);
m := (m shl 1) or bit;
end;
result:=price;
end;
procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer;Asymbol:integer);
var m,i,bit:integer;
begin
m:=1;
for i := 0 to ANumBitLevels -1 do begin
bit := Asymbol and 1;
ArangeEncoder.Encode(AModels, AstartIndex + m, bit);
m := (m shl 1) or bit;
Asymbol := Asymbol shr 1;
end;
end;
end.

174
Addons/UBufferedFS.pas
View File

@ -1,174 +0,0 @@
unit UBufferedFS;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type PBufferedFS = PStream;
{
const BufferSize=$10000;//64K
type TBFSMode=(BFMRead,BFMWrite);
TBufferedFS=class(TFileStream)
private
membuffer:array [0..BufferSize-1] of byte;
bytesinbuffer:integer;
bufferpos:integer;
bufferdirty:boolean;
Mode:TBFSMode;
procedure _Init;
procedure Flush;
procedure ReadBuffer;
public
constructor Create(const FileName: string; Mode: Word); overload;
constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload;
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
type TByteArray = array of byte;
PByteArray = ^TByteArray;
}
implementation
{
function MovePointer(const P:pointer;const dist:integer):pointer;
begin
result:=pointer(integer(p)+dist);
end;
procedure TBufferedFS.Init;
begin
bytesinbuffer:=0;
bufferpos:=0;
bufferdirty:=false;
mode:=BFMWrite;
end;
procedure TBufferedFS.Flush;
begin
if bufferdirty then
inherited Write(membuffer[0],bufferpos);
bufferdirty:=false;
bytesinbuffer:=0;
bufferpos:=0;
end;
constructor TBufferedFS.Create(const FileName: string; Mode: Word);
begin
inherited;
init;
end;
constructor TBufferedFS.Create(const FileName: string; Mode: Word; Rights: Cardinal);
begin
inherited;
init;
end;
destructor TBufferedFS.Destroy;
begin
flush;
inherited;
end;
procedure TBufferedFS.ReadBuffer;
begin
flush;
bytesinbuffer:=inherited Read(membuffer,buffersize);
bufferpos:=0;
end;
function TBufferedFS.Read(var Buffer; Count: Longint): Longint;
var p:PByteArray;
bytestoread:integer;
b:integer;
begin
if Mode=BFMWrite then flush;
mode:=BFMRead;
result:=0;
if count<=bytesinbuffer then begin
//all data already in buffer
move(membuffer[bufferpos],buffer,count);
bytesinbuffer:=bytesinbuffer-count;
bufferpos:=bufferpos+count;
result:=count;
end else begin
bytestoread:=count;
if (bytestoread<>0)and(bytesinbuffer<>0) then begin
//read data remaining in buffer and increment data pointer
b:=Read(buffer,bytesinbuffer);
p:=PByteArray(@(TByteArray(buffer)[b]));
bytestoread:=bytestoread-b;
result:=b;
end else p:=@buffer;
if bytestoread>=BufferSize then begin
//data to read is larger than the buffer, read it directly
result:=result+inherited Read(p^,bytestoread);
end else begin
//refill buffer
ReadBuffer;
//recurse
result:=result+Read(p^,math.Min(bytestoread,bytesinbuffer));
end;
end;
end;
function TBufferedFS.Write(const Buffer; Count: Longint): Longint;
var p:pointer;
bytestowrite:integer;
b:integer;
begin
if mode=BFMRead then begin
seek(-BufferSize+bufferpos,soFromCurrent);
bytesinbuffer:=0;
bufferpos:=0;
end;
mode:=BFMWrite;
result:=0;
if count<=BufferSize-bytesinbuffer then begin
//all data fits in buffer
bufferdirty:=true;
move(buffer,membuffer[bufferpos],count);
bytesinbuffer:=bytesinbuffer+count;
bufferpos:=bufferpos+count;
result:=count;
end else begin
bytestowrite:=count;
if (bytestowrite<>0)and(bytesinbuffer<>BufferSize)and(bytesinbuffer<>0) then begin
//write data to remaining space in buffer and increment data pointer
b:=Write(buffer,BufferSize-bytesinbuffer);
p:=MovePointer(@buffer,b);
bytestowrite:=bytestowrite-b;
result:=b;
end else p:=@buffer;
if bytestowrite>=BufferSize then begin
//empty buffer
Flush;
//data to write is larger than the buffer, write it directly
result:=result+inherited Write(p^,bytestowrite);
end else begin
//empty buffer
Flush;
//recurse
result:=result+Write(p^,bytestowrite);
end;
end;
end;
function TBufferedFS.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if (Origin=soCurrent)and(Offset=0) then result:=inherited seek(Offset,origin)+bufferpos
else begin
flush;
result:=inherited Seek(offset,origin);
end;
end;
}
end.

130
Addons/UDig.pas
View File

@ -1,130 +0,0 @@
unit UDig;
interface
function stri (n,n1:integer;zero,trim:boolean):string;
function strL (n: longint; n1 :integer):string;
{function strr(n:real;n1,n2:word):string;
function strH (w : longint; c : word) : string;}
function strhl(w : longint; c : word) : string;
function hexi(s:string):word;
function hexl(s:string):longint;
function inti(s:string):word;
{function intl(s:string):longint; }
implementation
uses UWrd, UStr;
function atrim(s : string) : string;
var t : string;
begin
t := s;
while (t[1] = ' ') and (length(t) > 0) do t := copy(t, 2, 255);
while (t[length(t)] = ' ') and (length(t) > 0) do t := copy(t, 1, length(t) - 1);
atrim := t;
end;
{
function strh;
const a:array[0..15] of cHar =
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
var r:string;
begin
if c>0 then r:=strh(w div 16,c-1)+a[w mod 16]
else r:='';
strH := r;
end;
}
function strhl;
const a:array[0..15] of cHar =
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
var r:string;
begin
if c > 0 then
if w mod 16 >= 0 tHen r := strhl(w sHr 4, c - 1) + a[ w mod 16] else
r := strHl(w sHr 4, c - 1) + a[16 + w mod 16]
else r := '';
strHl := r;
end;
function hexi;
const a : string[15] ='123456789ABCDEF';
var i : integer;
h :word;
begin
h:=0;
for i:=1 to length(s) do begin
if S[i]<>' ' then begin
h:=h shl 4;
h:=h+pos(UpCase(S[i]),a);
end;
end;
hexi:=h;
end;
function hexl;
const a : string[15] ='123456789ABCDEF';
var i : integer;
h :longint;
begin
h:=0;
for i:=1 to length(s) do begin
if S[i]<>' ' then begin
h:=h shl 4;
h:=h+pos(UpCase(S[i]),a);
end;
end;
hexl:=h;
end;
function inti;
var
rc : integer;
ww : longint;
begin
val(s, ww, rc);
inti := ww;
end;
{
function intl;
var
rc : integer;
ww : integer;
begin
val(s, ww, rc);
intl := ww;
end;
}
function stri;
var s : string;
i : integer;
begin
str(n: n1, s);
if zero THen begin
for i := 1 to lengtH(s) do
if s[i] = ' ' THen s[i] := '0';
end;
if trim then s := atrim(s);
stri := s;
end;
function strl;
var s:string;
begin
str(n:n1,s);
strl:=s;
end;
{
function strr;
var s:string;
begin
str(n:n1:n2,s);
strr:=s;
end;
}
end.

99
Addons/UFor.pas
View File

@ -1,99 +0,0 @@
unit UFor;
interface
function points(d : boolean; t : string; m : integer): string;
function toreal(r : string): real;
function rtostr(r : real): string;
function plslop(o, c: string; back, buys: boolean): string;
function plslom(o, c: string; back, buys: boolean; size, amnt, intr: string): string;
function chkprc(o, c, q, b: string): boolean;
implementation
uses SysUtils;
function points;
var s : string;
p,
i,
e : integer;
begin
s := t;
if pos('.', s) = 0 then s := s + '.';
while length(s) < 6 do s := s + '0';
p := pos('.', s);
s := copy(s, 1, p - 1) + copy(s, p + 1, 6 - p);
val(s, i, e);
if d then inc(i, m) else dec(i, m);
s := inttostr(i);
while length(s) < 5 do s := '0' + s;
s := copy(s, 1, p - 1) + '.' + copy(s, p, 6 - p);
points := s;
end;
function toreal(r: string): real;
var f : real;
i : integer;
s : string;
begin
S := R;
val(trim(S), F, I);
if (i > 0) and (I < length(S)) then begin
if S[I] = '.' then S[I] := ',' else
if S[I] = ',' then S[i] := '.';
val(trim(S), F, I);
end;
result := F;
end;
function rtostr;
var s : string;
begin
str(r:5:2, s);
rtostr := s;
end;
function plslop;
var op,
cl : real;
j : integer;
begin
op := toreal(o);
cl := toreal(c);
repeat
op := op * 10;
cl := cl * 10;
until op > 3000;
j := round(cl - op);
if back xor buys then j := -j;
plslop := inttostr(j);
end;
function plslom;
var op, cl: real;
dd: real;
begin
plslom := '0';
op := toreal(o);
cl := toreal(c);
if (op = 0) or (cl = 0) then exit;
if back then dd := cl - op
else dd := 1/op - 1/cl;
dd := dd * toreal(size);
if back xor buys then dd := -dd;
dd := dd * strtoint(amnt) - toreal(intr);
plslom := rtostr(dd);
end;
function chkprc;
var op, cl: real;
bk, sb: boolean;
begin
op := toreal(o);
cl := toreal(c);
bk := (q = 'EUR') or (q = 'GBP');
sb := (b = 'Buy');
chkprc := (op >= cl) xor (bk xor sb);
end;
end.

420
Addons/ULZBinTree.pas
View File

@ -1,420 +0,0 @@
unit ULZBinTree;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses ULZInWindow, KOL;
type
TArrayOfInteger = array [0..0] of Integer;
PArrayOfInteger = ^TArrayOfInteger;
type PLZBinTree = ^TLZBinTree;
TLZBinTree = object(TLZInWindow)
public
cyclicBufferPos:integer;
cyclicBufferSize:integer;
matchMaxLen:integer;
son: PArrayOfInteger;//array of integer;
hash: array of integer;
cutValue:integer;
hashMask:integer;
hashSizeSum:integer;
HASH_ARRAY:boolean;
kNumHashDirectBytes:integer;
kMinMatchCheck:integer;
kFixHashSize:integer;
constructor Create;
procedure SetType(const AnumHashBytes:integer);
procedure _Init;virtual;
procedure MovePos;virtual;
function _Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean;
function GetMatches(var Adistances:array of integer):integer;
procedure Skip(Anum:integer);
procedure NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer);
procedure Normalize;
procedure SetCutValue(const AcutValue:integer);
end;
implementation
const kHash2Size = 1 shl 10;
kHash3Size = 1 shl 16;
kBT2HashSize = 1 shl 16;
kStartMaxLen = 1;
kHash3Offset = kHash2Size;
kEmptyHashValue = 0;
kMaxValForNormalize = (1 shl 30) - 1;
var CRCTable: array [0..255] of integer;
constructor TLZBinTree.Create;
begin
inherited Create;
cyclicBufferSize:=0;
cutValue:=$FF;
hashSizeSum:=0;
HASH_ARRAY:=true;
kNumHashDirectBytes:=0;
kMinMatchCheck:=4;
kFixHashsize:=kHash2Size + kHash3Size;
end;
procedure TLZBinTree.SetType(const AnumHashBytes:integer);
begin
HASH_ARRAY := (AnumHashBytes > 2);
if HASH_ARRAY then begin
kNumHashDirectBytes := 0;
kMinMatchCheck := 4;
kFixHashSize := kHash2Size + kHash3Size;
end
else begin
kNumHashDirectBytes := 2;
kMinMatchCheck := 2 + 1;
kFixHashSize := 0;
end;
end;
procedure TLZBinTree._Init;
var i:integer;
begin
inherited _init;
for i := 0 to hashSizeSum - 1 do
hash[i] := kEmptyHashValue;
cyclicBufferPos := 0;
ReduceOffsets(-1);
end;
procedure TLZBinTree.MovePos;
begin
inc(cyclicBufferPos);
if cyclicBufferPos >= cyclicBufferSize then
cyclicBufferPos := 0;
inherited MovePos;
if pos = kMaxValForNormalize then
Normalize;
end;
function TLZBinTree._Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean;
var windowReservSize:integer;
_cyclicBufferSize:integer;
hs:integer;
begin
if (AhistorySize > kMaxValForNormalize - 256) then begin
result:=false;
exit;
end;
cutValue := 16 + (AmatchMaxLen shr 1);
windowReservSize := (AhistorySize + AkeepAddBufferBefore + AmatchMaxLen + AkeepAddBufferAfter) div 2 + 256;
inherited _Create(AhistorySize + AkeepAddBufferBefore, AmatchMaxLen + AkeepAddBufferAfter, windowReservSize);
self.matchMaxLen := AmatchMaxLen;
_cyclicBufferSize := AhistorySize + 1;
if self.cyclicBufferSize <> _cyclicBufferSize then begin
self.cyclicBufferSize:=_cyclicBufferSize;
son:= AllocMem(_cyclicBufferSize * 2);
// GetMem(son,_cyclicBufferSize * 2);
// setlength(son,_cyclicBufferSize * 2);
end;
hs := kBT2HashSize;
if HASH_ARRAY then begin
hs := AhistorySize - 1;
hs := hs or (hs shr 1);
hs := hs or (hs shr 2);
hs := hs or (hs shr 4);
hs := hs or (hs shr 8);
hs := hs shr 1;
hs := hs or $FFFF;
if (hs > (1 shl 24)) then
hs := hs shr 1;
hashMask := hs;
inc(hs);
hs := hs + kFixHashSize;
end;
if (hs <> hashSizeSum) then begin
hashSizeSum := hs;
setlength(hash,hashSizeSum);
end;
result:=true;
end;
function TLZBinTree.GetMatches(var Adistances:array of integer):integer;
var lenLimit:integer;
offset,matchMinPos,cur,maxlen,hashvalue,hash2value,hash3value:integer;
temp,curmatch,curmatch2,curmatch3,ptr0,ptr1,len0,len1,count:integer;
delta,cyclicpos,pby1,len:integer;
begin
if pos + matchMaxLen <= streamPos then
lenLimit := matchMaxLen
else begin
lenLimit := streamPos - pos;
if lenLimit < kMinMatchCheck then begin
MovePos();
result:=0;
exit;
end;
end;
offset := 0;
if (pos > cyclicBufferSize) then
matchMinPos:=(pos - cyclicBufferSize)
else matchMinPos:=0;
cur := bufferOffset + pos;
maxLen := kStartMaxLen; // to avoid items for len < hashSize;
hash2Value := 0;
hash3Value := 0;
if HASH_ARRAY then begin
temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF);
hash2Value := temp and (kHash2Size - 1);
temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8);
hash3Value := temp and (kHash3Size - 1);
hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask;
end else
hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8));
curMatch := hash[kFixHashSize + hashValue];
if HASH_ARRAY then begin
curMatch2 := hash[hash2Value];
curMatch3 := hash[kHash3Offset + hash3Value];
hash[hash2Value] := pos;
hash[kHash3Offset + hash3Value] := pos;
if curMatch2 > matchMinPos then
if bufferBase[bufferOffset + curMatch2] = bufferBase[cur] then begin
maxLen := 2;
Adistances[offset] := maxLen;
inc(offset);
Adistances[offset] := pos - curMatch2 - 1;
inc(offset);
end;
if curMatch3 > matchMinPos then
if bufferBase[bufferOffset + curMatch3] = bufferBase[cur] then begin
if curMatch3 = curMatch2 then
offset := offset - 2;
maxLen := 3;
Adistances[offset] := maxlen;
inc(offset);
Adistances[offset] := pos - curMatch3 - 1;
inc(offset);
curMatch2 := curMatch3;
end;
if (offset <> 0) and (curMatch2 = curMatch) then begin
offset := offset - 2;
maxLen := kStartMaxLen;
end;
end;
hash[kFixHashSize + hashValue] := pos;
ptr0 := (cyclicBufferPos shl 1) + 1;
ptr1 := (cyclicBufferPos shl 1);
len0 := kNumHashDirectBytes;
len1 := len0;
if kNumHashDirectBytes <> 0 then begin
if (curMatch > matchMinPos) then begin
if (bufferBase[bufferOffset + curMatch + kNumHashDirectBytes] <> bufferBase[cur + kNumHashDirectBytes]) then begin
maxLen := kNumHashDirectBytes;
Adistances[offset] := maxLen;
inc(offset);
Adistances[offset] := pos - curMatch - 1;
inc(offset);
end;
end;
end;
count := cutValue;
while (true) do begin
if (curMatch <= matchMinPos) or (count = 0) then begin
son[ptr1] := kEmptyHashValue;
son[ptr0] := son[ptr1];
break;
end;
dec(count);
delta := pos - curMatch;
if delta<=cyclicBufferPos then
cyclicpos:=(cyclicBufferPos - delta) shl 1
else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1;
pby1 := bufferOffset + curMatch;
len := min(len0, len1);
if bufferBase[pby1 + len] = bufferBase[cur + len] then begin
inc(len);
while (len <> lenLimit) do begin
if (bufferBase[pby1 + len] <> bufferBase[cur + len]) then
break;
inc(len);
end;
if maxLen < len then begin
maxLen := len;
Adistances[offset] := maxlen;
inc(offset);
Adistances[offset] := delta - 1;
inc(offset);
if (len = lenLimit) then begin
son[ptr1] := son[cyclicPos];
son[ptr0] := son[cyclicPos + 1];
break;
end;
end;
end;
if (bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF) then begin
son[ptr1] := curMatch;
ptr1 := cyclicPos + 1;
curMatch := son[ptr1];
len1 := len;
end else begin
son[ptr0] := curMatch;
ptr0 := cyclicPos;
curMatch := son[ptr0];
len0 := len;
end;
end;
MovePos;
result:=offset;
end;
procedure TLZBinTree.Skip(Anum:integer);
var lenLimit,matchminpos,cur,hashvalue,temp,hash2value,hash3value,curMatch:integer;
ptr0,ptr1,len,len0,len1,count,delta,cyclicpos,pby1:integer;
begin
repeat
if pos + matchMaxLen <= streamPos then
lenLimit := matchMaxLen
else begin
lenLimit := streamPos - pos;
if lenLimit < kMinMatchCheck then begin
MovePos();
dec(Anum);
continue;
end;
end;
if pos>cyclicBufferSize then
matchminpos:=(pos - cyclicBufferSize)
else matchminpos:=0;
cur := bufferOffset + pos;
if HASH_ARRAY then begin
temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF);
hash2Value := temp and (kHash2Size - 1);
hash[hash2Value] := pos;
temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8);
hash3Value := temp and (kHash3Size - 1);
hash[kHash3Offset + hash3Value] := pos;
hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask;
end else
hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8));
curMatch := hash[kFixHashSize + hashValue];
hash[kFixHashSize + hashValue] := pos;
ptr0 := (cyclicBufferPos shl 1) + 1;
ptr1 := (cyclicBufferPos shl 1);
len0 := kNumHashDirectBytes;
len1 := kNumHashDirectBytes;
count := cutValue;
while true do begin
if (curMatch <= matchMinPos) or (count = 0) then begin
son[ptr1] := kEmptyHashValue;
son[ptr0] := son[ptr1];
break;
end else dec(count);
delta := pos - curMatch;
if (delta <= cyclicBufferPos) then
cyclicpos:=(cyclicBufferPos - delta) shl 1
else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1;
pby1 := bufferOffset + curMatch;
len := min(len0, len1);
if bufferBase[pby1 + len] = bufferBase[cur + len] then begin
inc(len);
while (len <> lenLimit) do begin
if bufferBase[pby1 + len] <> bufferBase[cur + len] then
break;
inc(len);
end;
if len = lenLimit then begin
son[ptr1] := son[cyclicPos];
son[ptr0] := son[cyclicPos + 1];
break;
end;
end;
if ((bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF)) then begin
son[ptr1] := curMatch;
ptr1 := cyclicPos + 1;
curMatch := son[ptr1];
len1 := len;
end else begin
son[ptr0] := curMatch;
ptr0 := cyclicPos;
curMatch := son[ptr0];
len0 := len;
end;
end;
MovePos;
dec(Anum);
until Anum=0;
end;
procedure TLZBinTree.NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer);
var i,value:integer;
begin
for i:=0 to AnumItems-1 do begin
value := Aitems[i];
if value <= AsubValue then
value := kEmptyHashValue
else value := value - AsubValue;
Aitems[i] := value;
end;
end;
procedure TLZBinTree.Normalize;
var subvalue:integer;
begin
subValue := pos - cyclicBufferSize;
NormalizeLinks(son^, cyclicBufferSize * 2, subValue);
NormalizeLinks(hash, hashSizeSum, subValue);
ReduceOffsets(subValue);
end;
procedure TLZBinTree.SetCutValue(const Acutvalue:integer);
begin
self.cutValue:=Acutvalue;
end;
procedure InitCRC;
var i,r,j:integer;
begin
for i := 0 to 255 do begin
r := i;
for j := 0 to 7 do
if ((r and 1) <> 0) then
r := (r shr 1) xor integer($EDB88320)
else
r := r shr 1;
CrcTable[i] := r;
end;
end;
initialization
InitCRC;
end.

170
Addons/ULZInWindow.pas
View File

@ -1,170 +0,0 @@
unit ULZInWindow;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type TLZInWindow= object(TObj)
public
bufferBase: array of byte;// pointer to buffer with data
stream:PStream;
posLimit:integer; // offset (from _buffer) of first byte when new block reading must be done
streamEndWasReached:boolean; // if (true) then _streamPos shows real end of stream
pointerToLastSafePosition:integer;
bufferOffset:integer;
blockSize:integer; // Size of Allocated memory block
pos:integer; // offset (from _buffer) of curent byte
keepSizeBefore:integer; // how many BYTEs must be kept in buffer before _pos
keepSizeAfter:integer; // how many BYTEs must be kept buffer after _pos
streamPos:integer; // offset (from _buffer) of first not read byte from Stream
procedure MoveBlock;
procedure ReadBlock;
procedure _Free;
procedure _Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer);
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init;virtual;
procedure MovePos;virtual;
function GetIndexByte(const Aindex:integer):byte;
// index + limit have not to exceed _keepSizeAfter;
function GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer;
function GetNumAvailableBytes:integer;
procedure ReduceOffsets(const AsubValue:integer);
end;
implementation
procedure TLZInWindow.MoveBlock;
var offset,numbytes,i:integer;
begin
offset := bufferOffset + pos - keepSizeBefore;
// we need one additional byte, since MovePos moves on 1 byte.
if (offset > 0) then
dec(offset);
numBytes := bufferOffset + streamPos - offset;
// check negative offset ????
for i := 0 to numBytes -1 do
bufferBase[i] := bufferBase[offset + i];
bufferOffset := bufferOffset - offset;
end;
procedure TLZInWindow.ReadBlock;
var size,numreadbytes,pointerToPostion:integer;
begin
if streamEndWasReached then
exit;
while (true) do begin
size := (0 - bufferOffset) + blockSize - streamPos;
if size = 0 then
exit;
numReadBytes := stream.Read(bufferBase[bufferOffset + streamPos], size);
if (numReadBytes = 0) then begin
posLimit := streamPos;
pointerToPostion := bufferOffset + posLimit;
if (pointerToPostion > pointerToLastSafePosition) then
posLimit := pointerToLastSafePosition - bufferOffset;
streamEndWasReached := true;
exit;
end;
streamPos := streamPos + numReadBytes;
if (streamPos >= pos + keepSizeAfter) then
posLimit := streamPos - keepSizeAfter;
end;
end;
procedure TLZInWindow._Free;
begin
setlength(bufferBase,0);
end;
procedure TLZInWindow._Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer);
var _blocksize:integer;
begin
self.keepSizeBefore := AkeepSizeBefore;
self.keepSizeAfter := AkeepSizeAfter;
_blocksize := AkeepSizeBefore + AkeepSizeAfter + AkeepSizeReserv;
if (length(bufferBase) = 0) or (self.blockSize <> _blocksize) then begin
_Free;
self.blockSize := _blocksize;
setlength(bufferBase,self.blockSize);
end;
pointerToLastSafePosition := self.blockSize - AkeepSizeAfter;
end;
procedure TLZInWindow.SetStream(const Astream:PStream);
begin
self.stream:=Astream;
end;
procedure TLZInWindow.ReleaseStream;
begin
stream:=nil;
end;
procedure TLZInWindow._Init;
begin
bufferOffset := 0;
pos := 0;
streamPos := 0;
streamEndWasReached := false;
ReadBlock;
end;
procedure TLZInWindow.MovePos;
var pointerToPostion:integer;
begin
inc(pos);
if pos > posLimit then begin
pointerToPostion := bufferOffset + pos;
if pointerToPostion > pointerToLastSafePosition then
MoveBlock;
ReadBlock;
end;
end;
function TLZInWindow.GetIndexByte(const Aindex:integer):byte;
begin
result:=bufferBase[bufferOffset + pos + Aindex];
end;
function TLZInWindow.GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer;
var pby,i:integer;
begin
if streamEndWasReached then
if (pos + Aindex) + Alimit > streamPos then
Alimit := streamPos - (pos + Aindex);
inc(Adistance);
// Byte *pby = _buffer + (size_t)_pos + Aindex;
pby := bufferOffset + pos + Aindex;
i:=0;
while (i<Alimit)and(bufferBase[pby + i] = bufferBase[pby + i - Adistance]) do begin
inc(i);
end;
result:=i;
end;
function TLZInWindow.GetNumAvailableBytes:integer;
begin
result:=streamPos - pos;
end;
procedure TLZInWindow.ReduceOffsets(const Asubvalue:integer);
begin
bufferOffset := bufferOffset + Asubvalue;
posLimit := posLimit - Asubvalue;
pos := pos - Asubvalue;
streamPos := streamPos - Asubvalue;
end;
end.

104
Addons/ULZMABase.pas
View File

@ -1,104 +0,0 @@
unit ULZMABase;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
function StateInit:integer;
function StateUpdateChar(const index:integer):integer;
function StateUpdateMatch(const index:integer):integer;
function StateUpdateRep(const index:integer):integer;
function StateUpdateShortRep(const index:integer):integer;
function StateIsCharState(const index:integer):boolean;
function GetLenToPosState(len:integer):integer;
const kNumRepDistances = 4;
kNumStates = 12;
kNumPosSlotBits = 6;
kDicLogSizeMin = 0;
// kDicLogSizeMax = 28;
// kDistTableSizeMax = kDicLogSizeMax * 2;
kNumLenToPosStatesBits = 2; // it's for speed optimization
kNumLenToPosStates = 1 shl kNumLenToPosStatesBits;
kMatchMinLen = 2;
kNumAlignBits = 4;
kAlignTableSize = 1 shl kNumAlignBits;
kAlignMask = (kAlignTableSize - 1);
kStartPosModelIndex = 4;
kEndPosModelIndex = 14;
kNumPosModels = kEndPosModelIndex - kStartPosModelIndex;
kNumFullDistances = 1 shl (kEndPosModelIndex div 2);
kNumLitPosStatesBitsEncodingMax = 4;
kNumLitContextBitsMax = 8;
kNumPosStatesBitsMax = 4;
kNumPosStatesMax = (1 shl kNumPosStatesBitsMax);
kNumPosStatesBitsEncodingMax = 4;
kNumPosStatesEncodingMax = (1 shl kNumPosStatesBitsEncodingMax);
kNumLowLenBits = 3;
kNumMidLenBits = 3;
kNumHighLenBits = 8;
kNumLowLenSymbols = 1 shl kNumLowLenBits;
kNumMidLenSymbols = 1 shl kNumMidLenBits;
kNumLenSymbols = kNumLowLenSymbols + kNumMidLenSymbols + (1 shl kNumHighLenBits);
kMatchMaxLen = kMatchMinLen + kNumLenSymbols - 1;
implementation
function StateInit:integer;
begin
result:=0;
end;
function StateUpdateChar(const index:integer):integer;
begin
if (index < 4) then
result:=0
else
if (index < 10) then
result:=index - 3
else
result:=index - 6;
end;
function StateUpdateMatch(const index:integer):integer;
begin
if index<7 then result:=7
else result:=10;
end;
function StateUpdateRep(const index:integer):integer;
begin
if index<7 then result:=8
else result:=11;
end;
function StateUpdateShortRep(const index:integer):integer;
begin
if index<7 then result:=9
else result:=11;
end;
function StateIsCharState(const index:integer):boolean;
begin
result:=index<7;
end;
function GetLenToPosState(len:integer):integer;
begin
len := len - kMatchMinLen;
if (len < kNumLenToPosStates) then
result:=len
else result:=(kNumLenToPosStates - 1);
end;
end.

31
Addons/ULZMACommon.pas
View File

@ -1,31 +0,0 @@
unit ULZMACommon;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type TLZMAProgressAction=(LPAMax,LPAPos);
TLZMAProgress=procedure (const Action:TLZMAProgressAction;const Value:int64) of object;
function ReadByte(const stream:PStream):byte;
procedure WriteByte(const stream:PStream;b:byte);
const CodeProgressInterval = 50;//approx. number of times an OnProgress event will be fired during coding
implementation
function ReadByte(const stream:PStream):byte;
begin
stream.Read(result,1);
end;
procedure WriteByte(const stream:PStream;b:byte);
begin
stream.Write(b,1);
end;
end.

428
Addons/ULZMADecoder.pas
View File

@ -1,428 +0,0 @@
unit ULZMADecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses ULZMABase,UBitTreeDecoder,ULZOutWindow,URangeDecoder,KOL,ULZMACommon;
type PLZMALenDecoder = ^TLZMALenDecoder;
PLZMALiteralDecoder = ^TLZMALiteralDecoder;
PLZMADecoder = ^TLZMADecoder;
TLZMADecoder = object(TObj)
private
FOnProgress:TLZMAProgress;
procedure DoProgress(const Action:TLZMAProgressAction;const Value:integer);
public
m_OutWindow:PLZOutWindow;
m_RangeDecoder:PRangeDecoder;
m_IsMatchDecoders: array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1] of smallint;
m_IsRepDecoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG0Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG1Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG2Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRep0LongDecoders: array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1] of smallint;
m_PosSlotDecoder: array [0..ULZMABase.kNumLenToPosStates-1] of PBitTreeDecoder;
m_PosDecoders: array [0..ULZMABase.kNumFullDistances - ULZMABase.kEndPosModelIndex-1] of smallint;
m_PosAlignDecoder:PBitTreeDecoder;
m_LenDecoder:PLZMALenDecoder;
m_RepLenDecoder:PLZMALenDecoder;
m_LiteralDecoder:PLZMALiteralDecoder;
m_DictionarySize:integer;
m_DictionarySizeCheck:integer;
m_PosStateMask:integer;
constructor Create;
destructor Destroy;virtual;
function SetDictionarySize(const dictionarySize:integer):boolean;
function SetLcLpPb(const lc,lp,pb:integer):boolean;
procedure _Init;
function Code(const inStream,outStream:PStream;outSize:int64):boolean;
function SetDecoderProperties(const properties:array of byte):boolean;
property OnProgress:TLZMAProgress read FOnProgress write FOnProgress;
end;
TLZMALenDecoder = object(TObj)
public
m_Choice:array [0..1] of smallint;
m_LowCoder: array[0..ULZMABase.kNumPosStatesMax-1] of PBitTreeDecoder;
m_MidCoder: array[0..ULZMABase.kNumPosStatesMax-1] of PBitTreeDecoder;
m_HighCoder: PBitTreeDecoder;
m_NumPosStates:integer;
constructor Create;
destructor Destroy;virtual;
procedure _Create(const numPosStates:integer);
procedure _Init;
function Decode(const rangeDecoder:PRangeDecoder;const posState:integer):integer;
end;
PLZMADecoder2 = ^TLZMADecoder2;
TLZMADecoder2 = object(TObj)
public
m_Decoders: array [0..$300-1] of smallint;
procedure _Init;
function DecodeNormal(const ArangeDecoder:PRangeDecoder):byte;
function DecodeWithMatchByte(const ArangeDecoder:PRangeDecoder;AmatchByte:byte):byte;
end;
TLZMALiteralDecoder = object(TObj)
public
m_Coders: array of PLZMADecoder2;
m_NumPrevBits:integer;
m_NumPosBits:integer;
m_PosMask:integer;
procedure _Create(const AnumPosBits, AnumPrevBits:integer);
procedure _Init;
function GetDecoder(const Apos:integer;const AprevByte:byte):PLZMADecoder2;
destructor Destroy;virtual;
end;
implementation
constructor TLZMALenDecoder.Create;
begin
New(m_HighCoder, Create(ULZMABase.kNumHighLenBits));
m_NumPosStates:=0;
end;
destructor TLZMALenDecoder.Destroy;
var i:integer;
begin
m_HighCoder.free;
for i:=low(m_LowCoder) to high(m_LowCoder) do begin
if m_LowCoder[i]<>nil then m_LowCoder[i].free;
if m_MidCoder[i]<>nil then m_MidCoder[i].free;
end;
inherited;
end;
procedure TLZMALenDecoder._Create(const numPosStates:integer);
begin
while m_NumPosStates < numPosStates do begin
New(m_LowCoder[m_NumPosStates], Create(ULZMABase.kNumLowLenBits));
New(m_MidCoder[m_NumPosStates], Create(ULZMABase.kNumMidLenBits));
inc(m_NumPosStates);
end;
end;
procedure TLZMALenDecoder._Init;
var posState:integer;
begin
URangeDecoder.InitBitModels(m_Choice);
for posState := 0 to m_NumPosStates-1 do begin
m_LowCoder[posState]._Init;
m_MidCoder[posState]._Init;
end;
m_HighCoder._Init;
end;
function TLZMALenDecoder.Decode(const rangeDecoder:PRangeDecoder;const posState:integer):integer;
var symbol:integer;
begin
if (rangeDecoder.DecodeBit(m_Choice, 0) = 0) then begin
result:=m_LowCoder[posState].Decode(rangeDecoder);
exit;
end;
symbol := ULZMABase.kNumLowLenSymbols;
if (rangeDecoder.DecodeBit(m_Choice, 1) = 0) then
symbol := symbol + m_MidCoder[posState].Decode(rangeDecoder)
else symbol := symbol + ULZMABase.kNumMidLenSymbols + m_HighCoder.Decode(rangeDecoder);
result:=symbol;
end;
procedure TLZMADecoder2._Init;
begin
URangeDecoder.InitBitModels(m_Decoders);
end;
function TLZMADecoder2.DecodeNormal(const ArangeDecoder:PRangeDecoder):byte;
var symbol:integer;
begin
symbol := 1;
repeat
symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol);
until not (symbol < $100);
result:=symbol;
end;
function TLZMADecoder2.DecodeWithMatchByte(const ArangeDecoder:PRangeDecoder;AmatchByte:byte):byte;
var symbol:integer;
matchbit:integer;
bit:integer;
begin
symbol := 1;
repeat
matchBit := (AmatchByte shr 7) and 1;
AmatchByte := AmatchByte shl 1;
bit := ArangeDecoder.DecodeBit(m_Decoders, ((1 + matchBit) shl 8) + symbol);
symbol := (symbol shl 1) or bit;
if (matchBit <> bit) then begin
while (symbol < $100) do begin
symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol);
end;
break;
end;
until not (symbol < $100);
result:=symbol;
end;
procedure TLZMALiteralDecoder._Create(const AnumPosBits, AnumPrevBits:integer);
var numStates,i:integer;
begin
if (length(m_Coders) <> 0) and (m_NumPrevBits = AnumPrevBits) and (m_NumPosBits = AnumPosBits) then
exit;
m_NumPosBits := AnumPosBits;
m_PosMask := (1 shl AnumPosBits) - 1;
m_NumPrevBits := AnumPrevBits;
numStates := 1 shl (m_NumPrevBits + m_NumPosBits);
setlength(m_Coders,numStates);
for i :=0 to numStates-1 do
New(m_Coders[i], Create);
end;
destructor TLZMALiteralDecoder.Destroy;
var i:integer;
begin
for i :=low(m_Coders) to high(m_Coders) do
if m_Coders[i]<>nil then m_Coders[i].Free;
inherited;
end;
procedure TLZMALiteralDecoder._Init;
var numStates,i:integer;
begin
numStates := 1 shl (m_NumPrevBits + m_NumPosBits);
for i := 0 to numStates -1 do
m_Coders[i]._Init;
end;
function TLZMALiteralDecoder.GetDecoder(const Apos:integer;const AprevByte:byte):PLZMADecoder2;
begin
result:=m_Coders[((Apos and m_PosMask) shl m_NumPrevBits) + ((AprevByte and $FF) shr (8 - m_NumPrevBits))];
end;
constructor TLZMADecoder.Create;
var i:integer;
begin
FOnProgress:=nil;
New(m_OutWindow, Create);
New(m_RangeDecoder, Create);
New(m_PosAlignDecoder, Create(ULZMABase.kNumAlignBits));
New(m_LenDecoder, Create);
New(m_RepLenDecoder, Create);
New(m_LiteralDecoder, Create);
m_DictionarySize:= -1;
m_DictionarySizeCheck:= -1;
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
New(m_PosSlotDecoder[i], Create(ULZMABase.kNumPosSlotBits));
end;
destructor TLZMADecoder.Destroy;
var i:integer;
begin
m_OutWindow.Free;
m_RangeDecoder.Free;
m_PosAlignDecoder.Free;
m_LenDecoder.Free;
m_RepLenDecoder.Free;
m_LiteralDecoder.Free;
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
m_PosSlotDecoder[i].Free;
end;
function TLZMADecoder.SetDictionarySize(const dictionarySize:integer):boolean;
begin
if dictionarySize < 0 then
result:=false
else begin
if m_DictionarySize <> dictionarySize then begin
m_DictionarySize := dictionarySize;
m_DictionarySizeCheck := max(m_DictionarySize, 1);
m_OutWindow._Create(max(m_DictionarySizeCheck, (1 shl 12)));
end;
result:=true;
end;
end;
function TLZMADecoder.SetLcLpPb(const lc,lp,pb:integer):boolean;
var numPosStates:integer;
begin
if (lc > ULZMABase.kNumLitContextBitsMax) or (lp > 4) or (pb > ULZMABase.kNumPosStatesBitsMax) then begin
result:=false;
exit;
end;
m_LiteralDecoder._Create(lp, lc);
numPosStates := 1 shl pb;
m_LenDecoder._Create(numPosStates);
m_RepLenDecoder._Create(numPosStates);
m_PosStateMask := numPosStates - 1;
result:=true;
end;
procedure TLZMADecoder._Init;
var i:integer;
begin
m_OutWindow._Init(false);
URangeDecoder.InitBitModels(m_IsMatchDecoders);
URangeDecoder.InitBitModels(m_IsRep0LongDecoders);
URangeDecoder.InitBitModels(m_IsRepDecoders);
URangeDecoder.InitBitModels(m_IsRepG0Decoders);
URangeDecoder.InitBitModels(m_IsRepG1Decoders);
URangeDecoder.InitBitModels(m_IsRepG2Decoders);
URangeDecoder.InitBitModels(m_PosDecoders);
m_LiteralDecoder._Init();
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
m_PosSlotDecoder[i]._Init;
m_LenDecoder._Init;
m_RepLenDecoder._Init;
m_PosAlignDecoder._Init;
m_RangeDecoder._Init;
end;
function TLZMADecoder.Code(const inStream,outStream:PStream;outSize:int64):boolean;
var state,rep0,rep1,rep2,rep3:integer;
nowPos64:int64;
prevByte:byte;
posState:integer;
decoder2:PLZMADecoder2;
len,distance,posSlot,numDirectBits:integer;
lpos:int64;
progint:int64;
begin
DoProgress(LPAMax,outSize);
m_RangeDecoder.SetStream(inStream);
m_OutWindow.SetStream(outStream);
_Init;
state := ULZMABase.StateInit;
rep0 := 0; rep1 := 0; rep2 := 0; rep3 := 0;
nowPos64 := 0;
prevByte := 0;
progint:=outsize div CodeProgressInterval;
lpos:=progint;
while (outSize < 0) or (nowPos64 < outSize) do begin
if (nowPos64 >=lpos) then begin
DoProgress(LPAPos,nowPos64);
lpos:=lpos+progint;
end;
posState := nowPos64 and m_PosStateMask;
if (m_RangeDecoder.DecodeBit(m_IsMatchDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin
decoder2 := m_LiteralDecoder.GetDecoder(nowPos64, prevByte);
if not ULZMABase.StateIsCharState(state) then
prevByte := decoder2.DecodeWithMatchByte(m_RangeDecoder, m_OutWindow.GetByte(rep0))
else prevByte := decoder2.DecodeNormal(m_RangeDecoder);
m_OutWindow.PutByte(prevByte);
state := ULZMABase.StateUpdateChar(state);
inc(nowPos64);
end else begin
if (m_RangeDecoder.DecodeBit(m_IsRepDecoders, state) = 1) then begin
len := 0;
if (m_RangeDecoder.DecodeBit(m_IsRepG0Decoders, state) = 0) then begin
if (m_RangeDecoder.DecodeBit(m_IsRep0LongDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin
state := ULZMABase.StateUpdateShortRep(state);
len := 1;
end;
end else begin
if m_RangeDecoder.DecodeBit(m_IsRepG1Decoders, state) = 0 then
distance := rep1
else begin
if (m_RangeDecoder.DecodeBit(m_IsRepG2Decoders, state) = 0) then
distance := rep2
else begin
distance := rep3;
rep3 := rep2;
end;
rep2 := rep1;
end;
rep1 := rep0;
rep0 := distance;
end;
if len = 0 then begin
len := m_RepLenDecoder.Decode(m_RangeDecoder, posState) + ULZMABase.kMatchMinLen;
state := ULZMABase.StateUpdateRep(state);
end;
end else begin
rep3 := rep2;
rep2 := rep1;
rep1 := rep0;
len := ULZMABase.kMatchMinLen + m_LenDecoder.Decode(m_RangeDecoder, posState);
state := ULZMABase.StateUpdateMatch(state);
posSlot := m_PosSlotDecoder[ULZMABase.GetLenToPosState(len)].Decode(m_RangeDecoder);
if posSlot >= ULZMABase.kStartPosModelIndex then begin
numDirectBits := (posSlot shr 1) - 1;
rep0 := ((2 or (posSlot and 1)) shl numDirectBits);
if posSlot < ULZMABase.kEndPosModelIndex then
rep0 := rep0 + UBitTreeDecoder.ReverseDecode(m_PosDecoders,
rep0 - posSlot - 1, m_RangeDecoder, numDirectBits)
else begin
rep0 := rep0 + (m_RangeDecoder.DecodeDirectBits(
numDirectBits - ULZMABase.kNumAlignBits) shl ULZMABase.kNumAlignBits);
rep0 := rep0 + m_PosAlignDecoder.ReverseDecode(m_RangeDecoder);
if rep0 < 0 then begin
if rep0 = -1 then
break;
result:=false;
exit;
end;
end;
end else rep0 := posSlot;
end;
if (rep0 >= nowPos64) or (rep0 >= m_DictionarySizeCheck) then begin
m_OutWindow.Flush();
result:=false;
exit;
end;
m_OutWindow.CopyBlock(rep0, len);
nowPos64 := nowPos64 + len;
prevByte := m_OutWindow.GetByte(0);
end;
end;
m_OutWindow.Flush();
m_OutWindow.ReleaseStream();
m_RangeDecoder.ReleaseStream();
DoProgress(LPAPos,nowPos64);
result:=true;
end;
function TLZMADecoder.SetDecoderProperties(const properties:array of byte):boolean;
var val,lc,remainder,lp,pb,dictionarysize,i:integer;
begin
if length(properties) < 5 then begin
result:=false;
exit;
end;
val := properties[0] and $FF;
lc := val mod 9;
remainder := val div 9;
lp := remainder mod 5;
pb := remainder div 5;
dictionarySize := 0;
for i := 0 to 3 do
dictionarySize := dictionarysize + ((properties[1 + i]) and $FF) shl (i * 8);
if (not SetLcLpPb(lc, lp, pb)) then begin
result:=false;
exit;
end;
result:=SetDictionarySize(dictionarySize);
end;
procedure TLZMADecoder.DoProgress(const Action:TLZMAProgressAction;const Value:integer);
begin
if assigned(fonprogress) then
fonprogress(action,value);
end;
end.

1518
Addons/ULZMAEncoder.pas
View File

File diff suppressed because it is too large Load Diff

107
Addons/ULZOutWindow.pas
View File

@ -1,107 +0,0 @@
unit ULZOutWindow;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type PLZOutWindow = ^TLZOutWindow;
TLZOutWindow=object(TObj)
public
buffer: array of byte;
pos:integer;
windowSize:integer;
streamPos:integer;
stream:PStream;
procedure _Create(const AwindowSize:integer);
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init(const Asolid:boolean);
procedure Flush;
procedure CopyBlock(const Adistance:integer; Alen:integer);
procedure PutByte(const Ab:byte);
function GetByte(const Adistance:integer):byte;
end;
implementation
procedure TLZOutWindow._Create(const AwindowSize:integer);
begin
if (length(buffer)=0) or (self.windowSize <> AwindowSize) then
setlength(buffer,AwindowSize);
self.windowSize := AwindowSize;
pos := 0;
streamPos := 0;
end;
procedure TLZOutWindow.SetStream(const Astream:PStream);
begin
ReleaseStream;
self.stream:=Astream;
end;
procedure TLZOutWindow.ReleaseStream;
begin
flush;
self.stream:=nil;
end;
procedure TLZOutWindow._Init(const Asolid:boolean);
begin
if not Asolid then begin
streamPos:=0;
Pos:=0;
end;
end;
procedure TLZOutWindow.Flush;
var size:integer;
begin
size := pos - streamPos;
if (size = 0) then
exit;
stream.write(buffer[streamPos], size);
if (pos >= windowSize) then
pos := 0;
streamPos := pos;
end;
procedure TLZOutWindow.CopyBlock(const Adistance:integer;Alen:integer);
var _pos:integer;
begin
_pos := self.pos - Adistance - 1;
if _pos < 0 then
_pos := _pos + windowSize;
while Alen<>0 do begin
if _pos >= windowSize then
_pos := 0;
buffer[self.pos] := buffer[_pos];
inc(self.pos);
inc(_pos);
if self.pos >= windowSize then
Flush();
dec(Alen);
end;
end;
procedure TLZOutWindow.PutByte(const Ab:byte);
begin
buffer[pos] := Ab;
inc(pos);
if (pos >= windowSize) then
Flush();
end;
function TLZOutWindow.GetByte(const Adistance:integer):byte;
var _pos:integer;
begin
_pos := self.pos - Adistance - 1;
if (_pos < 0) then
_pos := _pos + windowSize;
result:=buffer[_pos];
end;
end.

100
Addons/URangeDecoder.pas
View File

@ -1,100 +0,0 @@
unit URangeDecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL,ULZMACommon;
type PRangeDecoder = ^TRangeDecoder;
TRangeDecoder=object(TObj)
public
Range,Code:integer;
Stream:PStream;
procedure SetStream(const AStream:PStream);
procedure ReleaseStream;
procedure _Init;
function DecodeDirectBits(const AnumTotalBits:integer):integer;
function DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer;
end;
procedure InitBitModels(var Aprobs: array of smallint);
implementation
const kTopMask = not ((1 shl 24) - 1);
kNumBitModelTotalBits = 11;
kBitModelTotal = (1 shl kNumBitModelTotalBits);
kNumMoveBits = 5;
procedure TRangeDecoder.SetStream(const AStream:PStream);
begin
self.Stream:=AStream;
end;
procedure TRangeDecoder.ReleaseStream;
begin
stream:=nil;
end;
procedure TRangeDecoder._Init;
var i:integer;
begin
code:=0;
Range:=-1;
for i:=0 to 4 do begin
code:=(code shl 8) or byte(ReadByte(stream));
end;
end;
function TRangeDecoder.DecodeDirectBits(const AnumTotalBits:integer):integer;
var i,t:integer;
begin
result:=0;
for i := AnumTotalBits downto 1 do begin
range:=range shr 1;
t := ((Code - Range) shr 31);
Code := Code - Range and (t - 1);
result := (result shl 1) or (1 - t);
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
end;
end;
function TRangeDecoder.DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer;
var prob,newbound:integer;
begin
prob:=Aprobs[Aindex];
newbound:=(Range shr kNumBitModelTotalBits) * prob;
if (integer((integer(Code) xor integer($80000000))) < integer((integer(newBound) xor integer($80000000)))) then begin
Range := newBound;
Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits));
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
result:=0;
end else begin
Range := Range - newBound;
Code := Code - newBound;
Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits));
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
result:=1;
end;
end;
procedure InitBitModels(var Aprobs: array of smallint);
var i:integer;
begin
for i:=0 to length(Aprobs)-1 do
Aprobs[i] := kBitModelTotal shr 1;
end;
end.

175
Addons/URangeEncoder.pas
View File

@ -1,175 +0,0 @@
unit URangeEncoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL,ULZMACommon;
const kNumBitPriceShiftBits = 6;
kTopMask = not ((1 shl 24) - 1);
kNumBitModelTotalBits = 11;
kBitModelTotal = (1 shl kNumBitModelTotalBits);
kNumMoveBits = 5;
kNumMoveReducingBits = 2;
type PRangeEncoder = ^TRangeEncoder;
TRangeEncoder=object(TObj)
private
ProbPrices: array [0..kBitModelTotal shr kNumMoveReducingBits-1] of integer;
public
Stream:PStream;
Low,Position:int64;
Range,cacheSize,cache:integer;
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init;
procedure FlushData;
procedure FlushStream;
procedure ShiftLow;
procedure EncodeDirectBits(const v,AnumTotalBits:integer);
function GetProcessedSizeAdd:int64;
procedure Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer);
constructor Create;
function GetPrice(const AProb,Asymbol:integer):integer;
function GetPrice0(const AProb:integer):integer;
function GetPrice1(const AProb:integer):integer;
end;
var RangeEncoder:PRangeEncoder;
procedure InitBitModels(var probs:array of smallint);
implementation
procedure TRangeEncoder.SetStream(const Astream:PStream);
begin
self.Stream:=AStream;
end;
procedure TRangeEncoder.ReleaseStream;
begin
stream:=nil;
end;
procedure TRangeEncoder._Init;
begin
position := 0;
Low := 0;
Range := -1;
cacheSize := 1;
cache := 0;
end;
procedure TRangeEncoder.FlushData;
var i:integer;
begin
for i:=0 to 4 do
ShiftLow();
end;
procedure TRangeEncoder.FlushStream;
begin
//stream.flush;
end;
procedure TRangeEncoder.ShiftLow;
var LowHi:integer;
temp:integer;
begin
LowHi := (Low shr 32);
if (LowHi <> 0) or (Low < int64($FF000000)) then begin
position := position + cacheSize;
temp := cache;
repeat
WriteByte(stream,temp + LowHi);
temp := $FF;
dec(cacheSize);
until(cacheSize = 0);
cache := (Low shr 24);
end;
inc(cacheSize);
Low := (Low and integer($FFFFFF)) shl 8;
end;
procedure TRangeEncoder.EncodeDirectBits(const v,AnumTotalBits:integer);
var i:integer;
begin
for i := AnumTotalBits - 1 downto 0 do begin
Range := Range shr 1;
if (((v shr i) and 1) = 1) then
Low := Low + Range;
if ((Range and kTopMask) = 0) then begin
Range := range shl 8;
ShiftLow;
end;
end;
end;
function TRangeEncoder.GetProcessedSizeAdd:int64;
begin
result:=cacheSize + position + 4;
end;
procedure InitBitModels(var probs:array of smallint);
var i:integer;
begin
for i := 0 to length(probs) -1 do
probs[i] := kBitModelTotal shr 1;
end;
procedure TRangeEncoder.Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer);
var prob,newbound:integer;
begin
prob := Aprobs[Aindex];
newBound := (Range shr kNumBitModelTotalBits) * prob;
if (Asymbol = 0) then begin
Range := newBound;
Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits));
end else begin
Low := Low + (newBound and int64($FFFFFFFF));
Range := Range - newBound;
Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits));
end;
if ((Range and kTopMask) = 0) then begin
Range := Range shl 8;
ShiftLow;
end;
end;
constructor TRangeEncoder.Create;
var kNumBits:integer;
i,j,start,_end:integer;
begin
kNumBits := (kNumBitModelTotalBits - kNumMoveReducingBits);
for i := kNumBits - 1 downto 0 do begin
start := 1 shl (kNumBits - i - 1);
_end := 1 shl (kNumBits - i);
for j := start to _end -1 do
ProbPrices[j] := (i shl kNumBitPriceShiftBits) +
(((_end - j) shl kNumBitPriceShiftBits) shr (kNumBits - i - 1));
end;
end;
function TRangeEncoder.GetPrice(const AProb,Asymbol:integer):integer;
begin
result:=ProbPrices[(((AProb - Asymbol) xor ((-Asymbol))) and (kBitModelTotal - 1)) shr kNumMoveReducingBits];
end;
function TRangeEncoder.GetPrice0(const AProb:integer):integer;
begin
result:= ProbPrices[AProb shr kNumMoveReducingBits];
end;
function TRangeEncoder.GetPrice1(const AProb:integer):integer;
begin
result:= ProbPrices[(kBitModelTotal - AProb) shr kNumMoveReducingBits];
end;
initialization
New(RangeEncoder, Create);
finalization
RangeEncoder.Free;
end.

301
Addons/USrv.pas
View File

@ -1,301 +0,0 @@
Unit USrv;
interface
uses Windows, Classes, Graphics, Controls, Messages, Dialogs,
SysUtils;
const WM_GETIMAGE = WM_USER + $0429;
function BitmapToRegion(Bitmap: TBitmap): HRGN;
function CopyToBitmap(Control: TControl; Bitmap: TBitmap; Anyway: boolean): boolean;
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
dwROP: dword); overload;
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
dwROP: dword); overload;
procedure AjustBitmap(const M: TBitmap; S, C: TColor);
procedure FadeBitmap(const M: TBitmap; C: TColor; D: byte);
function IncColor(C: TColor; D: integer): TColor;
implementation
function BitmapToRegion(Bitmap: TBitmap): HRGN;
var
X, Y: Integer;
XStart: Integer;
TransC: TColor;
R: HRGN;
begin
Result := 0;
with Bitmap do begin
TransC := Canvas.Pixels[0, 0];
for Y := 0 to Height - 1 do begin
X := 0;
while X < Width do begin
while (X < Width) and (Canvas.Pixels[X, Y] = TransC) do Inc(X);
if X >= Width then Break;
XStart := X;
while (X < Width) and (Canvas.Pixels[X, Y] <> TransC) do Inc(X);
R := CreateRectRgn(XStart, Y, X, Y + 1);
if Result = 0 then Result := R
else begin
CombineRgn(Result, Result, R, RGN_OR);
DeleteObject(R);
end;
end;
end;
end;
end;
function CopyToBitmap;
var x, y: integer;
begin
Result := False;
if Control = nil then exit;
x := BitMap.Width - 2;
y := BitMap.Height - 2;
if (Anyway) or
(x + 2 <> Control.Width) or
(y + 2 <> Control.Height) or
(BitMap.Canvas.Pixels[x, y] = $FFFFFF) or
(BitMap.Canvas.Pixels[x, y] = $000000) then begin
BitMap.Width := Control.Width;
BitMap.Height := Control.Height;
CopyParentImage(Control, BitMap.Canvas);
Result := True;
end;
end;
type
TParentControl = class(TWinControl);
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
I, Count, X, Y, SaveIndex: Integer;
DC: HDC;
R, SelfR, CtlR: TRect;
begin
if (Control = nil) or (Control.Parent = nil) then Exit;
Count := Control.Parent.ControlCount;
DC := Dest.Handle;
with Control.Parent do ControlState := ControlState + [csPaintCopy];
try
with Control do begin
SelfR := Bounds(Left, Top, Width, Height);
X := -Left; Y := -Top;
end;
{ Copy parent control image }
SaveIndex := SaveDC(DC);
try
if TParentControl(Control.Parent).Perform(
WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
SetViewportOrgEx(DC, X, Y, nil);
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
Control.Parent.ClientHeight);
with TParentControl(Control.Parent) do begin
Perform(WM_ERASEBKGND, DC, 0);
PaintWindow(DC);
end;
end;
finally
RestoreDC(DC, SaveIndex);
end;
{ Copy images of graphic controls }
for I := 0 to Count - 1 do begin
if Control.Parent.Controls[I] = Control then continue
else if (Control.Parent.Controls[I] <> nil) and
(Control.Parent.Controls[I] is TGraphicControl) then
begin
with TGraphicControl(Control.Parent.Controls[I]) do begin
CtlR := Bounds(Left, Top, Width, Height);
if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
ControlState := ControlState + [csPaintCopy];
SaveIndex := SaveDC(DC);
try
if Perform(
WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
{ SaveIndex := SaveDC(DC);}
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
IntersectClipRect(DC, 0, 0, Width, Height);
Perform(WM_PAINT, DC, 0);
end;
finally
RestoreDC(DC, SaveIndex);
ControlState := ControlState - [csPaintCopy];
end;
end;
end;
end;
end;
finally
with Control.Parent do ControlState := ControlState - [csPaintCopy];
end;
end;
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
dwROP: dword); overload;
begin
RestoreImage(DestDC, SrcBitmap, r.Left, r.Top,
r.Right - r.Left, r.Bottom - r.Top, dwROP);
end;
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
dwROP: dword); overload;
var x, y: integer;
begin
x := l + w div 2;
y := t + h div 2;
if (SrcBitmap.Canvas.Pixels[x, y] <> $FFFFFF) and
(SrcBitMap.Canvas.Pixels[x, y] <> $000000) then begin
x := l;
y := t;
if y + h > SrcBitMap.Height then begin
y := SrcBitMap.Height - h;
end;
bitblt(DestDC, l, t, w, h,
SrcBitMap.Canvas.Handle, x, y, dwROP);
end;
end;
procedure SplitColor(C: TColor; var r, g, b: integer);
begin
b := (c and $FF0000) shr 16;
g := (c and $00FF00) shr 08;
r := (c and $0000FF) shr 00;
end;
procedure AjustBitmap;
var i, j: integer;
t: TBitmap;
r,
g,
b,
r2,
g2,
b2: integer;
p: PRGBTriple;
function CalcColor(c1, c2, c3: integer): integer;
begin
if c1 = c3 then begin
Result := c2;
exit;
end;
if c1 = 0 then begin
Result := 0;
exit;
end;
{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
exit;}
Result := c1 * c2 div c3;
if c2 = 0 then Result := c1 * 150 div 255;
if Result > 255 then Result := 255;
if Result < 50 then Result := Result + 50;
{ exit;
a := trunc(x1 * 3);
a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
a := 255 * 255 - 4 * a;
try
x1 := Trunc((255 - sqrt(a)) / 2);
x2 := Trunc((255 + sqrt(a)) / 2);
if x1 > x2 then Result := Trunc(x1)
else Result := Trunc(x2);
except
Result := 0;
end;}
end;
begin
if s = c then exit;
if m.Width = 0 then exit;
if m.Height = 0 then exit;
t := TBitmap.Create;
m.PixelFormat := pf24bit;
t.Assign(m);
SplitColor(ColorToRGB(s), r, g, b);
if r = 0 then r := 1;
if g = 0 then g := 1;
if b = 0 then b := 1;
SplitColor(ColorToRGB(c), r2, g2, b2);
for j := 0 to t.Height - 1 do begin
p := t.scanline[j];
for i := 0 to t.Width - 1 do begin
p.rgbtRed := CalcColor(p.rgbtRed, r2, r);
p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b);
inc(p);
end;
end;
m.Assign(t);
t.Free;
end;
procedure FadeBitmap;
var i, j: integer;
t: TBitmap;
r,
g,
b: integer;
p: PRGBTriple;
function CalcColor(o: byte; c: byte; b: byte): byte;
var d: byte;
begin
Result := c;
if o > c then begin
d := $FF - c;
if d > b then d := b;
Result := c + c * d div 255;
end else
if o < c then begin
d := c;
if d > b then d := b;
Result := c - c * d div 255;
end;
end;
begin
if m.Width = 0 then exit;
if m.Height = 0 then exit;
t := TBitmap.Create;
m.PixelFormat := pf24bit;
t.Assign(m);
SplitColor(ColorToRGB(c), r, g, b);
if r = 0 then r := 1;
if g = 0 then g := 1;
if b = 0 then b := 1;
for j := 0 to t.Height - 1 do begin
p := t.scanline[j];
for i := 0 to t.Width - 1 do begin
p.rgbtRed := CalcColor(p.rgbtRed, r, d);
p.rgbtGreen := CalcColor(p.rgbtGreen, g, d);
p.rgbtBlue := CalcColor(p.rgbtBlue, b, d);
inc(p);
end;
end;
m.Assign(t);
t.Free;
end;
function IncColor;
var T: TColor;
P: PRGBTriple;
begin
T := ColorToRGB(C);
p := @T;
if D > 0 then begin
if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255;
if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255;
if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
end else begin
if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000;
if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000;
if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
end;
Result := T;
end;
end.

258
Addons/UStr.pas
View File

@ -1,258 +0,0 @@
unit UStr;
interface
function space ( n:integer):string ;
function replicate(ch:char; n:integer):string ;
function trim (str:string;c:boolean=false):string ;
function alike (a,b:string;var d, p: integer): boolean;
function center (str:string;n:integer):string ;
function UpSt ( s:string ):string;
function LoSt ( s:string ):string;
function lpad ( s:string;n:integer;c:char):string;
function rpad ( s:string;n:integer;c:char):string;
function addbackslash(p : string) : string;
function match (sm : string; var st: string) : boolean;
function lines (p, l, s : longint) : string;
function LoCase (c : char) : char;
function JustPathName(PathName : string) : string;
function JustFileName(PathName : string) : string;
function JustName (PathName : string) : string;
function CRC16 (s : string) : system.word;
implementation
function space;
var i : integer;
tempstr : string;
begin
tempstr:='';
for i:=1 to n do tempstr:=tempstr+' ';
space:=tempstr;
end;
function replicate;
var i : integer;
tempstr : string;
begin
tempstr:='';
for i:=1 to n do tempstr:=tempstr+ch;
replicate:=tempstr;
end;
function trim;
var i,j : integer;
s : string;
begin
trim := '';
s := str;
if length(str) > 1 then begin
i := length(str);
j := 1;
while (j <= i) and (str[j] = ' ') do inc(j);
if j > i then begin
result := '';
exit;
end;
while (str[i] = ' ') do dec(i);
s := copy(str, j, i - j + 1);
end;
if c and (length(s) > 3) then begin
repeat
i := pos(' ', s);
if i > 0 then begin
s := copy(s, 1, i - 1) + copy(s, i + 1, length(s) - i);
end;
until i = 0;
end;
if c then result := LoSt(s)
else result := s;
end;
function alike;
var e, f: integer;
begin
result := false;
p := 0;
e := length(a);
f := length(b);
if e + f = 0 then begin
result := true;
d := 100;
exit;
end;
if (e = 0) or (f = 0) then begin
d := 0;
exit;
end;
while (p < e) and (p < f) do begin
inc(p);
if a[p] <> b[p] then begin
dec(p);
break;
end;
end;
d := 200 * p div (e + f);
if p * 2 > (e + f) div 2 then begin
result := true;
end;
end;
function center;
var tempstr : string;
j : integer;
begin
j := n - length(trim(str));
if j > 0 then tempstr := space(j - j div 2) + trim(str) + space(j div 2)
else tempstr := trim(str);
center := tempstr;
end;
function UpSt;
var t : string;
i : integer;
begin
t := s;
for i := 1 to length(s) do t[i] := UpCase(s[i]);
UpSt := t;
end;
function LoSt;
var t : string;
i : integer;
begin
t := s;
for i := 1 to length(s) do t[i] := LoCase(s[i]);
LoSt := t;
end;
function lpad;
begin
lpad := replicate(c, n - length(s)) + s;
end;
function rpad;
begin
rpad := s + replicate(c, n - length(s));
end;
function addbackslash;
begin
if length(p) > 0 then
if p[length(p)] = '\' then addbackslash := p
else addbackslash := p + '\'
else addbackslash := p;
end;
function match(sm : string; var st: string) : boolean;
var p : integer;
_sm,
_st : string;
begin
match := false;
if (length(sm) > 0) and (length(st) > 0) then begin
_sm := UpSt(sm);
_st := UpSt(st);
while pos(_sm, _st) > 0 do begin
match := true;
p := pos(_sm, _st);
_st := copy(_st, 1, p - 1) + copy(_st, p + length(_sm), 250);
st := copy( st, 1, p - 1) + copy( st, p + length( sm), 250);
end;
end;
end;
function lines;
var o : string;
i : longint;
n : longint;
begin
if l > 0 then begin
i := p * s div l;
n := p * s * 2 div l;
o := replicate('�', i);
if n > i * 2 then o := o + '�';
lines := o + space(s - length(o));
end else lines := '';
end;
function LoCase;
var t : char;
begin
if (c >= 'A') and (c <= 'Z') then t := chr(ord(c) + 32)
else t := c;
LoCase := t;
end;
function JustPathname(PathName : string) : string;
{-Return just the drive:directory portion of a pathname}
var
I : Word;
begin
I := Succ(Word(Length(PathName)));
repeat
Dec(I);
until (PathName[I] in ['\',':',#0]) or (I = 1);
if I = 1 then
{Had no drive or directory name}
JustPathname := ''
else if I = 1 then
{Either the root directory of default drive or invalid pathname}
JustPathname := PathName[1]
else if (PathName[I] = '\') then begin
if PathName[Pred(I)] = ':' then
{Root directory of a drive, leave trailing backslash}
JustPathname := Copy(PathName, 1, I)
else
{Subdirectory, remove the trailing backslash}
JustPathname := Copy(PathName, 1, Pred(I));
end else
{Either the default directory of a drive or invalid pathname}
JustPathname := Copy(PathName, 1, I);
end;
function JustFilename(PathName : string) : string;
{-Return just the filename of a pathname}
var
I : Word;
begin
I := Succ(Word(Length(PathName)));
repeat
Dec(I);
until (I = 0) or (PathName[I] in ['\', ':', #0]);
JustFilename := Copy(PathName, Succ(I), 64);
end;
function JustName(PathName : string) : string;
{-Return just the name (no extension, no path) of a pathname}
var
DotPos : Byte;
begin
PathName := JustFileName(PathName);
DotPos := Pos('.', PathName);
if DotPos > 0 then
PathName := Copy(PathName, 1, DotPos-1);
JustName := PathName;
end;
function CRC16(s : string) : system.word; { By Kevin Cooney }
var
crc : longint;
t,r : byte;
begin
crc := 0;
for t := 1 to length(s) do
begin
crc := (crc xor (ord(s[t]) shl 8));
for r := 1 to 8 do
if (crc and $8000)>0 then
crc := ((crc shl 1) xor $1021)
else
crc := (crc shl 1);
end;
CRC16 := (crc and $FFFF);
end;
end.

101
Addons/UWrd.pas
View File

@ -1,101 +0,0 @@
unit UWrd;
interface
function words (str:string;d:char ):integer;
function wordn (str:string;d:char;n:integer):string ;
function wordd (str:string;d:char;n:integer):string ;
function wordp (str:string;d:char;n:integer):integer;
function wordi ( wrd,str:string;d:cHar):boolean;
function wordf (str:string;d:char;n:integer):string ;
implementation
function words;
var tempstr : string;
ins : boolean;
i,j : integer;
begin
tempstr := d + str + d;
ins := false;
j := 0;
for i := 1 to length(tempstr) do begin
if ins then
if tempstr[i] =d then ins:=false
else begin end
else
if tempstr[i]<>d then begin
inc(j);ins:=true;
end;
end;
words:=j;
end;
function wordn;
var i,j:integer;
tempstr:string;
begin
i:=words(str, d);
if i<n then begin
wordn:='';
exit;
end;
i:=1;
while words(copy(str,1,i), d)<n do inc(i);
j:=i;
tempstr:=str+d;
while tempstr[j]<>d do inc(j);
wordn:=copy(str,i,j-i);
end;
function wordd;
var i,j:integer;
sss:string;
tempstr:string;
begin
i:=words(str, d);
if i<n then begin
wordd:=str;
exit;
end;
i:=1;
while words(copy(str,1,i), d)<n do inc(i);
j:=i;
tempstr:=str+d;
while tempstr[j]<>d do inc(j);
sss :=copy(str,1,i-1);
wordd:=sss+copy(str,j+1,length(tempstr)-j);
end;
function wordp;
var i:integer;
begin
i:=words(str, d);
if i < n then begin
wordp := 0;
exit;
end;
i:=1;
while words(copy(str,1,i), d)<n do inc(i);
wordp := i;
end;
function wordi;
var i : integer;
begin
wordi := true;
for i := 1 to words(str, d) do
if wrd = wordn(str, d, i) tHen exit;
wordi := false;
end;
function wordf;
var i: integer;
begin
i := wordp(str, d, n);
wordf := '';
if (i > 0) and (i < length(str)) then
wordf := copy(str, i, length(str) - i + 1);
end;
end.

255
Addons/reader.pas
View File

@ -1,255 +0,0 @@
unit reader;
interface
function compare(_ts, _ms : string) : boolean;
procedure setvar ( vn, vv : string);
function getvar ( vn : string) : string;
function parstr : string;
procedure setglo ( vn, vv : string);
function getglo ( vn : string) : string;
function parse ( vn : string; al : boolean) : string;
procedure freeglob;
implementation
uses UStr, Serv, UWrd;
type
trec = record
name : string[12];
valu : string[255];
next : pointer;
end;
var
fvar,
fglo : pointer;
vrec,
vglo,
rrec : ^trec;
v,
z : string;
function compare;
label fail, succ;
var i,
j,
n : integer;
ts,
ms : string;
procedure freelist;
begin
vrec := fvar;
while vrec <> nil do begin
rrec := vrec;
vrec := vrec^.next;
freemem(rrec, sizeof(trec));
end;
fvar := nil;
end;
begin
ts := _ts;
ms := _ms;
i := 1;
j := 1;
compare := true;
freelist;
repeat
if (i > length(ts)) and (j > length(ms)) then goto succ;
if (i > length(ts)) or (j > length(ms)) then goto fail;
if ts[i] = ms[j] then begin
inc(i);
inc(j);
if j > length(ms) then goto succ;
end else
if ts[i] = '?' then begin
inc(i);
inc(j);
end else
if ts[i] = '*' then begin
inc(i);
if i > length(ts) then goto succ;
z := copy(ts, i, 255);
if pos('*', z) > 0 then z := copy(z, 1, pos('*', z) - 1);
if pos('?', z) > 0 then z := copy(z, 1, pos('?', z) - 1);
if pos('%', z) > 0 then z := copy(z, 1, pos('%', z) - 1);
while (j <= length(ms)) and (copy(ms, j, length(z)) <> z) do begin
while (j < length(ms)) and (ms[j] <> ts[i]) do inc(j);
if j > length(ms) then goto fail;
if copy(ms, j, length(z)) <> z then inc(j);
end;
end else
if ts[i] = '%' then begin
inc(i);
n := i;
while (i <= length(ts)) and (ts[i] <> '%') do inc(i);
if i > length(ts) then goto fail;
v := copy(ts, n, i - n);
v := upst(v);
inc(i);
n := j;
if i <= length(ts) then begin
while (j <= length(ms)) and (ms[j] <> ts[i]) do inc(j);
if j > length(ms) then goto fail;
end else begin
j := length(ms) + 1;
end;
z := copy(ms, n, j - n);
if fvar = nil then begin
getmem(fvar, sizeof(trec));
vrec := fvar;
end else begin
getmem(vrec^.next, sizeof(trec));
vrec := vrec^.next;
end;
fillchar(vrec^, sizeof(trec), #0);
vrec^.name := v;
vrec^.valu := z;
if fglo = nil then begin
getmem(fglo, sizeof(trec));
vglo := fglo;
rrec := fglo;
fillchar(vglo^, sizeof(trec), #0);
end else begin
rrec := fglo;
while (rrec <> nil) and (rrec^.name <> v) do begin
vglo := rrec;
rrec := rrec^.next;
end;
if rrec = nil then begin
getmem(vglo^.next, sizeof(trec));
vglo := vglo^.next;
rrec := vglo;
fillchar(vglo^, sizeof(trec), #0);
end;
end;
rrec^.name := v;
rrec^.valu := z;
end else begin
if (i > 1) and (j > i) then
if compare(ts, copy(ms, j, length(ms) - j + 1)) then goto succ
else goto fail
else goto fail;
end;
until false;
fail:
compare := false;
freelist;
exit;
succ:
exit;
end;
procedure setvar;
begin
vglo := fvar;
while vglo <> Nil do begin
if vglo^.name = UpSt(vn) then break;
vglo := vglo^.next;
end;
if vglo = Nil then vglo := NewEList(fvar, sizeof(trec), false);
vglo^.name := UpSt(vn);
vglo^.valu := vv;
end;
function getvar;
var
tv : string;
begin
getvar := '';
vrec := fvar;
tv := vn;
tv := upst(tv);
while vrec <> nil do begin
if vrec^.name = tv then begin
getvar := vrec^.valu;
exit;
end;
vrec := vrec^.next;
end;
end;
procedure setglo;
begin
vglo := fglo;
while vglo <> Nil do begin
if vglo^.name = UpSt(vn) then break;
vglo := vglo^.next;
end;
if vglo = Nil then vglo := NewEList(fglo, sizeof(trec), false);
vglo^.name := UpSt(vn);
vglo^.valu := vv;
end;
function getglo;
var
tv : string;
begin
getglo := '';
vglo := fglo;
tv := vn;
tv := upst(tv);
while vglo <> nil do begin
if vglo^.name = tv then begin
getglo := vglo^.valu;
exit;
end;
vglo := vglo^.next;
end;
end;
procedure freeglob;
begin
vglo := fglo;
while vglo <> nil do begin
rrec := vglo;
vglo := vglo^.next;
freemem(rrec, sizeof(trec));
end;
fglo := nil;
end;
function parstr;
var
tv : string;
begin
tv := '';
vrec := fvar;
while vrec <> nil do begin
tv := tv + ' ' + vrec^.valu;
vrec := vrec^.next;
end;
parstr := tv;
end;
function parse;
var i,
p : integer;
s : string;
rs : string;
begin
s := '';
i := 0;
repeat
inc(i);
rs := wordn(vn, '%', i + 1);
rs := getglo(rs);
s := s + wordn(vn, '%', i);
p := wordp(vn, '%', i + 1);
if p > 0 then begin
if al then s := copy(s, 1, p - 2);
if al then s := s + space(p - 2 - length(s));
end;
s := s + rs;
if rs <> '' then inc(i);
until i > words(vn, '%');
parse := s;
end;
begin
fvar := nil;
fglo := nil;
end.