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.
Related
I have tried to make a simple snake game with Free Pascal, when I started the programme, it drew the map exactly what I want but after that, I pressed the button that I have set to control the snake and it exited with exit code 201.
I don't know much about that exit code, could you explain me the problems of the programme? This is the longest program I have ever made with Pascal.
Here is the code:
uses crt;
type
ran=record
x:byte;
y:byte;
end;
var
f:ran;
s:array[1..1000] of ran;
i,j:longint;
st,l:byte;
function getkey:integer;
var
k:integer;
begin
k:=ord(readkey);
if k=0 then k:=-ord(readkey);
getkey:=k;
end;
procedure fa;
begin
randomize;
f.x:=random(98)+1;
f.y:=random(23)+1;
gotoxy(f.x,f.y);
writeln('o');
end;
procedure draw;
begin
gotoxy(1,1);
st:=1;
for i:=1 to 25 do begin
for j:=1 to 100 do write('X');
writeln
end;
gotoxy(st+1,st+1);
for i:=1 to 23 do begin
for j:=1 to 98 do write(' ');
gotoxy(st+1,i+2);
end;
end;
procedure sts;
begin
s[1].x:=19;
s[1].y:=6;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure fa1;
begin
f.x:=29;
f.y:=5;
gotoxy(f.x,f.y);
writeln('o');
end;
procedure eat;
begin
if (s[1].x=f.x) and (s[1].y=f.y) then begin
l:=l+1;
fa;
end;
end;
function die:boolean;
begin
die:=false;
if (s[1].x=1) or (s[1].x=100) or (s[1].y=1) or (s[1].y=25) then
die:=true;
if l>=5 then
for i:=5 to l do
if (s[1].x=s[i].x) and (s[1].y=s[i].y) then
die:=true;
end;
procedure up;
begin
for i:=l downto 2 do begin
s[i].y:=s[i-1].y;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x,s[l].y+1);
writeln(' ');
s[1].y:=s[1].y-1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure down;
begin
for i:=l downto 2 do begin
s[i].y:=s[i-1].y;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x,s[l].y-1);
writeln(' ');
s[1].y:=s[1].y+1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure left;
begin
for i:=l downto 2 do begin
s[i].x:=s[i-1].x;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x+1,s[l].y);
writeln(' ');
s[1].x:=s[1].x-1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure right;
begin
for i:=l downto 2 do begin
s[i].x:=s[i-1].x;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x-1,s[l].y);
writeln(' ');
s[1].x:=s[1].x+1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure auto(k:integer);
begin
case k of
-72:up;
-80:down;
-75:left;
-77:right;
119:up;
115:down;
97:left;
100:right;
end;
end;
procedure ingame(t:integer);
var
d,e:boolean;
begin
repeat
auto(t);
d:=die;
if d=true then exit;
eat;
until (keypressed);
if keypressed then t:=getkey;
case t of
-72:up;
-80:down;
-75:left;
-77:right;
119:up;
115:down;
97:left;
100:right;
end;
eat;
d:=die;
if d=true then exit;
end;
procedure first;
var
k:integer;
begin
draw;
fa1;
sts;
if keypressed then k:=getkey;
ingame(k);
end;
BEGIN
clrscr;
first;
readln
END.
I googled this: 201 : range error, so you probably go out of array bounds. The only array s in indexed by variables that depend on l value (weird name, BTW). But I see a single place where you do changing (increment) this variable and don't see any l initialization. So you are using arbitrary starting value (here perhaps zero because l is global).
Note that you could discover this bug (and perhaps others) with simple debugging.
The code 201 seems to be explained for example here: Runtime Error 201 at fpc
Exactly why this happens in your code, I don't know.
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 want to find all the posibilities of moving around these numbers 1,2,3,4,5 with the conditions that "4,3" is not possible and 1 and 5 can't be in the same solution. I have this code but when I compile it it doesn't show me anything.
var x:array[1..50] of integer;
i,k:integer;
avems,evalid:boolean;
procedure init;
begin
x[k]:=0;
end;
procedure succesor;
begin
if x[k]<5 then avems:=true
else avems:=false;
if avems=true then x[k]:=x[k]+1;
end;
function solutie:boolean;
begin
if k=3 then solutie:=true
else solutie:=false;
end;
procedure valid;
begin
evalid:=true;
for i:=1 to k-1 do
if (x[i]=1) or (x[i]=5) and (x[k]=1) or (x[k]=5) then evalid:=false;
if (k>1) and (x[k-1]=4) and (x[k]=3) then evalid:=false;
end;
procedure tipar;
begin
for i:=1 to 3 do
write(x[i],' ');
writeln;
end;
begin
k:=1;
init;
while k>0 do
begin
repeat
succesor;
until not(avems) or (avems and evalid);
if avems then
if solutie then tipar
else begin
k:=k+1;
init;
end
else k:=k-1;
end;
end.
What do you expect? Your code increments x[1] until it reaches 5, then sets avems:=false; and then decrements k to zero and exits the while loop.
Remember that Pascal does not use indentation for blocks like Python, so your
last steps are written more clearly as
if avems then begin
if solutie then tipar
else begin
k:=k+1;
init;
end
end
else k:=k-1;
If this is not what you want, you have to code some begin/end.
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
I am working on a Pascal program that works with sets without using the built in operations. However my toString function is not working and I cannot figure out why.
This is the main part of the program
unit isetADT; {// do not change this!}
interface
const
MAX_SIZE = 100; {// if needed, use value 100; arbitrary}
type
iset = record {// your type definition goes here}
arrayint:array[1..MAX_SIZE] of integer;
setsize:integer;
end;
procedure makeEmpty(var s:iset);
function isEmpty(s:iset):boolean;
function isMember(n:integer; s:iset):boolean;
function equals(s1,s2:iset):boolean;
function card(s:iset):integer; {// cardinality}
procedure add(n:integer; var s:iset); {// does nothing if n is already a member of s}
procedure remove(n:integer; var s:iset); {// does nothing if n is not in s}
procedure union(s1,s2:iset; var res:iset);
procedure intersect(s1,s2:iset; var res:iset);
procedure diff(s1,s2:iset; var res:iset); {// s1 - s2}
function toString(s:iset):ansistring;
implementation
{// your implementation code goes here}
procedure makeEmpty(var s:iset);
begin
{s:=[]; clears array, unneeded}
s.setsize:=0;
end;
function isEmpty(s:iset):boolean;
var
empty:boolean;
begin
empty:=false;
if s.setsize=0 then
empty:=true;
isEmpty:=empty;
end;
function isMember(n:integer; s:iset):boolean;
var
count:integer;
begin
member:=false;
if s.setsize>0 then
begin
for count:=1 to s.setsize do
begin
if s.arrayint[count]=n then
isMember:=true;
end;
end;
end;
function equals(s1,s2:iset):boolean;
var
equal:boolean;
count:integer;
begin
equal:=false;
if s1.setsize<>s2.setsize then
else
begin
for count:=1 to s1.setsize do
begin
if isMember(s1.arrayint[count],s2) then
equal:=true
else
equal:=false;
end;
end;
equals:=equal;
end;
function card(s:iset):integer; {// cardinality}
var
cardinality:integer;
begin
cardinality:=s.setsize;
end;
procedure add(n:integer; var s:iset);
begin
if isMember(n,s) then
{it is already in the set nothing is done}
else
begin
s.setsize:=s.setsize+1; {adds 1 to the size so that the new member can be added}
s.arrayint[s.setsize]:=n; {puts member in the newly created space}
end;
end;
procedure remove(n:integer; var s:iset);
var
newsize:integer;
count:integer;
count2:integer;
begin
{needed to keep size constant when it is being changed in nested loops}
newsize:=s.setsize;
if isMember(n,s) then
begin
for count:= 1 to newsize do
begin
if s.arrayint[count]=n then
begin
for count2:=1 to newsize do
begin
s.arrayint[count]:=s.arrayint[count+1]; {replaces the removed member}
end;
s.setsize:=s.setsize-1;{removes unneeded size}
end;
end;
end;
end;
procedure union(s1,s2:iset; var res:iset);
var
count:integer;
count2:integer;
begin
makeEmpty(res);
if equals(s1,s2) then
{they are the same, nothing is done}
else
begin
{takes a member of s2 and puts it res if it is not in s1 since res is the same as s1}
for count:=1 to s1.setsize do
begin
add(s1.arrayint[count],res);
end;
for count2:=1 to s2.setsize do
begin
add(s2.arrayint[count2],res);
end;
end;
end;
procedure intersect(s1,s2:iset; var res:iset);
var
count:integer;
begin
if equals(s1,s2) then
res:=s1 {since they are the same only 1 needs to be returned}
else
begin
for count:=1 to s1.setsize do
begin
{number is added to res if it is in both s1 AND s2 only}
if isMember(s1.arrayint[count],s2) then
add(s1.arrayint[count],res)
end;
end;
end;
procedure diff(s1,s2:iset; var res:iset);
var
member:boolean;
count:integer;
count2:integer;
begin
member:=false;
if equals(s1,s2) then
{if they are the same then nothing is returned because there is no difference}
makeEmpty(res)
else
begin
for count:=1 to s1.setsize do
begin
for count2:=1 to s2.setsize do
begin
{if number is in s1 and not s2 then it is true and it is added to res}
if s1.arrayint[count]=s2.arrayint[count2] then
member:=true;
end;
if member=false then
add(s1.arrayint[count],res);
end;
end;
end;
function toString(s:iset):ansistring; {this is just a string with no size limit}
var
print:ansistring;
x:string;
i: Integer;
count:integer;
begin
print:='';
for count:=1 to s.setsize do
begin
i:=s.arrayint[count];
str(i,x);
print:=print+x+',';
end;
print:='{'+ print+'}';
toString:=print;
end;
end. {END OF PROGRAM}
and this is the runner for the program
program testisetSample;
uses isetADT;
var
s1,s2,s3 : iset;
i : integer;
begin
makeEmpty(s1); makeEmpty(s2);
for i := 1 to 5 do
add(i,s1);
for i := 3 to 8 do
add(i,s2);
intersect(s1,s2,s3);
writeln(toString(s3));
readln;
end.
Obvious mistake:
You are using
print:=print+'x'+',';
when you want
print:=print+x+',';
Mistakes in isMember:
member:=false;
you are not setting isMember, the returned value will be "random". You could remove member altogether and always use `isMember?
if s.setsize=0 then
Should be > 0. But it is not needed