www.pudn.com > 3dtext.zip > 3DPLASM.PAS
uses crt;
Type TE = Record X : Integer;
px, py : Byte; End;
Table = Array[0..599] of TE;
PTable = ^Table;
tabelltype = array [0..199] of byte;
const
size=80;
sinsize = 2880;
shls = 3;
pointnum=7;
planenum=5;
points:array[0..pointnum,0..2] of integer=(
(-size,-size,-size),( size,-size,-size),( size, size,-size),(-size, size,-size),
(-size,-size, size),( size,-size, size),( size, size, size),(-size, size, size));
planes:array[0..planenum,0..3] of byte=(
(0,1,2,3),(5,4,7,6),(1,5,6,2),(4,0,3,7),
(3,2,6,7),(4,5,1,0));
var
bitmap : array[0..79,0..49] of byte;
facx : real;
sizecounter: word;
facy : real;
offsetx : real;
offsety : real;
textbuffer : pointer;
txtbuff : word;
TEXTF : string[17];
t,t2,t3,t4 : word;
tab1,tab2 : array[0..511] of byte;
moded : array[0..255] of byte;
color : byte;
y80 : array[0..50] of word;
i1,j1 : byte;
a1,a2 : word;
i4,j5 : byte;
a4,a5 : word;
i2,j2 : word;
c,qc : word;
xSpeed: word;
ySpeed: word;
zSpeed: word;
mathattribute:byte;
SinCalced: ARRAY[0..sinsize] OF Integer;
CosCalced: ARRAY[0..sinsize] OF Integer;
Counter: Word;
hiddengrad: Integer;
FullTurn: Real;
BufferR: Real;
BufferW: Integer;
RotAngleX: Word;
RotAngleY: Word;
RotAngleZ: Word;
VpDistance: Word;
PointX3D: Integer;
PointY3D: Integer;
PointZ3D: Integer;
PointX2D: Integer;
PointY2D: Integer;
SiX: Integer;
SiY: Integer;
SiZ: Integer;
CoX: Integer;
CoY: Integer;
CoZ: Integer;
unicolor : byte;
pxstep,pystep : integer;
pxval ,pyval : integer;
o1 : integer;
count : integer;
b : byte;
Left, Right : Table;
point : array[0..pointnum] of record x,y,z :integer; end;
col : array[0..5] of byte;
x,y,z : word;
r,g : byte;
f : text;
x1,x2,y1,y2 : integer;
hy1,hy2,hx1,hx2 : char;
x1p,x2p : shortint;
y1p,y2p : shortint;
FUNCTION PcSin(Angle: Integer): Integer;
BEGIN
asm
mov ax,angle
cmp ax,sinsize
jng @@mindre
@@back1:
sub ax,sinsize
cmp ax,sinsize
jg @@back1
jmp @@storre
@@mindre:
cmp ax,0
jnl @@storre
@@back2:
add ax,sinsize
cmp ax,0
jl @@back2
@@storre:
sal ax,1
mov si,offset sincalced
add si,ax
lodsw
mov angle,ax
end;{}
PcSin:=Angle;
END;
FUNCTION PcCos(Angle: Integer): Integer;
BEGIN
asm
mov ax,angle
cmp ax,sinsize
jng @@mindre
@@back1:
sub ax,sinsize
cmp ax,sinsize
jg @@back1
jmp @@storre
@@mindre:
cmp ax,0
jnl @@storre
@@back2:
add ax,sinsize
cmp ax,0
jl @@back2
@@storre:
mov angle,ax
sal ax,1
mov si,offset coscalced
add si,ax
lodsw
mov angle,ax
end;{}
PcCos:=Angle;
eND;
FUNCTION GetPointX3D: Integer;
BEGIN
GetPointX3D:=PointX3D;
END;
PROCEDURE GenRotAngles;
BEGIN
ASM
xor dx,dx
mov ax, RotAngleX
mov dx, xspeed
add ax, dx {Increase angle around X axis}
cmp ax, sinsize {Full rotation yet?}
jb @@10 {No, go on}
sub ax, sinsize {Yes, subtract 360 degrees}
@@10:
mov RotAngleX, ax
mov dx, yspeed
mov ax, RotAngleY
add ax, dx {Increase angle around Y axis}
cmp ax, sinsize {Full rotation yet?}
jb @@20 {No, go on}
sub ax, sinsize {Yes, subtract sinsize degrees}
@@20:
mov RotAngleY, ax
mov ax, RotAngleZ
mov dx, zspeed
add ax, dx {Increase angle around Z axis}
cmp ax, sinsize {Full rotation yet?}
jb @@30 {No, go on}
sub ax, sinsize {Yes, subtract sinsize degrees}
@@30:
mov RotAngleZ, ax
END;
SiX:=PcSin(RotAngleX);
SiY:=PcSin(RotAngleY);
SiZ:=PcSin(RotAngleZ);
CoX:=PcCos(RotAngleX);
CoY:=PcCos(RotAngleY);
CoZ:=PcCos(RotAngleZ);
END;
function getchar(x,y,segment:word) :char;
var temp:char;
begin
asm
mov ax,y
shl ax,4
mov bx,ax
shl ax,2
add ax,bx
add ax,x
mov es,segment
mov si,ax
mov al,[es:si]
mov temp,al
end;
getchar:=temp;
end;
PROCEDURE SetRotatespeed(NewXSpeed,NewYSpeed,NewZSpeed:word);
assembler;
asm
mov ax,newxspeed
mov xspeed,ax
mov ax,newyspeed
mov yspeed,ax
mov ax,newzspeed
mov zspeed,ax
end;
PROCEDURE SetPoint(NewPointX3D, NewPointY3D, NewPointZ3D: Integer); ASSEMBLER;
ASM
{ next up : x2d = (x3d*zoom)/(z+dist)}
mov ax, NewPointX3D
mov PointX3D, ax
mov ax, NewPointY3D
mov PointY3D, ax
mov ax, NewPointZ3D
mov PointZ3D, ax
mov ax, PointY3D {Do X axis rotation}
imul Cox
sar ax, 7
mov bx, ax
mov ax, PointZ3D
imul SiX
sar ax, 7
add ax, bx
mov cx, ax {cx holds new NY}
mov ax, PointZ3D
imul CoX
sar ax, 7
mov bx, ax
mov ax, PointY3D
imul SiX
sar ax, 7
sub bx, ax {bx holds new NZ}
mov PointZ3D, bx
mov PointY3D, cx
mov ax, PointX3D {Do Y axis rotation}
imul CoY
sar ax, 7
mov bx, ax
mov ax, PointZ3D
imul SiY
sar ax, 7
sub bx, ax
mov cx, bx {cx holds new NX}
mov ax, PointX3D
imul SiY
sar ax, 7
mov bx, ax
mov ax, PointZ3D
imul CoY
sar ax, 7
add ax, bx {ax holds new NZ}
mov PointX3D, cx
mov PointZ3D, ax
mov ax, PointX3D {Do Z axis rotation}
imul CoZ
sar ax, 7
mov bx, ax
mov ax, PointY3D
imul SiZ
sar ax, 7
add ax, bx
mov cx, ax {cx holds new NX}
mov ax, PointY3D
imul CoZ
sar ax, 7
mov bx, ax
mov ax, PointX3D
imul SiZ
sar ax, 7
sub bx, ax {bx holds new NY}
mov PointY3D, bx
mov PointX3D, cx
{ asx = (x3d*zoom)/(z+dist)}
{ neg pointx3d
neg pointy2d
mov ax,pointx3d
mov bx,zoom
imul bx
mov cx,pointz3d
add cx,Vpdistance
idiv cx
add ax,160
mov pointx2d,ax
mov ax,pointy3d
mov bx,zoom
imul bx
mov cx,pointz3d
add cx,vpdistance
idiv cx
add ax,100
mov pointy2d,ax}
mov cx, PointZ3D
add cx, VpDistance
add cx,100
mov ax, PointX3D
cmp cx,0
je @@divzero
imul VpDistance
idiv cx
mov PointY2D, ax
mov bx,100
add PointY2D, bx
mov ax, PointY3D
imul VpDistance
cmp cx,0
je @@divzero
idiv cx
mov PointX2D, ax
mov bx,160
add PointX2D, bx
@@divzero:
END;
PROCEDURE InitMath3D;
BEGIN
VpDistance:=250;
xspeed:=3;
yspeed:=6;
zspeed:=9;
RotAngleX:=0;
RotAngleY:=0;
RotAngleZ:=0;
PointX3D:=0;
PointY3D:=0;
PointZ3D:=0;
PointX2D:=0;
PointY2D:=0;
FullTurn:=2*Pi;
FOR Counter:=0 TO sinsize DO
BEGIN
BufferR:=Sin((Fullturn*Counter)/sinsize);
BufferW:=round(BufferR*128);
SinCalced[Counter]:=BufferW;
END;
FOR Counter:=0 TO sinsize DO
BEGIN
BufferR:=Cos((Fullturn*Counter)/sinsize);
BufferW:=round(BufferR*128);
CosCalced[Counter]:=BufferW;
END;
SiX:=PcSin(RotAngleX shl shls);
SiY:=PcSin(RotAngleY shl shls);
SiZ:=PcSin(RotAngleZ shl shls);
CoX:=PcCos(RotAngleX shl shls);
CoY:=PcCos(RotAngleY shl shls);
CoZ:=PcCos(RotAngleZ shl shls);
END;
procedure getrotangles(var anglex,angley,anglez:word);
begin
anglex:=rotanglex div 8;
angley:=rotangley div 8;
anglez:=rotanglez div 8;
end;
PROCEDURE SetRotAngles(NewAngleX, NewAngleY, NewAngleZ: Word);
BEGIN
ASM
mov ax, NewAngleX
sal ax, shls
mov RotAngleX, ax
mov ax, NewAngleY
sal ax, shls
mov RotAngleY, ax
mov ax, NewAngleZ
sal ax, shls
mov RotAngleZ, ax
end;
SiX:=PcSin(RotAngleX);
SiY:=PcSin(RotAngleY);
SiZ:=PcSin(RotAngleZ);
CoX:=PcCos(RotAngleX);
CoY:=PcCos(RotAngleY);
CoZ:=PcCos(RotAngleZ);
END;
PROCEDURE RETRACE;
ASSEMBLER;
ASM
mov dx,3dah
@@vert1:
in al,dx
test al,8
jz @@vert1
@@vert2:
in al,dx
test al,8
jnz @@vert2
END;
procedure clrscr2;
assembler;
asm
mov es,txtbuff
xor di,di
mov cx,2080*2
xor ax,ax
rep stosw
end;
procedure flip;
assembler;
asm
mov ax,0b800h
mov es,ax
mov dx,ds
mov ax,txtbuff
mov ds,ax
xor si,si
xor di,di
mov cx,2080*2
rep movsw
mov ds,dx
end;
procedure plotxy(position:word;x,y:byte;value:char;color:byte;segment:word);
assembler;
asm
mov si,position
cmp si,65535
jne @@pos
xor dh,dh
mov dl,y
shl dx,4
mov ax,dx
shl dx,2
add dx,ax
mov al,x
xor ah,ah
add dx,ax
mov si,dx
@@pos:
mov es,segment
mov al,value
mov ah,color
shl si,1
mov [es:si],ax
end;
procedure switch(one,two:longint);
var temp:longint;
begin
temp:=one;
one:=two;
two:=temp;
end;
Procedure TextureHLine(X1, X2, px1, py1, px2, py2, Y : Integer; Dim : Word);
var tt1,tt2,tt3:integer;
Begin
asm
sub y,200
mov bx,x2
sub bx,x1
inc bx
mov tt1,bx
mov ax,px2
sub ax,px1
shl ax,8
mov tt2,ax
mov ax,py2
sub ax,py1
shl ax,8
mov tt3,ax
end;
pxStep := tt2 Div tt1;
pyStep := tt3 Div tt1;
asm
mov bx, px1
shl bx, 8
mov pxval,bx { pxVal := px1 Shl 8;}
mov bx, py1
shl bx, 8
mov pyval,bx { pyVal := py1 Shl 8;}
mov ax,y
shl ax,4
mov di,ax
shl ax,2
add di,ax
add di,x1
mov o1, di
End;
For Count := X1 to X2 do
Begin
b:=Bitmap[Hi(pxVal),Hi(pyVal)];
if ( count<80 ) and ( y<50 ) then
plotxy(65535,count,y,chr(b),unicolor,txtbuff);
Asm
mov ax, pxval
add ax, pxstep
mov pxval, ax
mov ax, pyval
add ax, pystep
mov pyval, ax
inc o1
end;
End;
End;
Procedure Swap(Var A, B : Integer);
Var t : Integer;
Begin
t := a;
a := b;
b := t;
End;
Procedure Texture(X1, Y1, X2, Y2, X3, Y3, X4, Y4 : Integer; Dim : Byte);
Var yMin, yMax : Integer;
xStart, xEnd : Integer;
yStart, yEnd : Integer;
pxStart, pxEnd : Integer;
pyStart,pyEnd : Integer;
XVal, XStep : Longint;
pxVal, pxStep : Integer;
pyVal, pyStep : Integer;
Count : Integer;
Side : PTable;
Begin
asm
add y1,200
add y2,200
add y3,200
add y4,200
mov ax,y1
mov ymin,ax
mov ax,y1
mov ymax,ax
mov ax,y2
cmp ax,ymax
jl @@nabove1
mov ymax,ax
@@nabove1:
mov ax,y3
cmp ax,ymax
jl @@nabove2
mov ymax,ax
@@nabove2:
mov ax,y4
cmp ax,ymax
jl @@nabove3
mov ymax,ax
@@nabove3:
mov ax,y2
cmp ax,ymin
ja @@above1
mov ymin,ax
@@above1:
mov ax,y3
cmp ax,ymin
ja @@above2
mov ymin,ax
@@above2:
mov ax,y4
cmp ax,ymin
ja @@above3
mov ymin,ax
@@above3:
mov ax,x1
mov xstart,ax
mov ax,y1
mov ystart,ax
mov ax,x2
mov xend,ax
mov ax,y2
mov yend,ax
mov pxstart,0
mov pystart,0
mov al,[dim]
dec al
xor ah,ah
mov pxend,ax
mov pyend,0
end;
If yStart > yEnd Then
Begin
Swap(xStart, xEnd);
Swap(yStart, yEnd);
Swap(pxStart, pxEnd);
Side := @Left;
End
Else
Side := @Right;
XVal := Longint(xStart) Shl 8;
XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
pxVal := pxStart Shl 8;
pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1);
For Count := yStart to yEnd do
Begin
Side^[Count].x := XVal Shr 8;
Side^[Count].px := pxVal Shr 8;
Side^[Count].py := pyStart;
XVal := XVal + XStep;
pxVal := pxVal + pxStep;
End;
xStart := X2;
yStart := Y2;
xEnd := X3;
yEnd := Y3;
pxStart := Dim-1;
pyStart := 0;
pxEnd := Dim-1;
pyEnd := Dim-1;
If yStart > yEnd Then
Begin
Swap(xStart, xEnd);
Swap(yStart, yEnd);
Swap(pyStart, pyEnd);
Side := @Left;
End
Else Side := @Right;
XVal := Longint(xStart) Shl 8;
XStep:=(Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
pyVal := pyStart Shl 8;
pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1);
For Count := yStart to yEnd do
Begin
Side^[Count].x := XVal Shr 8;
Side^[Count].py := pyVal Shr 8;
Side^[Count].px := pxStart; XVal := XVal + XStep;
pyVal := pyVal + pyStep;
End;
xStart := X3;
yStart := Y3;
xEnd := X4;
yEnd := Y4;
pxStart := Dim-1;
pyStart := Dim-1;
pxEnd := 0;
pyEnd := Dim-1;
If yStart > yEnd Then
Begin
Swap(xStart, xEnd);
Swap(yStart, yEnd);
Swap(pxStart, pxEnd);
Side := @Left;
End
Else
Side := @Right;
XVal := Longint(xStart) Shl 8;
XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
pxVal := pxStart Shl 8;
pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1);
For Count := yStart to yEnd do
Begin
Side^[Count].x := XVal Shr 8;
Side^[Count].px := pxVal Shr 8;
Side^[Count].py := pyStart;
XVal := XVal + XStep;
pxVal := pxVal + pxStep;
End;
xStart := X4;
yStart := Y4;
xEnd := X1;
yEnd := Y1;
pxStart := 0;
pyStart := Dim-1;
pxEnd := 0;
pyEnd := 0;
If yStart > yEnd Then
Begin
Swap(xStart, xEnd);
Swap(yStart, yEnd);
Swap(pyStart, pyEnd);
Side := @Left;
End
Else
Side := @Right;
XVal := Longint(xStart) Shl 8;
XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
pyVal := pyStart Shl 8;
pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1);
For Count := yStart to yEnd do
Begin Side^[Count].x := XVal Shr 8;
Side^[Count].py := pyVal Shr 8;
Side^[Count].px := pxStart;
XVal := XVal + XStep;
pyVal := pyVal + pyStep;
End;
For Count := yMin to yMax do
if (count>199) and (count<400) then
If Left[Count].x < Right[Count].x
Then TextureHLine(Left[Count].x, Right[Count].x, Left[Count].px, Left[Count].py,
Right[Count].px, Right[Count].py, Count, Dim)
Else TextureHLine(Right[Count].x, Left[Count].x, Right[Count].px, Right[Count].py,
Left[Count].px, Left[Count].py, Count, Dim);
End;
function moded255(value:integer):byte;
begin
repeat
if value<0 then inc(value,255);
if value>255 then dec(value,255);
until (value>=0) and (value<=255);
moded255:=moded[value];
end;
PROCEDURE Syncronize;
ASSEMBLER;
ASM
@@Tester:
mov DX,3DAh
in AL,DX
test AL,1000b
jz @@Tester
END;
procedure initprog;
begin
for t:=0 to 50 do y80[t]:=t*80;
getmem(textbuffer,8000);
txtbuff:=seg(textbuffer^);
for t:=0 to 511 do
begin
tab1[t]:=round(sin(2*pi*t/255)*30)+15;
tab2[t]:=round(cos(2*pi*t/255)*30)+15;
end;
i1:=50;
j1:=90;
for t:=0 to 255 do moded[t]:=t mod 255;
end;
procedure plot(position:word; value:char;color:byte);
assembler;
asm
mov ax,txtbuff
mov es,ax
mov al,value
mov ah,color
mov si,position
shl si,1
mov [es:si],ax
end;
PROCEDURE Cursor(On: Boolean);
BEGIN
IF On=FALSE THEN
BEGIN
ASM
mov ah, 01h
mov cl, 20h
mov ch, 20h
int 10h
END;
END
ELSE
BEGIN
ASM
mov ah, 01h
mov cl, 06h
mov ch, 07h
int 10h
END;
END;
END;
function changecol :char;
begin
case (c mod 16) of
0 : begin changecol:=' '; color:=black; end;
1 : begin changecol:=' '; color:=lightgray; end;
2 : begin changecol:='°'; color:=lightgray; end;
3 : begin changecol:='°'; color:=lightgray; end;
4 : begin changecol:='±'; color:=lightgray; end;
5 : begin changecol:='±'; color:=lightgray; end;
6 : begin changecol:='²'; color:=lightgray; end;
7 : begin changecol:='²'; color:=lightgray; end;
8 : begin changecol:='Û'; color:=lightgray; end;
9 : begin changecol:='Û'; color:=lightgray; end;
10 : begin changecol:='²'; color:=lightgray; end;
11 : begin changecol:='²'; color:=lightgray; end;
12 : begin changecol:='±'; color:=lightgray; end;
13 : begin changecol:='±'; color:=lightgray; end;
14 : begin changecol:='°'; color:=lightgray; end;
15 : begin changecol:='°'; color:=lightgray; end;
end;
end;
procedure mainprog;
var cc : char;
begin
a1:=0;
a2:=0;
asm
mov ax,a1
add ax,274
mov i1,ah
mov a1,ax
mov ax,a2
add ax,324
mov j1,ah
mov a2,ax
mov ax,a4
add ax,395
mov i4,ah
mov a4,ax
mov ax,a5
add ax,257
mov j5,ah
mov a5,ax
end;
for y:=0 to 49 do begin
i2:=tab1[moded255(j2-i1)];
j2:=tab2[moded255(j1+j5)];
for x:=0 to 79 do
begin
qc:=tab1[moded255(i1+y)]+tab1[moded255(j5-x)];
c:=tab2[moded255(i2-y+i4)]+tab2[moded255(qc+x)];
bitmap[x,y]:=ord(changecol);
end;
end;
end;
FUNCTION GetPointZ3D: Integer;
BEGIN
GetPointZ3D:=PointZ3D;
END;
FUNCTION GetPointX2D: integer;
BEGIN
GetPointX2D:=PointX2D;
END;
FUNCTION GetPointY2D: integer;
BEGIN
GetPointY2D:=PointY2D;
END;
FUNCTION HIDDEN(X1,Y1,X2,Y2,X3,Y3:INTEGER) :BOOLEAN;
BEGIN
HIDDEN:=FALSE;
hiddengrad:=(x3-x1)*(y2-y1)-(x2-x1)*(y3-y1);
if hiddengrad<1 then HIDDEN:=TRUE;
END;
procedure chksize;
begin
if sizecounter<700 then inc(sizecounter);
if (sizecounter>400) and (sizecounter<500)then
begin
facx:=facx+0.016;
facy:=facy+0.018;
offsety:=offsety+0.5;
offsetx:=offsetx+0.8;
end;
if sizecounter=400 then setrotatespeed(3,12,7);
end;
begin
textmode(258);
clrscr;
textcolor(white);
textbackground(black);
offsetx:=0;
offsety:=-10;
facx:=4;
facy:=4;
unicolor:=blue;
initprog;
initmath3d;
setrotatespeed(5,12,7);
sizecounter:=0;
repeat
mainprog;
retrace;
flip;
clrscr2;
genrotangles;
for t:=0 to pointnum do
begin
setpoint(points[t,0],points[t,1],points[t,2]);
point[t].x:=getpointx2d+trunc(offsetx);
point[t].y:=getpointy2d+trunc(offsety);
point[t].z:=abs(round(getpointz3d*1.6));
end;
for t:=0 to planenum do
if not hidden(point[planes[t,0]].x,point[planes[t,0]].y,
point[planes[t,1]].x,point[planes[t,1]].y,
point[planes[t,2]].x,point[planes[t,2]].y) then
begin
unicolor:=t+1;
texture(round(point[planes[t,0]].x/facx),round(point[planes[t,0]].y/facy),
round(point[planes[t,1]].x/facx),round(point[planes[t,1]].y/facy),
round(point[planes[t,2]].x/facx),round(point[planes[t,2]].y/facy),
round(point[planes[t,3]].x/facx),round(point[planes[t,3]].y/facy),50);
end;
until keypressed;
freemem(textbuffer,8000);
end.
Made by The Joker of crusaders. This was used in a
part of his winning "ringnes motion". Spread at will.