Nickolay.info. Îáó÷åíèå. Ó÷åáíèê ïî Ïàñêàëþ. Ïðèëîæåíèå 4

Ïðèëîæåíèå 4. Äîïîëíèòåëüíûå ëèñòèíãè ïðîãðàìì

 

1. Ðåøåíèå ñèñòåìû ëèíåéíûõ àëãåáðàè÷åñêèõ óðàâíåíèé Ax=b ìåòîäîì Ãàóññà.

program Slau;

uses crt;

const size=30; {ìàêñèìàëüíî äîïóñòèìàÿ ðàçìåðíîñòü}

type matrix=array [1..size,1..size+1]

 of real;

type vector=array [1..size] of real;

 

function GetNumber (s:string;

  a,b:real):real;

{Ââîä ÷èñëà èç èíòåðâàëà a,b.

 Åñëè a=b, òî ÷èñëî ëþáîå}

var n:real;

begin

 repeat

  write (s);

  {$I-}readln (n);{$I+}

  if (IoResult<>0) then

    writeln ('Ââåäåíî íå ÷èñëî!')

  else if (a<b) and ((n<a) or (n>b)) then

   writeln ('×èñëî íå â èíòåðâàëå îò ',

    a,' äî ',b)

  else break;

 until false;

 GetNumber:=n;

end;

 

procedure GetMatrix (n,m:integer;

 var a:matrix); {ââîä ìàòðèöû}

var i,j:integer; si,sj: string [3];

begin

 for i:=1 to n do begin

  str (i,si);

  for j:=1 to m do begin

   str (j,sj);

   a[i,j]:=GetNumber ('a['+ si+ ','+ sj+

   ']=', 0,0);

  end;

 end;

end;

 

procedure GetVector (n:integer;

  var a:vector); {ââîä âåêòîðà}

var i:integer; si:string [3];

begin

 for i:=1 to n do begin

  str (i,si);

  a[i]:=GetNumber ('b['+si+']=',0,0);

 end;

end;

 

procedure PutVector (n:integer;

  var a:vector); {âûâîä âåêòîðà}

var i:integer;

begin

 writeln;

 for i:=1 to n do writeln (a[i]:10:3);

end;

 

procedure MV_Mult (n,m:integer;

  var a:matrix;var x,b:vector);

{óìíîæåíèå ìàòðèöû íà âåêòîð}

var i,j:integer;

begin

 for i:=1 to n do begin

  b[i]:=0;

  for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j];

 end;

end;

 

function Gauss (n:integer; var a:matrix;

   var x:vector):boolean;

{ìåòîä Ãàóññà ðåøåíèÿ ÑËÀÓ}

{a - ðàñøèðåííàÿ ìàòðèöà ñèñòåìû}

const eps=1e-6; {òî÷íîñòü ðàñ÷åòîâ}

var i,j,k:integer;

    r,s:real;

begin

 for k:=1 to n do begin  {ïåðåñòàíîâêà

        äëÿ äèàãîíàëüíîãî ïðåîáëàäàíèÿ}

  s:=a[k,k];

  j:=k;

  for i:=k+1 to n do begin

   r:=a[i,k];

   if abs(r)>abs(s) then begin

    s:=r;

    j:=i;

   end;

  end;

  if abs(s)<eps then begin

   {íóëåâîé îïðåäåëèòåëü, íåò ðåøåíèÿ}

   Gauss:=false;

   exit;

  end;

  if j<>k then

  for i:=k to n+1 do begin

   r:=a[k,i];

   a[k,i]:=a[j,i];

   a[j,i]:=r;

  end;  {ïðÿìîé õîä ìåòîäà}

  for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s;

  for i:=k+1 to n do begin

   r:=a[i,k];

   for j:=k+1 to n+1 do

     a[i,j]:=a[i,j]-a[k,j]*r;

  end;

 end;

 if abs(s)>eps then begin {îáðàòíûé õîä}

  for i:=n downto 1 do begin

   s:=a[i,n+1];

   for j:=i+1 to n do s:=s-a[i,j]*x[j];

   x[i]:=s;

  end;

  Gauss:=true;

 end

 else Gauss:=false;

end;

 

var a,a1:matrix;

    x,b,b1:vector;

    n,i,j:integer;

 

begin

 n:=trunc(GetNumber

 ('Ââåäèòå ðàçìåðíîñòü ìàòðèöû: ',2,size));

 GetMatrix (n,n,a);

 writeln ('Ââîä ïðàâîé ÷àñòè:');

 GetVector (n,b);

 for i:=1 to n do begin

  {äåëàåì ðàñøèðåííóþ ìàòðèöó}

  for j:=1 to n do a1[i,j]:=a[i,j];

  a1[i,n+1]:=b[i];

 end;

 if Gauss (n,a1,x)=true then begin

  write ('Ðåøåíèå:');

  PutVector (n,x);

  write ('Ïðîâåðêà:');

  MV_Mult (n,n,a,x,b1);

  PutVector (n,b1);

 end

 else write ('Ðåøåíèÿ íåò');

 reset (input); readln;

end.

 

2. Ïðîöåäóðíî-îðèåíòèðîâàííàÿ ðåàëèçàöèÿ çàäà÷è ñîðòèðîâêè îäíîìåðíîãî ìàññèâà ïî âîçðàñòàíèþ.

program sort;

const size=100;

type vector=array [1..size] of real;

 

procedure GetArray (var n:integer;

 var a:vector);

var i:integer;

begin

 repeat

  writeln ('Ââåäèòå ðàçìåðíîñòü ìàññèâà:');

  {$I-}readln (n); {$I+}

  if (IoResult<>0) or (n<2) or (n>size)

  then writeln

 ('Ðàçìåðíîñòü äîëæíà áûòü îò 2 äî ',size);

 until (n>1) and (n<size);

 for i:=1 to n do begin

  write (i,' ýëåìåíò=');

  readln (a[i]);

 end;

end;

 

procedure PutArray (n:integer;

  var a:vector);

var i:integer;

begin

 writeln;

 for i:=1 to n do writeln (a[i]:10:3);

end;

 

procedure sortArray (n:integer;

  var a:vector);

var i,j:integer; buf:real;

begin

 for i:=1 to n do

 for j:=i+1 to n do if a[i]>a[j] then begin

   buf:=a[i]; a[i]:=a[j]; a[j]:=buf;

 end;

end;

 

var a:vector;

    n:integer;

 

begin

 GetArray (n,a);

 sortArray (n,a);

 write ('Îòñîðòèðîâàííûé ìàññèâ:');

 PutArray (n,a);

end.

 

3. Âû÷èñëåíèå âñåõ ìèíîðîâ âòîðîãî ïîðÿäêà â êâàäðàòíîé ìàòðèöå.

program minor2_count;

const size=10;

type Matrix= array [1..size,1..size]

 of real;

 

function minor2 (n:integer;

   i,j,l,k:integer; a:matrix):real;

begin

 minor2:=a[i,j]*a[l,k]-a[l,j]*a[i,k];

end;

 

procedure Input2 (var n:integer;

  maxn:integer; var a:matrix);

var i,j:integer;

begin

 repeat

  writeln;

  write ('Ââåäèòå ðàçìåðíîñòü ìàòðèöû ',

   '(îò 2 äî ',size,' âêëþ÷èòåëüíî):');

  readln (n);

 until (n>1) and (n<size);

 for i:=1 to n do begin

  writeln;

  write ('Ââåäèòå ',i,' ñòðîêó ìàòðèöû:');

  for j:=1 to n do read (a[i,j]);

 end;

end;

 

var i,j,k,l,n:integer;

    s:real;

    a:matrix;

begin

 Input2 (n,size,a);

 for i:=1 to n do

 for j:=1 to n do

 for l:=i+1 to n do

 for k:=j+1 to n do begin

  s:=minor2 (n,i,j,l,k,a);

  writeln;

  writeln ('Ìèíîð [',i,',',j,']');

  writeln ('   [',l,',',k,']=',s:8:3);

 end;

end.

 

4. Ó÷åáíàÿ áàçà äàííûõ "Ñòóäåíòû".

type student = record

 {Îïðåäåëåíèå çàïèñè "Ñòóäåíò"}

 name:string[20];

 balls:array [1..4] of integer;

end;

const filename='students.dat';

                {Èìÿ áàçû äàííûõ}

var s:student; {Òåêóùàÿ çàïèñü}

    f:file of student; {Ôàéë áàçû äàííûõ}

    kol,current:longint;

    {Êîëè÷åñòâî çàïèñåé è òåêóùàÿ çàïèñü}

    size:integer; {Ðàçìåð çàïèñè â áàéòàõ}

    st1,st2:string;

     {Áóôåðíûå ñòðîêè äëÿ äàííûõ}

 

procedure Warning (msg:string);

 {Ñîîáùåíèå-ïðåäóïðåæäåíèå}

begin

 writeln; writeln (msg);

 write ('Íàæìèòå Enter äëÿ ïðîäîëæåíèÿ');

 reset (input); readln;

end;

 

procedure out; {Çàêðûòèå áàçû è âûõîä}

begin

 close (f); halt;

end;

 

procedure Error (msg:string);

{Ñîîáùåíèå îá îøèáêå + âûõîä èç ïðîãðàììû}

begin

 writeln; writeln (msg);

 write ('Íàæìèòå Enter äëÿ âûõîäà');

 reset (input); readln; out;

end;

 

procedure open; {îòêðûòü, ïðè íåîáõîäèìîñòè

  ñîçäàòü ôàéë çàïèñåé}

begin

 assign (f,filename);

 repeat

  {$I-} reset (f); {$I+}

  if IoResult <> 0 then begin

   Warning

  ('Íå ìîãó îòêðûòü ôàéë '+filename+

   '... Áóäåò ñîçäàí íîâûé ôàéë');

   {$I-}rewrite (f);{$I+}

   if IoResult <> 0 then

    Error ('Íå ìîãó ñîçäàòü ôàéë! '+

    'Ïðîâåðüòå ïðàâà è ñîñòîÿíèå äèñêà');

  end

  else break;

 until false;

end;

 

procedure getsize (var kol:longint;

  var size:integer);

{Âåðíåò òåêóùåå ÷èñëî çàïèñåé kol è

 ðàçìåð çàïèñè â áàéòàõ size}

begin

 reset (f);

 size:=sizeof(student);

 if filesize(f)=0 then kol:=0

 else begin

  seek(F, Filesize(F));

  kol:=filepos (f);

 end;

end;

 

function getname (s:string):string;

{Ïåðåâîäèò ñòðîêó â âåðõíèé ðåãèñòð

 c ó÷åòîì êèðèëëèöû DOS}

var i,l,c:integer;

begin

 l:=length(s);

 for i:=1 to l do begin

  c:=ord(s[i]);

  if (c>=ord('à')) and (c<=ord('ï'))

   then c:=c-32

  else if (c>=ord('ð')) and (c<=ord('ÿ'))

   then c:=c-80;

  s[i]:=Upcase(chr(c));

 end;

 getname:=s;

end;

 

procedure prints;

{Âñïîìîãàòåëüíàÿ ïðîöåäóðà ïå÷àòè -

 ïå÷àòàåò òåêóùóþ s}

var i:integer;

begin

 write (getname(s.name),': ');

 for i:=1 to 4 do begin

  write (s.balls[i]);

  if i<4 then write (',');

 end;

 writeln;

end;

 

procedure print (n:integer); {Âûâåñòè

 çàïèñü íîìåð n (ñ ïåðåõîäîì ê íåé)}

begin

 seek (f,n-1); read (f,s); prints;

end;

 

procedure go (d:integer); {Ïåðåéòè íà d

  çàïèñåé ïî áàçå}

begin

 writeln;

 write ('Òåêóùàÿ çàïèñü: ');

 if current=0 then writeln ('íåò')

 else begin

  writeln (current);

  print (current);

 end;

 current:=current+d;

 if current<1 then begin

  Warning ('Íå ìîãó ïåðåéòè íà çàïèñü '+

   'ñ íîìåðîì ìåíüøå 1');

  if kol>0 then current:=1

  else current:=0;

 end

 else if current>kol then begin

  str (kol,st1);

  Warning ('Íå ìîãó ïåðåéòè íà çàïèñü '+

   'ñ íîìåðîì áîëüøå '+st1);

  current:=kol;

 end

 else begin

  writeln ('Íîâàÿ çàïèñü: ',current);

  print (current);

 end;

end;

 

procedure search;

 {Ïîèñê çàïèñè â áàçå ïî ôàìèëèè}

var i,found,p:integer;

begin

 if kol<1 then

  Warning ('Áàçà ïóñòà! Èñêàòü íå÷åãî')

 else begin

  writeln;

  write ('Ââåäèòå ôàìèëèþ (÷àñòü ôàìèëèè)',

   ' äëÿ ïîèñêà, ðåãèñòð ñèìâîëîâ ëþáîé:');

  reset (input);

  readln (st1);

  st1:=getname(st1);

  seek (f,0);

  found:=0;

  for i:=0 to kol-1 do begin

   read (f,s);

   p:=pos(st1,getname(s.name));

   if p>0 then begin

    writeln ('Çàïèñü íîìåð ',i+1);

    prints;

    found:=found+1;

    if found mod 10 = 0 then

     Warning ('Ïàóçà...');

    {Ïàóçà ïîñëå âûâîäà 10 íàéäåííûõ}

   end;

  end;

  if found=0 then

    Warning ('Íè÷åãî íå íàéäåíî...');

 end;

end;

 

procedure add;

  {Äîáàâèòü çàïèñü â êîíåö áàçû}

var i,b:integer;

begin

 repeat

  writeln;

  write ('Ââåäèòå ôàìèëèþ ñòóäåíòà ',

   'äëÿ äîáàâëåíèÿ:');

  reset (input);

  readln (st1);

  if length(st1)<1 then begin

   Warning ('Ñëèøêîì êîðîòêàÿ ñòðîêà!'+

    ' Ïîâòîðèòå ââîä');

   continue;

  end

  else if length(st1)>20 then begin

   Warning ('Ñëèøêîì äëèííàÿ ñòðîêà! '+

    'Áóäåò îáðåçàíà äî 20 ñèìâîëîâ');

   st1:=copy (st1,1,20);

  end;

  s.name:=st1;

  break;

 until false;

 for i:=1 to 4 do begin

  repeat

   writeln; {ñëåäîâàëî áû ïðåäóñìîòðåòü

       âîçìîæíîñòü ââîäà íå âñåõ îöåíîê}

   write ('Ââåäèòå îöåíêó ',i,' èç 4:');

   {$I-}readln (b);{$I+}

   if (IoResult<>0) or (b<2) or (b>5)

   then begin

    Warning ('Íåâåðíûé ââîä! Îöåíêà - '+

      'ýòî ÷èñëî îò 2 äî 5! Ïîâòîðèòå.');

    continue;

   end

   else begin

    s.balls[i]:=b; break;

   end;

  until false;

 end;

 seek (f,filesize(f));

 write (f,s); kol:=kol+1; current:=kol;

end;

 

procedure delete; {Óäàëåíèå òåêóùåé çàïèñè}

var f2:file of student; i:integer;

begin

 if kol<1 then

  Warning ('Áàçà ïóñòà! Óäàëÿòü íå÷åãî')

 else begin

  assign (f2,'students.tmp');

  {$I-}rewrite(f2);{$I+}

  if IoResult<>0 then begin

   Warning ('Íå ìîãó îòêðûòü íîâûé ôàéë '+

     'äëÿ çàïèñè!'+#13+#10+

    ' Îïåðàöèÿ íåâîçìîæíà. Ïðîâåðüòå '+

      'ïðàâà äîñòóïà è òåêóùèé äèñê.');

   Exit;

  end;

  seek (f,0);

  for i:=0 to kol-1 do begin

   if i+1<>current then begin

   {ïåðåïèñûâàåì âñå çàïèñè, êðîìå òåêóùåé}

    read (f,s); write (f2,s);

   end;

  end;

  close (f); {çàêðûâàåì èñõîäíóþ ÁÄ}

  erase (f); {Óäàëÿåì èñõîäíóþ ÁÄ,

    ïðîâåðêà IoResult îïóùåíà!}

  rename (f2,filename); {Ïåðåèìåíîâûâàåì f2

    â èìÿ ÁÄ}

  close (f2); {Çàêðûâàåì

       ïåðåèìåíîâàííûé f2}

  open; {Ñâÿçûâàåì ÁÄ ñ ïðåæíåé

         ôàéëîâîé ïåðåìåííîé f}

  kol:=kol-1;

  if current>kol then current:=kol;

 end;

end;

 

procedure sort;

 {ñîðòèðîâêà áàçû ïî ôàìèëèè ñòóäåíòà}

var i,j:integer;

 s2:student;

begin

 if kol<2 then

  Warning ('Â áàçå íåò 2-õ çàïèñåé!'+

   ' Ñîðòèðîâàòü íå÷åãî')

 else begin

  for i:=0 to kol-2 do begin

   {Îáû÷íàÿ ñîðòèðîâêà}

   seek (f,i); {òîëüêî â ó÷åáíûõ öåëÿõ -

               ðàáîòàåò íåîïòèìàëüíî}

   read (f,s);{è ìíîãî îáðàùàåòñÿ ê äèñêó!}

   for j:=i+1 to kol-1 do begin

    seek (f,j);

    read (f,s2);

    if getname(s.name)>getname(s2.name)

    then begin

     seek (f,i); write (f,s2);

     seek (f,j); write (f,s);

     s:=s2;  {Ïîñëå ïåðåñòàíîâêè â s óæå

              íîâàÿ çàïèñü!}

    end;

   end;

  end;

 end;

end;

 

procedure edit; {ðåäàêòèðîâàíèå çàïèñè

   íîìåð current}

var i,b:integer;

begin

 if (kol<1) or (current<1) or (current>kol)

  then  Warning ('Íåâåðíûé íîìåð '+

  'òåêóùåé çàïèñè! Íå ìîãó ðåäàêòèðîâàòü')

 else begin

  seek (f,current-1);

  read (f,s);

  repeat

   writeln ('Çàïèñü íîìåð ',current);

   writeln ('Âûáåðèòå äåéñòâèå:');

   writeln ('1. Ôàìèëèÿ (',s.name,')');

   for i:=1 to 4 do

    writeln (i+1,'. Îöåíêà ',i,

     ' (',s.balls[i],')');

   writeln ('0. Çàâåðøèòü ðåäàêòèðîâàíèå');

   reset (input);

   {$I-}readln (b);{$I+}

   if (IoResult<>0) or (b<0) or (b>5) then

    Warning ('Íåâåðíûé ââîä! Ïîâòîðèòå')

   else begin

    if b=1 then begin

     write ('Ââåäèòå íîâóþ ôàìèëèþ:');

     {äëÿ ïðîñòîòû çäåñü íåò}

     {ïðîâåðîê êîððåêòíîñòè}

      reset (input); readln (s.name);

    end

    else if b=0 then break

    else begin

     write ('Ââåäèòå íîâóþ îöåíêó:');

     reset (input); readln (s.balls[b-1]);

    end;

   end;

  until false;

  seek (f,current-1);

  {Ïèøåì, äàæå åñëè çàïèñü íå ìåíÿëàñü -}

  write (f,s); {â ðåàëüíûõ ïðîåêòàõ

                òàê íå äåëàþò}

 end;

end;

 

procedure menu; {Óïðàâëåíèå ãëàâíûì ìåíþ è

   âûçîâ ïðîöåäóð}

var n:integer;

begin

 repeat

  writeln;

  writeln ('Âûáåðèòå îïåðàöèþ:');

  writeln ('1 - âïåðåä');

  writeln ('2 - íàçàä');

  writeln ('3 - ïîèñê ïî ôàìèëèè');

  writeln ('4 - äîáàâèòü â êîíåö');

  writeln ('5 - óäàëèòü òåêóùóþ');

  writeln ('6 - ñîðòèðîâàòü ïî ôàìèëèè');

  writeln ('7 - íà÷àëî áàçû');

  writeln ('8 - êîíåö áàçû');

  writeln ('9 - èçìåíèòü òåêóùóþ');

  writeln ('0 - âûõîä');

  reset (input);

  {$I-}read (n);{$I+}

  if (IoResult<>0) or (n<0) or (n>9)

  then begin

   Warning ('Íåâåðíûé ââîä!');

   continue;

  end

  else break;

 until false;

 case n of

  1: go (1);

  2: go (-1);

  3: search;

  4: add;

  5: delete;

  6: sort;

  7: go (-(current-1));

  8: go (kol-current);

  9: edit;

  0: out;

 end;

end;

 

begin {Ãëàâíàÿ ïðîãðàììà}

 open;

 getsize (kol,size);

 str(kol,st1);

 str(size,st2);

 writeln;

 writeln('==============================');

 writeln('Ó÷åáíàÿ áàçà äàííûõ "Ñòóäåíòû"');

 writeln('==============================');

 Warning ('Ôàéë '+FileName+

  ' îòêðûò'+#13+#10+

  '×èñëî çàïèñåé='+st1+#13+#10+

  'Ðàçìåð çàïèñè='+st2+#13+#10);

  {+#13+#10 - äîáàâèòü ê ñòðîêå ñèìâîëû

    âîçâðàòà êàðåòêè è ïåðâîäà ñòðîêè}

 if kol=0 then current:=0

 else current:=1;

 repeat

  menu;

 until false;

end.

 

5. Ïðîãðàììà ñîäåðæèò êîäû ÷àñòî èñïîëüçóåìûõ êëàâèø è ïå÷àòàåò èõ íàçâàíèÿ.

uses crt;

const ESC=#27; ENTER=#13; F1=#59; 

  F10=#68; TAB=#9;  SPACE=#32;

  UP=#72;  DOWN=#80; LEFT=#75; RIGHT=#77;

  HOME=#71; END_=#79;

  PAGE_UP=#73; PAGE_DN=#81;

var ch:char;

begin

 clrscr;

 repeat

  ch:=Upcase(readkey);

  case ch of

   'A'..'z': write ('Letter');

   SPACE: write ('SPACE');

   ENTER: write ('ENTER');

   TAB: write ('TAB');

   #0: begin

    ch:=readkey;

    case ch of

     F1: write ('F1');

     F10: write ('F10');

     LEFT: write ('LEFT');

     RIGHT: write ('RIGHT');

     UP: write ('UP');

     DOWN: write ('DOWN');

     HOME: write ('HOME'); 

     END_: write ('END');

     PAGE_UP: write ('PgUp');

     PAGE_DN: write ('PgDn');

    end;

   end;

   else begin

   end;

  end;

 until ch=Esc;

end.

 

6.1. Ïðîãðàììà ïîçâîëÿåò äâèãàòü ïî òåêñòîâîìó ýêðàíó "ïðèöåë" ñ ïîìîùüþ êëàâèø ñî ñòðåëêàìè.

uses crt;

{$V-} {îòêëþ÷èëè ñòðîãèé êîíòðîëü òèïîâ}

const ESC=#27; UP=#72;  DOWN=#80;

      LEFT=#75; RIGHT=#77;

var ch:char;

 

procedure Draw (x,y:integer;mode:boolean);

{mode îïðåäåëÿåò, íàðèñîâàòü èëè ñòåðåòü}

var sprite:array [1..3] of string [3];

 {"ïðèöåë", çàäàííûé ìàññèâîì sprite}

 i:integer;

begin

 sprite[1]:='/|\';

 sprite[2]:='-=-';

 sprite[3]:='\|/';

 if mode=true then textcolor (White)

 else textcolor (Black);

 for i:=y to y+2 do begin

  gotoxy (x,i); write (sprite[i-y+1]);

 end;

 gotoxy (x+1,y+1);

end;

 

procedure status (n:integer; s:string);

{ðèñóåò ñòðîêó ñòàòóñà

  âíèçó èëè ââåðõó ýêðàíà}

begin

 textcolor (Black); textbackground (White);

 gotoxy (1,n); write (' ':79);

 gotoxy (2,n); write (s);

 textcolor (White); textbackground (Black);

end;

 

var x,y:integer;

 

begin

 textMode (cO80);

 status (1,'Ïðèìåð óïðàâëåíèÿ äâèæåíèåì!');

 status(25,'Ñòðåëêè-óïðàâëåíèå;ESC-âûõîä');

 x:=10; y:=10;

 repeat

  Draw (x,y,true);

  ch:=Upcase(readkey);

  case ch of

   #0: begin

    ch:=readkey;

    Draw (x,y,false);

    case ch of

 LEFT:  if x>1 then x:=x-1;

 RIGHT: if x<77 then x:=x+1;

 UP:    if y>2 then y:=y-1;

 DOWN:  if y<22 then y:=y+1;

    end;

   end;

  end;

 until ch=ESC;

 clrscr;

end.

 

6.2. Ýòà âåðñèÿ ïðîãðàììû 6.1 ïîçâîëÿåò "ïðèöåëó" ïðîäîëæàòü äâèæåíèå äî òåõ ïîð, ïîêà îí íå íàòîëêíåòñÿ íà êðàé ýêðàíà.

uses crt;

{$V-}

const ESC=#27; UP=#72; DOWN=#80;

  LEFT=#75; RIGHT=#77;

const goleft=1; GoRight=2; goup=3;

  godown=4; gostop=0;

 {âîçìîæíûå íàïðàâëåíèÿ äâèæåíèÿ}

const myDelay=1000; {çàäåðæêà äëÿ Delay}

var ch:char; LastDir:integer;

{ïîñëåäíåå íàïðàâëåíèå äâèæåíèÿ}

 

procedure Draw (x,y:integer;mode:boolean);

var sprite:array [1..3] of string [3];

    i:integer;

begin

 sprite[1]:='/|\';

 sprite[2]:='-=-';

 sprite[3]:='\|/';

 if mode then textcolor (White)

 else textcolor (Black);

 for i:=y to y+2 do begin

  gotoxy (x,i);

  write (sprite[i-y+1]);

 end;

 gotoxy (x+1,y+1);

end;

 

procedure status (n:integer; s:string);

begin

 textcolor (Black); textbackground (White);

 gotoxy (1,n); write (' ':79);

 gotoxy (2,n); write (s);

 textcolor (White); textbackground (Black);

end;

 

var x,y:integer;

 

begin

 clrscr;

 status(1,'Óïðàâëåíèå äâèæåíèåì-2');

 status(25,'Ñòðåëêè-óïðàâëåíèå;ESC-âûõîä');

 x:=10; y:=10; LastDir:=goleft;

 repeat {áåñêîíå÷íûé öèêë ðàáîòû ïðîãðàììû}

  repeat {öèêë äî íàæàòèÿ êëàâèøè}

   Draw (x,y,true); Delay (myDelay);

   Draw (x,y,false);

   case LastDir of

    goLeft:

     if x>1 then Dec(x)

     else begin

      x:=1; LastDir:=gostop;

     end;

    GoRight:

     if x<77 then inc(x)

     else begin

      x:=77; LastDir:=gostop;

     end;

    goUp:

     if y>2 then Dec(y)

     else begin

      y:=2; LastDir:=gostop;

     end;

    goDown:

     if y<22 then inc(y)

     else begin

      y:=22; LastDir:=gostop;

     end;

   end;

  until keyPressed;

  {îáðàáîòêà íàæàòèÿ êëàâèøè}

  ch:=Upcase(readkey);

  case ch of

   #0: begin

    ch:=readkey;

    case ch of

     LEFT:  LastDir:=goLeft;

     RIGHT: LastDir:=GoRight;

     UP:    LastDir:=goUp;

     DOWN:  LastDir:=goDown;

    end;

   end;

   ESC: halt;

  end;

 until false;

end.

 

7. Äåìî-ïðîãðàììà äëÿ ñîçäàíèÿ íåñëîæíîãî äâóõóðîâíåâîãî ìåíþ ïîëüçîâàòåëÿ. Ïåðåîïðåäåëèâ ïîëüçîâàòåëüñêóþ ÷àñòü ïðîãðàììû, íà åå îñíîâå ìîæíî ñîçäàòü ñîáñòâåííûé êîíñîëüíûé èíòåðôåéñ.

uses crt; { Ãëîáàëüíûå äàííûå: }

const maxmenu=2; {êîëè÷åñòâî ìåíþ} 

  maxpoints=3; {ìàêñ. êîëè÷åñòâî ïóíêòîâ}

var x1,x2,y: array [1..maxmenu] of integer;

{x1,x2- íà÷àëî è êîíåö êàæäîãî ìåíþ,

 y- ñòðîêà íà÷àëà êàæäîãî ìåíþ}

 kolpoints, points: array [1..maxmenu] of

 integer;{Êîë-âî ïóíêòîâ è òåêóùèå ïóíêòû }

 text: array [1..maxmenu,1..maxpoints]

  of string[12]; { Íàçâàíèÿ ïóíêòîâ }

 txtcolor, textback, cursorback:integer;

  { Öâåòà òåêñòà, ôîíà, êóðñîðà}

 mainhelp:string[80]; { Ñòðîêà ïîìîùè }

 

procedure DrawMain (s:string); {Î÷èùàåò

   ýêðàí, ðèñóåò ñòðîêó ãëàâíîãî ìåíþ s }

begin   Window (1,1,80,25);

 textcolor (txtcolor); 

 textbackground (textback);

 clrscr; gotoxy (1,1); write (s);

end;

 

procedure DrawHelp (s:string);

 { Âûâîäèò ïîäñêàçêó s }

var i:integer; begin

 textcolor (txtcolor); 

 textbackground (textback); gotoxy (1,25);

 for i:=1 to 79 do write (' ');

 gotoxy (1,25); write (s);

end;

 

procedure doubleFrame (x1,y1,x2,y2:integer;

  Header: string);

{ Ïðîöåäóðà ðèñóåò äâîéíîé ðàìêîé îêíî }

var i,j: integer;

begin gotoxy (x1,y1);

write ('╔');

 for i:=x1+1 to x2-1 do write('═');

 write ('╗');

 for i:=y1+1 to y2-1 do begin

  gotoxy (x1,i);  write('║');

  for j:=x1+1 to x2-1 do write (' ');

  write('║');

 end;

 gotoxy (x1,y2);  write('╚');  

 for i:=x1+1 to x2-1 do write('═');

 write('╝');

 gotoxy (x1+(x2-x1+1-Length(Header))

  div 2,y1);

 write (Header); {Âûâîäèì çàãîëîâîê}

 gotoxy (x1+1,y1+1);

end;

 

procedure clearFrame (x1,y1,x2,y2:integer);

var i,j:integer;

begin textbackground (textback);

 for i:=y1 to y2 do begin

  gotoxy (x1,i);

  for j:=x1 to x2 do write (' ');

 end;

end;

 

procedure cursor (Menu,Point: integer;

 Action: boolean);{ Ïîäñâå÷èâàåò (åñëè

 Action=true) èëè ãàñèò ï. Point ìåíþ Menu}

begin textcolor (Txtcolor);

 if Action=true then

  textbackground (cursorBack)

 else textbackground (textBack);

 gotoxy (x1[Menu]+1,y[Menu]+Point);

 write (text[Menu][Point]);

end;

 

procedure DrawMenu (Menu:integer;

 Action: boolean);{Ðèñóåò ìåíþ ñ íîìåðîì

 Menu, åñëè Action=true, èíà÷å ñòèðàåò }

var i:integer;

begin

 if Action=true then textcolor (Txtcolor)

 else textcolor (textBack);

 textbackground (textBack);

 doubleFrame (x1[Menu], y[Menu], x2[Menu],

  y[Menu]+1+KolPoints[Menu],'');

 for i:=1 to KolPoints[Menu] do begin

  gotoxy (x1[Menu]+1, y[Menu]+i);

  writeln (text[Menu][i]);

 end;

end;

 

{×àñòü, îïðåäåëÿåìàÿ ïîëüçîâàòåëåì}

 

procedure Init; { Óñòàíîâêà ãëîáàëüíûõ

  äàííûõ è íà÷àëüíàÿ îòðèñîâêà }

begin

 txtcolor:=yELLOW; textback:=BLUE;

 cursorback:=LIGHTcyAN;

 kolpoints[1]:=2; kolpoints[2]:=1;

  {ïóíêòîâ â êàæäîì ìåíþ}

 points[1]:=1; points[2]:=1;

  {âûáðàí ïî óìîë÷àíèþ â êàæäîì ìåíþ}

 x1[1]:=1;  x2[1]:=9;  y[1]:=2;

 text[1,1]:='Çàïóñê'; text[1,2]:='Âûõîä ';

 x1[2]:=9;  x2[2]:=22; y[2]:=2;

 text[2,1]:='Î ïðîãðàììå';

 DrawMain ('Ôàéë   Ñïðàâêà');

 MainHelp:='ESC - Âûõîä èç ïðîãðàììû '+

 'ENTER - âûáîð ïóíêòà ìåíþ    '+

 'Ñòðåëêè - ïåðåìåùåíèå';

 DrawHelp(MainHelp);

end;

 

procedure Work; { Ðàáî÷àÿ ïðîöåäóðà }

var i,kol:integer; ch:char;

begin

 DrawHelp('Èäåò ðàñ÷åò...');

 { Ñòðîêà ñòàòóñà }

 textcolor (LIGHTGRAY);

 textbackground  (BLACK);

 { Âûáèðàåì öâåòà äëÿ ðàáîòû â îêíå }

 doubleFrame (2,2,78,24,' Ðàñ÷åò ');

 Window (3,3,77,23);

{Ñåêöèÿ äåéñòâèé, âûïîëíÿåìûõ ïðîãðàììîé}

 writeln;

 write ('Ââåäèòå ÷èñëî øàãîâ: ');

 {$I-}read (kol);{$I+}

 if IoResult<>0 then writeln

  ('Îøèáêà! Âû ââåëè íå ÷èñëî')

 else if kol>0 then begin

  for i:=1 to kol do

    writeln ('Âûïîëíÿåòñÿ øàã ',i);

  writeln ('Âñå ñäåëàíî!');

 end

 else writeln ('Îøèáêà! ×èñëî áîëüøå 0');

{Âîññòàíîâëåíèå îêíà è âûõîä}

 Window (1,1,80,25);

 DrawHelp('Íàæìèòå ëþáóþ êëàâèøó...');

 ch:=readkey;

 clearFrame (2,2,78,24); { Ñòèðàåì îêíî }

end;

 

procedure Out; { Î÷èñòêà ýêðàíà è âûõîä}

begin

 textcolor (LIGHTGRAY);

 textbackground (BLACK); clrscr; halt(0);

end;

 

procedure Help; {Îêíî ñ èíôîðìàöèåé}

var ch:char;

begin

 textcolor (Txtcolor);

 textbackground (textback);

 doubleFrame (24,10,56,13,' Î ïðîãðàììå ');

 DrawHelp ('Íàæìèòå êëàâèøó...');

 gotoxy (25,11);

 writeln(' Äåìîíñòðàöèÿ ïðîñòåéøåãî ìåíþ');

 gotoxy (25,12);

 write (  '  Íîâîñèáèðñê, ÍÃÀÑÓ');

 ch:=readkey;

 clearFrame (24,10,58,13);

end;

 

procedure command (Menu,Point:integer);

{Âûçûâàåò ïðîöåäóðû ïîñëå âûáîðà â ìåíþ }

begin

 if Menu=1 then begin

  if Point=1 then Work

  else if Point=2 then Out;

 end

 else begin

  if Point=1 then Help;

 end;

end;

{Êîíåö ÷àñòè ïîëüçîâàòåëÿ }

 

procedure MainMenu (Point,

 HorMenu:integer); { Ïîääåðæèâàåò ñèñòåìó

  îäíîóðîâíåâûõ ìåíþ }

var ch: char; funckey:boolean;

begin

 Points[HorMenu]:=Point;

 DrawMenu (HorMenu,true);

repeat

 cursor (HorMenu,Points[HorMenu],true);

 ch:=readkey;

 cursor (HorMenu,Points[HorMenu],false);

 if ch=#0 then begin

  funckey:=true;  ch:=readkey;

 end

 else funckey:=false;

 if funckey=true then begin

  ch:=Upcase (ch);

  if ch=#75 then begin { Ñòðåëêà âëåâî }

   DrawMenu (HorMenu,false);

   HorMenu:=HorMenu-1;

   if (HorMenu<1) then HorMenu:=maxMenu;

   DrawMenu (HorMenu,true);

  end

  else if ch=#77 then begin

   { Ñòðåëêà âïðàâî }

   DrawMenu (HorMenu,false);

   HorMenu:=HorMenu+1;

   if (HorMenu>maxMenu) then HorMenu:=1;

   DrawMenu (HorMenu,true);

  end

  else if ch=#72 then begin

   { Ñòðåëêà ââåðõ }

   Points[HorMenu]:=Points[HorMenu]-1;

   if Points[HorMenu]<1 then

    Points[HorMenu]:=Kolpoints[HorMenu];

  end

  else if ch=#80 then begin

   { Ñòðåëêà âíèç }

   Points[HorMenu]:=Points[HorMenu]+1;

   if (Points[HorMenu]>KolPoints[HorMenu])

   then Points[HorMenu]:=1;

  end;

 end

 else if ch=#13 then begin

  { Êëàâèøà ENTER }

  DrawMenu (HorMenu,false);

  command (HorMenu,Points[HorMenu]);

  DrawMenu (HorMenu,true);

  DrawHelp (MainHelp);

 end;

until (ch=#27) and (funckey=false);

{ Ïîêà íå íàæàòà êëàâèøà ESC }

end;

{ Îñíîâíàÿ ïðîãðàììà }

begin

 Init;

 MainMenu (1,1);

 Out;

end.

 

8. Ïðîñòåéøèé "ãåíåðàòîð" ïðîãðàììû íà Ïàñêàëå. Èç âõîäíîãî ôàéëà, ñîäåðæàùåãî òåêñò, ãåíåðèðóåòñÿ ïðîãðàììà äëÿ ëèñòàíèÿ ýòîãî òåêñòà.

program str2Pas;

uses crt; label 10,20;

var ch:char;str:string;

 I,J,Len,count:word; InFile,OutFile:text;

 

procedure Error (ErNum:char);

begin

 case ErNum of

  #1: writeln

   ('Çàïóñêàéòå ñ 2 ïàðàìåòðàìè -',#13,#10,

'èìåíàìè âõîäíîãî è âûõîäíîãî ôàéëà.',

#13,#10,

'Âî âõîäíîì ôàéëå ñîäåðæèòñÿ òåêñò',

#13,#10,

'â îáû÷íîì ASCII-ôîðìàòå,',#13,#10,

'â âûõîäíîì áóäåò ïðîãðàììà íà Ïàñêàëå');

  #2:

  writeln

  (' Íå ìîãó îòêðûòü âõîäíîé ôàéë!');

  #3:

  writeln

  (' Íå ìîãó îòêðûòü âûõîäíîé ôàéë!');

  else writeln (' Íåèçâåñòíàÿ îøèáêà!');

 end;

 halt;

end;

 

begin

 if Paramcount<>2 then Error (#1);

 assign (InFile,Paramstr(1));

 reset (InFile);

 if (IoResult<>0) then Error (#2);

 assign (OutFile,Paramstr(2));

 rewrite (OutFile);

 if (IoResult<>0) then Error (#3);

{ Âïèñàòü çàãîëîâîê ïðîãðàììû }

 writeln (OutFile,'uses crt;');

 write (OutFile,'const colstr=');

{ Óçíàòü ÷èñëî ñòðîê òåêñòà }

 count:=0;

 while not Eof (InFile) do begin

  readLn (InFile,str);

  count:=count+1;

 end;

 reset (InFile);

 writeln (OutFile,count,';');

 { Ñëåäóþùèé ñåãìåíò ïðîãðàììû: }

 writeln (OutFile,'var ch:char;');

 writeln (OutFile,'    List:boolean;');

 writeln (OutFile,

  '    I,start,endstr:word;');

 writeln (OutFile,

 '    ptext:array [1..colstr] of string;');

 writeln (OutFile,'begin');

 { Ñòðîêè ëèñòàåìîãî òåêñòà: }

 for I:=1 to count do begin

  Len:=0;

  repeat

   if (Eof (InFile)=true) then goto 10;

   read (InFile,ch);

   if ch=#39 then begin

    Len:=Len+1; str[Len]:=#39;

    Len:=Len+1; str[Len]:=#39;

   end

   else if ch=#13 then begin

    read (InFile,ch);

    if (ch=#10) then goto 10

    else goto 20;

   end

   else begin

20:

    Len:=Len+1; str[Len]:=ch;

   end;

  until false;

10:

  write (OutFile,' ptext[',I,']:=''');

  for J:=1 to Len do

    write (OutFile,str[J]);

  writeln (OutFile,''';');

 end;

 { Ñåãìåíò ïðîãðàììû }

 writeln (OutFile,' textcolor (YELLOW);');

 writeln (OutFile,

  ' textbackground (Blue);');

 writeln (OutFile,

  ' List:=true; start:=1;');

 { Ïîñëåäíÿÿ ñòðîêà íà ýêðàíå: }

 if (count>25) then

  writeln (OutFile,' endstr:=25;')

 else writeln (OutFile,' endstr:=colstr;');

 writeln (OutFile,' repeat');

 writeln (OutFile,

 '  if (List=true) then begin');

 writeln (OutFile,'   clrscr;');

 writeln (OutFile,

  '   for I:=start to endstr-1 do ',

  'write (ptext[I],#13,#10);');

 writeln (OutFile,

 '   write (ptext[endstr]);');

 writeln (OutFile,'   List:=false;');

 writeln (OutFile,'  end;');

 writeln (OutFile,'  ch:=readkey;');

 writeln (OutFile,

  '  if ch= #0 then begin');

 writeln (OutFile,'   ch:=readkey;');

 writeln (OutFile,'   case ch of');

 writeln (OutFile,'    #72: begin');

 writeln (OutFile,

  '     if start>1 then begin');

 writeln (OutFile,'      start:=start-1;');

 writeln (OutFile,

  '      endstr:=endstr-1;');

 writeln (OutFile,'      List:=true;');

 writeln (OutFile,'     end;');

 writeln (OutFile,'    end;');

 writeln (OutFile,'    #80: begin');

 writeln (OutFile,

  '     if endstr<colstr then begin');

 writeln (OutFile,'      start:=start+1;');

 writeln (OutFile,

  '      endstr:=endstr+1;');

 writeln (OutFile,'      List:=true;');

 writeln (OutFile,'     end;');

 writeln (OutFile,'    end;');

 { Ëèñòàíèå PgUp è PgDn }

 if (count>25) then begin

  writeln (OutFile,'    #73: begin');

  writeln (OutFile,

  '     if start>1 then begin');

  writeln (OutFile,

  '      start:=1; endstr:=25;');

  writeln (OutFile,'      List:=true;');

  writeln (OutFile,'     end;');

  writeln (OutFile,'    end;');

  writeln (OutFile,'    #81: begin');

  writeln (OutFile,

   '     if endstr<colstr then begin');

  writeln (OutFile,

'      start:=colstr-24; endstr:=colstr;');

  writeln (OutFile,'      List:=true;');

  writeln (OutFile,'     end;');

  writeln (OutFile,'    end;');

 end;

 { Çàêëþ÷èòåëüíûé ñåãìåíò }

 writeln (OutFile,'    else begin  end;');

 writeln (OutFile,'   end;');

 writeln (OutFile,'  end');

 writeln (OutFile,'  else begin');

 writeln (OutFile,'   case ch of');

 writeln (OutFile,'    #27: begin');

 writeln (OutFile,

 '     textcolor (LightGray);');

 writeln (OutFile,

  '     textbackground (Black);');

 writeln (OutFile,'     clrscr;');

 writeln (OutFile,'     halt;');

 writeln (OutFile,'    end;');

 writeln (OutFile,'    else begin');

 writeln (OutFile,'    end;');

 writeln (OutFile,'   end;');

 writeln (OutFile,'  end;');

 writeln (OutFile,' until false;');

 writeln (OutFile,'end.');

 close (InFile); close (OutFile);

 writeln ('OK.');

end.

 

9. Øàáëîí ïðîãðàììû äëÿ ðàáîòû ñ ìàòðèöàìè è òåêñòîâûìè ôàéëàìè.

program Files;{ Ïðîãðàììà äåìîíñòðèðóåò

 ðàáîòó ñ òåêñòîâûìè ôàéëàìè è ìàòðèöàìè }

const rows=10; cols=10;

type matrix=array [1..rows,1..cols]

 of real;

var f1,f2:text; a,b:matrix;

 Name1,Name2:string; n,m:integer;

 

procedure Error (msg:string);

begin

 writeln; writeln (msg);

 writeln ('Íàæìèòå Enter äëÿ âûõîäà');

 reset (Input); readln; halt;

end;

 

procedure readDim (var f:text;

 var n,m:integer);{ ×èòàåò èç ôàéëà f

 ðàçìåðíîñòè ìàòðèöû: n - ÷èñëî ñòðîê,

 m - ÷èñëî ñòîëáöîâ. Åñëè n<0 èëè n>rows

(÷èñëî ñòðîê) èëè m<0 èëè m>cols (÷èñëî

 ñòîëáöîâ), ïðåðâåò ðàáîòó. }

var s:string;

begin

 {$I-}read (f,n);{$I+}

 if (IoResult<>0) or (n<0) or (n>rows)

 then begin

  str (rows,s);

  Error ('Íåâåðíîå ÷èñëî ñòðîê '+

  'â ôàéëå äàííûõ!'+#13+#10+

  'äîëæíî áûòü îò 1 äî '+s);

 end;

 {$I-}read (f,m);{$I+}

 if (IoResult<>0) or (m<0) or (m>cols)

 then begin

  str (cols,s);

  Error ('Íåâåðíîå ÷èñëî ñòîëáöîâ '+

   'â ôàéëå äàííûõ!'+#13+#10+

   'äîëæíî áûòü îò 1 äî '+s);

 end;

end;

 

procedure readMatrix (var f:text;

  n,m:integer; var a:matrix);

{ ×èòàåò èç ôàéëà f ìàòðèöó a

   ðàçìåðíîñòüþ n*m }

var i,j:integer; er:boolean;

begin

 er:=false;

 for i:=1 to n do

 for j:=1 to m do begin

  {$I-}read (f,a[i,j]);{$I+}

  if IoResult<>0 then begin

   er:=true; a[i,j]:=0;

  end;

 end;

 if er=true then begin

  writeln;

  writeln

  (' ïðî÷èòàííûõ äàííûõ åñòü îøèáêè!');

  writeln ('Íåâåðíûå ýëåìåíòû ìàòðèöû',

   ' çàìåíåíû íóëÿìè');

 end;

end;

 

procedure writeMatrix (var f:text;

 n,m:integer; var a:matrix);

{ Ïèøåò â ôàéë f ìàòðèöó a[n,m] }

var i,j:integer;

begin

 for i:=1 to n do begin

  for j:=1 to m do write (f,a[i,j]:11:4);

  writeln (f);

 end;

end;

 

procedure Proc1 (n,m:integer;

  var a,b:matrix);

{ Ìàòðèöó a[n,m] ïèøåò â ìàòðèöó b[n,m],

  ìåíÿÿ çíàêè ýëåìåíòîâ }

var i,j:integer;

begin

  for i:=1 to n do

  for j:=1 to m do b[i,j]:=-a[i,j]

end;

 

begin

 if Paramcount<1 then begin

  writeln ('Èìÿ ôàéëà äëÿ ÷òåíèÿ:');

  readLn (Name1);

 end

 else Name1:=Paramstr(1);

 if Paramcount<2 then begin

  writeln ('Èìÿ ôàéëà äëÿ çàïèñè:');

  readLn (Name2);

 end

 else Name2:=Paramstr(2);

 assign (f1,Name1);

 {$I-}reset (f1);{$I+}

 if IoResult<>0 then

  Error ('Íå ìîãó îòêðûòü '+Name1+

 ' äëÿ ÷òåíèÿ');

 assign (f2,Name2);

{$I-}rewrite (f2);{$I+}

 if IoResult<>0 then

  Error ('Íå ìîãó îòêðûòü '+Name2+

  ' äëÿ çàïèñè');

 readDim (f1,n,m);

 readMatrix (f1,n,m,a);

 Proc1 (n,m,a,b);

 writeMatrix (f2,n,m,b);

 close (f1); close (f2);

end.

 

10. Ïîäñ÷åò êîëè÷åñòâà äíåé îò ââåäåííîé äàòû äî ñåãîäíÿøíåãî äíÿ.

program Days;

uses Dos;

const mondays: array [1..12] of integer =

(31,28,31, 30,31,30, 31,31,30, 31,30,31);

var d,d1,d2,m1,m2,y1,y2:word;

 

function Leapyear (year:word):boolean;

begin

 if (year mod 4 =0) and (year mod 100 <>0)

 or (year mod 400 =0) then Leapyear:=true

 else Leapyear:=false;

end;

 

function correctDate

  (day,mon,year:integer):boolean;

var maxday:integer;

begin

 if (year<0) or (mon<1) or (mon>12) or

  (day<1) then correctDate:=false

 else begin

  maxday:=mondays[mon];

  if (Leapyear (year)=true) and (mon=2)

  then maxday:=29;

  if (day>maxday) then correctDate:=false

  else correctDate:=true;

 end;

end;

 

function KolDays (d1,m1,d2,m2,y:word):word;

var i,f,s:word;

begin

 s:=0;

 if m1=m2 then KolDays:=d2-d1

 else for i:=m1 to m2 do begin

  f:=mondays[i];

  if (Leapyear (y)=true) and (i=2)

  then f:=f+1;

  if i=m1 then s:=s+(f-d1+1)

  else if i=m2 then s:=s+d2

  else s:=s+f;

  KolDays:=s;

 end;

end;

 

function countDays (day1, mon1, year1,

  day2, mon2, year2:word):word;

var f,i:word;

begin

 f:=0;

 if year1=year2 then countDays:=

  KolDays (day1, mon1, day2, mon2, year1)

 else for i:=year1 to year2 do begin

  if i=year1 then f:=

    KolDays (day1, mon1, 31, 12, year1)

  else if i=year2 then f:=f+

    KolDays (1,1,day2,mon2,year2)-1

  else f:=f+KolDays (1,1,31,12,i);

  countDays:=f;

 end;

end;

 

begin

 getdate (y2,m2,d2,d);

 writeln ('Ãîä Âàøåãî ðîæäåíèÿ?');

 readln (y1);

 writeln ('Ìåñÿö Âàøåãî ðîæäåíèÿ?');

 readln (m1);

 writeln ('Äåíü Âàøåãî ðîæäåíèÿ?');

 readln (d1);

 if correctDate (d1,m1,y1)=false then begin

  writeln ('Íåäîïóñòèìàÿ äàòà!'); halt;

 end;

 if (y2<y1) or   ( (y2=y1) and

    ( (m2<m1) or ( (m2=m1) and (d2<d1))))

 then begin writeln ('Ââåäåííàÿ äàòà',

  ' ïîçäíåå ñåãîäíÿøíåé!');    halt;

 end;

 d:=countDays (d1,m1,y1,d2,m2,y2);

 writeln ('Êîëè÷åñòâî äíåé= ',d);

end.

 

11.1. Èñõîäíûé òåêñò ìîäóëÿ äëÿ ïîääåðæêè ìûøè.

unit Mouse;

{Ïðèìåðû èñïîëüçîâàíèÿ -

 ñì. mousetst.pas â ãðàôèêå,

 mousetxt.pas â òåêñòîâîì ðåæèìå 80*25}

interface

var   MousePresent:boolean;

function MouseInit(var nb:integer):boolean;

{ Èíèöèàëèçàöèÿ ìûøè - âûçûâàòü ïåðâîé.

  Âåðíåò true, åñëè ìûøü îáíàðóæåíà }

procedure Mouseshow; {Ïîêàçàòü êóðñîð ìûøè}

procedure MouseHide; {Ñêðûòü êóðñîð ìûøè}

procedure Mouseread(var x,y,bMask:integer);

{Ïðî÷èòàòü ïîçèöèþ ìûøè.

 Âåðíåò ÷åðåç x,y êîîðäèíàòû êóðñîðà

 (äëÿ òåêñòîâîãî ðåæèìà ñì. ïðèìåð),

 ÷åðåç bmask - ñîñòîÿíèå êíîïîê

(0-îòïóùåíû,1-íàæàòà ëåâàÿ,2-íàæàòà ïðàâàÿ,

 3-íàæàòû îáå) }

procedure MousesetPos(x,y:word);

 {Ïîñòàâèòü êóðñîð â óêàçàííóþ ïîçèöèþ}

procedure Mouseminxmaxx(minx,maxx:integer);

 {Óñòàíîâèòü ãðàíèöû ïåðåìåùåíèÿ ïî x}

procedure Mouseminymaxy(miny,maxy:integer);

 {Óñòàíîâèòü ãðàíèöû ïåðåìåùåíèÿ ïî y}

procedure setVideoPage(Page:integer);

 {Óñòàíîâèòü íóæíóþ âèäåîñòðàíèöó}

procedure GetVideoPage(var Page:integer);

 {Ïîëó÷èòü íîìåð âèäåîñòðàíèöû}

function MouseGetb(bMask:word; var count,

 Lastx, Lasty:word):word;

procedure MousekeyPreset

 (var key,sost,x,y:integer);

 

implementation

uses Dos;

 

var   r: registers;

      Mi:pointer;

 

function MouseInit(var nb:integer):boolean;

begin

 if MousePresent then begin

  r.Ax:=0; Intr($33,r);

  if r.Ax=0 then begin

   nb:=0; MouseInit:=false

  end

  else begin

   nb:=r.Ax; MouseInit:=true

  end

 end

 else begin

  nb:=0; MouseInit:=false

 end

end;

 

procedure Mouseshow;

begin

   r.Ax:=1; Intr($33,r)

end;

 

procedure MouseHide;

begin

   r.Ax:=2; Intr($33,r)

end;

 

procedure Mouseread(var x,y,bMask:integer);

begin

 r.Ax:=3; Intr($33,r);

 x:=r.cx; y:=r.dx; bMask:=r.Bx

end;

 

procedure MousesetPos(x,y:word);

begin

 r.Ax:=4; r.cx:=x; r.dx:=y;

 Intr($33,r)

end;

 

function MouseGetb(bMask:word;

 var count,Lastx,Lasty:word):word;

begin

 r.Ax:=5; r.Bx:=bMask;Intr($33,r);

 count:=r.Bx; Lastx:=r.cx;

 Lasty:=r.dx; MouseGetb:=r.Ax

end;

 

procedure Mouseminxmaxx(minx,maxx:integer);

begin

 r.Ax:=7; r.cx:=minx;

 r.dx:=maxx; Intr($33,r)

end;

 

procedure Mouseminymaxy(miny,maxy:integer);

begin

 r.Ax:=8; r.cx:=miny;

 r.dx:=maxy; Intr($33,r)

end;

 

procedure setVideoPage(Page:integer);

begin

 r.Ax:=$1D; r.Bx:=Page; Intr($33,r)

end;

 

procedure GetVideoPage(var Page:integer);

begin

 r.Ax:=$1E; Intr($33,r); Page:=r.Bx;

end;

 

procedure MousekeyPreset

 (var key,sost,x,y:integer);

begin

 r.Ax:=$6; r.Bx:=key; Intr($33,r);

 key:=r.Ax; sost:=r.Bx;

 x:=r.cx; y:=r.dx;

end;

 

begin

 GetIntVec($33,Mi);

 if Mi=nil then

  MousePresent:=false

 else if byte(Mi^)=$cE then

  MousePresent:=false

 else MousePresent:=true

end.

 

11.2. Òåñò ìîäóëÿ mouse.pas â ãðàôè÷åñêîì ðåæèìå (mousetst.pas).

program MouseTst;

uses graph,Mouse,crt;

var grDriver : integer; grMode : integer;

 Errcode : integer;

procedure init;

begin

 grDriver:=VGA;grMode:=VGAHi;

 initgraph(grDriver, grMode, '');

 Errcode:=graphresult;

 if Errcode <> grOk then begin

  writeln('Îøèáêà èíèöèàëèçàöèè ãðàôèêè:',

  grapherrormsg(Errcode)); halt;

 end;

end;

 

var n,x,y,x0,y0,b:integer; s1,s2:string;

begin

 init;

 mouseinit(n);

 mouseshow;

 setfillstyle (solidfill,BLACK);

 setcolor (WHITE);

 settextJustify(centertext, centertext);

 x0:=-1; y0:=-1;

 repeat

  mouseread (x,y,b);

  if (x<>x0) or (y<>y0) then begin

   str (x,s1); str (y,s2);

   bar (getmaxx div 2-50,

    getmaxy-15,getmaxx div 2+50,getmaxy-5);

   outtextxy (getmaxx div 2,

    getmaxy-10,s1+' '+s2);

   x0:=x; y0:=y;

  end;

 until keypressed;

 mousehide;

 closegraph;

end.

 

11.3. Òåñò ìîäóëÿ mouse.pas â òåêñòîâîì ðåæèìå (mousetxt.pas).

program MouseTxt;

uses crt,mouse;

var n,x,y,b:integer;

 n1,k,lastx,lasty:word;

begin

 textmode(3);

 mouseinit (n);

 mouseshow;

 repeat

  mouseread (x,y,b);

  gotoxy (1,25);

  write ('x=',(x div 8 + 1):2,

   ' y=',(y div 8 + 1):2,' b=',b:2);

 until keypressed;

 mousehide;

end.

 

12.1. Ó÷åáíàÿ èãðà, èñïîëüçóþùàÿ ñîáñòâåííûé ôàéë ðåñóðñîâ. Ïåðâûé ëèñòèíã ñîäåðæèò óòèëèòó äëÿ ñîçäàíèÿ ôàéëà ðåñóðñîâ resfile èç ôàéëîâ *.bmp òåêóùåé äèðåêòîðèè, ñïèñîê êîòîðûõ íàõîäèòñÿ â ôàéëå filelist.txt. Ôàéëû *.bmp äîëæíû áûòü ñîõðàíåíû â ðåæèìå 16 öâåòîâ. Ïðè íåîáõîäèìîñòè ñëåäóåò èçìåíèòü â ïðîãðàììå êîíñòàíòó ïóòè ê Ïàñêàëþ.

uses graph,crt;

const VGAPath='c:\TP7\egavga.bgi';

 FileList='filelist.txt';

resfile='attack.res';

const width=32; height=20;

 

const color: array [0..15] of byte=

 (0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15);

const maxx=639; maxy=479;

 cx=MAxx div 2; cy=maxy div 2;

type bmpinfo=record

 h1,h2:char;

 size,reserved,offset,b,width,

  height: longint;

 plans,bpp:word;

end;

var Driver, Mode: integer;

 DriverF: file; List,res:text;

 DriverP: pointer; s:string;

 

procedure Wait;

var ch:char;

begin

 reset (Input); repeat until keyPressed;

 ch:=readkey; if ch=#0 then readkey;

end;

 

procedure closeMe;

begin

 if DriverP <> nil then begin

  FreeMem(DriverP, Filesize(DriverF));

  close (DriverF);

 end;

 closegraph;

end;

 

procedure graphError;

begin

 closeMe;

 writeln('graphics error:',

  grapherrormsg(graphresult));

 writeln('Press any key to halt ');

 Wait;

 halt (graphresult);

end;

 

procedure InitMe;

begin

 assign(DriverF, VGAPath);

 reset(DriverF, 1);

 getmem(DriverP, Filesize(DriverF));

 Blockread(DriverF, DriverP^,

  Filesize(DriverF));

 if registerBGIdriver(DriverP)<0 then

  graphError;

 Driver:=VGA; Mode:=VGAHi;

 initgraph(Driver, Mode,'');

 if graphresult < 0 then graphError;

end;

 

procedure clearscreen;

begin

 setfillstyle (solidfill, White);

 bar (0,0,maxx,maxy);

end;

 

procedure Window

 (x1,y1,x2,y2,color,Fillcolor:integer);

begin

 setcolor (color);

 setfillstyle (1,Fillcolor);

 bar (x1,y1,x2,y2);

 rectangle (x1+2,y1+2,x2-2,y2-2);

 rectangle (x1+4,y1+4,x2-4,y2-4);

 setfillstyle (1,DArKGrAy);

 bar (x1+8,y2+1,x2+8,y2+8);

 bar (x2+1,y1+8,x2+8,y2);

end;

 

procedure Error (code:integer; str:string);

begin

 Window (cx-140,cy-100,cx+140,

  cy-70,Black,YELLOW);

 case code of

  1: s:='Ôàéë '+str+' íå íàéäåí!';

  2: s:='Ôàéë '+str+' íå ôîðìàòà BMP-16';

  3: s:='Ôàéë '+str+' èñïîð÷åí!';

 end;

 settextjustify (Lefttext, toptext);

 settextstyle(DefaultFont, HorizDir, 1);

 outtextxy (cx-136,cy-92,s);

 Wait;

 halt(code);

end;

 

function Draw (x0,y0:integer; fname:string;

 transparent:boolean):integer;

var f:file of bmpinfo;

 bmpf:file of byte;

 res:integer; info:bmpinfo;

 x,y:integer; b,bh,bl:byte;

 nb,np:integer; tpcolor:byte;

 i,j:integer;

begin

 assign(f,fname);

 {$I-} reset (f); {$I+}

 res:=IoResult;

 if res <> 0 then Error (1,fname);

 read (f,info);

 close (f);

 if info.bpp<>4 then Error(2,fname);

 x:=x0;

 y:=y0+info.height;

 nb:=(info.width div 8)*4;

 if (info.width mod 8) <> 0 then nb:=nb+4;

 assign (bmpf,fname);

 reset (bmpf);

 seek (bmpf,info.offset);

 if transparent then begin

  read (bmpf,b);

  tpcolor:=b shr 4;

  seek (bmpf,info.offset);

 end

 else tpcolor:=17;

 for i:=1 to info.height do begin

  np:=0;

  for j:=1 to nb do begin

   read (bmpf,b);

   if np<info.width then begin

    bh:=b shr 4;

    if bh <> tpcolor then

     putpixel (x,y,color[bh]);

    inc (x);

    inc(np);

   end;

   if np<info.width then begin

    bl:=b and 15;

    if bl <> tpcolor then

     putpixel (x,y,color[bl]);

    inc(x);

    inc(np);

   end;

  end;

  x:=x0;

  dec(y);

 end;

 close (bmpf);

 Draw:=info.height;

end;

 

var i,j:word;

 b:char;

 r:integer;

begin

 InitMe;

 clearscreen;

 assign (List,FileList);

 {$I-}

 reset (List);

 {$I+}

 if IoResult <> 0 then Error (1,FileList);

 assign (res,resfile);

 {$I-}

 rewrite (res);

 {$I+}

 if IoResult <> 0 then Error (1,resfile);

 settextjustify (centertext,toptext);

 while not eof(List) do begin

  readLn (List,s);

  clearscreen;

  Draw (0,0,s,true);

  for j:=1 to height do

  for i:=1 to width do begin

   b:=chr(getpixel (i,j));

   write (res,b);

  end;

  setcolor (BLACK);

  outtextxy (cx,maxy-20,'Ôàéë '+s+' ÎÊ');

  Wait;

 end;

 closeMe;

 close (res);

 close (List);

end.

 

12.2. Ëèñòèíã ñîäåðæèò èñõîäíûé òåêñò èãðû â ñòèëå Invaders. Êîìïèëèðîâàòü â Ïàñêàëü 7. Ïðè íåîáõîäèìîñòè èçìåíèòü êîíñòàíòó ïóòè ê Ïàñêàëþ. Òðåáóåò ôàéëà ðåñóðñîâ, ñîçäàííîãî óòèëèòîé èç ëèñòèíãà 12.1. Òðåáóåò óñòàíîâëåííîãî ãðàôè÷åñêîãî øðèôòà trip.chr.

uses graph,crt,Dos;

const width=32; height=20;

type Picture=array [0..width-1,0..height-1]

  of char;

type sprite=record

 state,x,y,Pnum,PREDir: word;

end;

const VGAPath='c:\TP7\egavga.bgi';

  FontPath='c:\TP7\Trip.chr';

  sprName='attack.res';

const ESC=#27; F1=#59; SPACE=#32;

 UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;

const maxx=639; maxy=479;

 cx=maxx div 2; cy=maxy div 2;

 maxsprites=11; maxPictures=11;

 maxshoots=100;

const LeftDir=0; RightDir=1;

 UpDir=2; DownDir=3;

 Delta=2; shootradius=5;

var ch:char; s:string;

 Hour,min,sec,sec1,secN,secN1,

 sec100,secI,secI1:word;

var Driver, Mode, Font1,

 currentsprites, currentBottom,

 currentshoots, shootx, Lives,

 Enemyshooter, Enemies,

 shootsProbability: integer;

 score,Level:longint;

 DriverF,FontF: file;

 DriverP,FontP: pointer;

 spr: array [1..maxsprites] of sprite;

 Pict: array [1..maxPictures] of Picture;

 shoots: array [1..maxshoots] of sprite;

 shooter,DieMe,InGame,Initshoot:boolean;

 

procedure Wait;

var ch:char;

begin

 reset (Input); repeat until keyPressed;

 ch:=readkey; if ch=#0 then readkey;

end;

 

procedure closeAll;

begin

 if FontP <> nil then begin

  FreeMem(FontP, Filesize(FontF));

  close (FontF);

 end;

 if DriverP <> nil then begin

  FreeMem(DriverP, Filesize(DriverF));

  close (DriverF);

 end;

 closegraph;

end;

 

procedure graphError;

begin

 closeAll;

 writeln('graphics error:',

  grapherrormsg(graphresult));

 writeln('Press any key to halt');

 Wait; halt (graphresult);

end;

 

procedure InitAll;

begin

 assign(DriverF, VGAPath);

 reset(DriverF, 1);

 getmem(DriverP, Filesize(DriverF));

 Blockread(DriverF, DriverP^,

   Filesize(DriverF));

 if registerBGIdriver(DriverP)<0 then

   graphError;

 Driver:=VGA; Mode:=VGAHi;

 initgraph(Driver, Mode,'');

 if graphresult < 0 then graphError;

 assign(FontF, FontPath);

 reset(FontF, 1);

 getmem(FontP, Filesize(FontF));

 Blockread(FontF, FontP^, Filesize(FontF));

 Font1:=registerBGifont(FontP);

 if Font1 < 0 then graphError;

end;

 

procedure clearscreen;

begin

 setfillstyle (solidfill, White);

 bar (0,0,maxx,maxy);

end;

 

procedure Window

  (x1,y1,x2,y2,color,Fillcolor:integer);

begin

 setcolor (color);

 setfillstyle (1,Fillcolor);

 bar (x1,y1,x2,y2);

 rectangle (x1+2,y1+2,x2-2,y2-2);

 rectangle (x1+4,y1+4,x2-4,y2-4);

 setfillstyle (1,DArKGrAy);

 bar (x1+8,y2+1,x2+8,y2+8);

 bar (x2+1,y1+8,x2+8,y2);

end;

 

procedure outtextcxy (y:integer; s:string);

begin

 settextjustify (centertext,centertext);

 outtextxy (cx ,y,s);

end;

 

procedure start;

begin

 clearscreen;

 Window (10,10,maxx-10,maxy-10,Blue,White);

 settextstyle(Font1, HorizDir, 4);

 outtextcxy (25,'Àòàêà èç êîñìîñà');

 settextstyle(Font1, HorizDir, 1);

 outtextcxy (maxy-25,

  'Íàæìèòå êëàâèøó äëÿ íà÷àëà');

 Wait;

end;

 

procedure restorescreen

  (sNum,Dir,Delta:word);

var x,y:word;

begin

 x:=spr[sNum].x; y:=spr[sNum].y;

 setfillstyle (solidfill,White);

 case Dir of

  LeftDir: begin

   bar(x+width-Delta,y,x+width-1,

       y+height-1);

  end;

  RightDir: begin

   bar (x,y,x+Delta,y+height-1);

  end;

  UpDir: begin

   bar (x,y+height-Delta,

        x+width-1,y+height-1);

  end;

  DownDir: begin

   bar (x,y,x+width-1,y+Delta);

  end;

 end;

end;

 

procedure Drawsprite (sNum:word);

var i,j,x,y,n,b:integer;

begin

 N:=spr[sNum].PNum;

 x:=spr[sNum].x; y:=spr[sNum].y;

 for j:=y to y+height-1 do

 for i:=x to x+width-1 do begin

  b:=ord(Pict[n,i-x,j-y]);

  putpixel(i,j,b);

 end;

end;

 

procedure GoLeft;

var x,d2:word;

begin

 x:=spr[1].x; d2:=delta*4;

 if x>d2 then begin

  restorescreen (1,LeftDir,d2);

  Dec(spr[1].x,d2); Drawsprite (1);

 end;

end;

 

procedure GoRight;

var x,d2:word;

begin

 x:=spr[1].x;

 d2:=delta*4;

 if x+width < maxx then begin

  restorescreen (1,RightDir,d2);

  Inc(spr[1].x,d2);

  Drawsprite (1);

 end;

end;

 

procedure showLives;

begin

 str(Lives,s);

 setfillstyle (solidfill,White);

 setcolor (RED); bar (80,0,110,10);

 outtextxy (82,2,s);

end;

 

procedure showscore;

begin

 str(score,s);

 setfillstyle (solidfill,White);

 setcolor (Blue); bar (150,0,250,10);

 outtextxy (152,2,s);

end;

 

procedure showshoots;

begin

 str(currentshoots,s);

 setfillstyle (solidfill,White);

 setcolor (Black); bar (20,0,50,10);

 outtextxy (20,2,s);

end;

 

procedure showLevel;

begin

 str(Level,s);

 setfillstyle (solidfill,White);

 setcolor (Blue); bar (251,0,350,10);

 outtextxy (253,2,'Level '+s);

end;

 

procedure shoot;

var i:integer;

begin

 if currentshoots>0 then begin

  for i:=1 to maxshoots do

  if (sec<>sec1) and (shoots[i].state=0)

  then begin

   Dec(currentshoots);

   showshoots;

   spr[1].PNum:=6; Drawsprite (1);

   GetTime(Hour,min,sec,sec100);

   shootx:=spr[1].x; shooter:=true;

   shoots[i].x:=spr[1].x+ (width div 2);

   shoots[i].y:=spr[1].y - 5;

   shoots[i].PNum:=UpDir;

   shoots[i].state:=1;

   break;

  end;

 end;

end;

 

procedure Help(s:string);

begin

 setfillstyle (solidfill,White);

 setcolor (Blue);

 bar (10,maxy-10,maxx-10,maxy);

 outtextxy (10,maxy-9,s);

end;

 

procedure Error (code:integer; str:string);

begin

 Window (cx-120,cy-100,cx+120,cy-70,

  Black,YELLOW);

 case code of

  1: s:='Ôàéë '+str+' íå íàéäåí!';

 end;

 settextjustify (Lefttext, toptext);

 settextstyle(DefaultFont, HorizDir, 1);

 outtextxy (cx-116,cy-92,s);

 Wait; closeAll; halt(code);

end;

 

procedure DrawField;

var i,x,y:integer;

begin

 clearscreen;

 with spr[1] do begin

  state:=1; Pnum:=1;

  x:=maxx div 2;

  y:=maxy - 10 - height;

  Drawsprite (1);

 end;

 x:=100;

 y:=10;

 for i:=2 to currentsprites do begin

  spr[i].state:=1;

  spr[i].PNum:=7;

  spr[i].x:=x; spr[i].y:=y;

  Drawsprite (i);

  inc(x,50);

  if x>maxx-width then begin

   x:=100;

   if y<currentBottom-height then

    Inc(y,height)

   else y:=10;

  end;

 end;

 for i:=1 to maxshoots do

  shoots[i].state:=0;

 shooter:=false;

 Enemyshooter:=-1;

 sec:=0; secN:=0;

 secI1:=100; sec1:=100; secN1:=100;

 setfillstyle (solidfill,RED);

 FillEllipse (10,5,5,4);

 showshoots;

 setfillstyle (solidfill,Green);

 bar (60,1,72,10);

 setfillstyle (solidfill,LightGreen);

 bar (62,3,70,8);

 showLives;

 setfillstyle (solidfill,YELLOW);

 setcolor (Black);

 for i:=1 to 3 do begin

  circle (126+i*2,5,4);

  FillEllipse (126+i*2,5,4,4);

 end;

 showscore;

 showLevel;

 InGame:=true;

end;

 

procedure Loadsprites;

var F:text;

 n,i,j,r:integer;

 b:char;

begin

 assign (f,sprName);

 {$I-}

 reset (f);

 {$I+}

 if IoResult<>0 then Error (1,sprName);

 for n:=1 to maxPictures do

 for j:=0 to height-1 do

 for i:=0 to width-1 do begin

  read (f,b);

  Pict [n,i,j]:=b;

 end;

 close (f);

end;

 

procedure Deltas (sNum,Dir:integer;

 var dx,dy:integer);

var x,y:integer;

begin

 x:=spr[sNum].x; y:=spr[sNum].y;

 case Dir of

  LeftDir: begin

   Dec(x,Delta);

   if x<0 then x:=0;

  end;

  RightDir: begin

   Inc(x,Delta);

   if x>maxx-width then x:=maxx-width;

  end;

  UpDir: begin

   Dec (y,Delta);

   if y<10 then y:=10;

  end;

  DownDir: begin

   Inc(y,Delta);

   if y>currentBottom then

    y:=currentBottom;

  end;

 end;

 dx:=x; dy:=y;

end;

 

function Between (a,x,b:integer):boolean;

begin

 if (x>a) and (x<b) then Between:=true

 else Between:=false;

end;

 

procedure shootMovies;

var i,d,n:integer;

 x,y:word;

 found:boolean;

begin

 for i:=1 to maxshoots do

 if shoots[i].state=1 then begin

  x:=shoots[i].x; y:=shoots[i].y;

  d:=shoots[i].PNum;

  setfillstyle (solidfill,White);

  setcolor (White);

  fillellipse(x,y,shootradius,shootradius);

  if d=updir then begin

   setfillstyle (solidfill,RED);

   if y<15 then begin

    shoots[i].state:=0; continue;

   end;

   found:=false;

   for n:=2 to currentsprites do begin

    if spr[n].state=1 then begin

     if (Between(spr[n].x,x,

         spr[n].x+width)) and

         (Between(spr[n].y,y,

         spr[n].y+height)) then begin

      shoots[i].state:=0;

      found:=true;

      spr[n].state:=2;

      Inc(spr[n].PNum);

      Inc(score,10+5*n);

      showscore;

      break;

     end;

    end;

   end;

   if not found then Dec(y,Delta);

  end

  else begin

   setfillstyle (solidfill,Blue);

   if y>maxy-10-(height div 2) then begin

    shoots[i].state:=0;

    continue;

   end;

   found:=false;

   if Between(spr[1].x,x,spr[1].x+width)

      and

      Between(spr[1].y,y,spr[1].y+height)

      then begin

    shoots[i].state:=0; found:=true;

    Inc(spr[1].Pnum); DieMe:=true;

    Help ('you are missed one life :-(');

    Drawsprite (1);

   end;

   if not found then Inc(y,Delta);

  end;

  if not found then begin

  fillellipse(x,y,shootradius,shootradius);

   shoots[i].x:=x; shoots[i].y:=y;

  end;

 end;

end;

 

procedure Enemiesstep;

var i,k,Dir,dx,dy,n:integer;

begin

 Enemies:=0;

 for i:=2 to currentsprites do begin

  if spr[i].state=1 then begin

   Inc(Enemies);

   for k:=1 to 3 do begin

    dir:=random(4);

    if dir=spr[i].pREDir then break;

   end;

   spr[i].pREDir:=dir;

   Deltas (i, dir, dx, dy);

   restorescreen (i,Dir,Delta);

   spr[i].x:=dx; spr[i].y:=dy;

   Drawsprite (i);

   Initshoot:=false;

   GetTime(Hour,min,secN1,sec100);

   if (secN1<>secN) and

   (1+random(100)<shootsProbability) then

    Initshoot:=true;

   if Initshoot then begin

    secN:=secN1;

    for n:=1 to maxshoots do

    if (shoots[n].state=0) and

       (Enemyshooter<>i) then begin

     Enemyshooter:=i;

     shoots[n].x:=dx+ (width div 2);

     shoots[n].y:=dy +height +5;

     shoots[n].PNum:=DownDir;

     shoots[n].state:=1;

     break;

    end;

   end;

  end

  else if spr[i].state=2 then begin

   GetTime (Hour,min,secI,sec100);

   Drawsprite (i);

   if secI<>secI1 then begin

    secI1:=secI;

    if (spr[i].PNum<11) then

     Inc(spr[i].PNum)

    else begin

     spr[i].state:=0;

     setfillstyle (solidfill, White);

     bar (spr[i].x,spr[i].y,

       spr[i].x+width-1,spr[i].y+height-1);

    end;

   end;

  end;

 end;

end;

 

procedure Timefunctions;

var i:integer;

begin

 if not InGame then Exit;

 GetTime(Hour,min,sec1,sec100);

 if (shooter) and (sec<>sec1) then begin

  spr[1].PNum:=1;

  if shootx=spr[1].x then Drawsprite (1);

  shooter:=false;

 end;

 if (DieMe) and (sec<>sec1) then begin

  if spr[1].Pnum<5 then begin

   sec:=sec1; Inc(spr[1].PNum);

   Drawsprite (1); DieMe:=true;

  end

  else begin

   DieMe:=false;

   if Lives>0 then begin

    Dec(Lives); showLives;

    spr[1].PNum:=1;

    Drawsprite (1);

   end

   else InGame:=false;

  end;

 end;

end;

 

function getlongintTime:longint;

 {Âåðíåò ñèñòåìíîå âðåìÿ êàê longint}

var Hour,minute,second,sec100: word;

var k,r:longint;

begin

 GetTime (Hour, minute, second, sec100);

 k:=Hour; r:=k*360000;

 k:=minute; Inc (r,k*6000);

 k:=second; Inc(r,k*100);

 Inc(r,sec100); getlongintTime:=r;

end;

 

procedure Delay (ms:word);

var endTime,curTime : longint;

    cor:boolean;

begin

 cor:=false;

 endTime:=getlongintTime + ms div 10;

 if endTime>8639994 then cor:=true;

  repeat

  curTime:=getlongintTime;

  if cor=true then begin

   if curTime<360000 then

    Inc (curTime,8639994);

  end;

 until curTime>endTime;

end;

 

label 10,20;

begin

 randomize; InitAll; InGame:=false;

 start;

 settextstyle (DefaultFont,HorizDir,1);

 settextjustify (Lefttext,toptext);

 Loadsprites;

 currentBottom:=200; currentshoots:=50;

 Lives:=3; score:=0; Level:=1;

 shootsProbability:=5;

 currentsprites:=5;

10:

 DrawField;

 if Level>1 then begin

  str(Level-1,s);

  Help ('cool, you''re complete level '+s);

 end

 else Help

  ('Let''s go! Kill them, invaders!');

 repeat

  if InGame then repeat

   Enemiesstep;

   if Enemies=0 then begin

    Inc(score,100+Level*10);

    if shootsProbability<100 then

     Inc (shootsProbability);

    if currentsprites<maxsprites then

     Inc(currentsprites);

    if currentBottom<maxy-10-4*height then

     Inc(currentBottom,10);

    currentshoots:=50;

    Delay(1000);{Ïàóçà ïåðåä ñëåä. óðîâíåì}

    Inc(Level);

    goto 10;

   end;

   shootMovies;

   if not InGame then begin

    Help ('sorry, you''re dead');

   end;

   Timefunctions;

  until keypressed;

  ch:=readkey;

  case ch of

   SPACE:

    if not DieMe and InGame then shoot;

   #0: begin

    ch:=readkey;

    case ch of

     F1: Help

      ('Sorry, there''s no help here :-)');

     LEFT: if not DieMe and InGame

           then GoLeft;

     RIGHT: if not DieMe and InGame

           then GoRight;

     UP: if not DieMe and InGame

           then shoot;

    end;

   end;

  end;

 until ch=ESC;

 closeAll;

end.

Ðåéòèíã@Mail.ru
ââåðõ ãîñòåâàÿ; E-mail