Programalama > PASCAL

program sozluk;
uses crt;
const
alfabe='ABC€DEFG¦HI˜JKLMNO™PRSžTUšVYZ';
alfabe2='abc‡defg§hijklmno”prsŸtuvyz';
kelime_say:word=0;
i:byte=0;

type
st20=string[21];{proc. i‡ine sozcuk u koyabilmel i‡in bu tanmlamay yapamak
    zorundaym.}

var
dosya:TEXT;
dosyayeri:string[50];
secim:char;
sozcuk:st20;
anlam:string[40];
sozcukler:array[1..100]of st20;
anlamlar:array[1..100]of string[40];
kez:array[1..100]of integer ;
bosluk,h:string[1];
bulundu,buyuk_harf_mi:boolean;
m,j,f,y:byte;
melis,orta:word;
UZ:byte;
harf:array[1..29,1..20] of word;

procedure siralama;
var
kar1,kar2:char;
w,x,L:word;
gecici:string[20];
gecici2:string[40];
gecici3:integer;

     begin
     for w:=2 to kelime_Say do begin
       for x:=kelime_say downto w do
        begin
         for L:=1 to length(sozcukler[w]) do
         begin
         kar1:=sozcukler[x,L];
         kar2:=sozcukler[x-1,L];
         if (pos(kar1,alfabe))<(pos(kar2,alfabe))
             then
             begin
             gecici:=sozcukler[x-1];
             sozcukler[x-1]:=sozcukler[x];
             sozcukler[x]:=gecici;

             gecici2:=anlamlar[x-1];
             anlamlar[x-1]:=anlamlar[x];
             anlamlar[x]:=gecici2;

             gecici3:=kez[x-1];
             kez[x-1]:=kez[x];
             kez[x]:=gecici3;
             break;
             end;
         if (pos(kar1,alfabe))>(pos(kar2,alfabe)) then break;
         end;
       end;
     end;
end;

procedure arama(var sozcuk:ST20;var bulundu:boolean;var orta:word);
var
g:word;
begin
 for g:=1 to kelime_say do
    begin
      if sozcuk=sozcukler[g] then
            begin bulundu:=true;  orta:=g; break; end;
      end;
end;

procedure buyutme(var sozcuk:ST20;var i,UZ:byte);
var
L:byte;
sozcuk2:string[21];
begin
UZ:=length(sozcuk);
  for L:=1 to UZ do
     begin
      h:=copy(sozcuk,L,1);
		if (pos(h,alfabe)<>0)or(pos(h,alfabe2)<>0) then
                       begin
                       i:=i+1;
                       if pos(h,alfabe)<>0 then sozcuk2:=sozcuk;
                       if pos(h,alfabe2)<>0 then
                         begin
                            y:=pos(h,alfabe2);
                            h:=copy(alfabe,y,1);
                            insert(h,sozcuk2,L);
                          end;
                       end;
     end;
   delete(sozcuk,1,i);
   sozcuk:=sozcuk2;
   sozcuk:=copy(sozcuk,1,i);
end;


procedure ekleme(var kelime_say:word);

var
flag:boolean;
L:byte;
Begin
clrscr;
repeat
  repeat
  i:=0;
  bulundu:=false;
  writeln('Eklemek istediginiz Turkce kelimeyi girin: ');
  readln(sozcuk);
  buyutme(sozcuk,i,UZ);
  arama(sozcuk,bulundu,orta);
  if (bulundu=true) then writeln('Bu sozcuk, sozlukte zaten var!');
  until bulundu=false;

  flag:=true;
  if UZ-i>0 then
    begin
     writeln;
     writeln('Lutfen harften baska bir karakter girmeyiniz!');
     flag:=false;
    end;

  if UZ>20 then
    begin
     writeln;
     writeln('Lutfen 20 harften uzun kelime girmeyiniz!');
     flag:=false;
    end;

  if sozcuk='' then
    begin
     writeln;
     writeln('Lutfen bosluk girmeyiniz!');
     flag:=false;
    end;
