home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Stars of Shareware: Animation & Sound
/
SOS-ANIM_SOUND.ISO
/
archiv
/
mm_tease.zip
/
SOURCE.LZH
/
TEASER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-05-17
|
22KB
|
860 lines
program Skull;
uses
vga4page, crt;
{$M $4000,0,0} {16k stack, no heap - adjust as needed }
{$L MOD-obj.OBJ} { Link in Object file }
type
PointRec3D = array [1..3] of
record
x, y, z : integer
end;
Triangles = array [1..17] of PointRec3D;
var
t, t2 : triangles;
velocity : array [1..17] of
record
x, y, dx, dy,
theta1, theta2, theta3,
dt1, dt2, dt3 : integer;
end;
eye1x, eye1y, eye2x, eye2y : integer;
nose1x, nose1y, nose2x, nose2y, nose3x, nose3y,
nose4x, nose4y, nose5x, nose5y, nose6x, nose6y : integer;
dev : integer; { sound device for mod }
font : array [0..255, 0..15] of byte;
page : integer;
{$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 RGB (color, red, green, blue : integer);
begin
while (port [$3da] and 8) <> 8 do;
port [$3c8] := color;
port [$3c9] := red;
port [$3c9] := green;
port [$3c9] := blue
end;
Function ISqrt(a:word):integer;
begin
Isqrt:=round(sqrt(a));
end;
procedure fillcircle (x_center, y_center, radius, color : integer);
var
x,y,r2:integer;
begin
if radius=0 then exit;
r2:=radius*radius;
x:=0;
y:=radius;
repeat
hline(x_center-x,x_center+x,y_center-y,color,page);
hline(x_center-x,x_center+x,y_center+y,color,page);
hline(x_center-y,x_center+y,y_center-x,color,page);
hline(x_center-y,x_center+y,y_center+x,color,page);
inc(x);
y:=isqrt(r2-x*x);
until x>y;
end;
Procedure DrawQuad(x1,y1,x2,y2,x3,y3,x4,y4:word;color:byte);
var
i,x:integer;
mny,mxy:integer;
mnx,mxx,yc:integer;
mul1,div1,mul2,div2,mul3,div3,mul4,div4:integer;
begin
mny:=y1; mxy:=y1;
if y2<mny then mny:=y2;
if y2>mxy then mxy:=y2;
if y3<mny then mny:=y3;
if y3>mxy then mxy:=y3;
if y4<mny then mny:=y4;
if y4>mxy then mxy:=y4;
if mny<0 then mny:=0;
if mxy>479 then mxy:=479;
mul1:=x1-x4; div1:=y1-y4;
mul2:=x2-x1; div2:=y2-y1;
mul3:=x3-x2; div3:=y3-y2;
mul4:=x4-x3; div4:=y4-y3;
for yc:=mny to mxy do
begin
mnx:=360;
mxx:=-1;
if (y4>=yc) or (y1>=yc) then
if (y4<=yc) or (y1<=yc) then
if not(y4=y1) then
begin
x:=(yc-y4)*mul1 div div1+x4;
if x<mnx then
mnx:=x;
if x>mxx then
mxx:=x;
end;
if (y1>=yc) or (y2>=yc) then
if (y1<=yc) or (y2<=yc) then
if not(y1=y2) then
begin
x:=(yc-y1)*mul2 div div2+x1;
if x<mnx then
mnx:=x;
if x>mxx then
mxx:=x;
end;
if (y2>=yc) or (y3>=yc) then
if (y2<=yc) or (y3<=yc) then
if not(y2=y3) then
begin
x:=(yc-y2)*mul3 div div3+x2;
if x<mnx then
mnx:=x;
if x>mxx then
mxx:=x;
end;
if (y3>=yc) or (y4>=yc) then
if (y3<=yc) or (y4<=yc) then
if not(y3=y4) then
begin
x:=(yc-y3)*mul4 div div4+x3;
if x<mnx then
mnx:=x;
if x>mxx then
mxx:=x;
end;
if mnx<0 then
mnx:=0;
if mxx>359 then
mxx:=359;
if mnx<=mxx then
hline (mnx,mxx,yc,color,page);
end;
end;
procedure LoadBloodyFont;
var
fontfile:file;
chnum:byte;
crap:array[0..15] of byte;
Procedure LoadROMFont;
var
f8x8ofs, f8x8seg : word;
begin
asm
push bp
mov ah,11h
mov al,30h
mov bh,06h
int 10h
mov ax,bp
pop bp
mov f8x8ofs,ax
mov f8x8seg,es
end;
move(mem[f8x8seg:f8x8ofs],font,256*16)
end;
begin
assign(fontfile, 'BLOODY.FNT');
{$I-}
reset(fontfile,1);
if ioresult<>0 then
loadROMfont
else
for chnum:=0 to 255 do
begin
blockread(fontfile,font[chnum,0],16);
blockread(fontfile,crap,16);
end;
{$I+}
end;
Procedure GrWrite (line : string; x, y : integer; color : byte);
var
tx,ty:word;
i:byte;
begin
for i:=1 to length(line) do
for ty:=0 to 15 do
for tx:=0 to 7 do
if font[ord(line[i]),ty] and ($80 shr tx)<>0 then
putpixel(x+tx+(i-1)*10, y+ty, color, page)
end;
procedure CenterText (Str : string; y : integer; color : byte);
begin
GrWrite (Str, 320 div 2 - ((length (Str) * 10) div 2), y, Color)
end;
Procedure SBModPlay (md : string);
var
stat : integer;
begin
modinit;
modvolume (255,255,255,255); { Full volume }
modsetup (stat, dev, 10000, 0, 4, md);
end;
procedure getdata;
var
loop : integer;
begin
(*
+------ triangle number (1 through 17)
| +--- point (1, 2, 3)
v v
*)
fillchar (t, sizeof (t), 0);
t [1] [2].x := -10;
t [1] [2].y := 5;
t [1] [2].z := 0;
t [1] [3].x := -5;
t [1] [3].y := 10;
t [1] [3].z := 0;
t [2] [2].x := -5;
t [2] [2].y := 10;
t [2] [2].z := 0;
t [2] [3].x := 5;
t [2] [3].y := 10;
t [2] [3].z := 0;
t [3] [2].x := 5;
t [3] [2].y := 10;
t [3] [2].z := 0;
t [3] [3].x := 10;
t [3] [3].y := 5;
t [3] [3].z := 0;
t [4] [2].x := 10;
t [4] [2].y := 5;
t [4] [2].z := 0;
t [4] [3].x := 10;
t [4] [3].y := -5;
t [4] [3].z := 0;
t [5] [2].x := 10;
t [5] [2].y := -5;
t [5] [2].z := 0;
t [5] [3].x := 5;
t [5] [3].y := -10;
t [5] [3].z := 0;
t [6] [2].x := 5;
t [6] [2].y := -10;
t [6] [2].z := 0;
t [6] [3].x := -5;
t [6] [3].y := -10;
t [6] [3].z := 0;
t [7] [2].x := -5;
t [7] [2].y := -10;
t [7] [2].z := 0;
t [7] [3].x := -10;
t [7] [3].y := -5;
t [7] [3].z := 0;
t [8] [2].x := -10;
t [8] [2].y := -5;
t [8] [2].z := 0;
t [8] [3].x := -10;
t [8] [3].y := 5;
t [8] [3].z := 0;
t [9] [1].x := -5;
t [9] [1].y := 10;
t [9] [1].z := 0;
t [9] [2].x := -5;
t [9] [2].y := 18;
t [9] [2].z := 0;
t [9] [3].x := -4;
t [9] [3].y := 10;
t [9] [3].z := 0;
t [10] [1].x := -5;
t [10] [1].y := 18;
t [10] [1].z := 0;
t [10] [2].x := -4;
t [10] [2].y := 10;
t [10] [2].z := 0;
t [10] [3].x := -3;
t [10] [3].y := 18;
t [10] [3].z := 0;
t [11] [1].x := -3;
t [11] [1].y := 18;
t [11] [1].z := 0;
t [11] [2].x := -4;
t [11] [2].y := 10;
t [11] [2].z := 0;
t [11] [3].x := -3;
t [11] [3].y := 10;
t [11] [3].z := 0;
t [12] [1].x := -1;
t [12] [1].y := 10;
t [12] [1].z := 0;
t [12] [2].x := -1;
t [12] [2].y := 18;
t [12] [2].z := 0;
t [12] [3].x := 0;
t [12] [3].y := 10;
t [12] [3].z := 0;
t [13] [1].x := -1;
t [13] [1].y := 18;
t [13] [1].z := 0;
t [13] [2].x := 0;
t [13] [2].y := 10;
t [13] [2].z := 0;
t [13] [3].x := 1;
t [13] [3].y := 18;
t [13] [3].z := 0;
t [14] [1].x := 1;
t [14] [1].y := 18;
t [14] [1].z := 0;
t [14] [2].x := 0;
t [14] [2].y := 10;
t [14] [2].z := 0;
t [14] [3].x := 1;
t [14] [3].y := 10;
t [14] [3].z := 0;
t [15] [1].x := 3;
t [15] [1].y := 10;
t [15] [1].z := 0;
t [15] [2].x := 3;
t [15] [2].y := 18;
t [15] [2].z := 0;
t [15] [3].x := 4;
t [15] [3].y := 10;
t [15] [3].z := 0;
t [16] [1].x := 3;
t [16] [1].y := 18;
t [16] [1].z := 0;
t [16] [2].x := 4;
t [16] [2].y := 10;
t [16] [2].z := 0;
t [16] [3].x := 5;
t [16] [3].y := 18;
t [16] [3].z := 0;
t [17] [1].x := 5;
t [17] [1].y := 18;
t [17] [1].z := 0;
t [17] [2].x := 4;
t [17] [2].y := 10;
t [17] [2].z := 0;
t [17] [3].x := 5;
t [17] [3].y := 10;
t [17] [3].z := 0;
fillchar (velocity, sizeof (velocity), 0);
for loop := 1 to 17 do
begin
velocity [loop].x := 160;
velocity [loop].y := 100
end;
velocity [1].dx := -2;
velocity [1].dy := 1;
velocity [1].dt1 := 6;
velocity [1].dt2 := 6;
velocity [2].dy := 2;
velocity [2].dt2 := 6;
velocity [3].dx := 2;
velocity [3].dy := 1;
velocity [3].dt1 := 6;
velocity [3].dt2 := -6;
velocity [4].dx := 3;
velocity [4].dt1 := 8;
velocity [5].dx := 2;
velocity [5].dy := -1;
velocity [5].dt1 := -6;
velocity [5].dt2 := -6;
velocity [6].dy := -2;
velocity [6].dt2 := -6;
velocity [7].dx := -2;
velocity [7].dy := -1;
velocity [7].dt1 := -6;
velocity [7].dt2 := 6;
velocity [8].dx := -3;
velocity [8].dt1 := -8;
{ =-=-=-=-=-=-= }
{ Teeth }
{ =-=-=-=-=-=-= }
velocity [9].dx := -2;
velocity [9].dy := 1;
velocity [9].dt1 := 3;
velocity [9].dt2 := 3;
velocity [10].dx := -2;
velocity [10].dy := 1;
velocity [10].dt1 := 3;
velocity [10].dt2 := 3;
velocity [11].dx := -2;
velocity [11].dy := 1;
velocity [11].dt1 := 3;
velocity [11].dt2 := 3;
velocity [12].dy := 2;
velocity [12].dt2 := 4;
velocity [13].dy := 2;
velocity [13].dt2 := 4;
velocity [14].dy := 2;
velocity [14].dt2 := 4;
velocity [15].dx := 2;
velocity [15].dy := 1;
velocity [15].dt1 := -3;
velocity [15].dt2 := -3;
velocity [16].dx := 2;
velocity [16].dy := 1;
velocity [16].dt1 := -3;
velocity [16].dt2 := -3;
velocity [17].dx := 2;
velocity [17].dy := 1;
velocity [17].dt1 := -3;
velocity [17].dt2 := -3;
for loop := 1 to 17 do
begin
velocity [loop].dx := velocity [loop].dx * 8;
velocity [loop].dy := velocity [loop].dy * 8;
end;
end;
function rad (a : real) : real;
begin
rad := a * pi / 180
end;
procedure rotateall (lrtheta, udtheta, circtheta : real;
xshift, yshift: integer);
var
xa, ya, ca, e, f : real;
coslrtheta, sinlrtheta, cosudtheta, sinudtheta, coscirctheta,
sincirctheta : real;
loop, loop2 : integer;
begin
coslrtheta := cos (lrtheta);
sinlrtheta := sin (lrtheta);
cosudtheta := cos (udtheta);
sinudtheta := sin (udtheta);
coscirctheta := cos (circtheta);
sincirctheta := sin (circtheta);
for loop := 1 to 17 do
for loop2 := 1 to 3 do
begin
xa := (coslrtheta * t [loop][loop2].x) -
(sinlrtheta * t [loop][loop2].z);
ca := (sinlrtheta * t [loop][loop2].x) +
(coslrtheta * t [loop][loop2].z);
e := (coscirctheta * xa) + (sincirctheta * t [loop][loop2].y);
ya := (coscirctheta * t [loop][loop2].y) - (sincirctheta * xa);
t2 [loop][loop2].z := round ((cosudtheta * ca) - (sinudtheta * ya));
f := (sinudtheta * ca) + (cosudtheta * ya);
t2 [loop][loop2].x := round (e * 3 + xshift);
t2 [loop][loop2].y := round (f * 3 + yshift);
end;
xa := (coslrtheta * -4);
ca := (sinlrtheta * -4);
e := (coscirctheta * xa) + (sincirctheta * 3);
ya := (coscirctheta * 3) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
eye1x := round (e * 3 + xshift);
eye1y := round (f * 3 + yshift);
xa := (coslrtheta * 4);
ca := (sinlrtheta * 4);
e := (coscirctheta * xa) + (sincirctheta * 3);
ya := (coscirctheta * 3) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
eye2x := round (e * 3 + xshift);
eye2y := round (f * 3 + yshift);
xa := (coslrtheta * -1);
ca := (sinlrtheta * -1);
e := (coscirctheta * xa) + (sincirctheta * 7);
ya := (coscirctheta * 7) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose1x := round (e * 3 + xshift);
nose1y := round (f * 3 + yshift);
xa := (coslrtheta * -1);
ca := (sinlrtheta * -1);
e := (coscirctheta * xa) + (sincirctheta * 9);
ya := (coscirctheta * 9) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose2x := round (e * 3 + xshift);
nose2y := round (f * 3 + yshift);
xa := (coslrtheta * -2);
ca := (sinlrtheta * -2);
e := (coscirctheta * xa) + (sincirctheta * 9);
ya := (coscirctheta * 9) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose3x := round (e * 3 + xshift);
nose3y := round (f * 3 + yshift);
xa := (coslrtheta * 1);
ca := (sinlrtheta * 1);
e := (coscirctheta * xa) + (sincirctheta * 7);
ya := (coscirctheta * 7) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose4x := round (e * 3 + xshift);
nose4y := round (f * 3 + yshift);
xa := (coslrtheta * 1);
ca := (sinlrtheta * 1);
e := (coscirctheta * xa) + (sincirctheta * 9);
ya := (coscirctheta * 9) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose5x := round (e * 3 + xshift);
nose5y := round (f * 3 + yshift);
xa := (coslrtheta * 2);
ca := (sinlrtheta * 2);
e := (coscirctheta * xa) + (sincirctheta * 9);
ya := (coscirctheta * 9) - (sincirctheta * xa);
f := (sinudtheta * ca) + (cosudtheta * ya);
nose6x := round (e * 3 + xshift);
nose6y := round (f * 3 + yshift);
end;
procedure FadeInSkull;
var
tcount, red, white, iteration : integer;
red_up : boolean;
begin
rgb (1, 0, 0, 0);
rgb (15, 0, 0, 0);
rotateall (0, rad (5), rad (5), 160, 85);
for tcount := 1 to 17 do
begin
DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
t2 [tcount] [2].x, t2 [tcount] [2].y,
t2 [tcount] [3].x, t2 [tcount] [3].y,
t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
end;
DrawQuad (nose1x, nose1y, nose2x, nose2y, nose3x, nose3y, nose1x, nose1y, 0);
DrawQuad (nose4x, nose4y, nose5x, nose5y, nose6x, nose6y, nose4x, nose4y, 0);
fillcircle (eye1x, eye1y, 5, 0);
fillcircle (eye1x, eye1y, 3, 1);
fillcircle (eye1x, eye1y, 2, 2);
fillcircle (eye2x, eye2y, 5, 0);
fillcircle (eye2x, eye2y, 3, 1);
fillcircle (eye2x, eye2y, 2, 2);
red := 10;
white := 0;
red_up := true;
repeat
inc (iteration);
if red_up then inc (red)
else dec (red);
if red >= 63 then red_up := false;
if red <= 10 then red_up := true;
if iteration > 1000 then
if (white < 63) and (iteration mod 20 = 0) then
inc (white);
rgb (1, red, 0, 0);
rgb (2, red - 10, 0, 0);
rgb (15, white, white, white)
until keypressed or (iteration >= 2200);
end;
procedure RotateSkull;
var
tcount, loop, loop2, loop3, x, y, dx, dy, red, iterations : integer;
red_up : boolean;
begin
loop := 0;
loop2 := 5;
loop3 := 5;
x := 154;
y := 76;
dx := 6;
dy := 4;
red := 0;
red_up := true;
iterations := 0;
while not keypressed and (iterations < 85) do
begin
inc (iterations);
inc (x, dx);
inc (y, dy);
if x > 310 then dx := -6
else
if x < 50 then dx := 6;
if y > 150 then dy := -4
else
if y < 50 then dy := 4;
if dx > 0 then dec (loop, 10)
else inc (loop, 10);
if red_up then inc (red, 10)
else dec (red, 10);
if red + 10 > 63 then red_up := false;
if red - 10 < 0 then red_up := true;
rotateall (rad (loop*2), rad (loop2*2), rad (loop3*2), x, y);
for tcount := 1 to 17 do
begin
DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
t2 [tcount] [2].x, t2 [tcount] [2].y,
t2 [tcount] [3].x, t2 [tcount] [3].y,
t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
end;
DrawQuad (nose1x, nose1y, nose2x, nose2y, nose3x, nose3y, nose1x, nose1y, 0);
DrawQuad (nose4x, nose4y, nose5x, nose5y, nose6x, nose6y, nose4x, nose4y, 0);
rgb (1, red, 0, 0);
fillcircle (eye1x, eye1y, 5, 0);
fillcircle (eye1x, eye1y, 3, 1);
fillcircle (eye2x, eye2y, 5, 0);
fillcircle (eye2x, eye2y, 3, 1);
screen (page);
inc (page);
if page > 2 then page := 0;
clearscreen (page);
end;
end;
procedure Explosion;
var
tcount, loop : integer;
procedure rotate (n : integer; lrtheta, udtheta, circtheta : real;
xshift, yshift: integer);
var
xa, ya, ca, e, f : real;
coslrtheta, sinlrtheta, cosudtheta, sinudtheta, coscirctheta,
sincirctheta : real;
loop2 : integer;
begin
coslrtheta := cos (lrtheta);
sinlrtheta := sin (lrtheta);
cosudtheta := cos (udtheta);
sinudtheta := sin (udtheta);
coscirctheta := cos (circtheta);
sincirctheta := sin (circtheta);
for loop2 := 1 to 3 do
begin
xa := (coslrtheta * t [n][loop2].x) -
(sinlrtheta * t [n][loop2].z);
ca := (sinlrtheta * t [n][loop2].x) +
(coslrtheta * t [n][loop2].z);
e := (coscirctheta * xa) + (sincirctheta * t [n][loop2].y);
ya := (coscirctheta * t [n][loop2].y) - (sincirctheta * xa);
t2 [n][loop2].z := round ((cosudtheta * ca) - (sinudtheta * ya));
f := (sinudtheta * ca) + (cosudtheta * ya);
t2 [n][loop2].x := round (e * 3 + xshift);
t2 [n][loop2].y := round (f * 3 + yshift);
end
end;
begin
loop := 0;
ModStop;
SBModPlay ('1.MOD');
while not keypressed and (loop < 300) do
begin
for tcount := 1 to 17 do
if (velocity [tcount].x > 0) and (velocity [tcount].x < 320)
and (velocity [tcount].y > 0) and (velocity [tcount].y < 200) then
begin
rotate (tcount, rad (velocity [tcount].theta1),
rad (velocity [tcount].theta2),
rad (velocity [tcount].theta3),
velocity [tcount].x, velocity [tcount].y);
inc (velocity [tcount].x, velocity [tcount].dx);
inc (velocity [tcount].y, velocity [tcount].dy);
inc (velocity [tcount].theta1, velocity [tcount].dt1);
inc (velocity [tcount].theta2, velocity [tcount].dt2);
inc (velocity [tcount].theta3, velocity [tcount].dt3);
DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
t2 [tcount] [2].x, t2 [tcount] [2].y,
t2 [tcount] [3].x, t2 [tcount] [3].y,
t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
end;
screen (page);
inc (page);
if page > 2 then page := 0;
clearscreen (page);
inc (loop, 10);
if loop = 360 then loop := 0;
end;
end;
procedure MorbidText;
procedure DripColor (x1, y1, x2, y2 : integer; c1, c2 : byte);
var
x, y : integer;
procedure CheckColor (x, y : integer);
begin
if getpixel (x, y, page) = 0 then putpixel (x, y, c2, page)
end;
begin
for y := y1 to y2 do
for x := x1 to x2 do
begin
if getpixel (x, y, page) = c1 then
begin
CheckColor (x - 1, y);
CheckColor (x - 1, y - 1);
CheckColor (x, y - 1);
CheckColor (x + 1, y);
CheckColor (x + 1, y + 1);
CheckColor (x, y + 1);
CheckColor (x - 1, y + 1);
CheckColor (x + 1, y - 1);
end
end
end;
procedure FadeIn;
var
loop : integer;
begin
for loop := 0 to 30 do
begin
rgb (1, loop, 0, 0);
rgb (2, loop * 2, 0, 0);
delay (10);
end;
end;
procedure FadeOut;
var
loop : integer;
begin
for loop := 30 downto 0 do
begin
rgb (1, loop, 0, 0);
rgb (2, loop * 2, 0, 0);
delay (10);
end;
end;
begin
if keypressed then Exit;
page := 0;
ClearScreen (0);
Screen (0);
ClearScreen (0);
delay (1000);
ClearScreen (1);
page := 1;
CenterText ('Morbid Demo', 85, 2);
DripColor (100, 85, 220, 100, 2, 1);
Screen (1);
FadeIn;
delay (1000);
FadeOut;
Screen (0);
delay (1000);
ClearScreen (1);
page := 1;
CenterText ('Coming Soon', 85, 2);
DripColor (100, 85, 220, 100, 2, 1);
Screen (1);
FadeIn;
delay (1000);
FadeOut;
Screen (0);
delay (1000);
end;
begin
CheckBreak := false; { or else someone who presses Ctrl-C will lock-up}
getdata; { their computer }
page := 0;
ClrScr;
ModInit;
ModDevice (dev);
setmode13x4;
LoadBloodyFont;
SBModPlay ('0.MOD');
delay (2000);
setmode13x4;
FadeInSkull;
RotateSkull;
Explosion;
ModStop;
MorbidText;
textmode (lastmode)
end.