The following code for implementing AVL-tree insertion & deletion gives error #202 (stack overflow).
Source code looks like this:
program Avl_generator; uses Crt;
type p_Avl = ^Avl_node;
Avl_node = record
key: integer;
l, r, par: p_Avl; {pointers to left child, right child, parent}
bal, h: integer {balance factor, height}
end;
procedure init(var root: p_Avl); begin new(root); root:=nil end;
function get_height(var n: p_Avl): integer;
begin
if(n=nil) then get_height:=-1 else get_height:=n^.h;
end;
procedure reheight(var n: p_Avl); {refresh the height variable}
begin
if(n<>nil) then
begin
if(get_height(n^.r)>get_height(n^.l)) then n^.h:=1+get_height(n^.r)
else n^.h:=1+get_height(n^.l);
end;
end;
procedure set_balance(var n: p_Avl); begin reheight(n); n^.bal:=get_height(n^.r)-get_height(n^.l); end; {refresh the balance factor}
function rotate_l(var a: p_Avl): p_Avl; {left rotation, a is pivot}
var b: p_Avl;
begin
b := a^.r;
b^.par := a^.par;
a^.r := b^.l;
if(a^.r<>nil) then a^.r^.par := a;
b^.l := a;
a^.par := b;
if(b^.par<>nil) then
if(b^.par^.r=a) then b^.par^.r := b
else b^.par^.l := b;
set_balance(a); set_balance(b);
rotate_l := b;
end;
function rotate_r(var a: p_Avl): p_Avl; {right rotation, a is pivot}
var b: p_Avl;
begin
b := a^.l;
b^.par := a^.par;
a^.l := b^.r;
if(a^.l<>nil) then a^.l^.par := a;
b^.r := a;
a^.par := b;
if(b^.par<>nil) then
if(b^.par^.r=a) then b^.par^.r := b
else b^.par^.l := b;
set_balance(a); set_balance(b);
rotate_r := b;
end;
function rotate_l_r(var a: p_Avl): p_Avl; {left & right rotation, a is pivot}
begin
a^.l := rotate_l(a^.l);
rotate_l_r := rotate_r(a);
end;
function rotate_r_l(var a: p_Avl): p_Avl; {right & left rotation, a is pivot}
begin
a^.r := rotate_r(a^.r);
rotate_r_l := rotate_l(a);
end;
procedure rebalance(var root: p_Avl; var n: p_Avl); {refresh balance factors and see if sub-trees need rotating}
begin
set_balance(n);
if(n^.bal=-2) then
begin
if(get_height(n^.l^.l)>=get_height(n^.l^.r)) then n:=rotate_r(n)
else n:=rotate_l_r(n);
end
else if(n^.bal=2) then
begin
if(get_height(n^.r^.r)>=get_height(n^.r^.l)) then n:=rotate_l(n)
else n:=rotate_r_l(n);
end;
if(n^.par<>nil) then rebalance(root, n^.par) else root:=n; {recursion here}
end;
procedure insert(var root: p_Avl; what: integer);
var found: boolean;
pre_tmp, tmp: p_Avl;
begin
found:=false; tmp:=root; pre_tmp:= nil;
while(tmp<>nil) and not found do
if(tmp^.key=what) then found:=true
else if(tmp^.key>what) then begin pre_tmp:=tmp; tmp:=tmp^.l end
else begin pre_tmp:=tmp; tmp:=tmp^.r end;
if not found then
begin
new(tmp); tmp^.key:=what;
tmp^.l:=nil; tmp^.r:=nil; tmp^.par:=pre_tmp; tmp^.h:=0; tmp^.bal:=0;
if(pre_tmp=nil) then root:=tmp
else
begin
if(pre_tmp^.key>what) then pre_tmp^.l:=tmp else pre_tmp^.r:=tmp;
rebalance(root, pre_tmp);
end;
end;
end;
procedure delete(var root: p_Avl; what: integer);
var found: boolean;
tmp, pre_tmp, act, pre_act: p_Avl;
begin
found:=false; tmp:=root; pre_tmp:=nil;
while(tmp<>nil) and not found do
begin
if(tmp^.key=what) then found:=true
else if(tmp^.key>what) then
begin pre_tmp:=tmp; tmp:=tmp^.l end
else
begin pre_tmp:=tmp; tmp:=tmp^.r end;
if found then
if(tmp^.l=nil) then
begin
if(pre_tmp=nil) then root:=tmp^.r
else if(pre_tmp^.key>what) then pre_tmp^.l:=tmp^.r
else pre_tmp^.r:=tmp^.r;
dispose(tmp); rebalance(root,pre_tmp);
end else if(tmp^.r=nil) then
begin
if(pre_tmp=nil) then root:=tmp^.l
else if(pre_tmp^.key>what) then pre_tmp^.l:=tmp^.l
else begin pre_tmp^.r:=tmp^.l end;
dispose(tmp); rebalance(root,pre_tmp);
end else
begin
act:=tmp^.l; pre_act:=nil;
while(act^.r<>nil) do begin pre_act:=act; act:=act^.r end;
tmp^.key:=act^.key;
if(pre_act=nil) then begin tmp^.l:=act^.l; dispose(act); rebalance(root,tmp) end
else begin pre_act^.r:=act^.l; dispose(act); rebalance(root,pre_act) end;
end;
end;
end;
var Avl_tree: p_Avl;
begin
init(Avl_tree);
insert(Avl_tree,1);
insert(Avl_tree,2);
insert(Avl_tree,3);
insert(Avl_tree,4);
insert(Avl_tree,5);
writeln(get_path(Avl_tree, 5));
repeat until KeyPressed;
end.
This compiles fine (Turbo Pascal 7.0). When I run the code, though, the error occurs in the rotate_l procedure which is called after the third insertion (whereupon balance factor of the root node =2.
I checked some Java & C++ implementations and the rotation methods there seemed quite similar to mine, therefore I don't know where the problem is..?
Ok, it's been 14 years since I touched Pascal last time :)
So the problem is indeed with rotate_l function.
You are passing a parameter by-reference as indicated by var keyword.
rotate_l(var a: p_Avl)
That causes a to become nil when you overwrite b.par,
Because a references the address of b.par in that particular function invocation and you set b.par to nil.
So a now is referencing memory location that contains nil.
You need to change function signature to pass a parameter by value. This is done by removing var keyword.
rotate_l(a: p_Avl)
Stack overflow is caused by the same issue in rebalance procedure:
Change
procedure rebalance(var root: p_Avl; var n: p_Avl);
to
procedure rebalance(var root: p_Avl; n: p_Avl);
See Free Pascal language reference for parameters
http://wiki.lazarus.freepascal.org/Parameters
I have e-mail subject lines and I want to find ticket references in them it could be the TT ref is like 12345678. One subject line (string) can have multiple 8 digit numbers!
I have been using the below code but it is merely stripping out the first 8 digits then doing a check if that is 8 char long:
function StripNumbers(const aString: string): string;
var
C: char;
begin
Result := '';
for C in aString do
begin
if CharInSet(C, ['0'..'9']) then
begin
Result := Result + C;
end;
end;
end;
Example:
my string variable is
subject := "yada yada XF12345678 blabla XF87654321 duh XF11.223344"
function GetTTRefs(subject) should result "12345678;87654321;"
Thank you for answers.
function GotTTRefs(Subject:string;Digits:Byte):string;
var
i:integer;
TT:string;
begin
i:=1;
while i <= Length(Subject)-Digits+1 do
begin
if Subject[i] in ['1'..'9'] then
begin
TT:=Copy(Subject,i,Digits);
if (StrToQWordDef(TT, 0) <> 0) then
Result:=Result+TT+';';
end;
inc(i);
end;
end;
I am having problems with adding text I have entered into a tedit, into an record.
Here is the code i currently have:
procedure TForm7.AddNewQuestionClick(Sender: TObject);
var
w: integer;
QuestDesc, QuestAnsr: string;
begin
NewQuestID.text:=(GetNextQuestionID); //Increments QuestionID part of record
w:=Length(TQuestions);
SetLength(TQuestions, w+1);
QuestDesc:= NewQuestDesc.text;
QuestAnsr:= NewQuestAns.text;
TQuestionArray[w+1].Question:= QuestDesc; // Error on this line (No default property available)
TQuestionArray[w+1].Answer:= QuestAnsr;
end;
Here is the record I am trying to add to:
TQuestion = record
public
QuestionID: integer;
Question: shortstring;
Answer: shortstring;
procedure InitQuestion(anID:integer; aQ, anA:shortstring);
end;
TQuestionArray = array of TQuestion;
Any help solving this problem would be greatly appreciated.
You're missing a few things. You've declared a procedure to help initialize a new question - you should be using it.
This should get you going:
type
TQuestion = record
QuestionID: integer;
Question: ShortString;
Answer: ShortString;
procedure InitQuestion(anID: Integer; aQ, aAns: ShortString);
end;
TQuestionArray = array of TQuestion;
var
Form3: TForm3;
var
Questions: TQuestionArray;
procedure TForm7.AddNewQuestionClick(Sender: TObject);
begin
SetLength(Questions, Length(Questions) + 1);
Questions[High(Questions)].InitQuestion(GetNextQuestionID,
NewQuestDesc.Text,
NewQuestAns.Text);
end;
If you really want to do it individually setting the fields:
procedure TForm7.AddNewQuestionClick(Sender: TObject);
var
Idx: Integer;
begin
SetLength(Questions, Length(Questions) + 1);
Idx := High(Questions);
Questions[Idx].QuestionID := GetNextQuestionID;
Questions[Idx].Question := NewQuestDesc.Text;
Questions[Idx].Answer := NewQuestAns.Text;
end;
I want to convert a String to a byte array, the code looks like the following:
procedure StringToByteArray(const s : String; var tmp: array of Byte);
var
i : integer;
begin
For i:=1 to Length(s) do
begin
tmp[i-1] := Ord(s[i]);
end;
end;
s[i] here is the i'th String element (= char at pos i) and I'm saving its numerical value to tmp.
This works for some characters, but not for all, for example:
Ord('•') returns Dec(149), which is what I expect.
But in my procedure Ord(s[i]) returns Dec(8226) for the same character!
Edit1: I think the defect lies in my other function "ByteArrayToStr"
When converting ...
tmp:= 149 // tmp is of type byte
Log('experiment: ' + Chr(tmp)); // prints "•"
Log('experiment2 ' + IntToStr(Ord(Chr(tmp)))); // prints 149
... back and forth, this seems to work.
But using the same conversion in the following function won't do it:
function ByteArrayToStr( a : array of Byte ) : String;
var
S:String;
I:integer;
begin
S:='';
For I:=0 to Length(a) -1 do
begin
tmp := Chr(a[I]) ; // for a[I] equals 149 this will get me "?" instead of "•"
S:=S+tmp;
end;
Result:=S;
end;
To make it clear: ByteArrayToStr does not convert Ord(149) to "•" as expected, and therefore StringToByteArray won't work later on
You need to turn your parameters into AnsiString type. By doing so, you can write functions like this:
[Setup]
AppName=My Program
AppVersion=1.5
DefaultDirName={pf}\My Program
OutputDir=userdocs:Inno Setup Examples Output
[Code]
procedure StringToByteArray(const S: AnsiString; out ByteArray: array of Byte);
var
I: Integer;
begin
SetArrayLength(ByteArray, Length(S));
for I := 1 to Length(S) do
ByteArray[I - 1] := Ord(S[I]);
end;
function ByteArrayToString(const ByteArray: array of Byte): AnsiString;
var
I: Integer;
begin
SetLength(Result, GetArrayLength(ByteArray));
for I := 1 to GetArrayLength(ByteArray) do
Result[I] := Chr(ByteArray[I - 1]);
end;
procedure InitializeWizard;
var
S: AnsiString;
ByteArray: array of Byte;
begin
S := '•';
StringToByteArray(S, ByteArray);
MsgBox(IntToStr(ByteArray[0]), mbInformation, MB_OK);
S := '';
S := ByteArrayToString(ByteArray);
MsgBox(S, mbInformation, MB_OK);
end;
I have two stringlists that I wish to synchronize, so that equal lines get the same index, while different lines will be kept in the list where they originally were, and the other stringlist should get a "filler" for that index. Consider this example:
SL1: 1,1,2,3,5,8
SL2: 1,3,5,7,9
procedure SyncStringlists(aSL1,aSL2 : TStringList; aFill : string = '-');
The procedure should change the lists to this
SL1: 1,1,2,3,5,8,-,-
SL2: 1,-,-,3,5,-,7,9
or, if the lists are sorted, to this
SL1: 1,1,2,3,5,-,8,-
SL2: 1,-,-,3,5,7,',9
How should I go about doing this?
Try this for the case where your lists are monotone increasing.
procedure SyncStringlists(SL1, SL2: TStringList; const Fill: string='-');
var
i1, i2: Integer;
begin
i1 := 0;
i2 := 0;
while (i1<SL1.Count) and (i2<SL2.Count) do begin
if SL1[i1]<SL2[i2] then begin
SL2.Insert(i2, Fill);
end else if SL1[i1]>SL2[i2] then begin
SL1.Insert(i1, Fill);
end;
inc(i1);
inc(i2);
end;
while SL1.Count<SL2.Count do begin
SL1.Add(Fill);
end;
while SL2.Count<SL1.Count do begin
SL2.Add(Fill);
end;
end;
I actually managed to make a method that suits my need:
procedure SyncStringlists(aSL1,aSL2 : TStringList; aFill : string = '-');
var
I,J : integer;
begin
I := 0;
J := 0;
aSL1.Sort;
aSL2.Sort;
while (I<aSL1.Count) and (J<aSL2.Count) do
begin
if aSL1[I] > aSL2[J] then
aSL1.Insert(I,aFill)
else if aSL1[I] < aSL2[J] then
aSL2.Insert(J,aFill);
inc(I);
inc(J);
end;
while aSL1.Count < aSL2.Count do aSL1.Add(aFill);
while aSL2.Count < aSL1.Count do aSL2.Add(aFill);
end;
It requires the lists to be sorted, but NOT to have the sorted property true (because then we can't insert into it)
Sample run:
SL1: 1,1,2,3,5,8,a,b,c,d,e,f
SL2: 1,3,5,7,9,e,f,g,h,i
synced:
SL1: 1,1,2,3,5,-,8,-,a,b,c,d,e,f,-,-,-
SL2: 1,-,-,3,5,7,-,9,-,-,-,-,e,f,g,h,i
I hope some kind of this (Levenshtein distance) algorithm can help you.