until flag=true;
kelime_say:=kelime_say+1;
sozcukler[kelime_say]:=sozcuk;
writeln('Sozcugun Ingilizce anlamini yaziniz: ');
readln(anlam);
anlamlar[kelime_say]:=anlam;
kez[kelime_say]:=0;
siralama;
end;

procedure silme(var kelime_say:word);
var
L:word;
begin
  if kelime_say=0 then
     begin
       writeln('Sozlukte hic kelime yok!');
       readln; exit;
     end;
  repeat
     bulundu:=false;
     writeln('Silinecek sozcugu girin: ');
     readln(sozcuk);
     for L:=1 to length(sozcuk) do
      begin
       if pos(copy(sozcuk,L,1),alfabe2)<> 0 then buyutme(sozcuk,i,UZ);
     end;
     arama(sozcuk,bulundu,orta);
     if bulundu=false then writeln('Silmek istediginiz sozcuk,sozlukte yok!');
  until bulundu=true;
  for L:=orta to kelime_say-1 do
           begin
           sozcukler[L]:=sozcukler[L+1];
           anlamlar[L]:=anlamlar[L+1];
           kez[L]:=kez[L+1];
           end;
  kelime_say:=kelime_say-1;
writeln('Silindi!');
readln;
end;

procedure guncelleme;
var
L:byte;
begin
 if kelime_say=0 then
     begin
       writeln('Sozlukte hic kelime yok!');
       readln; exit;
     end;
 repeat
   bulundu:=false;
   writeln('Anlamini gncellemek istediginiz sozcugu giriniz: ');
   readln(sozcuk);
   for L:=1 to length(sozcuk) do
     begin
       if pos(copy(sozcuk,L,1),alfabe2)<> 0 then buyutme(sozcuk,i,UZ);
     end;
   arama(sozcuk,bulundu,orta);
   if bulundu=false then
         writeln('Guncellemek istediginiz sozcuk,sozlukte yok!');
 until bulundu=true;
    writeln('Yeni anlami giriniz: ');
    readln(anlam);
    anlamlar[orta]:=anlam;
    writeln('Kelimenin Anlami Guncellendi!');
readln;
end;

procedure sorgulama;
var
L:byte;
begin
if kelime_say=0 then
     begin
       writeln('Sozlukte hic kelime yok!');
       readln; exit;
     end;

repeat
  bulundu:=false;
  writeln('Sorgulamak istediginiz sozcugu girin: ');
  readln(sozcuk);
  for L:=1 to length(sozcuk) do
       if pos(copy(sozcuk,L,1),alfabe2)<> 0 then buyutme(sozcuk,i,UZ);
  arama(sozcuk,bulundu,orta);
  if bulundu=false then
       writeln('Sorgulamak istediginiz sozcuk,sozlukte yok!');
until bulundu=true;
kez[orta]:=kez[orta]+1;
writeln;
writeln(sozcukler[orta],' ':21-length(sozcukler[orta])
         ,kez[orta],' ',anlamlar[orta]);
readln;
end;

procedure listeleme;
var
 L:word;
 s:byte;
begin
  if kelime_say=0 then writeln('Sozlukte hic kelime yok!');
  for L:=1 to kelime_say do
    begin
       writeln(sozcukler[L],' ':20-length(sozcukler[L]),
         kez[L],' ',anlamlar[L]);
       s:=s+1;
       if s=50 then
            begin
            writeln;
            writeln('diger sayfa icin <enter> tusuna basin!');
            readln;
            s:=0;
            end;
    end;
readln;
end;

procedure max_min10;
var
s:word;
nerde:boolean;
gecici:integer;
gecici2:st20;
gecici3:string[40];
begin
clrscr;;
nerde:=true;
while nerde do
   begin
     nerde:=false;
     for s:=1 to (kelime_say-1) do
       begin
              if kez[s]<kez[s+1] then
              begin
                 gecici:=kez[s];
                 kez[s]:=kez[s+1];
                 kez[s+1]:=gecici;

                 gecici2:=sozcukler[s];
                 sozcukler[s]:=sozcukler[s+1];
                 sozcukler[s+1]:=gecici2;

                 gecici3:=anlamlar[s];
                 anlamlar[s]:=anlamlar[s+1];
                 anlamlar[s+1]:=gecici3;
                 nerde:=true;
              end;
       end;
   end;
