Sortowanie wyrazow (kubelkowe)

0

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.
0

O kurcze... Coby nie wzywać interwencji mocy niebieskich. Nie dało się tego napisać prościej? Sortowanie to jest parę linijek kodu i bez takich dzikich ograniczeń!

0

no wlasnie nie mialem pojecia jak to napisac i pisalem co popadlo,
niestety cos nie dziala i prosze o pomoc :)

0

juz sobie poradzilem sam :]
dziala <jupi>
jestem z siebie bardzo dumny :)

1 użytkowników online, w tym zalogowanych: 0, gości: 1