[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{
PS> I see that a lot of people around here have polygon, texture mapping and
PS> 3D routines so why don't you all post them here, even if you already
PS> have done in the past cause there are people who didn't get them
PS> and want them :)
}
{$G+,R-}
Program Polygoned_and_shaded_objects;
{ Mode-x version of polygoned objects }
{ Originally by Bas van Gaalen & Sven van Heel }
{ Optimized by Luis Mezquita Raya }
uses Crt,x3Dunit2;
{ ^^^^^ Contained in GRAPHICS.SWG file }
{$DEFINE Object1} { Try an object between 1..4 }
const
{$IFDEF Object1} { Octagon }
nofpolys=9; { Number of poligons-1 }
nofpoints=11; { Number of points-1 }
polypoints=4; { Number of points for each poly }
sc=5; { Number of visible planes }
cr=23; { RGB components }
cg=8;
cb=3;
point:array[0..nofpoints,0..2] of integer=(
(-20,-20, 30),( 20,-20, 30),( 40,-40, 0),( 20,-20,-30),
(-20,-20,-30),(-40,-40, 0),(-20, 20, 30),( 20, 20, 30),
( 40, 40, 0),( 20, 20,-30),(-20, 20,-30),(-40, 40, 0));
planes:array[0..nofpolys,0..3] of byte=(
(0,1,7,6),(1,2,8,7),(9,8,2,3),(10,9,3,4),(10,4,5,11),
(6,11,5,0),(0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
{$ENDIF}
{$IFDEF Object2} { Cube }
nofpolys=5; { Number of poligons-1 }
nofpoints=7; { Number of points-1 }
polypoints=4; { Number of points for each poly }
sc=3; { Number of visible planes }
cr=0; { RGB components }
cg=13;
cb=23;
point:array[0..nofpoints,0..2] of integer=(
(-40,-40, 40),( 40,-40, 40),( 40,-40,-40),(-40,-40,-40),
(-40, 40, 40),( 40, 40, 40),( 40, 40,-40),(-40, 40,-40));
planes:array[0..nofpolys,0..3] of byte=(
(0,1,5,4),(1,5,6,2),(6,7,3,2),
(7,3,0,4),(0,1,2,3),(6,5,4,7));
{$ENDIF}
{$IFDEF Object3} { Octahedron }
nofpolys=7; { Number of poligons-1 }
nofpoints=5; { Number of points-1 }
polypoints=3; { Number of points for each poly }
sc=4; { Number of visible planes }
cr=0; { RGB components }
cg=3;
cb=23;
point:array[0..nofpoints,0..2] of integer=(
( 0, 0, 45),(-40,-40, 0),(-40, 40, 0),( 40, 40, 0),
( 40,-40, 0),( 0, 0,-45));
planes:array[0..nofpolys,0..3] of byte=(
(0,1,2,0),(0,2,3,0),(0,3,4,0),(0,4,1,0),
(5,1,2,5),(5,2,3,5),(5,3,4,5),(5,4,1,5));
{$ENDIF}
{$IFDEF Object4} { Spiky }
nofpolys=15; { Number of poligons-1 }
nofpoints=19; { Number of points-1 }
polypoints=4; { Number of points for each poly }
sc=5; { Number of visible planes }
cr=23; { RGB components }
cg=5;
cb=5;
point:array[0..nofpoints,0..2] of integer=(
(-10,-10, 30),( 10,-10, 30),( 30,-30, 0),( 10,-10,-30),
(-10,-10,-30),(-30,-30, 0),(-10, 10, 30),( 10, 10, 30),
( 30, 30, 0),( 10, 10,-30),(-10, 10,-30),(-30, 30, 0),
( -2, -2, 60),( -2, 2, 60),( 2, -2, 60),( 2, 2, 60),
( -2, -2,-60),( -2, 2,-60),( 2, -2,-60),( 2, 2,-60));
planes:array[0..nofpolys,0..3] of byte=(
(0,1,14,12),(7,15,13,6),(1,14,15,7),(6,13,12,0),
(1,2,8,7),(9,8,2,3),
(10,9,19,17),(10,4,16,17),(3,4,16,18),(3,9,19,18),
(10,4,5,11),
(6,11,5,0),(0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
{$ENDIF}
type polytype=array[0..nofpolys] of integer;
pointype=array[0..nofpoints] of integer;
ptnode=word;
stack=ptnode;
const soplt=SizeOf(polytype);
sopit=SizeOf(pointype);
xst:integer=1;
yst:integer=1;
zst:integer=-2;
var polyz,pind:array[byte] of polytype;
xp,yp:array[byte] of pointype;
phix:byte;
Procedure QuickSort(lo,hi:integer); assembler; { Iterative QuickSort }
var i,j,x,y:integer; { NON RECURSIVE }
asm
mov ah,48h { Init stack }
mov bx,1
int 21h
jc @exit
mov es,ax
xor ax,ax
mov es:[4],ax
mov cx,lo { Push(lo,hi) }
mov dx,hi
call @Push
@QS: mov ax,es:[4] { ¨Stack empty? }
and ax,ax
jz @Empty
mov cx,es:[0] { Top(lo,hi) }
mov dx,es:[2]
mov lo,cx
mov hi,dx
mov bx,es:[4] { Pop }
mov ah,49h
int 21h
jc @exit
mov es,bx
mov ax,cx { ax:=(i+j) div 2 }
mov bx,dx
add ax,bx
shr ax,1
lea bx,polyz { ax:=polyz[ax] }
call @index
mov x,ax
@Rep: mov ax,cx { repeat ... }
lea bx,polyz { while polyz[i]<x do ... }
call @index
cmp ax,x
jge @Rep2
inc cx { inc(i); }
jmp @Rep
@Rep2: mov ax,dx { while x<polyz[j] do ... }
call @index
cmp x,ax
jge @EndR
dec dx { dec(j); }
jmp @Rep2
@EndR: cmp cx,dx { if i>j ==> @NSwap}
jg @NBl
je @NSwap
push cx
mov ax,cx
call @index
mov cx,ax { cx:=polyz[i] }
mov si,di
mov ax,dx { polyz[i]:=polyz[j] }
call @index
mov [si],ax
mov [di],cx { polyz[j]:=cx }
pop ax
push ax
lea bx,pind
call @index
mov cx,ax { cx:=pind[i] }
mov si,di
mov ax,dx { pind[i]:=pind[j] }
call @index
mov [si],ax
mov [di],cx { pind[j]:=cx }
pop cx
@NSwap: inc cx
dec dx
@NBl: cmp cx,dx { ... until i>j; }
jle @Rep
mov i,cx
mov j,dx
mov dx,hi { if i>=hi ==> @ChkLo }
cmp cx,dx
jge @ChkLo
call @Push { Push(i,hi) }
@ChkLo: mov cx,lo { if lo>=j ==> @QSend }
mov dx,j
cmp cx,dx
jge @QSend
call @Push { Push(lo,j) }
@QSend: jmp @QS { loop while stack isn't empty }
@Empty: mov ah,49h
int 21h
jmp @exit
@index: shl ax,1 { ax:=2*ax }
add ax,bx
mov di,ax
push bx
mov bl,soplt
mov al,phix
xor ah,ah
mul bl
add di,ax { di=2*index+SizeOf(polytype)+polyz }
pop bx
mov ax,[di]
ret
@Push: mov ah,48h { Push into stack }
mov bx,1
int 21h
jc @exit
mov bx,es
mov es,ax
mov es:[0],cx
mov es:[2],dx
mov es:[4],bx
mov di,ax
ret
@exit:
end;
Procedure Calc;
var z:pointype;
spx,spy,spz,
cpx,cpy,cpz,
zd,x,y,i,j,k:integer;
n,key,phiy,phiz:byte;
begin
phix:=0;
phiy:=0;
phiz:=0;
FillChar(xp,sizeof(xp),0);
FillChar(yp,sizeof(yp),0);
repeat
spx:=sinus(phix); { 'Precookied' constanst }
spy:=sinus(phiy);
spz:=sinus(phiz);
cpx:=cosinus(phix);
cpy:=cosinus(phiy);
cpz:=cosinus(phiz);
for n:=0 to nofpoints do
begin
i:=(cpy*point[n,0]-spy*point[n,2]) div divd;
j:=(cpz*point[n,1]-spz*i) div divd;
k:=(cpy*point[n,2]+spy*point[n,0]) div divd;
x:=(cpz*i+spz*point[n,1]) div divd;
y:=(cpx*j+spx*k) div divd;
z[n]:=(cpx*k-spx*j) div divd;
zd:=z[n]-dist;
xp[phix,n]:=(160+cpx)-(x*dist) div zd;
yp[phix,n]:=(200+spz) div 2-(y*dist) div zd;
end;
for n:=0 to nofpolys do
begin
polyz[phix,n]:=(z[planes[n,0]]+z[planes[n,1]]+
z[planes[n,2]]+z[planes[n,3]]) div 4;
pind[phix,n]:=n;
end;
QuickSort(0,nofpolys);
inc(phix,xst);
inc(phiy,yst);
inc(phiz,zst);
until phix=0;
end;
Procedure ShowObject;
var n:byte; pim:integer;
begin
retrace;
if address=0
then address:=16000
else address:=0;
setaddress(address);
cls;
for n:=sc to nofpolys do
begin
pim:=pind[phix,n];
polygon(xp[phix,planes[pim,0]],yp[phix,planes[pim,0]],
xp[phix,planes[pim,1]],yp[phix,planes[pim,1]],
xp[phix,planes[pim,2]],yp[phix,planes[pim,2]],
xp[phix,planes[pim,3]],yp[phix,planes[pim,3]],
polyz[phix,n]+30);
end;
end;
Procedure Rotate;
var i:byte;
begin
setmodex;
address:=0;
Triangles:=polypoints=3;
for i:=1 to 80 do setpal(i,cr+i shr 1,cg+i shr 1,cb+i shr 1);
setborder(63);
repeat
ShowObject;
inc(phix,xst);
until KeyPressed;
setborder(0);
end;
var i:byte;
s:stack;
x,y:integer;
begin
{border:=True;}
if ParamCount=1
then begin
Val(ParamStr(1),xst,yst);
if yst<>0 then Halt;
zst:=-2*xst;
yst:=xst;
end;
WriteLn('Wait a moment ...');
Calc;
Rotate;
TextMode(LastMode);
end.
But ... wait a moment ... you also need x3dUnit2.pas
which is also included in the SWAG files
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]