Паскаль / do11 / tmtp390d / SAMPLES / GRAPH / Frac3d

(***********************************************)
(* *)
(* Graph Unit Demo *)
(* Copyright (c) 1998 by TMT Development Corp. *)
(* Author: Vadim Bodrov, TMT Development Corp. *)
(* Based on original code by Ryan Jones *)
(* *)
(* Targets: *)
(* MS-DOS 32-bit protected mode *)
(* Win32 application *)
(***********************************************)

uses Crt, Graph;

const
ZInc = 25;
ZOfs = 256;
ZScale = 400;
Sc = 0.7;

type
ABType = record
LSide, RSide: Longint;
end;

Triangle = record
X1, Y1, Z1,
X2, Y2, Z2,
X3, Y3, Z3: Extended;
Color: DWORD;
end;

var
Tris: array [0..100] of Triangle;
Trin, l, i, hn: DWORD;
Ch: Char;
Page: Boolean := false;
Color: DWORD;

procedure ChangePage;
begin
if Page then begin
SetActivePage(0);
SetVisualPage(1,true);
Page:=false;
end else begin
SetActivePage(1);
SetVisualPage(0,true);
Page:=true;
end;
ClearPage;
OutTextXY(500, 468, 'Fractal-3D demo');
end;

procedure AddTris(i: DWORD);
var
OX1, OY1, OZ1,
OX2, OY2, OZ2,
OX3, OY3, OZ3: Extended;
OC: DWORD;
begin
with Tris[i] do begin
OX1 := X1; OY1 := Y1; OZ1 := Z1;
OX2 := X2; OY2 := Y2; OZ2 := Z2;
OX3 := X3; OY3 := Y3; OZ3 := Z3;
OC := Color + 24;
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;
Color := OC;
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;
Color := OC;
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;
Color := OC;
end;
inc(Trin, 3);
end;

procedure DrawTris;
var SX1, SY1, SX2, SY2, SX3, SY3, i: DWORD;
begin
i := 0;
repeat
with Tris[i] 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));
SetFillColor(Color);
FillTriangle(320 + SX1, 200 + SY1, 320 + SX2, 200 + SY2, 320 + SX3, 200 + SY3);
end;
inc(i);
until i = Trin;
ChangePage;
end;

procedure Rotate(var X,Y: Extended; Ang: Extended);
var XX, YY: Extended;
begin
XX := X * Cos(Ang / 180 * pi) + Y * Sin(Ang / 180 * pi);
YY := Y * Cos(Ang / 180 * pi) - X * Sin(Ang / 180 * pi);
X := XX;
Y := YY;
end;

procedure RotateTris(Ang: Extended);
var i: DWORD;
begin
i := 0;
repeat
with Tris[i] do begin
Rotate(X1, Z1, Ang);
Rotate(X2, Z2, Ang);
Rotate(X3, Z3, Ang);
end;
inc(i);
until i = Trin;
end;

procedure RotateTrisb(Ang: Extended);
var i: DWORD;
begin
i := 0;
repeat
with Tris[i] do begin
Rotate(X1, Y1, Ang);
Rotate(X2, Y2, Ang);
Rotate(X3, Y3, Ang);
end;
inc(i);
until i = Trin;
end;

procedure RotateTrisc(Ang: Extended);
var i: DWORD;
begin
i := 0;
repeat
with Tris[i] do begin
Rotate(Y1, Z1, Ang);
Rotate(Y2, Z2, Ang);
Rotate(Y3, Z3, Ang);
end;
inc(i);
until i = Trin;
end;

procedure ExpandTris;
const
Scd = 0.95;
var
i: DWORD;
begin
i := 0;
repeat
with Tris[i] do begin
X1 := X1 * Scd;
Y1 := Y1 * Scd;
X2 := X2 * Scd;
Y2 := Y2 * Scd;
X3 := X3 * Scd;
Y3 := Y3 * Scd;
end;
inc(i);
until i = Trin;
end;

begin
SetSVGAMode(640, 480, 8, LfbOrBanked);
OutTextXY(270, 230, 'Please wait...');
for i := 1 to 254 do
SetRGBPalette(i, i div 3 + 25, 2, i div 3 + 30);
SetRGBPalette(255, 63, 63, 63);
SetColor(255);
DrawBorder := false;
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;
Color := 24;
end;
Trin := 1;
l := 3;
repeat
i := 0;
hn := Trin;
repeat
AddTris(i);
inc(i);
until i = hn;
dec(l);
until l = 0;
Tris[0].Color := 24;

repeat // main loop
i := 0;
repeat
DrawTris;
RotateTris(4);
inc(i);
until (KeyPressed) or (i = 45);
i := 0;
repeat
DrawTris;
RotateTrisb(4);
inc(i);
until (KeyPressed) or (i = 45);
i := 0;
repeat
DrawTris;
RotateTrisc(4);
inc(i);
until (KeyPressed) or (i = 45);
until KeyPressed;
repeat
Ch := ReadKey
until not KeyPressed;
i := 100;
repeat // outro
DrawTris;
ExpandTris;
RotateTris(4);
RotateTrisb(4);
RotateTrisc(4);
dec(i);
until (i = 0) or (KeyPressed);
if KeyPressed then
repeat
Ch:=ReadKey
until not KeyPressed;
RestoreCrtMode;
end.