Словарь с графической оболочкой

Для компиляции нужны файлы EGAVGA.BGI и GRAPH.TPU. Они должны лежать в папке с компилируемым файлом.

code: #pascal
uses crt,graph; 
const N=10000; 
       h=5; 
type slovo=record 
       rus:string; 
       perevod:string; 
      end; 
 
      Data=array[1..n] of ^slovo; 
 
var a:data; 
     f:text; 
     gd,gm:integer; 
     DataCount,poz:integer; 
     FileName,DCount,naity:string; 
     simv,vybor:char; 
     MaxRus:integer; 
     poisk,y,y2:integer; 
 
function Rus(mes:string):string; 
var i:integer; 
BEGIN 
  for i:=1 to Length(mes) do 
  case mes[i] of 
  'а'..'п': mes[i]:=Chr(Ord(mes[i])-64); 
  'р'..'я': mes[i]:=Chr(Ord(mes[i])-16); 
  end; 
  rus:=mes; 
END; 
 
function Prepare(path:string):boolean; 
begin 
  Prepare:=true; 
  assign(f,path); 
  {$I-} 
  reset(f); 
  {$I+} 
  if IOResult<>0 then 
   begin 
    rewrite(f); 
    Prepare:=false; 
   end; 
  close(f); 
end; 
 
function Fill(var max_length:integer):integer; 
var tmp,max_str:string; 
     k:integer; 
begin 
  k:=0; 
  reset(f); 
  while not eof(f) do 
   begin 
    readln(f,tmp); 
    if length(tmp)>0 then 
     begin 
      inc(k); 
      new(a[k]); 
      a[k]^.rus:=copy(tmp,1,pos(' ',tmp)-1); 
      if k>1 then 
       begin 
        if Length(max_str)<Length((a[k]^.rus)) then 
         begin 
          max_str:=a[k]^.rus; 
          max_length:=length(a[k]^.rus); 
         end; 
       end 
      else 
       begin 
        max_str:=a[1]^.rus; 
        max_length:=length(a[1]^.rus); 
       end; 
      a[k]^.perevod:=copy(tmp,pos(' ',tmp)+1,length(tmp)-pos(' ',tmp)); 
     end; 
   end; 
  close(f); 
  Fill:=k; 
end; 
 
procedure Clear; 
var k:integer; 
begin 
  for k:=1 to DataCount do Dispose(a[k]); 
end; 
 
procedure LexSort(count:integer; var item:Data); 
{leksikograficheskoe uporiadochivanie} 
  procedure QuickSort(l,r:integer; var it:Data); 
  var i,j:integer; 
      x:string; 
      y:slovo; 
  begin 
   i:=l; 
   j:=r; 
   x:=it[(l+r) div 2]^.rus; 
   repeat 
    while it[i]^.rus<x do inc(i); 
    while x<it[j]^.rus 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 l<j then QuickSort(l,j,it); 
   if l<r then QuickSort(i,r,it); 
  end; 
begin 
  QuickSort(1,count,item); 
end; 
 
function BynarSearch(Search:string):integer; 
{dvoichnyi poisk} 
var left,right,middle:integer; 
     first,last:integer; 
begin 
   left:=1; 
   right:=DataCount; 
   repeat 
     middle:=left+(right-left) div 2; 
     if A[middle]^.rus>Search then right:=middle 
     else left:=middle; 
   until right-left<=1; 
   if Search=A[left]^.rus then BynarSearch:=left 
   else if Search=A[right]^.rus then BynarSearch:=right 
   else BynarSearch:=0; 
end; 
 
procedure PaintWindow; 
begin 
  SetFillStyle(1,White); 
  Bar(8,28,622,452); 
  SetColor(LightBlue); 
  Rectangle(8,28,622,452); 
  Line(311,28,311,452); 
end; 
 
procedure TheEnd; 
begin 
  Clear; 
  Halt; 
end; 
 
procedure Wait(x_,y_:integer); 
begin 
  repeat 
   Delay(30000); 
   SetFillStyle(1,LightRed); 
   Bar(x_,y_,x_+5,y_+2); 
   Delay(30000); 
   SetFillStyle(1,White); 
   Bar(x_,y_,x_+5,y_+2); 
  until keypressed; 
end; 
 
function InTextXY(x_,y_:integer; kol_simv:byte; msg:string):string; 
var tmp:string; 
     ch:char; 
     fl:boolean; 
