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
3d36cd89db65d2f79443de43037b250db361e85a
dos-phobia-welcome-intro/source/PHO.PAS
T
stefankoelle 3d36cd89db changes LICENSE
2026-08-04 22:58:39 +02:00

433 lines
12 KiB
ObjectPascal
Raw Blame History

{ Copyright (c) 2026 Stefan Koelle (https://stefankoelle.de) }
{ Licensed under the MIT License. See LICENSE file in project root for details. }
{$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