{ AUTICKO.PAS Copyright (c) Ales Kucik } { Hra auticko v grafickem rezimu - musite se vyhybat priseram. } { } { Datum:29.11.2002 http://www.trsek.com } program Auticko; {$G+} uses Crt; const Sirka= 15; Delka= 12; {Zalezi na grafickem modu} RelX=30; {Vzdalenost od leveho kraje obrazovky} Hustota=50; {Cislo udava s jakou pravdepodobnosti padne zed 1:Hustota} Dvoji=0; PocitadloX=60; PocitadloY=10; VGA =$a000; uber=1; type tBunka = (empty, wall); tHLmenu = (start,credit,konci); tOvladani = (levo,pravo,esc); tAuto = record xStary,x,y:byte; end; tPlocha = array[1..Delka, 1..Sirka] of tBunka; tVirtual = array [1..64000] of byte; VirtPtr = ^tVirtual; icon = array [1..15*15] of byte; tPal= array [0..255,1..3] of byte; {Typ pro uchivani palety} const fauto : icon =( 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,0,0,0,0,2,2,2,2,2,0,0,0,0,2, 2,0,0,0,0,0,2,2,2,0,0,0,0,0,2, 2,2,0,0,0,0,2,2,2,0,0,0,0,2,2, 0,0,0,0,0,2,2,2,2,2,0,0,0,0,0, 0,0,0,0,0,2,4,4,4,2,0,0,0,0,0, 0,0,0,0,0,2,2,2,2,2,0,0,0,0,0, 2,0,0,0,0,2,2,2,2,2,0,0,0,0,2, 2,0,0,0,0,0,2,2,2,0,0,0,0,0,2, 2,0,0,0,0,2,2,2,2,2,0,0,0,0,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,0,0,2,2,2,2,2,2,2,0,0,2,2, 2,0,0,0,0,2,2,2,2,2,0,0,0,0,2, 2,2,0,0,0,0,2,2,2,0,0,0,0,2,2); fwall : icon =( 0,3,3,0,0,3,3,0,0,3,3,0,0,0,0, 0,3,3,3,0,3,3,3,3,3,3,3,0,0,0, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, 0,3,3,3,3,3,3,3,3,3,3,3,0,0,3, 0,0,3,3,3,3,3,3,3,3,3,3,3,0,0, 0,3,3,3,3,3,3,3,3,3,3,3,0,0,0, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, 3,3,3,3,3,3,3,3,3,3,3,3,0,0,3, 0,0,3,3,3,3,3,3,3,3,3,3,3,0,0, 0,0,0,3,3,3,3,3,3,3,3,3,3,0,0, 0,0,3,3,3,3,3,3,3,3,3,3,0,0,3, 3,3,3,3,3,3,0,0,3,3,3,3,3,3,3, 0,3,0,0,3,3,0,0,0,3,3,3,0,0,3, 0,0,0,0,3,0,0,0,3,3,0,0,0,0,0, 0,0,0,3,3,0,0,0,0,3,3,0,0,0,0); var konec:boolean; VirScr:VirtPtr; Vaddr:word; font:pointer; height:byte; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure SetMCGA; { This procedure gets you into 320x200x256 mode. } BEGIN asm mov ax,0013h int 10h end; END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure SetText; { This procedure returns you to text mode. } BEGIN asm mov ax,0003h int 10h end; END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure Cls (Col : Byte; Where:word); { This clears the screen to the specified color } BEGIN asm push es mov cx, 32000; mov es,[where] xor di,di mov al,[col] mov ah,al rep stosw pop es End; END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure Putpixel (X,Y : Integer; Col : Byte; where:word); { This puts a pixel on the screen by writing directly to memory. } BEGIN Asm push ds push es mov ax,[where] mov es,ax mov bx,[X] mov dx,[Y] push bx {; and this again for later} mov bx, dx {; bx = dx} mov dh, dl {; dx = dx * 256} xor dl, dl shl bx, 1 shl bx, 1 shl bx, 1 shl bx, 1 shl bx, 1 shl bx, 1 {; bx = bx * 64} add dx, bx {; dx = dx + bx (ie y*320)} pop bx {; get back our x} add bx, dx {; finalise location} mov di, bx {; es:di = where to go} xor al,al mov ah, [Col] mov es:[di],ah pop es pop ds End; END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} procedure WaitRetrace; assembler; { This waits for a vertical retrace to reduce snow on the screen } label l1, l2; asm mov dx,3DAh l1: in al,dx and al,08h jnz l1 l2: in al,dx and al,08h jz l2 end; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure SetUpVirtual; { This sets up the memory needed for the virtual screen } BEGIN GetMem (VirScr,64000); vaddr := seg (virscr^); {GetMem (VirScr2,64000); vaddr2 := seg (virscr2^);} END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure ShutDown; { This frees the memory used by the virtual screen } BEGIN FreeMem (VirScr,64000); {FreeMem (VirScr2,64000);} END; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} procedure flip(source,dest:Word); { This copies the entire screen at "source" to destination } begin asm push ds mov ax, [Dest] mov es, ax mov ax, [Source] mov ds, ax xor si, si xor di, di mov cx, 32000 rep movsw pop ds end; end; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte); { This reads the values of the Red, Green and Blue values of a certain color and returns them to you. } Begin Port[$3c7] := ColorNo; R := Port[$3c9]; G := Port[$3c9]; B := Port[$3c9]; End; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure Pal(ColorNo : Byte; R,G,B : Byte); { This sets the Red, Green and Blue values of a certain color } Begin Port[$3c8] := ColorNo; Port[$3c9] := R; Port[$3c9] := G; Port[$3c9] := B; End; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} procedure GrabPalette(var XPalette : tPal); {Naplni zvolenou promenou typu tPal paletou jakou chci} var loop1:integer; begin for loop1:=0 to 255 do GetPal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]); end; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} procedure RestorePalette(XPalette : tPal); {Nastavy paletu jakou chci} var loop1:integer; begin for loop1:=0 to 255 do Pal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]); end; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} Procedure XYText(const Font: Pointer;const X,Y: Word; const Color: Byte;const S: String; where:word);Assembler; var FirstChar, CharHeight :Byte; CharNr, ScreenPTR :Word; asm push ds mov ax,where { Setup ES:[BX] = X,Y to plot at } mov es,ax mov bx,x mov ax,y xchg ah,al add bx,ax shr ax,2 add bx,ax lds di,font mov dl,[di] { height of font goes into dh } mov CharHeight,dl inc di mov dl,[di] mov FirstChar,dl mov CharNr,0 { Ugh! Character counter, not a very } { good method, but I'm all out of registers :-( } @nextchar: inc CharNr { also skips lengthbyte! } push ds { This I don't like, pushing and popping. } lds si,[S] { But unfortunately I can't seem to find } add si,CharNr { any spare registers? Intel, can you help? } lodsb { load asciivalue into al } pop ds cmp al,0 { check for null-termination } je @exit { exit if end of string } mov ScreenPTR,BX { save bx } mov dh,CharHeight xor ah,ah mov cl,firstchar { firstchar } sub al,cl { al = currentchar - firstchar } mov si,ax { di = scrap register } mul dh { ax * fontheight } add ax,si { ax + characters to skip } lds di,font { This can be omptimized I think (preserve DI) } add di,3 { skip header } add di,ax { Point into structure } mov cl,[di] { get character width } @nextline: mov ch,cl { ch is the height counter. cl is the original. } inc di { .. now points to bitmap } mov dl,[di] { get bitmap byte } @nextpixel: rol dl,1 { rotate bitmap and prepare for next pixel } mov al,dl { mov bitmap into al for manipulation } and al,1 { mask out the correct bit } jz @masked { jump if transperent } mov al,color mov byte ptr es:[bx],al { Set the pixel on the screen } @masked: inc bx { increment X-offset } dec ch { are we done? last byte in character? } jnz @nextpixel { nope, out with another pixel } add bx,320 { Go to next line on the screen } sub bx,cx { X-alignment fixup } dec dh { are we done with the character? } jnz @nextline mov bx,ScreenPTR { restore screen offset and prepare for next character } add bx,cx inc bx { A little gap between the letters, thank you... } jmp @nextchar @exit: pop ds end; {컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴} procedure Game; var loopG:integer; GameOver:boolean; Auto:tAuto; Plocha:tPlocha; Counter:longint; Xxloop:byte; {*************** Procedurky a Fce ****************} procedure PutFrame(x,y:integer;XFrame:icon; where:word); var i,j:integer; begin for i:=1 to 15 do for j:=1 to 15 do if XFrame[(i-1)*15+j]<>0 then putpixel(x*15+j-1,y*15+i-1,XFrame[(i-1)*15+j],where); end; procedure initFirst(var xAuto:tAuto; var xPlocha:tPlocha); var i,j:byte; begin xAuto.x:=10; xAuto.xStary:=xAuto.x; xAuto.y:=Delka; for i:=1 to delka do begin xPlocha[i,1] :=wall; xPlocha[i,sirka]:=wall; for j:=2 to sirka-1 do xPlocha[i,j]:=empty; end; end; procedure ZobrazG (var xPlocha:tPlocha; var XCount: longint); var i,j:byte; ss:string[8]; begin Cls(16,Vaddr); for i:=1 to delka do for j:=1 to sirka do if xPlocha[i,j]=wall then PutFrame((j-1),(i-1),fWall,Vaddr); str(XCount,ss); XYText(font,240,10,35,'SCORE:'+#0,vaddr); XYText(font,240,10+height,38,ss+#0,vaddr); WaitRetrace; flip(Vaddr,VGA); end; procedure ZobrazA (var xAuto:tAuto); var i,j:integer; begin if xAuto.x <> xAuto.xStary then for i:=(delka-1)*15 to (delka)*15 do for j:= (xAuto.xStary-1)*15 to xAuto.xStary*15 do PutPixel(j,i,0,VGA); PutFrame(xAuto.x-1,delka-1,fAuto,VGA); xAuto.xStary:=xAuto.x; end; procedure Vlevo (var xAuto:tAuto; var xPlocha:tPlocha); begin if xPlocha[xAuto.y,xAuto.x-1]=empty then xAuto.x:=xAuto.x-1; end; procedure Vpravo(var xAuto:tAuto; var xPlocha:tPlocha); begin if xPlocha[xAuto.y,xAuto.x+1]=empty then xAuto.x:=xAuto.x+1; end; procedure Dalsi (var xPlocha:tPlocha); var i,j:byte; begin for i:=delka downto 2 do for j:= 2 to sirka-1 do xPlocha[i,j]:=xPlocha[i-1,j]; for j:=2 to sirka-1 do begin if random(Hustota)=0 then xPlocha[1,j]:=wall else xPlocha[1,j]:=empty; end; end; function Ovladani:tOvladani; var Znak:char; begin Znak:=readkey; if ord(Znak)=Dvoji then {Cteni znaku s dvojim nacitanim} begin Znak:=readkey; case ord(Znak) of 75: Ovladani:= levo; 77: Ovladani:= pravo; end; end else if ord(Znak)= 27 then Ovladani:= Esc; end; procedure KonecHrac; begin cls(0,VGA); XYText(font,30,100-height,42,'*************************'+#0,VGA); XYText(font,30,100,38, '**** !!! KONEC !!! ****'+#0,VGA); XYText(font,30,100+height,42,'*************************'+#0,VGA); repeat until keypressed; end; function Koncis(xAuto:tAuto;xPlocha:tPlocha):boolean; begin if xPlocha[delka-1,xAuto.x]= wall then koncis:=true else koncis:= false; end; begin {Main GAME} initFirst(Auto,Plocha); GameOver:=false; Counter:=0; XxLoop:=10; SetUpVirtual; Cls(0,VGA); Cls(0,Vaddr); repeat ZobrazG(Plocha,Counter); ZobrazA(Auto); for loopG:=1 to XxLoop do begin WaitRetrace; ZobrazA(Auto); if keypressed then begin case Ovladani of levo : Vlevo (Auto,Plocha); pravo: Vpravo(Auto,Plocha); esc : GameOver:=true; end; end; end; Counter:=Counter+1; if ((counter mod 30)=0)and(XxLoop > 2)then XxLoop:=Xxloop-1; if GameOver then KonecHrac{Ukonceno uzivatelem} else if Koncis(Auto,Plocha) then begin GameOver:=true; {Uzivatel prohral} XYText(font,30,100,45,'Ha Ha NARAZILS !!!!'+#0,VGA); readln; end else Dalsi(Plocha); {Pokracovani hry} until GameOver; ShutDown; end; {Main GAME} {*************************** INTRO *********************************} procedure Intro; type iconlogo=array[1..15*66] of byte; const waitx=20; logo:iconLOGO=( 0,0,0,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,1,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,1,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,1,1,1,1,1,0,0,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1, 0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0, 0,0,0,0,0,1,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0, 0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0, 0,0,0,0,1,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0, 0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1, 0,0,0,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0, 0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); {15X66} var OldPal,NewPal:tPal; i,j:integer; procedure PutLogo; var i,j:integer; begin for i:=1 to 15 do for j:=1 to 66 do if logo[(i-1)*66+j]<>0 then putpixel(ROUND((320-66)/2)+j-1,ROUND((200-15)/2)+i-1,51,VGA); end; procedure HLine (y:integer; col:byte; where:word); var loop:integer; begin for loop:=0 to 319 do putpixel(loop,y,col,where); end; procedure PalPlay; var loop1,loop2:integer; R,G,B:byte; begin for loop1:=1 to 50 do begin delay(waitx+50); waitretrace; for loop2:=1 to loop1 do begin GetPal(loop2,R,G,B); Pal(loop2,R+1,0,0); end; end; end; procedure RedUp; var loop1,loop2:integer; Tmp : Array [1..3] of byte; { This is temporary storage for the values of a color } BEGIN For loop1:=1 to 64 do BEGIN { A color value for Red, green or blue is 0 to 63, so this loop only need be executed a maximum of 64 times } waitretrace; For loop2:=1 to 50 do BEGIN Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]); If Tmp[1]<63 then inc (Tmp[1]); Pal (loop2,Tmp[1],0,0); { Set the new, altered pallette color. } END; delay(waitx); END; END; Procedure Fadeup; { This procedure slowly fades up the new screen } VAR loop1,loop2:integer; Tmp : Array [1..3] of byte; { This is temporary storage for the values of a color } BEGIN For loop1:=1 to 64 do BEGIN { A color value for Red, green or blue is 0 to 63, so this loop only need be executed a maximum of 64 times } waitretrace; For loop2:=1 to 50 do BEGIN Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]); If Tmp[1]<63 then inc (Tmp[1]); If Tmp[2]<63 then inc (Tmp[2]); If Tmp[3]<63 then inc (Tmp[3]); Pal (loop2,Tmp[1],Tmp[2],Tmp[3]); { Set the new, altered pallette color. } END; delay(waitx); END; END; Procedure FadeOut; { This procedure slowly fades up the new screen } VAR loop1,loop2:integer; Tmp : Array [1..3] of byte; { This is temporary storage for the values of a color } BEGIN For loop1:=1 to 64 do BEGIN { A color value for Red, green or blue is 0 to 63, so this loop only need be executed a maximum of 64 times } waitretrace; For loop2:=1 to 50 do BEGIN Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]); If Tmp[1]>0 then dec (Tmp[1]); If Tmp[2]>0 then dec (Tmp[2]); If Tmp[3]>0 then dec (Tmp[3]); Pal (loop2,Tmp[1],Tmp[2],Tmp[3]); { Set the new, altered pallette color. } END; delay(waitx); END; END; procedure Obdelniky1; var loop1,loop2,loop3:integer; helpX,helpY,x,y:integer; begin for loop1:=0 to 48 do begin y:=200-loop1*4; x:=round(8*y/5); helpX:=round((320-x)/2); helpY:=loop1*2; for loop2:=helpy to Helpy+y-1 do for loop3:=helpx to helpx+x-1 do putpixel(loop3,loop2,loop1+1,VGA); end; end; begin SetUpVirtual; Cls(0,Vaddr); Cls(0,VGA); GrabPalette(OldPal); for i:=1 to 51 do pal(i,0,0,0); for i:=0 to 49 do for j:=0 to 3 do HLine(i*4+j,i+1,VGA); PutLogo; Palplay; RedUp; FadeUp; Obdelniky1; for i:=1 to 50 do begin waitretrace; pal(i,64-i,64-i,64-i); delay(30); end; fadeout; for i:=1 to 50 do begin waitretrace; pal(i,64-i,64-i,0); delay(30); end; for i:=1 to 25 do begin waitretrace; pal(i,0,0,64-i); delay(30); end; for i:=26 to 50 do begin waitretrace; pal(i,0,0,14+i); delay(30); end; j:=0; pal(51,0,0,0); pal(52,0,0,0); XYText(font,round((320-5*9)/2),80,51, 'FUNNY'+#0,VGA); XYText(font,round((320-5*9)/2),100,52,'SPACE'+#0,VGA); for i:=0 to 63 do begin pal(51,i,0,0); pal(52,i,i,0); delay(20); end; fadeout; delay(500); waitretrace; cls(0,VGA); RestorePalette(OldPal); ShutDown; end; procedure JaJenJA; begin cls(0,VGA); XYText(font,120+4,1*height,32,'WRITTEN'+#0,VGA); delay(500); XYText(font,120,3*height,35,'DESIGNED'+#0,VGA); delay(500); XYText(font,120,5*height,38,'ANIMATED'+#0,VGA); delay(500); XYText(font,120,7*height,41,' BY '+#0,VGA); delay(500); XYText(font,120,9*height,44,' ALESEK '+#0,VGA); repeat until keypressed; readkey; end; procedure ZobrazHLm; begin XYText(font,0,0,32,'Start hry.........s'+#0,VGA); XYText(font,0,Height,33,'Credits...........c'+#0,VGA); XYText(font,0,2*Height,34,'Konec...........ESC'+#0,VGA); end; function HLmenu:tHLmenu; var Znak:char; begin Znak:=readkey; case Znak of 's','S': HLmenu:= start; 'c','C': HLmenu:= credit; chr(27): HLmenu:= konci; end; end; var f:file; fsize:word; begin {Main program} clrscr; Assign(f,'rose.dat');{Mozna bude potreba upravit tuto cesu k danemu souboru} {$I-} Reset(f,1); {$I+} if IOresult <> 0 then begin writeln('Nenasel jsem soubor s fontem - rose.dat'); writeln('Nejspis bude potreba upravit cestu na radku 766 nebo ->'); writeln('Pokud spoustite program v kompilatoru musi byt soubor'); writeln('umisten v c:\rose.dat.'); writeln('Jinak jestli spoustite zkompilovanou verzi (*.exe) musi'); writeln('byt rose.dat ve stejnem adresari jako dany soubor!'); writeln;writeln; writeln('Stisknete klavesu'); repeat until keypressed; halt; end; fsize:=filesize(f); getmem(font,fsize); BlockRead(f,Font^,FileSize(F)); Close(f); reset(f,1); blockread(f,height,sizeof(height)); close(f); randomize; SetMCGA; intro; repeat waitretrace; cls(0,VGA); ZobrazHLm; case HLmenu of start : Game; credit: JaJenJA; konci : konec:=true; end; until konec; settext; freemem(font,fsize); end.