Poznalem ostatnio teorie sortowamia kubelkowego wyrazow,
postanowilem napisac do tego program
- podajemy 5 wyrazow max 8 literowych
- do wyboru sa jedynie literki A D M O R S
- kazde slowo jest 8 elementowa tablica znakow CHAR
- wszystkie slowa sa zapisane w tablicy tablic char
- niestety nie dziala, nie wiem czemu... oto kod:
program kubelki;
uses
crt;
type
slowo=array[1..8] of char;
tablica=array[1..5] of slowo;
var
tb,ka,ks,kd,km,ko,kr,pusty:tablica;
I,P,Q,n,x,y,la,ld,lm,lo,lr,ls,lp:byte;
a:char;
procedure wypisz;
var x,y:byte;
begin
for x:=1 to 5 do
begin
writeln;
for y:=1 to 8 do
begin
if not (tb[x,y]='0') then
write(tb[x,y]);
end;
end;
end;
procedure czyscGLOWNA;
var a,b:byte;
begin
for a:=1 to 5 do
for b:=1 to 8 do
tb[a,b]:='0';
end;
procedure czyscKUBELKI;
var a,b:byte;
begin
for a:=1 to 5 do
for b:=1 to 8 do
pusty[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
ka[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
kd[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
km[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
ko[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
kr[a,b]:='0';
for a:=1 to 5 do
for b:=1 to 8 do
ks[a,b]:='0';
end;
begin
clrscr;
writeln('Podaj 5 wyrazow skladajach sie maksymalnie z 8 liter [A,D,M,O,R,S]...');
writeln;
czyscGLOWNA;
for I:=1 to 5 do
begin
write(I,' wyraz: ');
p:=1;
repeat
a:=readkey;
a:=upcase(a);
case a of
'A':begin write('A'); tb[I,P]:='A'; inc(p); end;
'O':begin write('O'); tb[I,P]:='O'; inc(p); end;
'R':begin write('R'); tb[I,P]:='R'; inc(p); end;
'S':begin write('S'); tb[I,P]:='S'; inc(p); end;
'M':begin write('M'); tb[I,P]:='M'; inc(p); end;
'D':begin write('D'); tb[I,P]:='D'; inc(p); end;
end;
until (p>8) or (a=#13);
writeln;
end;
wypisz;
for Q:=1 to 8 do
begin
P:=9-Q;
czyscKUBELKI;
lp:=0; la:=0; ld:=0; lm:=0; lo:=0; lr:=0; ls:=0;
for I:=1 to 5 do
begin
case tb[I,P] of
'A':begin inc(la); for n:=1 to 8 do ka[la,n]:=tb[I,n] end;
'O':begin inc(lo); for n:=1 to 8 do ko[lo,n]:=tb[I,n] end;
'R':begin inc(lr); for n:=1 to 8 do kr[lr,n]:=tb[I,n] end;
'S':begin inc(ls); for n:=1 to 8 do ks[ls,n]:=tb[I,n] end;
'M':begin inc(lm); for n:=1 to 8 do km[lm,n]:=tb[I,n] end;
'D':begin inc(ld); for n:=1 to 8 do kd[ld,n]:=tb[I,n] end;
else
begin
inc(lp);
for n:=1 to 8 do pusty[I,n]:=tb[I,n];
end;
end;
czyscGLOWNA;
y:=1;
while lp>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=pusty[x,n];
inc(x);
inc(y);
dec(lp);
end;
while la>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=ka[x,n];
inc(x);
inc(y);
dec(la);
end;
while ld>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=kd[x,n];
inc(x);
inc(y);
dec(ld);
end;
while lm>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=km[x,n];
inc(x);
inc(y);
dec(lm);
end;
while lo>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=ko[x,n];
inc(x);
inc(y);
dec(lo);
end;
while lr>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=kr[x,n];
inc(x);
inc(y);
dec(lr);
end;
while ls>=1 do
begin
x:=1;
for n:=1 to 8 do
tb[y,n]:=ks[x,n];
inc(x);
inc(y);
dec(ls);
end;
end;
end;
wypisz;
readln;
end.