writeln('Max Sorgulanan 10 Kelime');
writeln('* - * - * - * - * - * - * - * - * - * - * - * - * - * - * - *');
    for s:=1 to 10 do writeln(sozcukler[s],' ':21-length(sozcukler[s]),
                             kez[s],' ',anlamlar[s]);
writeln;
writeln('Min Sorgulanan 10 Kelime');
writeln('* - * - * - * - * - * - * - * - * - * - * - * - * - * - * - *');
    for s:=kelime_Say-10 to kelime_say do writeln(sozcukler[s],
         ' ':21-length(sozcukler[s]),kez[s],' ',anlamlar[s]);
readln;
end;

procedure tablo;
var
w,x:word;
kar:string;
yer:byte;
begin
  for w:=1 to kelime_say do
    for x:=1 to length(sozcukler[w]) do
        begin
          kar:=copy(sozcukler[w],x,1);
          yer:=pos(kar,alfabe);
          harf[yer,x]:=harf[yer,x]+1;
        end;
     for w:=1 to 29 do
        begin
          write(copy(alfabe,w,1),' ');
          for x:=1 to 20 do write(' ',harf[w,x]);
          writeln;
        end;
readln;
end;

procedure cikis;
var
L:word;
begin
assign(dosya,dosyayeri);
rewrite(dosya);
for L:= 1 to kelime_say do
  writeln(dosya,sozcukler[L],' ':21-length(sozcukler[L]),
                                kez[L],' ',anlamlar[L]);
close(dosya);
end;

BEGIN{ ANA PROGRAM}
clrscr;
repeat
 repeat
   writeln('dosyann yerini giriniz:');
   readln(dosyayeri);
   assign(dosya,dosyayeri);  
   {$I-}
   reset(dosya);
   {$I+}
   if IOresult<>0 then writeln('Dosya Bulunamadi!!!');
 until IOresult=0;

 while not(EOF(dosya)) do
  begin
   kelime_say:=kelime_say+1;
   readln(dosya,sozcukler[kelime_say],kez[kelime_say],
          bosluk,anlamlar[kelime_say]);
   end;
  close(dosya);
  for melis:=1 to kelime_say do{tk&#8225;e soz.un icindeki bosluklar cikdi.}
     begin
       for f:=1 to length(sozcukler[melis]) do
          if copy(sozcukler[melis],f,1)=' 'then
             begin
             sozcukler[melis]:=copy(sozcukler[melis],1,f-1);
             break;
             end;
     end;

  for melis:=1 to kelime_say do
   for f:=1 to length(sozcuk) do
     begin
       if pos(copy(sozcuk,f,1),alfabe2)<> 0 then buyutme(sozcuk,i,UZ);
     end;
  siralama;

 if kelime_say>500 then
   begin
   writeln('dosyada 500 den fazla kelime var.');
   writeln('Dosyadaki kelime sayisi 500 u gecmemeli!');
   end;
until kelime_say<501;
repeat
 clrscr;
  repeat
   writeln;
   writeln('***************       MENU      ***************');
   writeln('Yeni kelime eklemek                              : 1');
   writeln('Kelime silmek i&#8225;in                               : 2');
   writeln('Ingilizce anlam gncellemek i&#8225;in                 : 3');
   writeln('Trk&#8225;e bir kelimenin &#732;ngilizce anlam i&#8225;in       : 4');
   writeln('S&#8221;zlkteki tm kelimeleri listelemek i&#8225;in        : 5');
   writeln('En &#8225;ok ve en az sorgulanan kelimeleri g&#8221;rmek i&#8225;in: 6');
   writeln('Kelimelerin konumlanma tablosu i&#8225;in              : 7');
   writeln('&#8364;ikmak icin                                      : 8');
   readln(secim);
  until secim in['1','2','3','4','5','6','7','8'];

  case secim of
  '1':ekleme(kelime_say);
  '2':silme(kelime_say);
  '3':guncelleme;
  '4':sorgulama;
  '5':listeleme;
  '6':max_min10;
  '7':tablo;
  '8':cikis;
  end;
until secim='8';
END.