Simulátor F15 v peknej grafickej podobe ovládaný my¹ou

Delphi & Pascal (èeská wiki)
Pøejít na: navigace, hledání
Kategórie: KMP (Programy mladých programátorù)
f-15.pngAutor: Róbert Bobák
Program: F-15.pas
Soubor exe: F-15.exe
Potøebné: Egavga.bgi

Simulátor F15 v peknej grafickej podobe ovládaný my¹ou.
{ F-15.PAS                                                          }
{                                                                   }
{ Author: Robert Bobak                                              }
{ Date  : 15.02.1997                           http://www.trsek.com }
 
program LeteckySimulatorF15;
uses crt,graph,DOS;
var gd,gm,x,y:integer;
    ch:char;
    P,M: pointer;
    Size: Word;
    xm,ym,but,XM1,YM1,BUT1:integer;
    STRXM,STRYM,STRBUT:STRING;
    konci:boolean;
 
PROCEDURE IKONA(X1,Y1,X2,Y2:INTEGER;TEXT:STRING);
BEGIN
SETLINESTYLE(0,0,3);SETFILLSTYLE(1,7);
BAR(X1,Y1,X2,Y2);SETCOLOR(15);
LINE(X1,Y1,X2,Y1);
LINE(X1,Y1,X1,Y2);
SETCOLOR(8);
LINE(X1,Y2,X2,Y2);LINE(X2,Y2,X2,Y1);
OUTTEXTXY(X1+8,(Y1+Y2) DIV 2 -4,TEXT);
SETLINESTYLE(0,0,1);
END;
 
 
function gminit:boolean;
var reg:registers;
begin
 reg.ax:=$0000;
 intr($33,reg);
 if reg.ax=$0000 then gminit:=false
                 else gminit:=true;
 but:=reg.bx;
end;
 
procedure zobraz_mys;
var reg:registers;
begin
 reg.ax:=$0001;
 intr($33,reg);
end;
 
 
procedure NEzobraz_mys;
var reg:registers;
begin
 reg.ax:=$0002;
 intr($33,reg);
end;
 
procedure test_mys(var x,y,but:integer);
var reg:registers;
begin
 reg.ax:=$0003;
 intr($33,reg);
 x:=reg.cx;
 y:=reg.dx;
 but:=reg.bx;
end;
PROCEDURE IKONY;
BEGIN
 ikona(10,10,100,30,'PLAY');IKONA(10,60,100,80,'HI-SCORE');
 IKONA(10,110,100,130,'END');
 END;
 
procedure f15(x,y,f:integer);
var a:integer;
begin
setcolor(f);
{-------------------zadna chvostova plocha---------------------------}
line(x+0,y+5,x+25,y+5);
line(x+10,y+5,x+52,y+32);
line(x+52,y+32,x+45,y+35);
moveto(x+45,y+35);lineto(x+5,y+35);
lineto(x+0,y+5);
line(x-2,y+6,x+2,y+6);
line(x-2,y+8,x+2,y+8);
{-----------------------stabilizatory--------------------------------}
for a:=40 to 41 do line(x+-5,y+a,x+30,y+a);
{-------------------------motor--------------------------------------}
moveto(x+7,y+40);lineto(x+7,y+47);
line(x+5,y+35,x+5,y+40);
lineto(x+17,y+50);lineto(x+17,y+40);
{--------------------------nasavaci otvor----------------------------}
line(x+17,y+50,x+150,y+45);
moveto(x+150,y+45);
lineto(x+172,y+27);
lineto(x+157,y+22);lineto(x+50,y+30);
{---------------------------predna cast+kabina-----------------------}
moveto(x+205,y+17);lineto(x+175,y+20);
line(x+152,y+42,x+204,y+40);
lineto(x+165,y+15);lineto(x+160,y+10);
lineto(x+150,y+15);line(x+160,y+10,x+182,y+5);
line(x+182,y+5,x+182,y+19);line(x+182,y+5,x+205,y+17);
line(x+197,y+13,x+197,y+18);
{-------------------kridlo+pripojka na kridlo-----------------------}
line(x+140,y+23,x+157,y+32);
moveto(x+157,y+32);
lineto(x+145,y+37);
lineto(x+80,y+40);
lineto(x+60,y+35);
lineto(x+80,y+28);
for a:=1 to 3 do line(x+56,y+33+a,x+125,y+29+a);
{--------------------------obluky-----------------------------------}
arc(x+200,y+155,69,90,138);
arc(x+190,y-98,270,296,138);
arc(x+109,y-61,270,300,87);
{-------------------------vyplnovanie-------------------------------}
setfillstyle(1,7);
floodfill(x+100,y+35,8);
floodfill(x+10,y+20,8);
floodfill(x+100,y+40,8);
floodfill(x+160,y+35,8);
setfillstyle(1,8);
floodfill(x+10,y+45,8);
setfillstyle(1,7);
floodfill(x+200,y+30,8);
setfillstyle(1,9);
floodfill(x+170,y+15,8);
floodfill(x+190,y+15,8);
floodfill(x+200,y+15,8);
{-------------------------znak--------------------------------}
setcolor(8);
line(x+180,y+30,x+195,y+30);
moveto(x+195,y+30);
lineto(x+195,y+35);
lineto(x+180,y+35);
lineto(x+180,y+30);
setcolor(lightred);
line(x+181,y+32,x+194,y+32);
setcolor(1);
for a:=1 to 4 do circle(x+187,y+32,a);
end;
 
procedure mrak(x,y:integer);
var a:integer;
begin
setcolor(15);
for a:=1 to 12 do circle(x+40,y+50,a);
for a:=1 to 12 do circle(x+34,y+54,a);
for a:=1 to 20 do circle(x+80,y+20,a);
for a:=1 to 20 do circle(x+100,y+20,a);
for a:=1 to 30 do circle(x+60,y+50,a);
for a:=1 to 30 do circle(x+50,y+54,a);
for a:=1 to 30 do circle(x+144,y+50,a);
for a:=1 to 32 do circle(x+110,y+50,a);
end;
 
 
procedure demo(x,y:integer);
begin
SETBKCOLOR(0);
CLEARDEVICE;
f15(x+5,y,8);
setcolor(10);
outtextxy(x,y+60,'ÛÛÛÛÛÛÛÛ            ÛÛ  ÛÛÛÛÛÛÛÛ');
outtextxy(x,y+68,'ÛÛÛÛÛÛÛÛ            ÛÛ  ÛÛÛÛÛÛÛÛ');
outtextxy(x,y+76,'ÛÛ    ÛÛ          ÛÛÛÛ  ÛÛ    ÛÛ');
outtextxy(x,y+84,'ÛÛ    ÛÛ          ÛÛÛÛ  ÛÛ    ÛÛ');
outtextxy(x,y+92,'ÛÛ                  ÛÛ  ÛÛ');
outtextxy(x,y+100,'ÛÛ                  ÛÛ  ÛÛ');
outtextxy(x,y+108,'ÛÛ  ÛÛ              ÛÛ  ÛÛ');
outtextxy(x,y+116,'ÛÛÛÛÛÛ   ÛÛÛÛÛ      ÛÛ  ÛÛÛÛÛÛÛÛ');
outtextxy(x,y+124,'ÛÛÛÛÛÛ   ÛÛÛÛÛ      ÛÛ  ÛÛÛÛÛÛÛÛ');
outtextxy(x,y+132,'ÛÛ  ÛÛ              ÛÛ        ÛÛ');
outtextxy(x,y+140,'ÛÛ                  ÛÛ        ÛÛ');
outtextxy(x,y+148,'ÛÛ                  ÛÛ        ÛÛ');
outtextxy(x,y+156,'ÛÛ                  ÛÛ        ÛÛ');
outtextxy(x,y+164,'ÛÛ                  ÛÛ  ÛÛ    ÛÛ');
outtextxy(x,y+172,'ÛÛ                  ÛÛ  ÛÛÛÛÛÛÛÛ');
outtextxy(x,y+180,'ÛÛ                  ÛÛ  ÛÛÛÛÛÛÛÛ');
 
outtextxy(x,y+200,'ÛÛÛÛÛ   ÞÛÝ   ÛÛÛÛÛ  Û      ÛÛÛÛÛ');
outtextxy(x,y+208,'Û   Û         Û   Û  Û      Û   Û');
outtextxy(x,y+216,'Û             Û      Û      Û');
outtextxy(x,y+224,'Û             Û      Û      Û');
outtextxy(x,y+232,'ÛÜÛ           Û  ÜÜ  Û      ÛÜÛ');
outtextxy(x,y+240,'ÛßÛ           Û  ßÛ  Û      ÛßÛ');
outtextxy(x,y+248,'Û             Û   Û  Û      Û');
outtextxy(x,y+256,'Û             Û   Û  Û      Û');
outtextxy(x,y+264,'Û             Û   Û  Û   Û  Û   Û');
outtextxy(x,y+272,'ÛÛÛÛÛ  ÛÛ ÛÛ  ÛÛÛÛÛ  ÛÛÛÛÛ  ÛÛÛÛÛ');
line(x+60,y+273,x+72,y+208);
line(x+80,y+208,x+92,y+273);
line(x+72,y+257,x+68,y+273);
line(x+72,y+257,x+80,y+257);
line(x+80,y+257,x+84,y+224+49);
line(x+72,y+249,x+80,y+249);
moveto(x+80,y+249);
lineto(x+76,180+49+y);
lineto(x+72,y+249);
setfillstyle(1,10);
floodfill(x+76,y+175+49,10);
end;
 
PROCEDURE MYS;
BEGIN
 if not(gminit) then writeln('Nemas nainstalovany ovladac na mys.');
 zobraz_mys;
 konci:=false;
 
 repeat
  test_mys(xm,ym,but);
 
  IF ((XM>9) AND (XM<101) AND (YM>10) AND (YM<30) AND (BUT=1)) THEN BEGIN
      NEZOBRAZ_MYS;
      DEMO(200,100);
      IKONY;
      ZOBRAZ_MYS;
      konci:=true;
     END;
 
  IF ((XM>10) AND (XM<101) AND (YM>60) AND (YM<80) AND (BUT=1)) THEN BEGIN
      CLEARDEVICE;
      IKONY;
      SETCOLOR(13);
      OUTTEXTXY(500,100,'Hi-score:');
     end;
 
  IF ((XM>10) AND (XM<101) AND (YM>110) AND (YM<130) AND (BUT=1)) THEN konci:=true;
 
 until (konci);
end;
 
procedure kresli(x,y:integer);
begin
  GetImage(x,y,265+x,50+y,M^);
  PutImage(x,y,P^,2);
  delay(300);
  PutImage(x,y,M^,NormalPut);
end;
 
procedure uvod_demo;
var i,a:integer;
begin
 Size := ImageSize(0,0,270,50);
 GetMem(P, Size);
 f15(10,10,8);
 GetImage(0,0,270,50,P^);
 cleardevice;
 
 for i:=1 to 50 do begin
    putimage(i*5,100,P^,NormalPut);
    sound(200);
    delay(10);
   end;
 
 a:=500;
 for i:=1 to 60 do begin
    putimage(250+i*2,100+i*5,P^,NormalPut);
    a:=a-5;
    sound(a);
    delay(10);
   end;
 nosound;
end;
 
{                       zaciatok programu               }
begin
 gd:=detect;
 initgraph(gd,gm,'');
 if graphresult<>grok then halt(1);
 setbkcolor(0);
 cleardevice;
 uvod_demo;
 
 demo(200,100);
 ikona(10,10,100,30,'PLAY');
 IKONA(10,60,100,80,'HI-SCORE');
 IKONA(10,110,100,130,'END');
 MYS;
 
 setbkcolor(0);
 cleardevice;
 mrak(100,100);mrak(240,300);mrak(500,140);
 Size := ImageSize(0,0,265,50);
 GetMem(P, Size);
 GetMem(M, Size);
 GetImage(0,0,265,50,M^);
 f15(10,0,8);
 GetImage(0,0,265,50,P^);
 PutImage(0,0,M^,NormalPut);
 outtextxy(10,470,'Pohyb sipkami.    Esc koniec.');
 konci:=false;
 
 repeat
  ch:=readkey;
  if ch='H' then y:=y-10;
  if ch='P' then y:=y+10;
  if ch='K' then x:=x-10;
  if ch='M' then x:=x+10;
  kresli(x,y);
 until ch=#27;
 
 REPEAT UNTIL KEYPRESSED;
 closegraph;
end.