Groesz.org
/
rsvk
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
rsvk/Component/FSortUnit.pas

654 lines
16 KiB
Plaintext
Raw Permalink Blame History

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.
Reference in New Issue View Git Blame Copy Permalink