Program Frac3d1;

{
	The only problem with this program is that i didn't optimize it, so
   you should have at least a pentium (or a fast 486) to run it; however,
   i did use 32-bit instructions, so it can't be run on 8086's or 8088's
	at all.

   Runs in 320x200x256

	Features:
		A double buffer
		32-Bit moves and fills
      Weak color layering and palette changing
      3D graphics (using slow Real numbers)
      3D fractal
      A pretty fast polygon statement

   Programmed by Ryan Jones (Dios@Rworld.com)
}

Uses
	CRT;

Const
	ZInc = 25;
   ZOfs = 256;
   ZScale = 256;
   Sc = 0.7;
	Red = 0;
	Green = 1;
	Blue = 2;

Type
	Palette = Array[0..255, Red..Blue] Of Byte;
	ABType = Record LSide, RSide : Integer; End;
	Triangle =
   	Record
      	X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3 : Real;
         Color : Byte;
      End;

Var
	Segment, Ofset : Word; { Double Buffer info }
	Tris : Array[0..100] Of Triangle; { Triangle info }
   Trin,                             { # of triangles }
	l, n, hn : Word;                  { fractal stuff }
   db : Pointer; { Double Buffer }
   Ch : Char;

Procedure SetScreenPtr(Var Ptr); { lets Poly know where to do its stuff }
	Begin
   	Segment := Seg(Ptr);
      Ofset := Ofs(Ptr);
   End;

Procedure SetVideoMode( N : Byte ); Assembler; { sets the video mode }
   Asm
      MOV AH, 0
      MOV AL, N
      INT $10
   End;

Procedure Credit; { lets you know who made it }
	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 DisplayPalette(P : Palette; First, Last : Word); Assembler; { updates palette }
	Asm
     	CLI
     	PUSH DS
     	PUSH SI
      LDS SI, P

      MOV CX, First
      ADD SI, CX
      ADD SI, CX
      ADD SI, CX

      MOV AX, Last
      SUB AX, First
      INC AX
      MOV CX, AX
      SHL CX, 1
      ADD CX, AX

      MOV AX, First
      MOV DX, $3C8
      OUT DX, AL
      INC DX
      REP OUTSB
      POP SI
      POP DS
      STI
   End;

Procedure Fill(Var A; L : Word; B : Byte); Assembler; { similar to FillChar }
	Asm
   	CLI
      CLD
      LES DI, A
      MOV CX, L
   	MOV AL, BYTE PTR B
      REP STOSB
      STI
   End;

Procedure FillDW(Var A; L : Word; Dw : LongInt); Assembler;
{ similar to FillChar, except uses Double Words }
	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;
{ similar to Move, except uses Double Words }
	Asm
   	CLI
      CLD
      PUSH DS
      LDS SI, A
      LES DI, B
      MOV CX, L
      DB $66; REP MOVSW
      POP DS
      STI
   End;

Procedure Poly(x1, y1, x2, y2, x3, y3, x4, y4, c1 : Integer);
{ draws a Polygon or Triangle }
	Type
      ScrType = Array[0..199, 0..319] Of Byte;

	Var
		Xa : Array[0..199] Of ABType;
      x, y, dx : LongInt;
      L, R : Integer;
      Scr : ^ScrType;
      c : Byte;

   Procedure CalcSideX(x1, y1, x2, y2 : Integer);
   	Var t : Integer;
   	Begin
         If y1 = y2 Then
         	Begin
            	If (y1 >= 0) And (y1 <= 199) Then
               	Begin
			         	If (x1 < Xa[y1].LSide) Then Xa[y1].LSide := x1;
			         	If (x1 > Xa[y1].RSide) Then Xa[y1].RSide := x1;
			         	If (x2 < Xa[y1].LSide) Then Xa[y1].LSide := x2;
			         	If (x2 > Xa[y1].RSide) Then Xa[y1].RSide := x2;
                  End;
               Exit;
            End;
      	If y1 > y2 Then
				Begin
            	t := x1;
               x1 := x2;
               x2 := t;
            	t := y1;
               y1 := y2;
               y2 := t;
				End;
      	dx := LongInt(x2 - x1) SHL 16 DIV (y2-y1);
         y := y1;
         x := LongInt(x1) SHL 16;
         repeat
         	If (y >= 0) And (y <= 199) Then
					Begin
		         	If (Integer(x SHR 16) < Xa[y].LSide) Then Xa[y].LSide := x SHR 16;
		         	If (Integer(x SHR 16) > Xa[y].RSide) Then Xa[y].RSide := x SHR 16;
               End;
         	x := x + dx;
            y := y + 1;
         until y > y2;
      End;

	Begin
   	Scr := Ptr(Segment, Ofset);
   	FillDW(Xa[0], 200, $80007FFF);
      CalcSideX(x1, y1, x2, y2);
      CalcSideX(x2, y2, x3, y3);
      CalcSideX(x3, y3, x4, y4);
      CalcSideX(x4, y4, x1, y1);
      c := c1;
      y := 0;
      repeat
      	L := Xa[y].LSide;
         R := Xa[y].RSide;
         If L < 0 Then L := 0;
         If R > 319 Then R := 319;
{         If Not ((L > 319) Or (R < 0)) Then Fill(Scr^[y, L], (R-L)+1, c);}
			If Not ((L > 319) Or (R < 0)) Then
         	Asm
            	MOV AX, Segment
               MOV ES, AX
            	MOV AX, WORD PTR y
               XCHG AH, AL
               MOV BX, AX
               SHR AX, 1
               SHR AX, 1
               ADD BX, AX
               ADD BX, WORD PTR L
               ADD BX, Ofset
               MOV CX, WORD PTR R
               SUB CX, WORD PTR L
               INC CX
               MOV DX, c1
               @L1:
               	ADD ES:[BX], DL
                  INC BX
               LOOP @L1
            End;
         y := y + 1;
      until y > 199;
   End;

Procedure AddTris(n : Word);
	Var
		OX1, OY1, OZ1, OX2, OY2, OZ2, OX3, OY3, OZ3 : Real;
   	OC : Byte;
	Begin
   	With Tris[n] 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;
      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));
		         Poly(160+SX1, 100+SY1, 160+SX2, 100+SY2, 160+SX3, 100+SY3, 160+SX1, 100+SY1, Color);
         	End;
         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;

Procedure ExpandTris;
	Const Scd = 0.95;
	Var n : Word;
	Begin
   	n := 0;
      Repeat
      	With Tris[n] Do
         	Begin
            	X1 := X1 * Scd;
            	Y1 := Y1 * Scd;
            	X2 := X2 * Scd;
            	Y2 := Y2 * Scd;
            	X3 := X3 * Scd;
            	Y3 := Y3 * Scd;
            End;
         n := n + 1;
      Until n = Trin;
   End;

Procedure Pal; { sets up my palette }
	Var P : Palette;
   	n : Word;
	Begin
   	n := 0;
      repeat
      	P[n, Red] := n div 4;
      	P[n, Green] := 0;
      	P[n, Blue] := n div 6+21;
         n := n + 1;
      until n = 256;
      DisplayPalette(P, 1, 255);
   End;

Begin
	SetVideoMode($13);
   Pal;
   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;
	   	Color := 24;
      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;
   Tris[0].Color := 24;

   Repeat { main loop }
   	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;
   n := 150;
   Repeat { outro }
   	DrawTris;
      ExpandTris;
      RotateTris(Pi/72);
      RotateTrisb(Pi/72);
      RotateTrisc(Pi/72);
      n := n - 1;
   Until (n = 0) Or KeyPressed;
   If KeyPressed Then Repeat Ch := ReadKey Until Not KeyPressed;
   SetVideoMode($03);
   Credit;
End.