[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
Program Frac3d;
{
See Frac3D1.pas for info.
Programmed by Ryan Jones (Dios@Rworld.Com)
}
Uses
CRT;
Const
ZInc = 25;
ZOfs = 256;
ZScale = 256;
Sc = 0.7;
Type
Triangle =
Record
X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3 : Real;
End;
Var
Segment, Ofset : Word;
Tris : Array[0..100] Of Triangle;
Trin,
l, n, hn : Word;
db : Pointer;
Ch : Char;
Procedure SetScreenPtr(Var Ptr);
Begin
Segment := Seg(Ptr);
Ofset := Ofs(Ptr);
End;
Procedure SetVideoMode( N : Byte ); Assembler;
Asm
MOV AH, 0
MOV AL, N
INT $10
End;
Procedure Credit;
Var
St : String;
n : Word;
Begin
SetVideoMode($03);
Textcolor(15);
Textbackground(0);
St := 'Qsphsbnnfe!cz!Szbo!Kpoft/';
n := 1;
Repeat
St[n] := Chr(Ord(St[n]) - 1);
n := n + 1;
Until n > Length(St);
Writeln(St);
Textcolor(7);
WriteLn;
End;
Procedure _Line(X1, Y1, X2, Y2, C : Integer); Assembler;
{ It's more efficient than it looks}
Asm
CLI
MOV AX, X2
CMP AX, X1
JNE @Sk
MOV AX, Y2
CMP AX, Y1
JE @NoLine
@Sk:
MOV AX, X2
CMP AX, X1
JG @Skip
MOV BX, X1
MOV X2, BX
MOV X1, AX
MOV AX, Y2
MOV BX, Y1
MOV Y2, BX
MOV Y1, AX
@Skip:
MOV DX, C { Set DX To _GetColor }
MOV AX, Segment
MOV ES, AX { Set ES To $A000 }
MOV BX, Y1
XCHG BH, BL
MOV AX, BX
SHR BX, 1
SHR BX, 1
ADD BX, AX
ADD BX, X1 { Set BX == X + (Y*320) }
ADD BX, Ofset
MOV SI, X2
MOV DI, Y2
SUB SI, X1
SUB DI, Y1
@ABCD:
CMP DI, $8888
JB @CD
@AB:
NEG DI
CMP SI, DI
JB @A
@B:
MOV CX, SI
MOV AX, SI
SHR AX, 1
@Loopa:
MOV ES:[BX], DL
INC BX
ADD AX, DI
CMP AX, SI
JLE @Skipa
SUB BX, 320
SUB AX, SI
@Skipa:
LOOP @Loopa
JMP @Exit
@A:
MOV CX, DI
MOV AX, DI
SHR AX, 1
@Loopb:
MOV ES:[BX], DL
SUB BX, 320
ADD AX, SI
CMP AX, DI
JLE @Skipb
ADD BX, 1
SUB AX, DI
@Skipb:
LOOP @Loopb
JMP @Exit
@CD:
CMP SI, DI
JB @D
@C:
MOV CX, SI
MOV AX, SI
SHR AX, 1
@Loopc:
MOV ES:[BX], DL
INC BX
ADD AX, DI
CMP AX, SI
JLE @Skipc
ADD BX, 320
SUB AX, SI
@Skipc:
LOOP @Loopc
JMP @Exit
@D:
MOV CX, DI
MOV AX, DI
SHR AX, 1
@Loopd:
MOV ES:[BX], DL
ADD BX, 320
ADD AX, SI
CMP AX, DI
JLE @Skipd
ADD BX, 1
SUB AX, DI
@Skipd:
LOOP @Loopd
JMP @Exit
@NoLine:
MOV AX, X2
MOV BX, Y2
MOV DX, C
MOV BX, Y1
XCHG BH, BL
MOV AX, BX
SHR BX, 1
SHR BX, 1
ADD BX, AX
ADD BX, X1
MOV AX, Segment
MOV ES, AX
@Exit:
MOV ES:[BX], DL
STI
End;
Procedure FillDW(Var A; L : Word; Dw : LongInt); Assembler;
Asm
CLI
CLD
LES DI, A
MOV CX, L
DB $66; MOV AX, WORD PTR Dw
DB $66; REP STOSW
STI
End;
Procedure MoveDW(Var A, B; L : Word); Assembler;
Asm
CLI
CLD
PUSH DS
LDS SI, A
LES DI, B
MOV CX, L
DB $66; REP MOVSW
POP DS
STI
End;
Procedure ClipLine(x1, y1, x2, y2, c : Word);
Begin
If (x1 > 0) and (x1 < 320) and
(y1 > 0) and (y1 < 200) and
(x2 > 0) and (x2 < 320) and
(y2 > 0) and (y2 < 200) then _Line(x1, y1, x2, y2, c);
End;
Procedure AddTris(n : Word);
Var OX1, OY1, OZ1, OX2, OY2, OZ2, OX3, OY3, OZ3 : Real;
Begin
With Tris[n] Do
Begin
OX1 := X1;
OY1 := Y1;
OZ1 := Z1;
OX2 := X2;
OY2 := Y2;
OZ2 := Z2;
OX3 := X3;
OY3 := Y3;
OZ3 := Z3;
End;
With Tris[Trin] Do
Begin
X1 := OX1;
Y1 := OY1;
Z1 := OZ1+ZInc;
X2 := OX1*2/3+OX2/3;
Y2 := OY1*2/3+OY2/3;
Z2 := OZ2+ZInc;
X3 := OX1*2/3+OX3/3;
Y3 := OY1*2/3+OY3/3;
Z3 := OZ3+ZInc;
End;
With Tris[Trin+1] Do
Begin
X1 := OX2*2/3+OX1/3;
Y1 := OY2*2/3+OY1/3;
Z1 := OZ1+ZInc;
X2 := OX2;
Y2 := OY2;
Z2 := OZ2+ZInc;
X3 := OX2*2/3+OX3/3;
Y3 := OY2*2/3+OY3/3;
Z3 := OZ3+ZInc;
End;
With Tris[Trin+2] Do
Begin
X1 := OX3*2/3+OX1/3;
Y1 := OY3*2/3+OY1/3;
Z1 := OZ1+ZInc;
X2 := OX3*2/3+OX2/3;
Y2 := OY3*2/3+OY2/3;
Z2 := OZ2+ZInc;
X3 := OX3;
Y3 := OY3;
Z3 := OZ3+ZInc;
End;
Trin := Trin + 3;
End;
Procedure DrawTris;
Var SX1, SY1, SX2, SY2, SX3, SY3, n : Word;
Begin
SetScreenPtr(db^);
FillDW(db^, 16000, $00000000);
n := 0;
Repeat
With Tris[n] Do
Begin
SX1 := Round((ZScale*X1)/(Z1-ZOfs));
SY1 := Round((ZScale*Y1)/(Z1-ZOfs));
SX2 := Round((ZScale*X2)/(Z2-ZOfs));
SY2 := Round((ZScale*Y2)/(Z2-ZOfs));
SX3 := Round((ZScale*X3)/(Z3-ZOfs));
SY3 := Round((ZScale*Y3)/(Z3-ZOfs));
End;
ClipLine(160+SX1, 100+SY1, 160+SX2, 100+SY2, 15);
ClipLine(160+SX2, 100+SY2, 160+SX3, 100+SY3, 15);
ClipLine(160+SX3, 100+SY3, 160+SX1, 100+SY1, 15);
n := n + 1;
Until n = Trin;
MoveDW(db^, Ptr($A000, 0)^, 16000);
End;
Procedure Rotate(Var X, Y, ang : Real);
Var XX, YY : Real;
Begin
XX := X*Cos(ang)+Y*Sin(ang);
YY := Y*Cos(ang)-X*Sin(ang);
X := XX;
Y := YY;
End;
Procedure RotateTris(ang : Real);
Var n : Word;
Begin
n := 0;
Repeat
With Tris[n] Do
Begin
Rotate(X1, Z1, ang);
Rotate(X2, Z2, ang);
Rotate(X3, Z3, ang);
End;
n := n + 1;
Until n = Trin;
End;
Procedure RotateTrisb(ang : Real);
Var n : Word;
Begin
n := 0;
Repeat
With Tris[n] Do
Begin
Rotate(X1, Y1, ang);
Rotate(X2, Y2, ang);
Rotate(X3, Y3, ang);
End;
n := n + 1;
Until n = Trin;
End;
Procedure RotateTrisc(ang : Real);
Var n : Word;
Begin
n := 0;
Repeat
With Tris[n] Do
Begin
Rotate(Y1, Z1, ang);
Rotate(Y2, Z2, ang);
Rotate(Y3, Z3, ang);
End;
n := n + 1;
Until n = Trin;
End;
Begin
SetVideoMode($13);
GetMem(db, 64000);
With Tris[0] Do
Begin
X1 := 0;
Y1 := 86;
Z1 := 0;
X2 := 100;
Y2 := -86;
Z2 := 0;
X3 := -100;
Y3 := -86;
Z3 := 0;
X1 := X1 * Sc;
Y1 := Y1 * Sc;
Z1 := Z1 * Sc;
X2 := X2 * Sc;
Y2 := Y2 * Sc;
Z2 := Z2 * Sc;
X3 := X3 * Sc;
Y3 := Y3 * Sc;
Z3 := Z3 * Sc;
End;
Trin := 1;
l := 3;
Repeat
n := hn;
hn := Trin;
Repeat
AddTris(n);
n := n + 1;
Until n = hn;
l := l - 1;
Until l = 0;
Repeat
n := 0;
Repeat
DrawTris;
RotateTris(Pi/72);
n := n + 1;
Until KeyPressed Or (n = 144);
n := 0;
Repeat
DrawTris;
RotateTrisb(Pi/72);
n := n + 1;
Until KeyPressed Or (n = 144);
n := 0;
Repeat
DrawTris;
RotateTrisc(Pi/72);
n := n + 1;
Until KeyPressed Or (n = 144);
Until KeyPressed;
Repeat Ch := ReadKey Until Not KeyPressed;
SetVideoMode($03);
Credit;
End.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]