stefankoelle/dos-phobia-welcome-intro
1
0
Fork 0
mirror of https://github.com/skoelle/dos-phobia-welcome-intro.git synced 2026-09-17 20:50:24 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
91bbfc05fbd57d0a6bd03f0080e4b7c2c01e58fa
dos-phobia-welcome-intro/PHO.PAS
T
Stefan Koelle 91bbfc05fb Add files via upload 
initial commit
2025-01-03 19:58:23 +01:00

431 lines
13 KiB
ObjectPascal
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
{$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
{$M 16384,0,59360}
uses crt,textgraf,pho_u,pho_u2;
const rot:array[0..1] of integer=(1,0);
VERSION='1.3';
FADE_SPEED=10;
TANZ=10;
text:array[1..6*TANZ] of string[30]=('PRESENTS'
,'WELCOME'
,'---------------'
,''
,'PC INTRO BY'
,'STEFAN KOELLE'
,'[[[[[[[[[['
,'[ PHOBIA ['
,'[ 1994 ['
,'[ """""" ['
,'[ BY NST ['
,'[[[[[[[[[['
,''
,'CREDITS'
,'------'
,'CODING BY'
,'STEFAN'
,''
,''
,'CREDITS'
,'------'
,'GFX BY'
,'STEFAN'
,''
,''
,'CREDITS'
,'------'
,'MUSIC'
,'RIPPED'
,''
,''
,'CREDITS'
,'------'
,'IDEA FROM AN'
,'AMIGA DEMO'
,''
,''
,'SPECIAL GREETINGS'
,'----------------'
,'MAD DOC'
,'M T L'
,''
,''
,'NORMAL GREETINGS'
,'---------------'
,'SATAN CLAUS'
,'MAJ-SOFT'
,''
,''
,'INFO'
,'-------'
,'CODED 1994'
,'ON 486 DX50'
,''
,''
,'BYE BYE'
,'------'
,'PRESS ANY'
,'KEY'
,'');
var
dev,mix,stat,pro,loop : integer;
md : string;
i,txtz,txti,j,x,y,k:integer;
r,ri:real;
rb:boolean;
w:word;
p:vgacolors;
l:vgacolors;
cyc:array[0..2] of byte;
cy2:array[0..2,1..10] of byte;
s:string;
ch:char;
font : array[1..57,0..15,0..17] of byte;
{$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-}
procedure ch_pal;
var x,y,i,j:integer;
begin
inc(k);
if k=3 then begin
k:=0;
for i:=0 to 2 do cyc[i]:=p[94,i];
for j:=93 downto 80 do
for i:=0 to 2 do p[j+1,i]:=p[j,i];
for i:=0 to 2 do p[80,i]:=cyc[i];
end;
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[16+x-1+y*25+20,i];
for y:=0 to 1 do
for x:=1 to 5 do
for j:=1 to 4 do
for i:=0 to 2 do p[35+x+y*25-j*5+5,i]:=p[35+x+y*25-j*5,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[16+x-1+y*25,i]:=cy2[i,(x+rot[y]*5)];
ri:=ri+1;
if ri>372 then ri:=ri-372;
if sin(ri*6.3)*15<0 then begin
r:=r-sin(ri*6.3)*15;
rb:=FALSE;
end else begin
r:=r+sin(ri*6.3)*15;
rb:=TRUE;
end;
if r>20 then begin
r:=r-20;
if rb then begin
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[20+(x-1)*5+y*25,i];
for y:=0 to 1 do
for j:=1 to 4 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25-j+1,i]:=p[20+(x-1)*5+y*25-j,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25-4,i]:=cy2[i,x+rot[y]*5];
end else begin
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[16+(x-1)*5+y*25,i];
for y:=0 to 1 do
for j:=1 to 4 do
for x:=1 to 5 do
for i:=0 to 2 do p[16+(x-1)*5+y*25+j-1,i]:=p[16+(x-1)*5+y*25+j,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25,i]:=cy2[i,x+rot[y]*5];
end;
end;
end;
procedure writeline(wly : integer; wls : string);
var i,x,y,num,wlx:integer;
begin
wlx:=160-length(wls)*9+14;
for i:=1 to length(wls) do
for x:=0 to 15 do for y:=0 to 17 do begin
if wls[i]<>' ' then begin
case wls[i] of
'A'..'Z':num:=ord(wls[i])-64;
'0'..'9':num:=ord(wls[i])-19;
'*':num:=39;
'"':num:=40;
'!':num:=41;
'$':num:=42;
':':num:=43;
'.':num:=44;
',':num:=45;
'\':num:=46;
'?':num:=47;
'-':num:=48;
'+':num:=49;
'=':num:=50;
'[':num:=51;
']':num:=52;
'%':num:=53;
'(':num:=54;
')':num:=55;
end;
if font[num,x,y]<>0 then mem[$A000:(wly+y)*word(320)+wlx+x+(i-1)*16]:=font[num,x,y];
end;
end;
end;
procedure writeback(wly : integer; wls : string);
var i,x,y,num,wlx:integer;
begin
wlx:=160-length(wls)*9+14;
for i:=1 to length(wls) do
for x:=0 to 15 do for y:=0 to 17 do begin
if wls[i]<>' ' then begin
case wls[i] of
'A'..'Z':num:=ord(wls[i])-64;
'0'..'9':num:=ord(wls[i])-19;
'*':num:=39;
'"':num:=40;
'!':num:=41;
'$':num:=42;
':':num:=43;
'.':num:=44;
',':num:=45;
'\':num:=46;
'?':num:=47;
'-':num:=48;
'+':num:=49;
'=':num:=50;
'[':num:=51;
']':num:=52;
'%':num:=53;
'(':num:=54;
')':num:=55;
end;
if (font[num,x,y]<>0) then mem[$A000:(wly+y)*word(320)+wlx+x+(i-1)*16]
:=mem[seg(phopic):ofs(phopic)+(wly+y)*word(320)+wlx+x+(i-1)*16];
end;
end;
end;
procedure CLI; inline( $FA ); { Interrupts unterdr�cken }
procedure STI; inline( $FB ); { Interrupts wieder erlauben }
begin
CLI;
modinit;
clrscr;
writeln('PHOB­A Intro');
writeln('------------');
writeln;
writeln('F1 -PC Speaker (10000 kHz)');
writeln('F2 -PC Speaker (20000 kHz)');
writeln('F3 -SoundBlaster (10000 kHz)');
writeln('F4 -SoundBlaster (20000 kHz)');
writeln('F5 -D/A Wandler (10000 kHz)');
writeln('F6 -D/A Wandler (20000 kHz)');
writeln('F7 -Disney Source (10000 kHz)');
writeln('F8 -Disney Source (20000 kHz)');
writeln('F9 -PC Speaker (????? kHz)');
writeln('F10-SoundBlaster (????? kHz)');
writeln('ESC-No Sound');
writeln;
writeln('Press F1-F10 or ESC...');
i:=1;
repeat
ch:=readkey;
if ch=#27 then begin
i:=0;
dev:=255;
end;
if ch='+' then begin
clrscr;
writeln('Intro by: Stefan Koelle of Phobia * Version '+VERSION);
writeln('Intro skipped !!!');
STI;
halt(1);
end;
if ch=#0 then begin
ch:=readkey;
if (ord(ch)>58) and (ord(ch)<69) then i:=0;
end;
until i=0;
case ord(ch) of
59:begin
dev := 0;
mix := 10000;
end;
60:begin
dev := 0;
mix := 20000;
end;
61:begin
dev := 7;
mix := 10000;
end;
62:begin
dev := 7;
mix := 20000;
end;
63:begin
dev := 1;
mix := 10000;
end;
64:begin
dev := 1;
mix := 20000;
end;
65:begin
dev := 11;
mix := 10000;
end;
66:begin
dev := 11;
mix := 20000;
end;
67:begin
dev := 0;
writeln;
write('Enter Sample-Frequence (<=44000 kHz): ');
readln(mix);
end;
68:begin
dev := 7;
writeln;
write('Enter Sample-Frequence (<=20000 kHz): ');
readln(mix);
end;
end;
if (dev<>255) then begin
if paramcount=1 then begin
md:=paramstr(1);
end else begin
md:='pho.rsc';
end;
pro := 0; {Leave at 0}
loop :=4; {4 means mod will play forever}
modvolume (255,255,255,255); { Full volume }
end;
case InitTextGraf of
1: begin end;
end;
GrafikMode($13);
for w:=0 to 63999 do mem[$A000:w]:=0;
for i:=0 to 255 do for j:=0 to 2 do
l[i,j]:=0;
setvgacolors(l);
for w:=0 to 63999 do mem[$A000:w]:=mem[seg(phofnt):ofs(phofnt)+w];
for j:=0 to 1 do for i:=0 to 18 do
for x:=0 to 15 do for y:=0 to 17 do
font[i+j*19+1,x,y]:=mem[$A000:(y+j*18+1)*word(320) + x+i*16];
j:=2; for i:=0 to 18 do
for x:=0 to 15 do for y:=0 to 17 do
font[i+j*19+1,x,y]:=mem[$A000:(y+j*18+2)*word(320) + x+i*16];
for w:=0 to 63999 do mem[$A000:w]:=mem[seg(phopic):ofs(phopic)+w];
for i:=1 to 6 do
writeline(53+i*20,text[i]);
move(mem[seg(phopal):ofs(phopal)],p,sizeof(p));
k:=0;ri:=0;r:=0;
for x:=(40 div FADE_SPEED) downto 0 do begin
ch_pal;
for i:=0 to 255 do for j:=0 to 2 do begin
l[i,j]:=p[i,j]-x*FADE_SPEED;
if l[i,j]>p[i,j] then l[i,j]:=0;
end;
repeat until port[$3da] and 8 = 8;
setvgacolors(l);
end;
ch:='@';
txtz:=0;txti:=0;
if (dev<>255) then modsetup ( stat, dev, mix, pro, loop, md );
STI;
repeat
inc(txtz);
if txtz>150 then begin
txtz:=0;
j:=txti;
inc(txti);
if txti=TANZ then txti:=0;
for i:=1 to 6 do begin
ch_pal;
setvgacolors(p);
writeback(53+i*20,text[i+j*6]);
ch_pal;
setvgacolors(p);
writeline(53+i*20,text[i+txti*6]);
end;
end;
inc(k);
if k=3 then begin
k:=0;
for i:=0 to 2 do cyc[i]:=p[94,i];
for j:=93 downto 80 do
for i:=0 to 2 do p[j+1,i]:=p[j,i];
for i:=0 to 2 do p[80,i]:=cyc[i];
end;
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[16+x-1+y*25+20,i];
for y:=0 to 1 do
for x:=1 to 5 do
for j:=1 to 4 do
for i:=0 to 2 do p[35+x+y*25-j*5+5,i]:=p[35+x+y*25-j*5,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[16+x-1+y*25,i]:=cy2[i,(x+rot[y]*5)];
ri:=ri+1;
if ri>372 then ri:=ri-372;
if sin(ri*6.3)*15<0 then begin
r:=r-sin(ri*6.3)*15;
rb:=FALSE;
end else begin
r:=r+sin(ri*6.3)*15;
rb:=TRUE;
end;
if r>20 then begin
r:=r-20;
if rb then begin
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[20+(x-1)*5+y*25,i];
for y:=0 to 1 do
for j:=1 to 4 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25-j+1,i]:=p[20+(x-1)*5+y*25-j,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25-4,i]:=cy2[i,x+rot[y]*5];
end else begin
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do cy2[i,x+y*5]:=p[16+(x-1)*5+y*25,i];
for y:=0 to 1 do
for j:=1 to 4 do
for x:=1 to 5 do
for i:=0 to 2 do p[16+(x-1)*5+y*25+j-1,i]:=p[16+(x-1)*5+y*25+j,i];
for y:=0 to 1 do
for x:=1 to 5 do
for i:=0 to 2 do p[20+(x-1)*5+y*25,i]:=cy2[i,x+rot[y]*5];
end;
end;
repeat until port[$3da] and 8 = 8;
setvgacolors(p);
until keypressed;
ch:=readkey;
CLI;
if (dev<>255) then modstop;
for x:=1 to (40 div FADE_SPEED) do begin
ch_pal;
for i:=0 to 255 do for j:=0 to 2 do begin
if p[i,j]<FADE_SPEED then p[i,j]:=0 else dec(p[i,j],FADE_SPEED);
end;
repeat until port[$3da] and 8 = 8;
setvgacolors(p);
end;
for w:=0 to 63999 do mem[$A000:w]:=0;
TEXTMODE(co80);
clrscr;
writeln('Intro by: Stefan Koelle of Phobia * Version '+VERSION);
STI;
end.
Reference in New Issue View Git Blame Copy Permalink