How do you implement Levenshtein distance in Delphi? - algorithm

I'm posting this in the spirit of answering your own questions.
The question I had was: How can I implement the Levenshtein algorithm for calculating edit-distance between two strings, as described here, in Delphi?
Just a note on performance:
This thing is very fast. On my desktop (2.33 Ghz dual-core, 2GB ram, WinXP), I can run through an array of 100K strings in less than one second.

function EditDistance(s, t: string): integer;
var
d : array of array of integer;
i,j,cost : integer;
begin
{
Compute the edit-distance between two strings.
Algorithm and description may be found at either of these two links:
http://en.wikipedia.org/wiki/Levenshtein_distance
http://www.google.com/search?q=Levenshtein+distance
}
//initialize our cost array
SetLength(d,Length(s)+1);
for i := Low(d) to High(d) do begin
SetLength(d[i],Length(t)+1);
end;
for i := Low(d) to High(d) do begin
d[i,0] := i;
for j := Low(d[i]) to High(d[i]) do begin
d[0,j] := j;
end;
end;
//store our costs in a 2-d grid
for i := Low(d)+1 to High(d) do begin
for j := Low(d[i])+1 to High(d[i]) do begin
if s[i] = t[j] then begin
cost := 0;
end
else begin
cost := 1;
end;
//to use "Min", add "Math" to your uses clause!
d[i,j] := Min(Min(
d[i-1,j]+1, //deletion
d[i,j-1]+1), //insertion
d[i-1,j-1]+cost //substitution
);
end; //for j
end; //for i
//now that we've stored the costs, return the final one
Result := d[Length(s),Length(t)];
//dynamic arrays are reference counted.
//no need to deallocate them
end;

Related

Insert values ordered from least to greatest in an Array

I need to create an array within a register that is a sequence of natural numbers, these are inserted by the user and cannot be repeated. My problem is sorting the array values as they are inserted in ascending order. I have tried this code without success. Thank you.
const
MAX = 10;
type
Natural = 0..MAXINT;
Secuencia = RECORD
valores : ARRAY [1..MAX] OF Natural;
tope : 0..MAX;
END;
TipoResultado = (Fallo, Creado, Agregado);
Resultado = RECORD
CASE quePaso : TipoResultado OF
Fallo: ();
Creado: ();
Agregado: (posicion: Natural);
END;
//Non-repeating value search function in array
Function BLineal(valor: Natural; sec: Secuencia ): boolean;
var i : integer;
begin
i := 1;
while (i <= sec.tope) and (sec.valores[i] <> valor) do
i := i + 1;
BLineal := i <= sec.tope
end;
Procedure to order values within the arrangement from smallest to largest by insertion.
//Procedure ORDER
Procedure OrdIns (var sec: Secuencia);
var
i,j: integer;
aux: Natural;
begin
for i := 2 to sec.tope do begin
j := i;
while (j >= 2) and ((sec.valores[j]) < (sec.valores[j-1])) do
begin
aux:=sec.valores[j-1];
sec.valores[j-1]:=sec.valores[j];
sec.valores[j]:=aux;
j := j - 1
end
end;
end;
Do the problem in two steps. First, create a binary tree and insert values as entered. Then when no more values are found simply walk the tree and create the array.

Pascal: Updating Recent Scores Array

