[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]
program cube; { Author: Yves Hetzer 2:248/1003.8 }
uses crt; { Erfurt, Germany }
const gCrtc = $3d4; gScreensize = 400*80;
gscreenPage0 = $0000; gScreenpage1 = gscreensize;
gscreensegment = $0a000; gscrwidth = 80; scal= 20;
sintab : array[0..90] of byte = (0,4,9,13,18,22,27,31,36,40,44,49,53,58,62,66,71,75,79,83,88,
92,96,100,104,108,112,116,120,124,128,132,136,139,143,147,150,154,158,161,165,
168,171,175,178,181,184,187,190,193,196,199,202,204,207,210,212,215,217,219,222,
224,226,228,230,232,234,236,237,239,241,242,243,245,246,247,248,249,250,251,252,
253,254,254,254,255,255,255,255,255,255);
type tupel = record
x,y,z : integer;
end;
rtupel = record
x,y,z : real;
end;
PointType = record
X, Y : integer;
end;
bild_point = array[1..12] of rtupel;
kehrtab = array [1..10000] of real;
const pk : bild_point =((x:0;y:6;z:0),(x:2;y:2;z:2),(x:-2;y:2;z:2),
(x:2;y:2;z:-2),(x:-2;y:2;z:-2),(x:2;y:-2;z:2),(x:-2;y:-2;z:2),
(x:2;y:-2;z:-2),(x:-2;y:-2;z:-2),(x:0;y:-6;z:0),(x:6;y:0;z:0),
(x:-6;y:0;z:0));
var scrofs, hlength, scrmemoff,offs,gscreen : word;
bit_maske :byte;
rp : array[1..3,1..3] of real;
pd : bild_point;
u,v: array[1..12] of integer;
lauf,al,ga,f,leftb,rightb,upb,downb,help : integer;
eck : array [0..4] of pointtype;
kehrt:^kehrtab;
rmask,lmask:array [0..639] of byte;
procedure waitblank;
assembler;
asm;
mov dx,gCRTC+6;@g_r: in al,dx;test al,8;jz @g_r;@g_d: in al,dx;
test al,8;jnz @g_d
end;
procedure calcxy;
assembler;
asm;
mov cx,ax;mov ax,80;mul bx;mov dx,0a000h;push dx;mov dx,ax;
mov ax,cx;shr ax,1;shr ax,1;shr ax,1;add dx,ax;mov di,dx;
and cl,7;mov dl,80h;shr dl,cl;pop es;mov ax,gscreen;add di,ax;
mov ds:[offs], di;mov ds:[bit_maske],dl
end;
procedure set_dot(x,y,farbe : word);
assembler;
asm;
mov ax,x;mov bx,y;mov cx,farbe;call calcxy;mov ah,bit_maske;
mov dx,3ceh;mov al,08h;out dx,ax;mov ax,0a000h;mov es,ax;
mov di,offs;mov cx,farbe;mov ch,[es:di];mov [es:di], cl;
end;
procedure graph_init;
assembler;
asm;
mov ax,0012h;int 10h;mov dx,3ceh;mov ax,0205h;out dx,ax;mov ax,1003h;
out dx,ax; end;
PROCEDURE Draw(xA,yA,xB,yB,col:Integer); { DRAWALL.INC }
VAR
x,y,kriterium,dX,dY,stepX,stepY:Integer;
BEGIN
dX:=Abs(xB-xA);
dY:=Abs(yB-yA);
IF dX=0 THEN kriterium:=0 ELSE kriterium:=Round(-dX/2);
IF xB>xA THEN stepX:=1 ELSE stepX:=-1;
IF yB>yA THEN stepY:=1 ELSE stepY:=-1;
x:=xA;y:=yA;
set_dot(x,y,col);
WHILE Not ((x=xB) And (y=yB)) DO
BEGIN
IF kriterium <0 THEN
BEGIN
x:=x+stepX; kriterium:=kriterium+dY;
END;
IF (kriterium>=0) And ( y<>yB) THEN
BEGIN
y:=y+stepY; kriterium:=kriterium-dX;
END;
set_dot(x,y,col);
END;
END;
procedure hline(x1,x2:integer);
var y : word;
Begin
if x1>x2 then Begin help := x2;x2:=x1;x1:=help;end;
help := x1 shr 3;
scrofs := help + scrmemoff;
hlength := x2 shr 3 - help;
if hlength = 0 then
Begin
port[$3cf] := lmask[x1] and rmask[x2];
inc (mem[$a000:scrofs]);
end else
if hlength > 1 then
Begin
port[$3cf] := lmask[x1];
inc (mem[$a000:scrofs]);
port [$3cf] := $ff;
for lauf := 1 to hlength-1 do inc(mem[$a000:scrofs+lauf]);
port [$3cf] := rmask[x2];
inc (mem[$a000:scrofs+hlength]);
end else
Begin
port [$3cf] := lmask [x1];
inc (mem[$a000:scrofs]);
port [$3cf] := rmask [x2];
inc (mem[$a000:scrofs+1]);
end;
end;
procedure fillfourangle(var x1,y1,x2,y2,x3,y3,x4,y4,ficol:integer);
var ho1,ho2,ho3,ho4,ypos,start,ende,diff,counter1,counter2,polyho,
ya,ye,yr,yl,dy : integer;
stepx1,stepx2,stepx3,stepx4,links,rechts,xa,xe,xr,xl : longint;
sre,ore,sl,ol : word;
trapez,clip : boolean;
stepx : real;
procedure height (var h : integer);
Begin
if h = 0 then h := 1 else if h > 5000 then h := 5000;
end;
Begin
asm;mov dx,3ceh;mov ax,0005h;out dx,ax;mov ax,1003h;out dx,ax;end;
if ((x1<leftb) and (x2<leftb) and (x3<leftb) and (x4<leftb)) or
((x1>rightb) and (x2>rightb) and (x3>rightb) and (x4> rightb)) then exit;
clip := false;
if (x1<=leftb) or (x2<=leftb) or (x3<=leftb) or (x4<=leftb) or
(x1>=rightb) or (x2 >= rightb) or (x3 >= rightb) or (x4>=rightb) then clip :=
true;
eck[1].x := x1;eck[2].x := x2;eck[3].x := x3;eck[4].x := x4;
eck[1].y := y1;eck[2].y := y2;eck[3].y := y3;eck[4].y := y4;
for start := 1 to 3 do
for ende := 4 downto start do
if eck[start].y > eck[ende].y then begin
eck[0] := eck[start];
eck[start] := eck[ende];
eck[ende] := eck[0];
end;
polyho := eck[4].y-eck[1].y;
if (eck[1].y > downb) or (eck[4].y < upb) or (polyho < 1) then exit;
dy := eck[4].y - eck[1].y;
if dy = 0 then dy := 1;
if dy < 5000 then stepx := (eck[4].x-eck[1].x)*kehrt^[dy] else
stepx := (eck[4].x-eck[1].x)/dy;
xa := trunc ((eck[2].y-eck[1].y)*stepx+eck[1].x);
xe := trunc (eck[4].x-(eck[4].y-eck[3].y)*stepx);
if ((xa<eck[2].x)and(xe<eck[3].x)) or ((xa>eck[2].x) and (xe>eck[3].x))
then trapez := true else trapez := false;
xa := eck[1].x; xa := xa * 256;ya := eck[1].y; xe := eck[4].x;
xe := xe * 256; ye := eck[4].y;xl := eck[2].x; xl := xl * 256;
yl := eck[2].y; xr := eck[3].x;xr := xr * 256; yr := eck[3].y;
if not trapez then
Begin
ho1 := abs(yr-ya);ho2 := abs(ye-yr);height (ho1);height (ho2);
stepx1 := trunc((xr-xa)*kehrt^[ho1]);stepx2 := trunc((xe-xr)*kehrt^[ho2]);
ho4 := abs(yl-ya);ho3 := abs(ye-yl);height (ho4);height (ho3);
stepx4 := trunc((xl-xa)*kehrt^[ho4]);stepx3 := trunc((xe-xl)*kehrt^[ho3]);
end else
Begin
ho1 := abs(yl-ya);ho2 := abs(yr-yl);height (ho1);height (ho2);
stepx1 := trunc((xl-xa)*kehrt^[ho1]);stepx2 := trunc((xr-xl)*kehrt^[ho2]);
ho4 := abs(ye-ya);ho3 := abs(ye-yr);height (ho4);height (ho3);
stepx4 := trunc((xe-xa)*kehrt^[ho4]);stepx3 := trunc((xe-xr)*kehrt^[ho3]);
end;
port[$3ce] := 1; port[$3cf] := $0f;port[$3ce] := 0; port[$3cf]:=ficol;
port[$3ce] := 8;
links := xa; rechts := links; start := ya; ende := start + polyho - 1;
counter1:= 0; counter2 :=0;
if start < upb then Begin
diff := upb - start;inc (start,diff);inc (counter1,diff);
if not trapez then Begin
inc (counter2,diff);
if counter2<ho4 then inc (links,diff*stepx4)
else links := xl + (upb-yl)*stepx3;
if counter1<ho1 then inc(rechts,diff*stepx1)
else rechts := xr + (upb-yr)*stepx2;
end else Begin
inc(links,diff*stepx4);
if counter1<ho1 then inc(rechts,diff*stepx1)
else Begin
inc (counter2,diff-ho1);
if counter2 < ho2 then rechts := xl + (upb-yl)*stepx2
else rechts := xr + (upb-yr)*stepx3;
end;
end;
end;
scrmemoff := gscreen+start*gscrwidth;
if ende > downb then ende := downb;
sl := seg(links);ol := ofs(links)+1;sre := seg(rechts);ore := ofs(rechts)+1;
if not trapez then
begin
for ypos := start to ende do
begin
if counter2< ho4 then
Begin
inc(links,stepx4);inc(counter2);
end else inc(links,stepx3);
if counter1<ho1 then
begin
inc(rechts,stepx1);inc(counter1);
end else inc (rechts,stepx2);
hline(memw[sl:ol],memw[sre:ore]);
inc(scrmemoff,gscrwidth);
end;
end else
begin
for ypos := start to ende do
begin
inc(links,stepx4);
if counter1<ho1 then
begin
inc(rechts,stepx1);inc(counter1);
end else
if counter2<ho2 then
begin
inc(rechts,stepx2);inc(counter2);
end else inc(rechts,stepx3);
hline(memw[sl:ol],memw[sre:ore]);
inc(scrmemoff,gscrwidth);
end;
end;
port [$3cf] := $ff; port[$3ce] := 1;port [$3cf] := 0; port [$3ce] := 0;
port [$3cf] := 15;
end;
procedure setrgbpalette(i,r,g,b : byte);
begin
asm;mov dx,3c8h;mov al,i;out dx,al;inc dx;mov al,r;out dx,ax;mov al,g;
out dx,al;mov al,b;out dx,al;end;end;
function csin(winkel :integer): integer;
begin
while winkel < 0 do winkel := winkel + 360;
winkel := winkel mod 360;
if (winkel >= 0) and (winkel <= 90) then csin := sintab[winkel];
if (winkel > 90) and (winkel <= 180) then csin := sintab[180-winkel];
if (winkel > 180) and (winkel <= 270) then csin := -sintab[winkel-180];
if (winkel > 270) and (winkel <= 360) then csin := -sintab[360-winkel];
end;
function ccos(winkel :integer): integer;
begin
winkel := winkel+ 90;
while winkel < 0 do winkel := winkel + 360;
winkel := winkel mod 360;
ccos := csin(winkel);
end;
procedure gstartaddr(addr : word);
assembler;
asm;
mov bx,addr;push ds;mov dx,gCRTC;mov ah,bh;mov al,0ch;out dx,ax;
mov ah,bl;mov al,0dh;out dx,ax;mov cx,0040h;mov ds,cx;
mov word ptr ds:[004eh],bx;pop ds;end;
procedure waehle_seite (seite : byte);
begin
gscreen := seite * gscreensize;
end;
procedure zeige_seite(seite : byte);
var adr : word;
begin
adr := seite * gscreensize;
gstartaddr (adr);
end;
procedure wechsel5;
begin
if gscreen = gscreenpage0 then begin
zeige_seite(0); waehle_seite(1); end
else begin
zeige_seite(1); waehle_seite(0);
end;
end;
procedure gclear;
assembler;
asm;
mov ax,gscreensegment;mov es,ax;mov al,es:[0];mov di,gscreen;mov dx,3ceh;
mov ax,0205h;out dx,ax;mov ax,0003h;out dx,ax;mov ax,0ffffh;out dx,ax;
mov ax,$00;mov cx,gscreensize/2;rep stosw;mov dx,3ceh;mov ax,0205h;out dx,ax;
mov ax,1003h;out dx,ax;end;
procedure dreh_m;
var x,y,u,v : real;
begin
x:=csin(ga)/256; y:=ccos(al)/256; u:=csin(al)/256; v:=ccos(ga)/256;
rp[1,1]:=v; rp[2,1]:=x; rp[3,1]:=0; rp[1,2]:=y*x; rp[2,2]:=y*v; rp[3,2]:=-u;
rp[1,3]:=u*x; rp[2,3]:=u*v; rp[3,3]:=y;end;
procedure dreh(var x:rtupel);
var temp:rtupel;
begin
temp.x:=(x.x*rp[1,1]+x.y*rp[1,2]+x.z*rp[1,3]) * scal;
temp.y:=(x.x*rp[2,1]+x.y*rp[2,2]+x.z*rp[2,3])*scal;
temp.z:=(x.y*rp[3,2]+x.z*rp[3,3])*scal;
x:=temp;
end;
procedure zeichnen;
begin
for lauf := 1 to 12 do begin
u[lauf] := round(pd[lauf].x)+320;v[lauf] := round(pd[lauf].z)+200;end;
draw(u[1],v[1],u[2],v[2],1);draw(u[1],v[1],u[4],v[4],1);
draw(u[1],v[1],u[3],v[3],1);draw(u[1],v[1],u[5],v[5],1);
draw(u[2],v[2],u[3],v[3],1);draw(u[2],v[2],u[4],v[4],1);
draw(u[3],v[3],u[5],v[5],1);draw(u[5],v[5],u[4],v[4],1);
draw(u[6],v[6],u[7],v[7],1);draw(u[6],v[6],u[8],v[8],1);
draw(u[7],v[7],u[9],v[9],1);draw(u[9],v[9],u[8],v[8],1);
draw(u[2],v[2],u[6],v[6],1);draw(u[3],v[3],u[7],v[7],1);
draw(u[4],v[4],u[8],v[8],1);draw(u[5],v[5],u[9],v[9],1);
draw(u[10],v[10],u[6],v[6],1);draw(u[10],v[10],u[7],v[7],1);
draw(u[10],v[10],u[8],v[8],1);draw(u[10],v[10],u[9],v[9],1);
draw(u[11],v[11],u[6],v[6],1);draw(u[11],v[11],u[2],v[2],1);
draw(u[11],v[11],u[8],v[8],1);draw(u[11],v[11],u[4],v[4],1);
draw(u[12],v[12],u[3],v[3],1);draw(u[12],v[12],u[5],v[5],1);
draw(u[12],v[12],u[7],v[7],1);draw(u[12],v[12],u[9],v[9],1); end;
procedure initkehrtaB;
var a: word;
begin new (kehrt); for a:= 1 to 10000 do kehrt^[a] := 1/a; end;
procedure initmasktab;
var a,wert : word;
begin
for a:= 0 to 639 do
begin
lmask[a]:=$ff shr (a and 7);wert := $ff shl (7-(a and 7));
rmask[a] := lo(wert); end;end;
procedure gexit;
assembler; asm;push ax;xor ah,ah;mov al,3h;int 10h;pop ax;end;
begin
graph_init;
setrgbpalette(1,63,0,0); setrgbpalette(2,0,42,0); setrgbpalette(3,10,63,10);
setrgbpalette(4,42,0,0); setrgbpalette(5,63,10,10);setrgbpalette(6,42,21,0);
setrgbpalette(7,42,42,42);
gscreen := 0; initkehrtab; initmasktab;
al := 0; ga := 0;leftb := 10;upb := 10;rightb := 600;downb := 400;
repeat
dec(al,5);ga := ga + csin(al) div 25+csin(ga) div 50;pd := pk;
dreh_m;for lauf := 1 to 12 do dreh(pd[lauf]);
zeichnen;f := 2;
fillfourangle(u[1],v[1],u[4],v[4],u[5],v[5],u[1],v[1],f);
fillfourangle(u[1],v[1],u[2],v[2],u[3],v[3],u[1],v[1],f);
fillfourangle(u[1],v[1],u[5],v[5],u[3],v[3],u[1],v[1],f);
fillfourangle(u[1],v[1],u[2],v[2],u[4],v[4],u[1],v[1],f);f := 4;
fillfourangle(u[11],v[11],u[2],v[2],u[6],v[6],u[11],v[11],f);
fillfourangle(u[11],v[11],u[4],v[4],u[8],v[8],u[11],v[11],f);
fillfourangle(u[11],v[11],u[6],v[6],u[8],v[8],u[11],v[11],f);
fillfourangle(u[11],v[11],u[2],v[2],u[4],v[4],u[11],v[11],f);f := 2;
fillfourangle(u[10],v[10],u[8],v[8],u[9],v[9],u[10],v[10],f);
fillfourangle(u[10],v[10],u[6],v[6],u[7],v[7],u[10],v[10],f);
fillfourangle(u[10],v[10],u[9],v[9],u[7],v[7],u[10],v[10],f);
fillfourangle(u[10],v[10],u[6],v[6],u[8],v[8],u[10],v[10],f);f := 4;
fillfourangle(u[12],v[12],u[3],v[3],u[7],v[7],u[12],v[12],f);
fillfourangle(u[12],v[12],u[5],v[5],u[9],v[9],u[12],v[12],f);
fillfourangle(u[12],v[12],u[3],v[3],u[5],v[5],u[12],v[12],f);
fillfourangle(u[12],v[12],u[7],v[7],u[9],v[9],u[12],v[12],f);
wechsel5; waitblank; gclear;
until keypressed;
dispose(kehrt);gexit;end.
[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]