uses crt; 
const Max=10; 
type DataArray=array[1..Max] of string; 
var a:DataArray;{massiv dannyh} 
     i,n:integer;{i-dlia indekos massiva,n-fakticheskoe kol-vo elementov} 
     path:string;{imia faila} 
     vybor,ch:char;{dlia konstrukcii [y/n]} 
     Rez,Flag:boolean;{Rez-rezultat chtenia dannyh, Flag-polon li massiv} 
 
function ReadFromFile(FileName: string):boolean; 
{chtenie faila/konsoli 
parametr imia faila 
pustoi - konsol 
vozvraschaet TRUE pri uspeshnom zavershenii} 
var f:text; 
     buf:string; 
  begin 
    Assign(f,FileName); 
    {$I-} 
    Reset(f); 
    {$I+} 
    if IOResult<>0 then 
     begin 
      ReadFromFile:=False; 
      Writeln('Problemy s failom!'); 
      exit; 
     end; 
    repeat 
     inc(n); 
     readln(f,buf); 
     if buf<>'' then a[n]:=buf 
     else 
      begin 
       dec(n); 
       break; 
      end; 
     if n=Max then 
      begin 
       Flag:=True; 
       writeln('Massiv polnostiu zapolnen!'); 
       break; 
      end; 
    until eof(f)=True; 
    Close(f); 
    if n>0 then 
     begin 
      writeln('Prochitanno slov: ',n); 
      ReadFromFile:=True; 
     end 
    else 
     begin 
      writeln('NE prochitanno ni odnogo slova!'); 
      ReadFromFile:=False; 
     end; 
   end; 
 
procedure PereborSearch; 
{poisk polnym pereborom} 
var kol:integer;{kol-vo sovpadenii} 
     s:string; 
begin 
  repeat 
   write('Nuzhno naiti: '); 
   readln(s); 
   if s='' then writeln('Massiv NE soderzhit pustyh strok! Zadaite druguiu stroku.'); 
  until s<>''; 
  kol:=0; 
  for i:=1 to n do 
  if a[i]=s then 
   begin 
    inc(kol); 
    writeln('Pozicia: ',i,'.'); 
   end; 
  if kol>0 then writeln('Vsego sovpadenii: ',kol) 
  else if (Flag=True) or (n=Max) then 
     begin 
      writeln('Nichego NE naideno!'); 
      writeln('Slovo NE mozhet byt dobavlenno - massiv zapolnen!'); 
     end 
     else 
      begin 
       writeln('Nichego NE naideno!'); 
       inc(n); 
       a[n]:=s; 
       writeln('Slovo ',a[n],' dobavlenno v massiv.'); 
      end; 
end; 
 
procedure LexSort(var item: DataArray; count:integer); 
{leksikograficheskoe uporiadochivanie} 
  procedure QuickSort(l, r: integer; var it:DataArray); 
  var i_,j: integer; 
      x, y: string; 
  begin 
   i_:=l; 
   j:=r; 
   x:=it[(l+r) div 2]; 
   repeat 
    while it[i_]do inc(i_); 
    while x[j] do dec(j); 
    if i_<=j then 
     begin 
      y:=it[i_]; 
      it[i_]:=it[j]; 
      it[j]:=y; 
      inc(i_); 
      dec(j); 
     end; 
   until i_>j; 
   if lthen QuickSort(l, j, it); 
   if lthen QuickSort(i_, r, it); 
  end; 
begin 
  QuickSort(1,count,item); 
end; 
 
procedure BinarSearch; 
{dvoichnyi poisk} 
var left,right,middle:integer; 
     first,last,kol:integer; 
     s:string; 
begin 
   repeat 
    write('Nuzhno naiti: '); 
    readln(s); 
    if s='' then writeln('Massiv NE soderzhit pustyh strok! Zadaite druguiu stroku.'); 
   until s<>''; 
   left:=1; 
   right:=N; 
   repeat 
     middle:=left+(right-left) div 2; 
     if A[middle]>s then right:=middle 
     else left:=middle; 
   until right-left<=1; 
   if s=A[left] then last:=left 
   else if s=A[right] then last:=right 
   else last:=0; 
   if last>0 then 
    begin 
     first:=last; 
     kol:=0; 
     repeat 
      if a[first]=a[last] then 
       begin 
        dec(first); 
        inc(kol); 
       end; 
     until a[first]<>a[last]; 
     for i:=first+1 to last do writeln('Pozicia: ',i,'.'); 
     writeln('Vsego sovpadenii ',kol); 
    end 
    else writeln('Nichego NE naideno!'); 
end; 
 