I have a program that stores the last three recent scores of a game. However, I would like to store only the best scores. Eg. Recent Scores: Tom - 12, Sam - 14, Sue - 16. If i played the game and got a new score of 20, i would like it to store the new score of 20 (with name) and the other two scores of Sam and Sue ...thereby losing Tom. (I'm not worried about order).
Const NoOfRecentScores = 3;
TRecentScore = Record
Name : String;
Score : Integer;
End;
TRecentScores = Array[1..NoOfRecentScores] of TRecentScore;
Var
RecentScores : TRecentScores;
When i play the game, i call a procedure called UpdateRecentScores. Here it is:
Procedure UpdateRecentScores(Var RecentScores : TRecentScores; Score : Integer);
Var
PlayerName : String;
Count,count2 : Integer;
FoundSpace : Boolean;
MinMark,position: Integer;
ScorePresent:boolean = false;
Begin
PlayerName := GetPlayerName;
FoundSpace := False;
Count :=1;
While Not FoundSpace And (Count <= NoOfRecentScores)
Do If RecentScores[Count].Name = ''
Then FoundSpace := True
Else Count := Count + 1;
Here is the part i am struggling with. If no score is previously entered, then i have to accept that the first entered score is going to be the minimum:
If ScorePresent = False then
begin
MinMark:=Score;
ScorePresent:=True;
RecentScores[Count].Name := PlayerName;
RecentScores[Count].Score := Score;
writeln('Minimum Mark is: ',MinMark);
end
...the problem with the above, however, is that if the first score is a very high score, that becomes my minimum score!
Below, i am simply saying that if the Score achieved is greater than the MinMark (i.e. the minimum score) then the score should be stored in the array.
else if Score> MinMark then
begin
For count:= 1 to NoOfRecentScores do
begin
if RecentScores[count].score<Score then
position:=count;
RecentScores[position].Name := PlayerName;
RecentScores[position].Score := Score;
end;
End;
end;
As you can see, i am trying to check what the MinMark is first of all. Then, compare the score that i've just got with the MinMarker to see if it should be stored.
To clarify therefore, I want to save the best 3 scores and not recent scores.
To store n best scores, it is convenient to order them from high to low.
Let us go with an example first. Suppose you have the following four records: Tim - 14, Susan - 7, Don - 5, and Derek - 12. Then the array will look like [('Tim', 14), ('Derek', 12), ('Susan', 7), ('Don', 5)].
Now, what happens when Bert achieves a score of 9? Turns out we just want to insert a pair in a sorted array, so that it becomes [('Tim', 14), ('Derek', 12), ('Bert', 9), ('Susan', 7), ('Don', 5)]. After that, we drop the last element.
If we have to modify the array in place, we find the position pos where to insert Bert (it is position 3), then move everything in positions pos..(n-1) into positions (pos+1)..n, and after that, write Ben and his score to position pos.
Since you're using such a small array (3 records), it's relatively simple. (If your array was considerably larger, you'd want to keep it sorted and use a faster means of locating the right position for it, but your array is extremely small.)
Let's say you now have three RecentScore records, containing Tim - 14, Susan - 7, Derek - 12.
You need to find out if there's a score lower than the one the user just attained by Gemma (9) which is in the CurrentScore record (type TRecentScore), and if so replace it with Gemma's name and score.
Here's a working console project (compiled and run in XE5):
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
TRecentScore = record
Name: string;
Score: Integer;
end;
TRecentScores = array of TRecentScore;
// Function to find lower score than the one we're trying to add.
// Returns the index of the next lower item if there is one, or
// -1 if there isn't one.
function FindLowerScore(Scores: TRecentScores; CheckScore: Integer): Integer;
var
i: Integer;
MinScore: Integer; // Lowest score found
begin
Result := -1; // No index found
MinScore := CheckScore; // Lowest score so far
for i := Low(Scores) to High(Scores) do
if Scores[i].Score < MinScore then // Lower than CheckScore?
begin
MinScore := Scores[i].Score; // Yep. Store it (new lowest)
Result := i; // and where it was found
end;
end;
// Utility procedure to display list of scores
procedure PrintScores(const Prelude: string; Scores: TRecentScores);
var
Score: TRecentScore;
begin
WriteLn(Prelude);
for Score in Scores do
Writeln(' ' + Score.Name + ' = ' + IntToStr(Score.Score));
end;
var
RecentScores: TRecentScores;
CurrentScore: TRecentScore;
i: Integer;
begin
SetLength(RecentScores, 3);
RecentScores[0].Name := 'Tim';
RecentScores[0].Score := 14;
RecentScores[1].Name := 'Susan';
RecentScores[1].Score := 7;
RecentScores[2].Name := 'Derek';
RecentScores[2].Score := 12;
// Show scores where we begin
PrintScores('Before', RecentScores);
CurrentScore.Name := 'Gemma'; CurrentScore.Score := 9;
// Check for lower score than Gemma's
i := FindLowerScore(RecentScores, CurrentScore.Score);
if i = -1 then
WriteLn('No lower score found!')
else
begin
// We have a lower score in the array. Update that one
// with our new score.
RecentScores[i].Name := CurrentScore.Name;
RecentScores[i].Score := CurrentScore.Score;
PrintScores('After', RecentScores);
end;
ReadLn;
end.
Here is what i used, following your advice...
Procedure UpdateRecentScores(Var RecentScores : TRecentScores; Score : Integer);
Var
PlayerName : String;
Count : Integer;
FoundSpace : Boolean;
Begin
PlayerName := GetPlayerName;
FoundSpace := False;
Count := 1;
While Not FoundSpace And (Count <= NoOfRecentScores)
Do If RecentScores[Count].Name = ''
Then
begin
FoundSpace := True;
RecentScores[Count].Name := PlayerName;
RecentScores[Count].Score := Score;
end
Else Count := Count + 1;
If Not FoundSpace
Then
Begin
SortRecentScores(RecentScores); // sort them into order of score
if score > RecentScores[NoOfRecentScores].Score then
begin
RecentScores[NoOfRecentScores].Name:= PlayerName;
RecentScores[NoOfRecentScores].Score:= Score;
end;
End;
End;

How many times does one number divide into another, and how much is left over?

I need an algorithm in Delphi to generate partitions for a specified integer value.
Example: for 13 if 5 is specified as the max value for partition it will give 5,5,3; if 4 is specified as max partition value the result should be 4,4,4,1, and so on.
It's simple enough to solve the problem using div and mod. Here's an example program that I don't think needs any further explanation:
program IntegerPartitions;
{$APPTYPE CONSOLE}
function Partitions(const Total, Part: Integer): TArray<Integer>;
var
Count: Integer;
Rem: Integer;
i: Integer;
begin
Assert(Total>0);
Assert(Part>0);
Count := Total div Part;
Rem := Total mod Part;
if Rem=0 then
SetLength(Result, Count)
else
SetLength(Result, Count+1);
for i := 0 to Count-1 do
Result[i] := Part;
if Rem<>0 then
Result[Count] := Rem;
end;
var
Value: Integer;
begin
for Value in Partitions(13, 5) do
Writeln(Value);
Readln;
end.

delphi mergesort for string arrays [closed]

It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 10 years ago.
Found this coded mergesort on http://www.explainth.at/en/delphi/dsort.shtml (site down but try wayback machine or this site: http://read.pudn.com/downloads192/sourcecode/delphi_control/901147/Sorts.pas__.htm) but essentially the array defined was not for an array of string.
type TSortArray = array[0..8191] of Double;
I want to pass an array of string that would possibly eliminate duplicates (this would be Union?) and preserve original order if possible for later resorting it back to original index position minus the duplicates of course (original index) so array can be passed back for further processing. I am using very large files of strings with millions of strings (14 to 30 million) so TStringList is not an option. Best option for these large files is to use arrays of string or arrays of records (or maybe single linked list??) and sort with stable algorithm made for large amount of data.
How can I change this to take array of string?
How can it be further modified to delete or at least mark duplicates?
Is it possible to store original index number to place back strings in original position?
Are arrays of string or arrays of record better for large number of strings as compared to a single linked list?
Questions are listed in order of importance so if you answer question number 1 only that is fine. Thank you in advance for all your input.
procedure MergeSort(var Vals:TSortArray;ACount:Integer);
var AVals:TSortArray;
procedure Merge(ALo,AMid,AHi:Integer);
var i,j,k,m:Integer;
begin
i:=0;
for j:=ALo to AMid do
begin
AVals[i]:=Vals[j];
inc(i);
//copy lower half or Vals into temporary array AVals
end;
i:=0;j:=AMid + 1;k:=ALo;//j could be undefined after the for loop!
while ((k < j) and (j <= AHi)) do
if (AVals[i] < Vals[j]) then
begin
Vals[k]:=AVals[i];
inc(i);inc(k);
end else
begin
Vals[k]:=Vals[j];
inc(k);inc(j);
end;
{locate next greatest value in Vals or AVals and copy it to the
right position.}
for m:=k to j - 1 do
begin
Vals[m]:=AVals[i];
inc(i);
end;
//copy back any remaining, unsorted, elements
end;
procedure PerformMergeSort(ALo,AHi:Integer);
var AMid:Integer;
begin
if (ALo < AHi) then
begin
AMid:=(ALo + AHi) shr 1;
PerformMergeSort(ALo,AMid);
PerformMergeSort(AMid + 1,AHi);
Merge(ALo,AMid,AHi); <==== passing the array as string causes AV breakdown here
end;
end;
begin
SetLength(AVals, ACount);
PerformMergeSort(0,ACount - 1);
end;
Answer to the second question: Mergesort modification with duplicate deleting. Should work for strings.
//returns new valid length
function MergeSortRemoveDuplicates(var Vals: array of Integer):Integer;
var
AVals: array of Integer;
//returns index of the last valid element
function Merge(I0, I1, J0, J1: Integer):Integer;
var
i, j, k, LC:Integer;
begin
LC := I1 - I0;
for i := 0 to LC do
AVals[i]:=Vals[i + I0];
//copy lower half or Vals into temporary array AVals
k := I0;
i := 0;
j := J0;
while ((i <= LC) and (j <= J1)) do
if (AVals[i] < Vals[j]) then begin
Vals[k] := AVals[i];
inc(i);
inc(k);
end else if (AVals[i] > Vals[j]) then begin
Vals[k]:=Vals[j];
inc(k);
inc(j);
end else begin //duplicate
Vals[k] := AVals[i];
inc(i);
inc(j);
inc(k);
end;
//copy the rest
while i <= LC do begin
Vals[k] := AVals[i];
inc(i);
inc(k);
end;
if k <> j then
while j <= J1 do begin
Vals[k]:=Vals[j];
inc(k);
inc(j);
end;
Result := k - 1;
end;
//returns index of the last valid element
function PerformMergeSort(ALo, AHi:Integer): Integer; //returns
var
AMid, I1, J1:Integer;
begin
//It would be wise to use Insertion Sort when (AHi - ALo) is small (about 32-100)
if (ALo < AHi) then
begin
AMid:=(ALo + AHi) shr 1;
I1 := PerformMergeSort(ALo, AMid);
J1 := PerformMergeSort(AMid + 1, AHi);
Result := Merge(ALo, I1, AMid + 1, J1);
end else
Result := ALo;
end;
begin
SetLength(AVals, Length(Vals) div 2 + 1);
Result := 1 + PerformMergeSort(0, High(Vals));
end;
//short test
var
A: array of Integer;
i, NewLen: Integer;
begin
Randomize;
SetLength(A, 12);
for i := 0 to High(A) do
A[i] := Random(10);
NewLen := MergeSortRemoveDuplicates(A);
SetLength(A, NewLen);
for i := 0 to High(A) do
Memo1.Lines.Add(IntToStr(A[i]))
end;
Simple modification for strings:
function MergeSortRemoveDuplicates(var Vals: array of String):Integer;
var
AVals: array of String;
and test case:
var
List: TStringList;
Arr: array of string;
i, n: Integer;
begin
with TStringList.Create do try
LoadFromFile('F:\m2.txt'); //contains some equal strings
SetLength(Arr, Count);
for i := 0 to Count - 1 do
Arr[i] := Strings[i];
finally
Free
end;
n := MergeSortRemoveDuplicates(Arr);
for i := 0 to n - 1 do
Memo1.Lines.Add(Arr[i]);
end;
You'd need to modify the declaration TSortArray from array of double to array of string (or array of MyRecord)
The comparison routines in the Merge nested proc needs to be made compatible for strings. Check for anywhere that determines whether AVal[x] < / > AVal[y]. Delphi has procedures for this (AnsiCompareText / AnsiCompareStr depending on whether you want case-sensitivity)
That should work, but if you hadn't done this in your earlier attempts then Delphi should have complained about type mismatches rather than giving an AV, so there may be something else going on
I think duplicate checking should be done post-sort - it only requires one scan through of the data
If you want to store original index data then you will probably need to use an array of record (data: string; OriginalIndex: integer). Code in the Merge procedure then needs to be modified to pass Vals[x].Data to comparison routines. Filling the OriginalIndex values will be a quick scan before calling the Merge procedure
Not 100% sure, to be honest - it's easier to move large contiguous chunks of data with linked lists than with arrays, and arrays don't need messing about with pointers. If your dataset is sufficiently large you may even need to resort to streaming to disk which is likely to drive your choice more than either of those points.

How to convert a tree recursive function ( or algorithm ) to a loop one?

I have written a recursive Tree Function in pascal ( or delphi ) but i had an 'Out of Memory' message when I ran it.
I need to turn the Calculate recursive function in this code to non-recursive function, can you tell me how please :
program testing(input, output);
type
ptr = ^tr;
tr = record
age: byte;
left, right: ptr;
end;
var
topper: ptr;
total, day: longint;
procedure mycreate(var t: ptr);
var
temp:ptr;
begin
new(temp);
temp^.age := 1;
temp^.left := nil;
temp^.right := nil;
t := temp;
end;
procedure gooneday(var t: ptr);
begin
if t^.age <> 5 then
begin
if t^.age = 2 then
mycreate(t^.left)
else if t^.age = 3 then
mycreate(t^.right);
t^.age := t^.age + 1;
total := total + 1;
end;
end;
procedure calculate(var crnt: ptr);
begin
if crnt <> nil then
begin
gooneday(crnt);
calculate(crnt^.left);
calculate(crnt^.right);
end;
end;
begin
total := 0;
mycreate(topper);
day := 0;
while total < 1000000000000 do
begin
total := 0;
day := day + 1;
calculate(topper);
end;
writeln(day);
writeln(total);
end.
Recursive functions use a stack to keep the state of the recursion.
When converting to a loop, you must actually create an explicit stack. You must push and pop elements off the stack within the loop.

Resources