home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / MISC / MAG10.ZIP / VECTOR1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-26  |  7.7 KB  |  213 lines
  1.                Program VectorBalls;
  2.  
  3.                Uses Mode13h,Crt;
  4.  
  5.                Type BallSprite=Array[1..8,1..8] Of Byte;
  6.  
  7.                Const Balls=35;
  8.                      Ball1:BallSprite=
  9.                      ((0,0,2,2,2,1,0,0),(0,2,3,3,3,2,1,0),(2,3,4,3,3,2,1,1),
  10.                       (2,3,3,3,2,2,1,1),(2,2,3,3,2,1,1,1),(1,2,2,2,1,1,1,1),
  11.                       (0,1,1,1,1,1,1,0),(0,0,1,1,1,1,0,0));
  12.                      Ball2:BallSprite=
  13.                      ((0,0,6,6,6,5,0,0),(0,6,7,7,7,6,5,0),(6,7,8,7,7,6,5,5),
  14.                       (6,7,7,7,6,6,5,5),(6,6,7,7,6,5,5,5),(5,6,6,6,5,5,5,5),
  15.                       (0,5,5,5,5,5,5,0),(0,0,5,5,5,5,0,0));
  16.  
  17.                Type Ball3d=Record
  18.                                  Color:Byte;
  19.                                  X,Y,Z:Real;
  20.                            End;
  21.  
  22.                Var S:Array[1..Balls] of Ball3d;
  23.                    A:Integer;
  24.                    C:Char;
  25.  
  26.                Procedure InitColors;
  27.                Begin
  28.                     SetColor(0,0,0,0);
  29.                     SetColor(1,0,0,30);
  30.                     SetColor(2,0,0,50);
  31.                     SetColor(3,0,20,63);
  32.                     SetColor(4,0,40,63);
  33.                     SetColor(5,30,0,0);
  34.                     SetColor(6,50,0,0);
  35.                     SetColor(7,63,20,20);
  36.                     SetColor(8,63,40,40);
  37.                End;
  38.  
  39.                Procedure InitObject;
  40.                Var X,Y:Byte;
  41.                Begin
  42.                     For X:=1 To 5 Do
  43.                       For Y:=0 To 6 Do
  44.                       Begin
  45.                            S[Y*5+X].Color:=1;
  46.                            S[Y*5+X].X:=X*10-25;
  47.                            S[Y*5+X].Y:=Y*10-35;
  48.                            S[Y*5+X].Z:=256;
  49.                       End;
  50.                       S[7].Color:=2; S[8].Color:=2; S[9].Color:=2;
  51.                       S[17].Color:=2; S[18].Color:=2; S[19].Color:=2;
  52.                       S[27].Color:=2; S[28].Color:=2; S[29].Color:=2;
  53.                       S[12].Color:=2; S[24].Color:=2;
  54.                End;
  55.  
  56.                Procedure DrawSprite(X,Y:Integer;Sp:BallSprite;Where:Word);
  57.                Var A,B:Byte;
  58.                Begin
  59.                     For A:=1 To 8 Do For B:=1 To 8 Do
  60.                       If Sp[A,B]<>0 Then PutPixel(X+A-1,Y+B-1,Sp[A,B],Where);
  61.                End;
  62.  
  63.                Procedure DrawBall(P:Ball3d;Where:Word);
  64.                Var Xt,Yt:Integer;
  65.                Begin
  66.                     { Convert X,Y,Z to X,Y }
  67.                     Xt:=160+Trunc((P.X*256)/P.Z);
  68.                     If (Xt<0) Or (Xt>319) Then Exit;
  69.                     Yt:=100+Trunc((P.Y*256)/P.Z);
  70.                     If (Yt<0) Or (Yt>199) Then Exit;
  71.                     { Draw the ball }
  72.                     If P.Color=1 Then DrawSprite(Xt,Yt,Ball1,Where);
  73.                     If P.Color=2 Then DrawSprite(Xt,Yt,Ball2,Where);
  74.                End;
  75.  
  76.                Procedure Sort;
  77.                Var Flag:Boolean;
  78.                    I,J:Integer;
  79.                    N:Real;
  80.                    X:Ball3d;
  81.  
  82.                    Procedure SortSubArray(Left,Right:Byte);
  83.                    Begin
  84.                         { Partition }
  85.                         I:=Left;
  86.                         J:=Right;
  87.                         N:=S[(Left+Right) Div 2].Z;
  88.                         Repeat
  89.                               { Find first number from the left to be < N }
  90.                               While S[I].Z<N Do Inc(I);
  91.                               { Find first number from the right to be > N }
  92.                               While S[J].Z>N Do Dec(J);
  93.                               { Exchange }
  94.                               If I<=J Then
  95.                               Begin
  96.                                    X:=S[J];
  97.                                    S[J]:=S[I];
  98.                                    S[I]:=X;
  99.                                    Inc(I);
  100.                                    Dec(J);
  101.                               End;
  102.                         Until J<I;
  103.                         { Order left and right subarrays }
  104.                         If Left<J Then SortSubArray(Left,J);
  105.                         If I<Right Then SortSubArray(I,Right);
  106.                    End;
  107.  
  108.                Begin
  109.                     SortSubArray(1,Balls);
  110.                End;
  111.  
  112.                Procedure DrawBalls(Where:Word);
  113.                Var A:Byte;
  114.                Begin
  115.                     Sort;
  116.                     For A:=Balls DownTo 1 Do DrawBall(S[A],Where);
  117.                End;
  118.  
  119.                Procedure RotateX(Deg:Integer);
  120.                Var A:Byte;
  121.                    Angle:Real;
  122.                    ZTemp:Real;
  123.                    Si,Co:Real;
  124.                Begin
  125.                     Angle:=0.0175*Deg;
  126.                     Si:=Sin(Angle);
  127.                     Co:=Cos(Angle);
  128.                     For A:=1 To Balls Do
  129.                       With S[A] Do
  130.                       Begin
  131.                            ZTemp:=Z;
  132.                            Z:=ZTemp*Co-Y*Si;
  133.                            Y:=Y*Co+ZTemp*Si;
  134.                       End;
  135.                End;
  136.  
  137.                Procedure RotateY(Deg:Integer);
  138.                Var A:Byte;
  139.                    Angle:Real;
  140.                    XTemp:Real;
  141.                    Si,Co:Real;
  142.                Begin
  143.                     Angle:=0.0175*Deg;
  144.                     Si:=Sin(Angle);
  145.                     Co:=Cos(Angle);
  146.                     For A:=1 To Balls Do
  147.                       With S[A] Do
  148.                       Begin
  149.                            XTemp:=X;
  150.                            X:=XTemp*Co-Z*Si;
  151.                            Z:=Z*Co+XTemp*Si;
  152.                       End;
  153.                End;
  154.  
  155.                Procedure RotateZ(Deg:Integer);
  156.                Var A:Byte;
  157.                    Angle:Real;
  158.                    XTemp:Real;
  159.                    Si,Co:Real;
  160.                Begin
  161.                     Angle:=0.0175*Deg;
  162.                     Si:=Sin(Angle);
  163.                     Co:=Cos(Angle);
  164.                     For A:=1 To Balls Do
  165.                       With S[A] Do
  166.                       Begin
  167.                            XTemp:=X;
  168.                            X:=XTemp*Co-Y*Si;
  169.                            Y:=Y*Co+XTemp*Si;
  170.                       End;
  171.                End;
  172.  
  173.                Procedure Rotate(XRot,YRot,ZRot:Integer);
  174.                Begin
  175.                     RotateX(XRot);
  176.                     RotateY(XRot);
  177.                     RotateZ(XRot);
  178.                End;
  179.  
  180.                Procedure Move(XOff,YOff,ZOff:Integer);
  181.                Begin
  182.                     For A:=1 To Balls Do
  183.                     Begin
  184.                          S[A].X:=S[A].X+XOff;
  185.                          S[A].Y:=S[A].Y+YOff;
  186.                          S[A].Z:=S[A].Z+ZOff;
  187.                     End;
  188.                End;
  189.  
  190.                Begin
  191.                     { Setup program }
  192.                     InitGraph;
  193.                     InitVirt;
  194.                     InitColors;
  195.                     InitObject;
  196.                     Cls(0,VGA);
  197.                     Cls(0,VP[1]);
  198.                     { Main cicle }
  199.                     Repeat
  200.                           { Clear virtual screen }
  201.                           Cls(0,VP[1]);
  202.                           Move(0,0,-256);
  203.                           Rotate(5,-10,10);
  204.                           Move(0,0,256);
  205.                           { Draw balls }
  206.                           DrawBalls(VP[1]);
  207.                           { Copy virtual screen to VGA screen }
  208.                           CopyPage(VP[1],VGA);
  209.                     Until Keypressed;
  210.                     { Shutdown }
  211.                     CloseVirt;
  212.                     Closegraph;
  213.                End.