begin 
  {osnovnaia programma} 
  n:=0; 
  textmode(259); 
  TextBackGround(blue); 
  textcolor(yellow); 
  repeat 
   clrscr; 
   writeln('***********************'); 
   writeln('******POISK SLOVA******'); 
   writeln('***********************'); 
   writeln; 
   writeln('Vyberite variant poiska: '); 
   writeln('1 - Polnyi perebor'); 
   writeln('2 - Binarnyi poisk'); 
   writeln; 
   writeln('ESC - EXIT'); 
   writeln('-----------------------'); 
   write('...'); 
   vybor:=readkey; 
  until (vybor='1') or (vybor='2') or (vybor=#27); 
  if vybor=#27 then halt; 
  Flag:=False; 
  case vybor of 
   '1':begin 
        clrscr; 
        writeln('Prochitat iz faila? [y/n]'); 
        ch:=readkey; 
        ch:=upcase(ch); 
        if ch='Y' then 
         begin 
          clrscr; 
          writeln('Vvedite put k failu i ego imia (bez rashirenia): '); 
          readln(path); 
          path:=path+'.txt'; 
          Rez:=ReadFromFile(path); 
          if Rez=False then 
           begin 
            readkey; 
            halt; 
           end; 
          writeln('IN: '+path); 
          writeln('Poluchennye slova: '); 
          for i:=1 to n do 
          if i=n then write(a[i],'.') 
          else write(a[i],', '); 
          writeln; 
          write('Press any key to CONTINUE... '); 
          readkey; 
          repeat 
           writeln; 
           PereborSearch; 
           writeln('Prodolzhit? [y/n]'); 
           ch:=readkey; 
           ch:=upcase(ch); 
           if not Flag then 
            begin 
             clrscr; 
             writeln('Vsego slov: ',n); 
             writeln('IN: '+path); 
             writeln('Poluchennye slova: '); 
             for i:=1 to n do 
             if i=n then write(a[i],'.') 
             else write(a[i],', '); 
             writeln; 
            end; 
          until ch='N'; 
         end 
         else 
          begin 
           writeln('IN: consol'); 
           writeln('Vvodite elementy. Konec - pustaia stroka:'); 
           Rez:=ReadFromFile(''); 
           if Rez=False then 
            begin 
             readkey; 
             halt; 
            end; 
           writeln('Poluchennye slova: '); 
           for i:=1 to n do 
           if i=n then write(a[i],'.') 
           else write(a[i],', '); 
           repeat 
            writeln; 
            PereborSearch; 
            writeln('Prodolzhit? [y/n]'); 
            ch:=readkey; 
            ch:=upcase(ch); 
            if not Flag then 
             begin 
              clrscr; 
              writeln('Vsego slov: ',n); 
              writeln('IN: '+path); 
              writeln('Poluchennye slova: '); 
              for i:=1 to n do 
              if i=n then write(a[i],'.') 
              else write(a[i],', '); 
              writeln; 
             end; 
           until ch='N'; 
          end; 
       end; 
   '2':begin 
        clrscr; 
        writeln('Prochitat iz faila? [y/n]'); 
        ch:=readkey; 
        ch:=upcase(ch); 
        if ch='Y' then 
         begin 
          clrscr; 
          writeln('Vvedite put k failu i ego imia (bez rashirenia): '); 
          readln(path); 
          path:=path+'.txt'; 
          Rez:=ReadFromFile(path); 
          if Rez=False then 
           begin 
            readkey; 
            halt; 
           end; 
          writeln('IN: '+path); 
          writeln('Poluchennye slova: '); 
          LexSort(a,n); 
          for i:=1 to n do 
          if i=n then write(a[i],'.') 
          else write(a[i],', '); 
          writeln; 
          write('Press any key to CONTINUE... '); 
          writeln; 
          readkey; 
          repeat 
           writeln; 
           BinarSearch; 
           LexSort(a,n); 
           writeln('Prodolzhit? [y/n]'); 
           ch:=readkey; 
           ch:=upcase(ch); 
          until ch='N'; 
         end 
         else 
          begin 
           writeln('IN: consol'); 
           writeln('Vvodite elementy. Konec - pustaia stroka:'); 
           Rez:=ReadFromFile(''); 
           if Rez=False then 
            begin 
             readkey; 
             halt; 
            end; 
           writeln('Poluchennye slova: '); 
           LexSort(a,n); 
           for i:=1 to n do 
           if i=n then write(a[i],'.') 
           else write(a[i],', '); 
           writeln; 
           write('Press any key to CONTINUE... '); 
           readkey; 
           repeat 
            writeln; 
            BinarSearch; 
            writeln('Prodolzhit? [y/n]'); 
            ch:=readkey; 
            ch:=upcase(ch); 
           until ch='N'; 
          end; 
       end; 
  end; 
  write('Pres any key to EXIT... '); 
  readkey; 
end.