Apple-2-SW/tb1
1
0
Fork 0
mirror of https://github.com/deater/tb1.git synced 2024-11-19 12:31:56 +00:00
Code Issues Projects Releases Wiki Activity
b8225aed5d
tb1/legacy_pascal/tb1sb.pas
Vince Weaver 6314d373e4 SDL Conversion, 2.9.1
2012-11-30 00:36:21 -05:00

949 lines
30 KiB
ObjectPascal
Raw Blame History

program TOM_BOMB_EM_AND_INVASION_OF_INANIMATE_OBJECTS;
{by Vincent Weaver....21085-4706}
uses vmwgraph,crt;
{$I c:\vmw\pascal\programs\tb1ans.pas}
{$M $4000,0,$20000} {16k stack, no heap - adjust as needed }
{$L MOD-obj.OBJ} { Link in Object file }
{$F+} { force calls to be 'far'}
procedure modvolume(v1,v2,v3,v4:integer); external ; {Can do while playing}
procedure moddevice(var device:integer); external ;
procedure modsetup(var status:integer;device,mixspeed,pro,loop:integer;var str:string); external ;
procedure modstop; external ;
procedure modinit; external;
{$F-}
type screentype = array [0..3999] of byte;
Type Shipinfo = Record { This is format of of each of our }
x,y:integer; { records for the flying toasters }
speed,frame:integer;
active:boolean;
END;
Virtual = Array [1..64000] of byte; { The size of our Virtual Screen }
VirtPtr = ^Virtual; { Pointer to the virtual screen }
var
dev,mix,stat,pro,loop : integer;
md : string;
VAR Virscr : VirtPtr; { Our first Virtual screen }
VirScr2 : VirtPtr; { Our second Virtual screen }
Vaddr : word; { The segment of our virtual screen}
Vaddr2 : Word; { The segment of our 2nd virt. screen}
ourpal : Array [0..255,1..3] of byte; { A virtual pallette }
shipv : Array [1..1] of shipinfo; { The toaster info }
Sound : Pointer;
Check : BOOLEAN;
frame:array[0..2,0..47,0..29] of byte;
bigflame:array[0..1,0..26,0..18] of byte;
smallflame:array[0..1,0..3,0..4] of byte;
barge:array[0..15,0..18] of byte;
truck:array[0..1,0..5,0..8] of byte;
score,level,lives,energy:integer;
axel_und_carmen:boolean;
tempi,tempj:integer;
scorest:string[8];
var grapherror:byte;
temp:array[1..3] of byte;
palf:text;
i,j:byte;
x,y,barpos:integer;
screen:screentype absolute $B800:0000;
ch:char;
function menuread:char;
var chtemp,ch2:char;
begin
repeat until keypressed;
ch2:=#0;
chtemp:=readkey;
if chtemp=chr(0) then ch2:=readkey;
chtemp:=upcase(chtemp);
if (ord(chtemp)<10) and (ord(chtemp)<128) then begin
if ch2='H' then chtemp:='<27>'; {up}
if ch2='M' then chtemp:='<27>'; {right}
if ch2='P' then chtemp:='<27>'; {down}
if ch2='K' then chtemp:='<27>'; {left}
if ch2=';' then chtemp:='<27>'; {f1}
if ch2='I' then chtemp:='<27>'; {pgup}
if ch2='Q' then chtemp:='<27>'; {pgdown}
end;
menuread:=chtemp;
end;
procedure coolbox(x1,y1,x2,y2:integer;fill:boolean;page:word);
begin
for i:=0 to 5 do box(x1+i,y1+i,x2-i,y2-i,31-i,page);
if fill then for i:=y1+5 to y2-5 do line(x1+5,i,x2-5,i,7,page);
end;
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
Procedure ShutDown;
{ This frees the memory used by the virtual screen }
BEGIN
FreeMem (VirScr,64000);
FreeMem (VirScr2,64000);
END;
procedure QUIT;
label menu2;
begin
coolbox(90,75,230,125,true,vga);
barpos:=0;
outtextxy('QUIT??? ARE YOU',97,82,15,9,7,vga,false);
outtextxy('ABSOLUTELY SURE?',97,90,15,9,7,vga,false);
repeat
if barpos=0 then outtextxy('YES-RIGHT NOW!',97,98,15,150,0,vga,true)
else outtextxy('YES-RIGHT NOW!',97,98,15,150,7,vga,true);
if barpos=1 then outtextxy('NO--NOT YET.',97,106,15,150,0,vga,true)
else outtextxy('NO--NOT YET.',97,106,15,150,7,vga,true);
ch:=menuread;
if (ord(ch)>219) and (ord(ch)<224) then inc(barpos);
if ch='Y' then barpos:=0;
if ch='N' then barpos:=1;
if barpos=2 then barpos:=0;
until ch=#13;
if barpos=1 then goto menu2;
settext;
move(imagedata,screen,4000);
gotoxy(1,23);
halt;
menu2:
barpos:=6;
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;
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
Procedure drawstars(menu:boolean);
{ This procedure sets up the static background to be used in the program }
CONST circ : Array [1..5,1..5] of byte =
((00,00,30,00,00),
(00,00,26,00,00),
(30,26,18,26,30),
(00,00,26,00,00),
(00,00,30,00,00));
VAR i,x,y:integer;
loop1,loop2,loop3:integer;
tempaddr:word;
procedure makehole(y:integer);
var i:integer;
begin
for i:=10 to 75 do line(239+i,y,239+i,y+9,0,tempaddr);
line(249,y,314,y,24,tempaddr);
line(249,y+10,313,y+10,18,tempaddr);
line(249,y,249,y+9,24,tempaddr);
line(314,y+1,314,y+10,18,tempaddr);
end;
BEGIN
tempaddr:=vaddr;
For loop1:=1 to 200 do BEGIN
x:=random (315);
y:=random (195);
For loop2:=1 to 5 do
For loop3:=1 to 5 do
if circ [loop2,loop3]<>0 then
putpixel (x+loop2,y+loop3,circ [loop2,loop3],tempaddr);
END;
if menu=false then begin
for i:=240 to 319 do line(i,0,i,199,19,tempaddr);
line(240,0,240,199,18,tempaddr);
line(240,0,319,0,18,tempaddr);
line(319,0,319,199,24,tempaddr);
line(241,199,319,199,24,tempaddr);
outtextxy('SCORE',241,1,15,127,0,tempaddr,false);
outtextxy('SCORE',242,2,15,143,0,tempaddr,false);
makehole(10);
outtextxy(' 0',250,12,15,12,0,tempaddr,false);
outtextxy('HI-SCORE',241,21,15,127,0,tempaddr,false);
outtextxy('HI-SCORE',242,22,15,143,0,tempaddr,false);
makehole(30);
outtextxy(' 0',250,32,15,12,0,tempaddr,false);
outtextxy('LEVEL',241,41,15,127,0,tempaddr,false);
outtextxy('LEVEL',242,42,15,143,0,tempaddr,false);
makehole(50);
outtextxy('12345675',251,52,15,12,0,tempaddr,false);
outtextxy('SHIELDS',241,61,15,127,0,tempaddr,false);
outtextxy('SHIELDS',242,62,15,143,0,tempaddr,false);
makehole(70);
for i:=0 to 63 do line(250+i,71,250+i,79,((i div 4)+32),tempaddr);
outtextxy('WEAPONS',241,81,15,127,0,tempaddr,false);
outtextxy('WEAPONS',242,82,15,143,0,tempaddr,false);
makehole(90);
for i:=0 to 65 do line(249+i,111,249+i,189,0,tempaddr);
line(249,111,249,189,24,tempaddr);
line(315,111,315,189,18,tempaddr);
line(249,111,315,111,24,tempaddr);
line(249,189,315,189,18,tempaddr);
outtextxy(' VMW ',251,114,15,15,0,tempaddr,false);
outtextxy('F1-HELP ',251,124,15,15,0,tempaddr,false);
outtextxy('ESC-QUIT',251,135,15,15,0,tempaddr,false);
outtextxy('F2-SAVE ',251,145,15,15,0,tempaddr,false);
end;
if not(menu) then begin
flip (vaddr,vga); { Copy the entire screen at vaddr, our virtual screen }
{ on which we have done all our graphics, onto the }
{ screen you see, VGA }
flip (vaddr,vaddr2);
end;
END;
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
Procedure ScreenTrans (x,y,p1,p2:word);
{ This is a small procedure to copy a 30x30 pixel block from coordinates
x,y on the virtual screen to coordinates x,y on the true vga screen }
BEGIN
asm
push ds
push es
mov ax,p1
mov es,ax
mov ax,p2
mov ds,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}
mov si, di
mov al,60
mov bx, 30 { Hight of block to copy }
@@1 :
mov cx, 24 { Width of block to copy divided by 2 }
rep movsw
add di,110h { 320 - 48 = 272 .. or 110 in hex }
add si,110h
dec bx
jnz @@1
pop es
pop ds
end;
{ I wrote this procedure late last night, so it may not be in it's
most optimised state. Sorry :-)}
END;
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
Procedure newship;
{ This adds a new toaster to the screen }
VAR loop1:integer;
BEGIN
loop1:=1;
if not (shipv[1].active) then BEGIN
shipv[1].x:=36;
shipv[1].y:=165;
shipv[1].active:=true;
shipv[1].frame:=1;
shipv[1].speed:=5;
loop1:=10;
END;
END;
procedure putico(x,y,fra:byte;where:word);
var i,j,col:integer;
begin
for i:=0 to 47 do
for j:=0 to 29 do begin
col:=frame[fra,i,j];
if col<>0 then putpixel(i+x,y+j,col,where);
end;
end;
procedure putwave(x,y,fra:byte;where:word);
var i,j,col:integer;
begin
for i:=10 to 30 do
for j:=0 to 5 do begin
col:=frame[fra,i,j];
if col<>0 then putpixel((i+x)-10,y+j,col,where);
end;
end;
procedure changescore;
begin
str(score:8,scorest);
outtextxy(scorest,250,12,15,12,0,vaddr,true);
end;
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
Procedure shiproutine;
VAR loop1,loop2:integer;
ch,ch2:char;
shieldcol:integer;
wave1:array[0..5] of boolean;
bulletx,bullety,oldwavex,oldwavey,wavex,wavey,i,waveadd:integer;
bulletout:boolean;
BEGIN
pal(254,0,0,0);
shieldcol:=0;
shipv[1].active:=false;
newship;
ch:=#1; ch2:=#1;
wavex:=0; wavey:=0; waveadd:=5;
oldwavex:=0; oldwavey:=0;
bulletout:=false; bulletx:=0; bullety:=0;
for i:=0 to 4 do wave1[i]:=true;
Repeat
ch2:=#1;
if (bulletout) and (bulletx>wavex) and (bulletx<wavex+100) and
(bullety>wavey) and (bullety<wavey+10) then begin
bulletout:=false;
inc(score,10);
changescore;
wave1[(bulletx-wavex) div 20]:=false;
end;
if bulletout then begin
screentrans(bulletx,bullety,vaddr,vaddr2);
dec(bullety,5);
if bullety<5 then bulletout:=false;
if bulletout then putwave(bulletx,bullety,1,vaddr);
end;
for i:=0 to 5 do
screentrans((oldwavex+20*i),oldwavey,vaddr,vaddr2);
for i:=0 to 5 do
if wave1[i] then putwave(wavex+20*i,wavey,1,vaddr);
oldwavex:=wavex; oldwavey:=wavey;
wavex:=wavex+waveadd;
if (wavex>100) or (wavex<5) then begin
inc(wavey,5);
waveadd:=-waveadd;
end;
if wavey>150 then begin
wavey:=0;
for i:=0 to 5 do if wave1[i]=false then wave1[i]:=true;
end;
if keypressed then BEGIN
ch:=readkey;
if ch=chr(0) then ch2:=readkey;
if ch2='M' then inc(shipv[1].x,5);
if ch2='K' then dec(shipv[1].x,5);
if ch=' ' then begin
bulletout:=true;
bulletx:=shipv[1].x+10;
bullety:=shipv[1].y;
putwave(bulletx,bullety,1,vaddr);
end;
if ch='+' then begin inc(shieldcol,3); pal(254,shieldcol,0,0);
if shieldcol>58 then shieldcol:=59;
end;
if ch='-' then begin dec(shieldcol,3); pal(254,shieldcol,0,0);
if shieldcol<5 then shieldcol:=3;
end;
end;
if shipv[1].active then BEGIN
screentrans (shipv[1].x,shipv[1].y,vaddr,vaddr2);
{ Restore the backgrond the toaster was over }
{ Move the toaster }
if (shipv[1].x<1) then shipv[1].x:=1;
if (shipv[1].x>255) then shipv[1].x:=255;
{ When toaster reaches the edge of the screen, render it inactive
and bring a new one into existance. }
END;
if shipv[1].active then BEGIN
CASE shipv [1].frame of
1 : putico (shipv[1].x,shipv[1].y,0,vaddr);
3 : putico (shipv[1].x,shipv[1].y,1,vaddr);
2,4 : putico (shipv[1].x,shipv[1].y,2,vaddr);
END;
shipv[1].frame:=shipv[1].frame+1;
if shipv[1].frame=5 then shipv[1].frame:=1;
{ Draw all the toasters on the VGA screen }
end;
waitretrace;
flip (vaddr,vga);
until ch=#27;
fade
END;
procedure playthegame(lev:integer);
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>}
var palloop,paldir:integer;
begin
cls(0,vaddr);
grapherror:=loadpicsuperpacked(0,0,vga,'tbma1.tb1');
outtextxy('MOONBASE ALPHA: EARTH''S LAST CHANCE!',5,5,15,1,0,vga,false);
pal(255,0,0,0);
palloop:=0;
paldir:=1;
repeat
pal(255,palloop,0,0);
if paldir=1 then inc(palloop)
else dec(palloop);
if palloop>62 then paldir:=-1;
if palloop<1 then paldir:=1;
delay(50);
until keypressed;
ch:=readkey;
drawstars(false);
shiproutine;
end;
procedure dographics;
var i,j:integer;
begin
grapherror:=loadpicsuperpacked(0,0,vaddr,'ships.tb1');
for i:=0 to 47 do
for j:=0 to 29 do
frame[0,i,j]:=getpixel(i,j,vaddr);
for i:=0 to 47 do
for j:=0 to 29 do
frame[1,i,j]:=getpixel(i,j+32,vaddr);
for i:=0 to 47 do
for j:=0 to 29 do
frame[2,i,j]:=getpixel(i,j+64,vaddr);
end;
procedure background;
begin
cls(0,vaddr);
drawstars(true);
coolbox(0,0,319,199,false,vaddr);
end;
procedure options;
begin
background;
flip(vaddr,vga);
outtextxy('AS OF YET THERE ARE NO OPTIONS!',10,10,15,9,0,vga,false);
repeat until keypressed;
ch:=readkey;
end;
procedure loadgame;
begin
coolbox(90,75,230,125,true,vga);
outtextxy('LOAD WHICH GAME',97,82,15,9,7,vga,false);
outtextxy(' (0-9) ',97,90,15,9,7,vga,false);
repeat until keypressed;
level:=0;
end;
procedure help;
begin
background;
flip(vaddr,vga);
outtextxy('HELP',10,10,15,9,0,vga,false);
outtextxy('Press ESC to exit most stuff.',10,20,15,9,0,vga,false);
outtextxy('Use the arrows to manuever.',10,30,15,9,0,vga,false);
repeat until keypressed;
ch:=readkey;
end;
procedure story;
var error:byte;
xtemp,ytemp:integer;
thrustcol:integer;
thrust:real;
tempch:char;
procedure putbigflame(xp,yp,frame:integer);
var xtemp,ytemp:integer;
begin
for xtemp:=0 to 26 do
for ytemp:=0 to 18 do
putpixel(xtemp+xp,ytemp+yp,bigflame[frame,xtemp,ytemp],vaddr);
end;
procedure putsmallflame(xp,yp,frame:integer);
var xtemp,ytemp:integer;
begin
for xtemp:=0 to 3 do
for ytemp:=0 to 4 do
putpixel(xtemp+xp,ytemp+yp,smallflame[frame,xtemp,ytemp],vaddr);
end;
procedure putbarge(xp,yp:integer;where:word);
var xtemp,ytemp:integer;
col:byte;
begin
for xtemp:=0 to 15 do
for ytemp:=0 to 18 do begin
if (ytemp+yp>=0) then begin
col:=barge[xtemp,ytemp];
if col<>0 then putpixel(xtemp+xp,ytemp+yp,col,where);
end;
end;
end;
procedure puttruck(xp,yp,frame:integer;where:word);
var xtemp,ytemp:integer;
col:byte;
begin
for xtemp:=0 to 5 do
for ytemp:=0 to 8 do begin
col:=truck[frame,xtemp,ytemp];
if (ytemp+yp>=173) then begin
if col<>0 then putpixel(xtemp+xp,ytemp+yp,col,where);
end;
end;
end;
begin
fade;
error:=loadpicsuperpacked(0,0,vaddr,'tbsobj.tb1');
for xtemp:=0 to 26 do
for ytemp:=0 to 18 do begin
bigflame[0,xtemp,ytemp]:=getpixel(xtemp,ytemp+2,vaddr);
bigflame[1,xtemp,ytemp]:=getpixel(xtemp,ytemp+21,vaddr);
end;
for xtemp:=0 to 3 do
for ytemp:=0 to 4 do begin
smallflame[0,xtemp,ytemp]:=getpixel(xtemp,ytemp+43,vaddr);
smallflame[1,xtemp,ytemp]:=getpixel(xtemp,ytemp+47,vaddr);
end;
for xtemp:=0 to 15 do
for ytemp:=0 to 18 do
barge[xtemp,ytemp]:=getpixel(xtemp+65,ytemp+100,vaddr);
for xtemp:=0 to 5 do
for ytemp:=0 to 8 do begin
truck[0,xtemp,ytemp]:=getpixel(xtemp+85,ytemp+100,vaddr);
truck[1,xtemp,ytemp]:=getpixel(xtemp+95,ytemp+100,vaddr);
end;
{******FIRST MESSAGE*******}
cls(0,vga);
outtextxy('MOON BASE ALPHA:',5,5,15,9,0,vga,false);
outtextxy(' THE FIRST PRIVATELY FINANCED SPACE ',5,15,15,9,0,vga,false);
outtextxy(' VENTURE. FOUNDED IN 2004 BY PIONEER',5,25,15,9,0,vga,false);
outtextxy(' VINCE WEAVER. IN ORDER TO SUPPORT',5,35,15,9,0,vga,false);
outtextxy(' ITSELF, IT DISPOSED OF GARBAGE AND',5,45,15,9,0,vga,false);
outtextxy(' NUCLEAR WASTE FROM EARTH BY LAUNCHING',5,55,15,9,0,vga,false);
outtextxy(' IT INTO DEEP SPACE WITH BARGES. ',5,65,15,9,0,vga,false);
outtextxy('NOW IT IS 2018, AND THE LAST BARGE IS',5,75,15,9,0,vga,false);
outtextxy(' TO BE LAUNCHED. NOW ALL WORK THERE',5,85,15,9,0,vga,false);
outtextxy(' WILL BE CONCENTRATED ON BUILDING A',5,95,15,9,0,vga,false);
outtextxy(' TERRAN SPACE FLEET.',5,105,15,9,0,vga,false);
unfade;
repeat until keypressed; tempch:=readkey;
pal(250,0,0,0);
fade;
{******BARGE TAKING OFF**********}
error:=loadpicsuperpacked(0,0,vaddr2,'tbma1.tb1');
putbarge(141,157,vaddr2);
flip(vaddr2,vaddr);
flip(vaddr,vga);
unfade;
for ytemp:=191 downto 165 do begin
screentrans(145,ytemp,vaddr,vaddr2);
puttruck(145,ytemp,ytemp mod 2,vaddr);
vdelay(7);
flip(vaddr,vga);
end;
error:=loadpicsuperpacked(0,0,vaddr2,'tbma1.tb1');
vdelay(20);
flip(vaddr2,vaddr);
putbarge(141,157,vaddr);
thrustcol:=0;
ytemp:=157;
thrust:=0;
while ytemp>-25 do begin
thrust:=thrust+0.05;
if thrustcol<63 then inc(thrustcol);
screentrans(141,ytemp,vaddr,vaddr2);
putbarge(141,ytemp,vaddr);
vdelay(7);
pal(250,thrustcol,0,0);
flip(vaddr,vga);
ytemp:=ytemp-round(thrust);
end;
vdelay(100);
fade;
{******SECOND MESSAGE*******}
cls(0,vga);
outtextxy('5 YEARS LATER, 1 LIGHT YEAR DISTANT',5,5,15,9,0,vga,false);
outtextxy(' CATASTROPHE STRIKES!! ',5,15,15,9,0,vga,false);
unfade;
vdelay(100);
repeat until keypressed; tempch:=readkey;
fade;
{******ALIEN DELEGATION*****}
error:=loadpicsuperpacked(0,0,vaddr2,'tbcrash.tb1');
flip(vaddr2,vaddr);
unfade;
repeat
putbigflame(213,100,0);
putsmallflame(105,90,1);
putsmallflame(151,71,0);
putsmallflame(218,72,1);
putbarge(160,180,vaddr);
flip(vaddr,vga);
vdelay(5);
putbigflame(213,100,1);
putsmallflame(105,90,0);
putsmallflame(151,71,1);
putsmallflame(218,72,0);
flip(vaddr,vga);
vdelay(5);
until keypressed;
ch:=readkey;
{****ALIEN MESSAGE*****}
fade;
error:=loadpicsuperpacked(0,0,vga,'tbgorg.tb1');
unfade;
outtextxy('GREETINGS EARTHLINGS.',0,162,15,12,0,vga,false);
outtextxy('I AM GORGONZOLA THE REPULSIVE.',0,171,15,12,0,vga,false);
outtextxy('YOU HAVE MADE A BIG MISTAKE.',0,180,15,12,0,vga,false);
readln;
end;
procedure credits;
var j:integer;
sp:integer;
procedure rotate(stri:string;col:integer);
var j1:integer;
begin
if sp=1 then begin
for j1:=0 to 7 do begin
outtextxy(stri,0,198,j1,col,0,vga,false);
Move (mem[vga:320],mem[vga:0],63680);
if keypressed then begin inc(sp); cls(0,vga); end;
end;
end;
if sp<>1 then begin
outtextxy(stri,0,180,15,col,0,vga,true);
Move (mem[vga:3200],mem[vga:0],60800);
end;
end;
procedure skip; begin rotate(' ',0); end;
begin
sp:=1;
cls(0,vaddr);
flip(vaddr,vga);
j:=0;
if keypressed then ch:=readkey;
rotate(' TOM BOMBEM',4);
rotate(' INVASION OF THE INANIMATE OBJECTS',4);
skip; rotate(' PROGRAMMING',9);
skip; rotate(' VINCENT M WEAVER',9);
skip; skip; rotate(' GRAPHICS',10);
skip; rotate(' VINCENT M WEAVER',10);
skip; skip; rotate(' SOUND',11);
skip; rotate(' VINCENT M WEAVER',11);
skip; skip; rotate(' GRAPHICS INSPIRATION',12);
skip; rotate(' JEFF WARWICK',12);
skip; skip; rotate(' UTOPIA BBS 410-557-0868',13);
skip; rotate(' JOHN CLEMENS',13);
skip; rotate(' JASON GRIMM',13);
skip; skip; rotate(' PCGPE AUTHORS, esp',14);
skip; rotate(' GRANT SMITH',14);
skip; skip; rotate(' SOUND BLASTER INFO',15);
skip; rotate(' AXEL STOLZ',15);
skip; skip; rotate(' INSPIRATION',9);
skip; rotate(' DOUGLAS ADAMS',9);
skip; rotate(' GENE RODENBERRY',9);
skip; rotate(' CLIFF STOLL',9);
skip; rotate(' ARTHUR C CLARKE',9);
skip; rotate(' ISAAC ASIMOV',9);
skip; rotate(' GORDON KORMAN',9);
skip; skip; rotate(' THANKS TO ALL THE AGENTS',10);
skip; rotate(' B,D,JL,L,N,P,S,W,PM,E',10);
skip; rotate(' AND ESPECIALLY AGENT G',10);
i:=0;
repeat
move(mem[vaddr2:(i*320)],mem[vga:63680],320);
Move (mem[vga:320],mem[vga:0],63680);
inc(i);
until (keypressed) or (i=299);
if keypressed then ch:=readkey;
end;
procedure shadowrite(st:string;x5,y5,forecol,backcol:integer);
begin
outtextxy(st,x5+1,y5+1,15,backcol,0,vga,false);
outtextxy(st,x5,y5,15,forecol,0,vga,false);
end;
procedure register;
var pagenum,oldpagenum,numpages:integer;
pagest:string;
numst:string[2];
procedure page1;
begin
flip(vaddr,vga);
shadowrite(' TO REGISTER',10,10,9,1);
shadowrite('THIS GAME WAS WRITTEN BY A 16 YEAR OLD',10,30,9,1);
shadowrite(' ENTIRELY IN HIS FREE TIME.',10,40,9,1);
shadowrite('HOPEFULLY YOU FEEL HIS FREE TIME IS',10,50,9,1);
shadowrite(' WORTH SOMETHING.',10,60,9,1);
shadowrite('WARNING:',10,80,12,4);
shadowrite(' VMW SOFTWARE IS NOT AN INCORPORATED',10,90,12,4);
shadowrite(' COMPANY, NOR DOES IT HAVE ANY INCOME',10,100,12,4);
shadowrite(' EXCEPT DONATIONS. NONE OF ITS',10,110,12,4);
shadowrite(' SYMBOLS ARE TRADEMARKED EITHER. (BUT',10,120,12,4);
shadowrite(' I DOUBT YOU''LL NAME A COMPANY AFTER',10,130,12,4);
shadowrite(' MY ININTIALS)',10,140,12,4);
end;
procedure page2;
begin
flip(vaddr,vga);
shadowrite('PLEASE SEND ANY DONATIONS TO:',10,10,10,2);
shadowrite(' VINCENT WEAVER',10,20,10,2);
shadowrite(' 326 FOSTER KNOLL DR.',10,30,10,2);
shadowrite(' JOPPA, MD 21085-4706, USA, ETC.',10,40,10,2);
shadowrite('ANY DONATION OF $5 OR MORE GETS THE',10,60,13,5);
shadowrite(' NEWEST VERSION OF THE GAME, PLUS',10,70,13,5);
shadowrite(' ANY OTHER COOL PROGRAMS I HAVE AT',10,80,13,5);
shadowrite(' THE TIME.',10,90,13,5);
shadowrite('ALSO IF YOU SEND ME A SELF ADDRESSED',10,110,11,3);
shadowrite(' STAMPED ENVELOPE WITH SUFFICIENT',10,120,11,3);
shadowrite(' POSTAGE AND A 3 1/2 INCH DISK IN',10,130,11,3);
shadowrite(' IT, I WILL COPY THE NEWEST VERSION',10,140,11,3);
shadowrite(' OF THE GAME ONTO IT.',10,150,11,3);
end;
procedure page3;
begin
flip(vaddr,vga);
shadowrite('OTHER VMW SOFTWARE PRODUCTIONS:',10,10,15,7);
shadowrite(' PAINTPRO:',10,30,13,5);
shadowrite(' LOAD AND SAVE GRAPHICS PICTURES',10,40,13,5);
shadowrite(' INTO C, PASCAL, BASIC, ETC.',10,50,13,5);
shadowrite(' WITH SCREEN CAPTURE UTILITY.',10,60,13,5);
shadowrite(' SPACEWAR III:',10,70,11,3);
shadowrite(' ALMOST COMPLETE GAME WITH WORKING',10,80,11,3);
shadowrite(' SPACESHIPS. SORT OF COOL.',10,90,11,3);
shadowrite(' AITAS: (ADVENTURES IN TIME AND SPACE)',10,100,12,4);
shadowrite(' THIS GAME WILL BE FINISHED SOMEDAY.',10,110,12,4);
shadowrite(' IT HAS BEEN UNDER WAY FOR 3 YEARS.',10,120,12,4);
shadowrite(' MISC PASCAL/BASIC PROGRAMS:',10,130,9,1);
shadowrite(' OVER 500 PROGRAMS WRITTEN OR TYPED',10,140,9,1);
shadowrite(' IN BY ME....FUN TO LOOK AT.',10,150,9,1);
end;
procedure page4;
begin
flip(vaddr,vga);
shadowrite('DISCLAIMERS:',10,10,12,14);
shadowrite('** THE ABOVE PROGRAMS HAVE NEVER DONE**',5,30,12,4);
shadowrite('** ANYTHING BAD TO MY COMPUTER THAT **',5,40,12,4);
shadowrite('** CTRL-ALT-DEL WOULDN''T FIX. I AM **',5,50,12,4);
shadowrite('** NOT RESPONSIBLE FOR HARD DISK **',5,60,12,4);
shadowrite('** DISSAPPEARANCES, MISSING MODEMS **',5,70,12,4);
shadowrite('** MOUSE BREAKDOWNS, MELTING MONITORS**',5,80,12,4);
SHADOWRITE('** OR ANYTHING ELSE. **',5,90,12,4);
shadowrite('%% ALL VMW SOFTWARE PRODUCTIONS ARE %%',5,110,11,3);
shadowrite('%% CERTIFIED VIRUS FREE!!!!!!!!!!!! %%',5,120,11,3);
end;
begin
background;
pagenum:=1;
oldpagenum:=1;
numpages:=4;
page1;
shadowrite('PAGE 1 of 4: ESC QUITS',50,180,15,7);
repeat
ch:=menuread;
if (ch=' ') or (ch=#13) then inc(pagenum);
if (ch='<27>') or (ch='<27>') or (ch='<27>') then inc(pagenum);
if (ch='<27>') or (ch='<27>') or (ch='<27>') then dec(pagenum);
if pagenum>4 then pagenum:=1;
if pagenum<1 then pagenum:=4;
if oldpagenum<>pagenum then begin
if pagenum=1 then page1;
if pagenum=2 then page2;
if pagenum=3 then page3;
if pagenum=4 then page4;
str(pagenum:2,numst);
pagest:=concat('PAGE ',numst);
str(numpages:2,numst);
pagest:=concat(pagest,' of ',numst,': ESC QUITS');
shadowrite(pagest,50,180,15,7);
oldpagenum:=pagenum;
end;
until ch=#27;
end;
label picloader,menu;
begin
axel_und_carmen:=true; {as_of_9-22-94} {change_back_10-6-94}
randomize;
setupvirtual;
fade;
setmcga;
dographics;
energy:=15;
lives:=2;
score:=0;
level:=0;
for x:=0 to 40 do begin
pal(100+x,x+20,0,0);
pal(141+x,0,0,x+20);
pal(182+x,0,x+20,0);
end;
fade;
modinit;
dev:=7;
md:='vmwfan.tb1';
mix := 10000; {use 10000 normally }
pro := 0; {Leave at 0}
loop :=0; {4 means mod will play forever}
modvolume (255,255,255,255); { Full volume }
modsetup ( stat, dev, mix, pro, loop, md );
case stat of
1: writeln('Not a mod');
2: writeln('Already playing');
4: writeln('Out of memory');
end;
for x:=0 to 40 do begin
line(x+40,45,x+40,45+(2*x),100+x,vga);
line(x+120,45,x+120,45+(2*x),141+x,vga);
line(x+200,45,x+200,45+(2*x),141+x,vga);
line(x+80,125,x+80,125-(2*x),182+x,vga);
line(x+160,125,x+160,125-(2*x),182+x,vga);
end;
for x:=40 downto 0 do begin
line(x+80,45,x+80,125-(2*x),140-x,vga);
line(x+160,45,x+160,125-(2*x),181-x,vga);
line(x+240,45,x+240,125-(2*x),181-x,vga);
line(x+120,125,x+120,45+(2*x),222-x,vga);
line(x+200,125,x+200,45+(2*x),222-x,vga);
end;
unfade;
outtextxy('A VMW SOFTWARE PRODUCTION',60,140,15,15,15,VGA,false);
y:=0;
repeat until keypressed;
ch:=readkey;
modstop;
fade;
cls(0,vga);
assign(palf,'pal.tb1');
reset(palf);
for i:=0 to 255 do begin
for j:=1 to 3 do readln(palf,temp[j]);
pal(i,temp[1],temp[2],temp[3]);
end;
close(palf);
fade;
PICLOADER:
grapherror:=loadpicsuperpacked(0,0,vaddr2,'tbomb1.tb1');
if not(axel_und_carmen) then begin
for tempi:=193 to 199 do
for tempj:=290 to 319 do
putpixel(tempj,tempi,0,vaddr2);
end;
MENU:
modinit;
dev:=7;
md:='weave1.tb1';
mix := 10000; {use 10000 normally }
pro := 0; {Leave at 0}
loop :=0; {4 means mod will play forever}
modvolume (255,255,255,255); { Full volume }
modsetup ( stat, dev, mix, pro, loop, md );
case stat of
1: writeln('Not a mod');
2: writeln('Already playing');
4: writeln('Out of memory');
end;
flip(vaddr2,vga);
unfade;
repeat until keypressed;
ch:=readkey;
barpos:=0;
outtextxy('F1 HELP',0,190,15,9,7,vga,false);
coolbox(117,61,199,140,true,vga);
repeat
if barpos=0 then outtextxy('NEW GAME',123,67,15,32,0,vga,true)
else outtextxy('NEW GAME',123,67,15,32,7,vga,true);
if barpos=1 then outtextxy('OPTIONS',123,77,15,32,0,vga,true)
else outtextxy('OPTIONS',123,77,15,32,7,vga,true);
if barpos=2 then outtextxy('REGISTER',123,87,15,32,0,vga,true)
else outtextxy('REGISTER',123,87,15,32,7,vga,true);
if barpos=3 then outtextxy('LOAD GAME',123,97,15,32,0,vga,true)
else outtextxy('LOAD GAME',123,97,15,32,7,vga,true);
if barpos=4 then outtextxy('STORY',123,107,15,32,0,vga,true)
else outtextxy('STORY',123,107,15,32,7,vga,true);
if barpos=5 then outtextxy('CREDITS',123,117,15,32,0,vga,true)
else outtextxy('CREDITS',123,117,15,32,7,vga,true);
if barpos=6 then outtextxy('QUIT',123,127,15,32,0,vga,true)
else outtextxy('QUIT',123,127,15,32,7,vga,true);
ch:=menuread;
if (ord(ch)=222) or (ord(ch)=220) then inc(barpos);
if (ord(ch)=223) or (ord(ch)=221) then dec(barpos);
if (ord(ch)=168) then begin barpos:=10; ch:=#13; end;
if ch='N' then barpos:=0;
if ch='O' then barpos:=1;
if ch='R' then barpos:=2;
if ch='L' then barpos:=3;
if ch='S' then barpos:=4;
if ch='C' then barpos:=5;
if ch='Q' then barpos:=6;
if ch='A' then axel_und_carmen:=not(axel_und_carmen);
if ch=#27 then begin
barpos:=6;
ch:=#13;
end;
if barpos=7 then barpos:=0;
if barpos=-1 then barpos:=6;
until ch=#13;
modstop;
if barpos=6 then quit;
if barpos=1 then options;
if barpos=2 then register;
if barpos=3 then loadgame;
if barpos=4 then story;
if barpos=5 then credits;
if barpos=10 then help;
if barpos=0 then playthegame(0);
if barpos=0 then goto picloader;
if barpos=4 then goto picloader;
goto menu;
end.
Reference in New Issue View Git Blame Copy Permalink