begin 
  tmp:=''; 
  InTextXY:='Slovar.txt'; 
  fl:=false; 
  Wait(x_,y_+TextHeight(' ')-4); 
  repeat 
   ch:=readkey; 
   if fl=true then 
    begin 
     Bar(x_,y_,x_+TextWidth(msg)+TextWidth(' '),y_+TextHeight(msg)); 
     fl:=false; 
    end; 
   if ch=#27 then TheEnd; 
   if ch<>#13 then 
   if (ch<>#8) and (length(tmp)<=kol_simv) then tmp:=tmp+ch 
   else if length(tmp)>0 then delete(tmp,length(tmp),1); 
   if length(tmp)<=kol_simv then 
    begin 
     Bar(x_,y_,x_+TextWidth(tmp)+TextWidth(' '),y_+TextHeight(tmp)); 
     OutTextXY(x_,y_,tmp); 
    end; 
   if (ch=#13) and ((length(tmp)=0) or (tmp=' ')) then 
    begin 
     Bar(x_,y_,x_+TextWidth(tmp)+TextWidth(' '),y_+TextHeight(Tmp)); 
     SetColor(LightRed); 
     OutTextXY(x_,y_,msg); 
     SetColor(LightBlue); 
     fl:=true; 
    end; 
  until (ch=#13) and (length(tmp)>0) and (tmp<>' '); 
  InTextXY:=tmp; 
end; 
 
procedure Add(x_,y_:integer; kol_simv:byte; msg:string); 
var tmp:string; 
begin 
  x_:=x_+TextWidth(' '); 
  Bar(x_,y_,x_+TextWidth(' ')*kol_simv,y_+TextHeight(' ')); 
  tmp:=InTextXY(x_+8,y_,kol_simv,msg); 
  inc(DataCount); 
  new(a[DataCount]); 
  a[DataCount]^.rus:=naity; 
  a[DataCount]^.perevod:=tmp; 
  append(f); 
  writeln(f,a[DataCount]^.rus,' ',a[DataCount]^.perevod); 
  Close(f); 
  if length(naity)>MaxRus then MaxRus:=length(naity); 
  Bar(312,y_,x_+TextWidth(' ')*kol_simv,y_+TextHeight(' ')); 
  SetColor(Blue); 
  OutTextXY(316,y_,': '+tmp); 
end; 
 
function ChooseSlovar:string; 
var tmp:string; 
begin 
  SetFillStyle(1,Yellow); 
  Bar(150,146,472,160); 
  Rectangle(150,146,472,160); 
  SetColor(LightBlue); 
  OutTextXY(254,150,'VYBOR SLOVARIA'); 
  SetFillStyle(1,White); 
  Bar(150,160,472,190); 
  Rectangle(150,160,472,190); 
  FileName:=InTextXY(172,170,35,'Vvedite imia faila-slovaria!'); 
  OutTextXY(171,10,'|  File://'+FileName); 
end; 
 
begin 
  DataCount:=0; 
  gd:=detect; 
  initgraph(gd,gm,''); 
  if graphresult<>grok then 
   begin 
    writeln('Oshibka pri zapuske graficheskogo rezhima!'); 
    readln; 
    halt; 
   end 
  else 
   begin 
    SetBkColor(LightCyan); 
    HighVideo; 
    ClearDevice; 
    SetFillStyle(1,Yellow); 
    Bar(8,5,622,21); 
    SetColor(LightBlue); 
    OutTextXY(14,10,'PROGRAMMA "SLOV@R"'); 
    Rectangle(8,5,622,21); 
    SetColor(Blue); 
    OutTextXY(280,460,'ESC-EXIT'); 
    SetColor(LightBlue); 
    ChooseSlovar; 
    PaintWindow; 
 
    repeat 
     poisk:=0; 
     repeat 
      if Prepare(FileName) then 
       begin 
        DataCount:=Fill(MaxRus); 
        LexSort(DataCount,a); 
       end; 
 
      SetFillStyle(1,Yellow); 
      Bar(510,9,620,17); 
      SetColor(LightBlue); 
      if DataCount>0 then 
       begin 
        Str(DataCount,DCount); 
        OutTextXY(510,10,DCount+' slov'); 
       end 
      else OutTextXY(510,10,'slovar pust'); 
 
      y:=h*2*poisk; 
      OutTextXY(12,36+y,'> '); 
 
      naity:=InTextXY(28,36+y,35,'Vvedite slovo!'); 
 
      if length(naity)<=MaxRus then 
       begin 
        poz:=0; 
        if DataCount>0 then poz:=BynarSearch(naity); 
        if poz>0 then 
         begin 
          SetColor(Blue); 
          OutTextXY(316,36+y,': '+a[poz]^.perevod); 
         end 
        else 
         begin 
          SetColor(Red); 
          OutTextXY(316,36+y,': Net v slovare. Dobavit? [y/n]'); 
          Wait(572,40+y); 
          vybor:=upcase(readkey); 
          if vybor='Y' then Add(316,36+y,35,'Vvedite perevod slova!') 
          else 
           begin 
            Bar(316,36+y,316+TextWidth(' ')*35,36+y+TextHeight(' ')); 
            OutTextXY(316,36+y,': Net v slovare.'); 
           end; 
         end; 
       end 
      else 
       begin 
        SetColor(Red); 
        OutTextXY(316,36+y,': Net v slovare. Dobavit? [y/n]'); 
        Wait(572,40+y); 
        vybor:=upcase(readkey); 
        if vybor='Y' then Add(316,36+y,35,'Vvedite perevod slova') 
        else 
         begin 
          Bar(316,36+y,316+TextWidth(' ')*35,36+y+TextHeight(' ')); 
          OutTextXY(316,36+y,': Net v slovare.'); 
         end; 
       end; 
      inc(poisk); 
      if poisk=41 then readkey; 
     until poisk=41; 
     poisk:=0; 
     PaintWindow; 
    until h=11; 
   end; 
   TheEnd; 
end. 

автор: delpas

Поделиться:

Похожие статьи: