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.