{ 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.