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.
Related
I'm trying to sort a string grid filled with scores and strings like so:
via a sorted string list which is sorted by single columns from the grid called SUB 1, SUB 2, FINAL, TOTAL respectively (all these columns work except FINAL) and I'm not getting the results I need in the FINAL column.
I'm trying to get the column sorted like so, for example :
24
20
12
5
DNF
EXE
WE
but I'm getting this result instead (the result I do not want):
DNF
EXE
WE
24
20
12
5
In what way could I change my code to sort the grid as I want to sort it?
My code:
function Compare2(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
begin
//comparer for custom sort used in SortLTSGrid
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] < List[Index2] then
Result := 1
else
Result := -1;
end;
procedure TfrmPuntehou.SortLTSGrid(var grid: TStringGrid; columntotal: Integer);
var
TheList : TStringList;
i,l,iCount,m:integer;
const
separator = ',';
const
arrCodes:array[1..10] of string = ('DNF','DNS','WD','WE','DNA','OD','RD','EXR','EXE','PP');
begin
//sorts grid largest to smallest according to one column
//get grid row amount
iCount:=grid.RowCount - 1;
//create and fill the string list
TheList := TStringList.Create;
//fill the list
for i := 1 to (iCount) do
begin
for l := 1 to Length(arrCodes) do
begin
if grid.Rows[i].Strings[columntotal] = arrCodes[l] then
begin
TheList.Add('0'+separator+grid.Rows[i].Text);
end;
end;
TheList.Add(grid.Rows[i].Strings[columntotal]+separator+grid.Rows[i].Text);
end;
//try block to sort and write all strings in the list to the grid correctly
try
TheList.CustomSort(Compare2);
for i:= 1 to (iCount) do
begin
grid.Rows[i].Text := TheList.Strings[(i-1)] ;
end;
//fill the row numbers
for m := 1 to iCount do
begin
grid.Cells[0,m]:= IntToStr(m);
end;
finally
TheList.Free;
end;
end;
You can use two different lists to store items, and two different sorting functions (because you want to sort them in different direction; numbers will be ordered as decreasing and strings will be ordered as ascending) to sort lists. Sort the lists separately, and than merge them.
Please consider #David Heffernan's performance warning.
program Project3;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.Classes;
var
slStrings, slNumbers:TStringList;
test:string;
function CompareForNumbers(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
val1, val2:Integer;
begin
val1 := StrToInt(List[Index1]);
val2 := StrToInt(List[Index2]);
if val1 = val2 then
Result := 0
else if val1 < val2 then
Result := 1
else
Result := -1;
end;
function CompareForStrings(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
begin
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] > List[Index2] then
Result := 1
else
Result := -1;
end;
begin
slStrings := TStringList.Create();
slNumbers := TStringList.Create();
try
slStrings.Add('EXE');
slStrings.Add('WE');
slStrings.Add('DNF');
slNumbers.Add('5');
slNumbers.Add('20');
slNumbers.Add('24');
slNumbers.Add('12');
slNumbers.CustomSort(CompareForNumbers);
slStrings.CustomSort(CompareForStrings);
slNumbers.AddStrings(slStrings);
Writeln(slNumbers.Text);
Readln(test);
finally
slStrings.Free();
slNumbers.Free();
end;
end.
To use single list to handle #David Heffernan's performance warning, i've write this;
program Project3;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.Classes;
var
slStrings:TStringList;
test:string;
function Compare(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
val1, val2:Integer;
val1integer, val2integer:Boolean;
begin
val1integer := TryStrToInt(List[Index1], val1);
val2integer := TryStrToInt(List[Index2], val2);
if val1integer and val2integer then
begin
if val1 = val2 then
Result := 0
else if val1 < val2 then
Result := 1
else
Result := -1;
end
else if (not val1integer) And (not val2integer) then
begin
if List[Index1] = List[Index2] then
Result := 0
else if List[Index1] > List[Index2] then
Result := 1
else
Result := -1;
end
else
begin
if val1integer then
Result := -1
else
Result := 1;
end;
end;
begin
slStrings := TStringList.Create();
try
slStrings.Add('EXE');
slStrings.Add('5');
slStrings.Add('WE');
slStrings.Add('20');
slStrings.Add('DNF');
slStrings.Add('24');
slStrings.Add('12');
slStrings.Add('A');
slStrings.Add('6');
slStrings.Add('E');
slStrings.Add('B');
slStrings.Add('4');
slStrings.Add('T');
slStrings.Add('444');
slStrings.CustomSort(Compare);
Writeln(slStrings.Text);
Readln(test);
finally
slStrings.Free();
end;
end.
I believe you want to sort times by shortest to longest first, then all text alphabetically (although that is arguable).
I would not modify the texts in the way that you do. Instead I would simply modify the comparer function and pass the texts 'as is'.
To test it I used a TMemo, but the principle applies to the tables - just copy the appropriate column to the string list.
function Compare2(
List : TStringList;
Index1 : Integer;
Index2 : Integer) : Integer;
var
i1IsNumeric, i2IsNumeric : boolean;
i1, i2 : integer;
begin
//comparer for custom sort used in SortLTSGrid
i1IsNumeric := TryStrToInt( List[Index1], i1 );
i2IsNumeric := TryStrToInt( List[Index2], i2 );
if i1IsNumeric and (not i2IsNumeric) then
begin
Result := -1;
end
else if i2IsNumeric and (not i1IsNumeric) then
begin
Result := 1;
end
else if i1IsNumeric then
begin
Result := Sign( i1-i2);
end
else
begin
Result := CompareStr( List[Index1], List[Index2] );
end;
end;
Here is my test routine using a memo
procedure TForm4.Button1Click(Sender: TObject);
var
iList : TStringList;
begin
iList := TStringList.Create;
try
iList.Assign( Memo1.Lines );
iList.CustomSort( Compare2 );
Memo1.Lines.Assign( iList );
finally
iList.Free;
end;
end;
Your routine would be more like (although this I have not tested)
procedure TfrmPuntehou.SortLTSGrid(var grid: TStringGrid; columntotal: Integer);
var
TheList : TStringList;
i,l,iCount,m:integer;
const
separator = ',';
const
arrCodes:array[1..10] of string = ('DNF','DNS','WD','WE','DNA','OD','RD','EXR','EXE','PP');
begin
//sorts grid largest to smallest according to one column
//get grid row amount
iCount:=grid.RowCount - 1;
//create and fill the string list
TheList := TStringList.Create;
//fill the list
for i := 1 to (iCount) do
begin
TheList.Add(grid.Rows[i].Text);
end;
//try block to sort and write all strings in the list to the grid correctly
try
TheList.CustomSort(Compare2);
for i:= 1 to (iCount) do
begin
grid.Rows[i].Text := TheList.Strings[(i-1)] ;
end;
//fill the row numbers
for m := 1 to iCount do
begin
grid.Cells[0,m]:= IntToStr(m);
end;
finally
TheList.Free;
end;
end;
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
program ideone;
var
s : string;
t,len,i,j,count : integer;
begin
readln(t);
while t>0 do
begin
read(s);
len := byte(s[0]);
i :=0;
j :=len-1;
count :=0;
while i<j do
begin
if s[i]<>s[j] then
begin
count :=count+1;
if count>1 then
begin
writeln('no');
break;
end;
end;
i :=i+1;
j :=j-1;
end;
if count<2 then
writeln('yes');
t := t-1;
end;
end.
I have to check whether changing only one character in the given string can make it a 'Palindrome'...
INPUT:
3
arora
abcd
mitin
OUTPUT:
yes
no
yes
So im trying to add all 'spent' data, belonging to specific client number, on a binary tree.
Type
pointer_tree = ^bTree;
bTree = record
nclient: integer;
spent: integer;
big, small: pointer_tree
end;
{adder is 0}
function add (pT: pointer_tree; client_number: integer; adder: integer): integer;
begin
if pT <> nil then begin
if pT^.nclient = client_number then
adder:= pT^.spent + adder
add(pT^.big,client_number,adder);
add(pT^.small,client_number,adder);
end;
add:= adder;
end;
Function add will not return the added elements and will return a random number instead. Also is there a better way to add them all up?
I don't like the way that you're using the variable 'adder' as both a parameter to the function and also as a temporary store for the calculated value. I think it would be better if the function were written as follows, without the 'adder' variable:
function add (pT: pointer_tree; client_number: integer): integer;
begin
result:= 0;
if pT <> nil then
begin
if pT^.nclient = client_number then result:= pT^.spent;
inc (result, add (pT^.big, client_number));
inc (result, add (pT^.small, client_number));
end;
end;
Incidentally, your code is missing a semicolon after the 'adder:= pT^.spent + adder' line.
I have using pascal for my parallel language .(I don't like it , but force.) So the
Merge sort in parallel with fork & join not working, can some one tell me why?
here is my code :
program parrallelmergesort;
architecture shared(100);
const
n=100;(*big array*)
size=10;
var
t,globalCounter:integer;
unsorted:array[1..n] of integer;
procedure CallMerge(var lower,mid,high:integer);
var
i,j,k,count:integer;
S:array[1..n] of integer;
BEGIN
i:=lower;
j:=mid+1;
k:=lower;
count:=high-lower+1;
while (i<=mid) and (j<=high) do
begin
if unsorted[i]<unsorted[j] then
begin
S[k] :=unsorted[i];
i :=i+1;
end
else
begin
S[k] :=unsorted[j];
j :=j+1;
end;
k:=k+1;
end;
if i>mid then
begin
while j<=high do
begin
S[k] :=unsorted[j];
j :=j+1;
k :=k+1;
end;
end
else if j>high then
begin
while i<=mid do
begin
S[k] :=unsorted[i];
i :=i+1;
k :=k+1;
end;
end;
for t:=lower to high do
unsorted[t] :=S[t];
end;
procedure CallMergeSort(bottom,up:integer);
var middle,nextOfMiddle:integer;
begin
if up>bottom then
begin
middle := (up+bottom) div 2;
nextofMiddle :=middle+1;
fork CallMergeSort(bottom,middle);
fork CallMergeSort(nextOfMiddle,up);
join;join;
CallMerge(bottom,middle,up);
end;
end;
begin
unsorted[1] :=4; unsorted[2] :=3; unsorted[3] :=10; unsorted[4] :=5; unsorted[5] :=0;
unsorted[6] :=1; unsorted[7] :=8; unsorted[8] :=6; unsorted[9] :=11; unsorted[10] :=12;
CallMergeSort(1,size);
for globalCounter:=1 to size do
writeln(unsorted[globalCounter]);
readln;
end.
When should I use fork ? before CallMergeSort (Recursive) ?
Last lines is main function in pascal.
don't call fork and join inside the rec function.
Just call them twice from the main.