home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / D1 / SPINCUBE.ZIP / CCUBE.PAS < prev   
Pascal/Delphi Source File  |  1995-06-13  |  22KB  |  681 lines
  1. unit Ccube;  { Spinning Cube Component }
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, ExtCtrls, Misc, 
  8.   {$IFDEF DEBUG} Misc,Timer, {$ENDIF} Dialogs;
  9.  
  10. type
  11.   TPoint3d = Record X,Y,Z :Integer; End;
  12.   TCubeDispOpt = (cdoErase,
  13.                   cdoHide,  { Hidden Line Removal? }
  14.                   cdoDblBuf,
  15.                   cdoAuto,
  16.                   cdoFaces,
  17.                   cdoShade,
  18.                   cdoColor);
  19.   TCubeDispOpts = Set of TCubeDispOpt;
  20.   TCubeSpin = class(TPanel)
  21.   private
  22.     { Private declarations }
  23.     Vertices :Array [0..7] of TPoint3d;
  24.     VRotated :Array [0..7] of TPoint3d;
  25.     XForm3d  :Array [0..3,0..3] of Single;
  26.     Perspective :Integer;
  27.     XP :Integer;
  28.     YP :Integer;
  29.     ScaleMe :Integer;  { Scaling up from 1 }
  30.     ZScale :Integer;
  31.     fContinuous :Boolean;
  32.     fSpinInc :Integer;
  33.  
  34.     AngleX :Integer;  { Y/Z Rotation about X }
  35.     AngleY :Integer;  { X/Z Rotation about Y }
  36.     AngleZ :Integer;  { X/Y Rotation about Z }
  37.     fXSpinOn :Boolean;
  38.     fYSpinOn :Boolean;
  39.     fZSpinOn :Boolean;
  40.  
  41.     fOptions :TCubeDispOpts;
  42.     fOnSpin :TNotifyEvent;
  43.  
  44.     HideV  :Integer;  { Hidden vertex }
  45.     LastV  :Integer;  { Last Drawn Vector }
  46.  
  47.     CubeBMP: HBITMAP; { Cache the bitmap for redraw speed }
  48.     BMPCanvas :TCanvas;
  49.     fUpdating :Boolean;  { Updating Controls }
  50.     fTimer :TTimer;
  51.     fForceErase :Boolean;
  52.  
  53.     function Rotate(P:TPoint; Rotation:Integer):TPoint;
  54.     function Rotate2D(P:TPoint; Rotation:Integer):TPoint;
  55.     function Rotate3D(Const P:TPoint3D):TPoint3D;
  56.     function Rotate3D2(Const P:TPoint3D):TPoint3D;
  57.     Procedure XFormBld; { Precompute Transformation Matrix }
  58.     function Rotate3D3(Const P:TPoint3D):TPoint3D;
  59.     function MapPt(Vertex:Integer):TPoint;
  60.     procedure MovetoPt(dc:HDC; P:TPoint);
  61.     procedure LinetoPt(dc:HDC; P:TPoint);
  62.     procedure Connect(dc:HDC; V1,V2:Integer);
  63.     procedure SetSize;
  64.     procedure DrawCube;
  65.     procedure BMPDraw;
  66.     procedure RotateCube;
  67.     procedure DrawEdges(dc:HDC);
  68.     procedure DrawFaces(c:TCanvas);
  69.  
  70.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  71.     procedure WMEnterIdle(var Message: TWMEnterIdle); message WM_ENTERIDLE;
  72.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  73.     procedure TimerElapse(Sender: TObject);
  74.   protected
  75.     { Protected declarations }
  76.     procedure Paint; override;
  77.   public
  78.     { Public declarations }
  79.     Probs :TStrings;
  80.     Constructor Create(AOwner:TComponent); Override;
  81.     Destructor Destroy; Override;
  82.     Procedure SetAngles( AX,AY,AZ :Integer);
  83.     procedure SetXSpin( newValue :Integer);
  84.     procedure SetYSpin( newValue :Integer);
  85.     procedure SetZSpin( newValue :Integer);
  86.     procedure SetOptions( newValue :TCubeDispOpts);
  87.     procedure SetContinuous( newValue:Boolean);
  88.   published
  89.     { Published declarations }
  90.     Property XSpin :Integer Read AngleX Write SetXSpin;
  91.     Property YSpin :Integer Read AngleY Write SetYSpin;
  92.     Property ZSpin :Integer Read AngleZ Write SetZSpin;
  93.  
  94.     Property Options :TCubeDispOpts Read fOptions Write SetOptions;
  95.     Property Continuous :Boolean Read fContinuous Write SetContinuous;
  96.     Property SpinInc :Integer Read fSpinInc Write fSpinInc Default 1;
  97.  
  98.     Property XSpinOn :Boolean Read fXSpinOn Write fXSpinOn Default True;
  99.     Property YSpinOn :Boolean Read fYSpinOn Write fYSpinOn Default True;
  100.     Property ZSpinOn :Boolean Read fZSpinOn Write fZSpinOn Default True;
  101.  
  102.     Property OnSpin :TNotifyEvent Read fOnSpin Write fOnSpin;
  103.   end;
  104.  
  105. procedure Register;
  106.  
  107. implementation
  108.  
  109. procedure Register;
  110. begin
  111.   RegisterComponents('Samples', [TCubeSpin]);
  112. end;
  113.  
  114. { Computing SIN and COS are VERY slow.  Because we do this
  115.   A LOT, and we only work in even degrees we precompute the
  116.   SIN for all 360 degrees (which also saves a degrees -> Radians
  117.   conversion).  This dramatically speeds up processing cube
  118.   Rotations. }
  119.  
  120. Var Sins :Array[0..359] of Single;
  121. Function FastSin(Degrees:Integer):Single;
  122. Begin
  123.   While Degrees < 0 do Inc(Degrees,360);
  124.   While Degrees >= 360 do Dec(Degrees,360);
  125.   Result := Sins[Degrees];
  126. End;
  127. Function FastCos(Degrees:Integer):Single;
  128. Begin
  129.   Result := FastSin(90-Degrees);
  130. End;
  131. Procedure InitSin;
  132. Var Degrees:Integer;
  133. Begin
  134.   For Degrees := 0 to 359 do
  135.       Sins[Degrees] := Sin(Degrees * PI /180);
  136.   {$IFDEF DEBUG}
  137.   Degrees := 0;
  138.   While Degrees <= 360 do Begin
  139.       If ABS(FastCos(Degrees) - Cos(Degrees * PI /180)) > 0.000001 Then
  140.          Raise Exception.Create(
  141.                StrVal(['No match on ',Degrees,': ',FastCos(Degrees),' <> ',Cos(Degrees * PI /180)]));
  142.       Inc(Degrees,5);
  143.   End;
  144.   {$ENDIF}
  145. End;
  146.  
  147. { Take the X,Y, and Z coordinates and return a 3D Point }
  148. Function Point3d(X1,Y1,Z1:Integer):TPoint3d;
  149. Begin
  150.   Result.X := X1;
  151.   Result.Y := Y1;
  152.   Result.Z := Z1;
  153. End;
  154.  
  155. { Compare two (2D) points for equality }
  156. Function ComparePt(A,B:TPoint):Boolean;
  157. Begin
  158.   Result := (A.X = B.X) and (A.Y = B.Y);
  159. End;
  160.  
  161. { Take a 3D Point (vertex #) and map it to the 2D screen }
  162. function TCubeSpin.MapPt(Vertex:Integer):TPoint;
  163. Var NewPt   :TPoint;
  164.     New3DPt :TPoint3D;
  165. Begin
  166.   With VRotated[Vertex] do
  167.     if cdoHide in fOptions Then Begin { Hidden Line Removal? }
  168.        { No Perspective }
  169.        Result.X := X+XP;
  170.        Result.Y := Y+YP;
  171.     End Else Begin { Perspective }
  172.        Result.X := X+XP + X * Z div ZScale;
  173.        Result.Y := Y+YP + Y * Z div ZScale;
  174.      End;
  175. End;
  176.  
  177. { Rotate a point by transforming it from rectangular to polar,
  178.   adjusting the polar angle, and transforming it back.
  179.   This was WAY too slow and was replaced with the
  180.   2D transformation matrix approach below }
  181. function TCubeSpin.Rotate(P:TPoint; Rotation:Integer):TPoint;
  182. Var   D     :Single;
  183.       Angle :Integer;
  184. Begin
  185.   { Compute Polar }
  186.   With P Do Begin
  187.     D   := Sqrt(X*X + Y*Y);
  188.     If Y <> 0 Then
  189.        Angle := Trunc(ArcTan(X/Y) * 180 / PI)
  190.     Else
  191.        If X < 0 Then
  192.           Angle := -90
  193.        Else
  194.           Angle := 90;
  195.     If Y < 0 Then
  196.        Angle := Angle + 180;
  197.   End;
  198.   { Compute New X,Y }
  199.   Angle :=Angle + Rotation;
  200.   Result.X := Trunc(D * FastSin(Angle));
  201.   Result.Y := Trunc(D * FastCos(Angle));
  202. End;
  203.  
  204. { 2D Rotation via transform matrix:
  205.            [ cos A,  sin A, 0 ]  general [ a  b  0 ]
  206.            [ -sin A, cos A, 0 ]          [ c  d  0 ]
  207.            [ 0,      0,     0 ]          [ tx ty 1 ]
  208.    or X' := aX + bY + tx := (cos A)X  + (sin A)Y;
  209.       Y' := cX + dY + ty := (-sin A)X + (cos A)Y;
  210. }
  211. function TCubeSpin.Rotate2D(P:TPoint; Rotation:Integer):TPoint;
  212. Var   sinA, cosA :Single;
  213. Begin
  214.   sinA := FastSin(Rotation);
  215.   cosA := FastCos(Rotation);
  216.   Result.X := Trunc(cosA * P.X  + sinA * P.Y);
  217.   Result.Y := Trunc(-sinA * P.X + cosA * P.Y);
  218. (*  If Not ComparePt(Result, Rotate(P, Rotation)) Then
  219.      Raise Exception.Create(
  220.            StrVal(['No match on ',Rotation,': ',StrPt(P),' -> ',
  221.                        StrPt(Result),' ',
  222.                        StrPt(Rotate(P, Rotation))])); *)
  223. End;
  224.  
  225. { Do a 3D rotate by performing 2D rotates around each axis.
  226.   This is probably much slower than using a 3D transformation
  227.   Matrix, but I've been too lazy to figure out what a three-D
  228.   transformation Matrix would look like. }
  229. function TCubeSpin.Rotate3D(Const P:TPoint3D):TPoint3D;
  230. Var NewPt  :TPoint;
  231. Begin
  232.   Result := P;
  233.   With Result do Begin
  234.     NewPt := Rotate2D(Point(X,Y), AngleZ); { X/Y Rotate about Z }
  235.     X := NewPt.X;  Y := NewPt.Y;
  236.     NewPt := Rotate2D(Point(X,Z), AngleY); { X/Z Rotate about Y }
  237.     X := NewPt.X;  Z := NewPt.Y;
  238.     NewPt := Rotate2D(Point(Y,Z), AngleX); { Y/Z Rotate about X }
  239.     Y := NewPt.X;  Z := NewPt.Y;
  240.   End;
  241. End;
  242.  
  243. { Do a 3D rotate by using a 3D transformation Matrix:
  244.    [ cos Az * cos Ay, sin Az, -sin Ay, 0 ]  general [ a  b  c  0 ]
  245.    [ -sin Az, cos Az * cos Ax, sin Ax, 0 ]          [ d  e  f  0 ]
  246.    [ sin Ay, -sin Ax, cos Ax * cos Ay, 0 ]          [ g  h  i  0 ]
  247.    [ 0,      0,       0,               1 ]          [ tx ty tz 1 ]
  248.    or X' := aX + bY + cZ + tx := (cos Az)(cos Ay)X  + (sin Az)Y - (sin Ay)Z;
  249.       Y' := dX + eY + fZ + ty := (-sin Az)X + (cos Az)(cos Ax)Y + (sin Ax)Z;
  250.       Z' := fX + gY + hZ + ty := (sin Ay)X -(sin Ax)Y + (cos Ax)(cos Ay)Z;
  251.  
  252.  [ cosY*cosZ                 cosY*-sinZ                 -sinY      0  ]
  253.  [ -sinXsinY*cosZ+cosX*sinZ  -sinXsinY*-sinZ+cosX*cosZ  -sinXcosY  0  ]
  254.  [ cosXsinY*cosZ+sinX*sinZ   cosXsinY*-sinZ+sinX*cosZ   cosXcosY   0  ]
  255.  [ 0                         0                          0          1  ]
  256.  
  257. or
  258.  
  259. X' = cosAY*cosAZ*X - cosAY*sinAZ*Y - sinAY*Z
  260. Y' = (-sinAX*sinAY*cosAZ + cosAX*sinAZ)*X + (sinAX*sinAY*sinAZ+cosAX*cosAZ)Y
  261.     - sinAX*cosAY*Z
  262. Z' = (cosAX*sinAY*cosAZ+sinAX*sinAZ)*X + (-cosAX*sinAY*sinAZ+sinAX*cosAZ)Y
  263.     + (cosAX*cosAY)Z
  264. }
  265. function TCubeSpin.Rotate3D2(Const P:TPoint3D):TPoint3D;
  266. Var NewPt  :TPoint3d;
  267.     sinAx, cosAx :Single;
  268.     sinAy, cosAy :Single;
  269.     sinAz, cosAz :Single;
  270. Begin
  271.   sinAx := FastSin(AngleX);  cosAx := FastCos(AngleX);
  272.   sinAy := FastSin(AngleY);  cosAy := FastCos(AngleY);
  273.   sinAz := FastSin(AngleZ);  cosAz := FastCos(AngleZ);
  274.   With P do Begin
  275.     Result.X := Trunc( cosAY*cosAZ*X - cosAY*sinAZ*Y - sinAY*Z);
  276.     Result.Y := Trunc( (-sinAX*sinAY*cosAZ + cosAX*sinAZ)*X
  277.                        + (sinAX*sinAY*sinAZ+cosAX*cosAZ)*Y
  278.                    - sinAX*cosAY*Z);
  279.     Result.Z := Trunc( (cosAX*sinAY*cosAZ+sinAX*sinAZ)*X
  280.                        + (-cosAX*sinAY*sinAZ+sinAX*cosAZ)*Y
  281.                    + (cosAX*cosAY)*Z);
  282.   End;
  283. (*  NewPt := Rotate3d(P);
  284.   If (Abs(NewPt.X-Result.X)>2) or (Abs(NewPt.Y-Result.Y)>2) or (Abs(NewPt.Z-Result.Z)>2) Then
  285.      { Raise Exception.Create( }
  286.      Probs.Add( Format( 'No match on X %3d:%4d ->%4d %4d, Y %3d:%4d ->%4d %4d, Z %3d:%4d ->%4d %4d',
  287.                         [AngleX,P.X,Result.X,NewPt.X,
  288.                          AngleY,P.Y,Result.Y,NewPt.Y,
  289.                          AngleZ,P.Z,Result.Z,NewPt.Z ]));   (**)
  290. End;
  291.  
  292. Procedure TCubeSpin.XformBld; { Build the 3D Transformation Matrix }
  293. Var sinAx, cosAx :Single;
  294.     sinAy, cosAy :Single;
  295.     sinAz, cosAz :Single;
  296. Begin
  297.   sinAx := FastSin(AngleX);  cosAx := FastCos(AngleX);
  298.   sinAy := FastSin(AngleY);  cosAy := FastCos(AngleY);
  299.   sinAz := FastSin(AngleZ);  cosAz := FastCos(AngleZ);
  300.   XForm3d[0,0] := cosAY*cosAZ;       { X' }
  301.   XForm3d[0,1] := - cosAY*sinAZ;
  302.   XForm3d[0,2] := -sinAY;
  303.   XForm3d[1,0] := -sinAX*sinAY*cosAZ + cosAX*sinAZ; { Y' }
  304.   XForm3d[1,1] := sinAX*sinAY*sinAZ+cosAX*cosAZ;
  305.   XForm3d[1,2] := - sinAX*cosAY;
  306.   XForm3d[2,0] := cosAX*sinAY*cosAZ+sinAX*sinAZ; { Z' }
  307.   XForm3d[2,1] := -cosAX*sinAY*sinAZ+sinAX*cosAZ;
  308.   XForm3d[2,2] := cosAX*cosAY;
  309. End;
  310. { Now use it! }
  311. function TCubeSpin.Rotate3D3(Const P:TPoint3D):TPoint3D;
  312. Var NewPt  :TPoint3d;
  313. Begin
  314.   With P do Begin
  315.     Result.X := Trunc( XForm3d[0,0]*X + XForm3D[0,1]*Y + XForm3D[0,2]*Z);
  316.     Result.Y := Trunc( XForm3d[1,0]*X + XForm3D[1,1]*Y + XForm3D[1,2]*Z);
  317.     Result.Z := Trunc( XForm3d[2,0]*X + XForm3D[2,1]*Y + XForm3D[2,2]*Z);
  318.   End;
  319. (*  NewPt := Rotate3d(P);
  320.   If (Abs(NewPt.X-Result.X)>2) or (Abs(NewPt.Y-Result.Y)>2) or (Abs(NewPt.Z-Result.Z)>2) Then
  321.      { Raise Exception.Create( }
  322.      Probs.Add( Format( 'No match on X %3d:%4d ->%4d %4d, Y %3d:%4d ->%4d %4d, Z %3d:%4d ->%4d %4d',
  323.                         [AngleX,P.X,Result.X,NewPt.X,
  324.                          AngleY,P.Y,Result.Y,NewPt.Y,
  325.                          AngleZ,P.Z,Result.Z,NewPt.Z ]));   (**)
  326. End;
  327.  
  328. { Does a GDI moveto using a point instead of X,Y coords }
  329. procedure TCubeSpin.MovetoPt(dc:HDC; P:TPoint);
  330. Begin
  331.   Moveto(dc,P.X,P.Y);
  332. End;
  333.  
  334. { Does a GDI lineto using a point instead of X,Y coords }
  335. procedure TCubeSpin.LinetoPt(dc:HDC; P:TPoint);
  336. Begin
  337.   Lineto(dc,P.X,P.Y);
  338. End;
  339.  
  340. { Draw a line from the last point to this point.
  341.   Also does 3D to 2D mapping and limited hidden
  342.   line removal. }
  343. procedure TCubeSpin.Connect(dc:HDC; V1,V2:Integer);
  344. Begin
  345.   If (cdoHide in fOptions) and ( (V1=HideV) or (V2=HideV) ) Then Exit;
  346.   If V1 <> LastV Then
  347.      MovetoPt(dc, MapPt(V1));
  348.   LineToPt(dc, MapPt(V2));
  349.   LastV := V2;
  350. End;
  351.  
  352. { Windows calls here to ask us to repaint }
  353. procedure TCubeSpin.Paint;
  354. Begin
  355.   if CubeBMP = 0 Then
  356.      CubeBMP := CreateCompatibleBitmap(Canvas.Handle, ClientWidth, ClientHeight);
  357.   { MUST be false if not Double Buffering to avoid endless loop }
  358.   { Must be true for double buffering so we don't get trash! }
  359.   DrawCube;
  360. End;
  361.  
  362. { Rotate the Cube to the correct angles, then
  363.   Check for hidden line removal and process }
  364. procedure TCubeSpin.RotateCube;
  365. Var I   :Integer;
  366. begin
  367.   XFormBld; { Precompute Transformation Matrix }
  368.   For I := Low(Vertices) to High(Vertices) do
  369.       VRotated[I] := Rotate3D3(Vertices[I]);
  370.   if (cdoHide in fOptions) Then Begin  { Find furthest back vector and hide it }
  371.      HideV  := Low(Vertices);
  372.      For I := Low(Vertices)+1 to High(Vertices) do
  373.          If VRotated[HideV].Z > VRotated[I].Z Then
  374.             HideV := I;
  375.   End;
  376. end;
  377.  
  378. { Come here to draw the cube by it's edges }
  379. procedure TCubeSpin.DrawEdges(dc:HDC);
  380. begin
  381.     MovetoPT(dc,MapPt(0));  { Draw the Top }
  382.     LastV  := 0;  { Last Drawn Vector }
  383.     Connect(dc,0,1);
  384.     Connect(dc,1,2);
  385.     Connect(dc,2,3);
  386.     Connect(dc,3,0);
  387.     Connect(dc,4,5);  { Draw the Bottom }
  388.     Connect(dc,5,6);
  389.     Connect(dc,6,7);
  390.     Connect(dc,7,4);
  391.     Connect(dc,4,0);  { Draw the sides }
  392.     Connect(dc,5,1);
  393.     Connect(dc,6,2);
  394.     Connect(dc,7,3);
  395. end;
  396.  
  397. { Come here to draw the cube by it's faces }
  398. procedure TCubeSpin.DrawFaces(C:TCanvas);
  399.   { Computes Color Brightness for a Face }
  400.   Function Intensity(V:Array of Integer):Integer;
  401.   Var  I :Integer;
  402.        MinZ, MaxZ :Integer;
  403.   Begin
  404.     MinZ := Low(V);
  405.     MaxZ := Low(V);
  406.     For I := Low(V)+1 to High(V) do Begin
  407.         If VRotated[V[I]].Z < VRotated[V[MinZ]].Z Then
  408.            MinZ := I;
  409.         If VRotated[V[I]].Z > VRotated[V[MaxZ]].Z Then
  410.            MaxZ := I;
  411.     End;
  412.     { Faces flat to observer get highest value,
  413.       Faces on edge get lowest.  This will actually make
  414.       the back face bright, but who cares since it's never seen.
  415.       }
  416.     Result := Abs(VRotated[V[MinZ]].Z - VRotated[V[MaxZ]].Z);
  417.     { Use LongInt for intermediate calc,
  418.       When descaled, longest distance is 2
  419.     }
  420.     Result := 255 - LongInt(Result) * 64 Div ScaleMe;
  421.     If Result < 0 Then Result := 0;
  422.   End;
  423.   procedure OneFace(V1,V2,V3,V4:Integer);
  424.   Var  I :Integer;
  425.   Begin
  426.     If HideV in [V1,V2,V3,V4] Then Exit; { Hidden }
  427.     if cdoShade in Options Then Begin
  428.        I := Intensity([V1,V2,V3,V4]); { How bright }
  429.        if cdoColor in Options Then
  430.           C.Brush.Color := RGB(I div 2,I div 4,I)
  431.        Else
  432.           C.Brush.Color := RGB(I, I, I);  { Gray Scale }
  433.     End Else Begin
  434.        if cdoColor in Options Then
  435.           C.Brush.Color := RGB(V1*64,V2*64,V3*64)
  436.        Else Begin
  437.           I := (V1 * 64 + V2 * 16 + V3) Mod 256;
  438.           C.Brush.Color := RGB(I, I, I);
  439.        End;
  440.     End;
  441.     {C.Brush.Color := RGB((A SHR 1) and 255, A and 63, -A and 63);}
  442.     C.Polygon([ MapPt(V1), MapPt(V2), MapPt(V3), MapPt(V4) ]);
  443.   End;
  444. begin
  445.     OneFace(0,1,2,3);  { Draw the Top }
  446.     OneFace(4,5,6,7);  { Draw the Bottom }
  447.     OneFace(0,1,5,4);  { Draw the Sides }
  448.     OneFace(1,2,6,5);
  449.     OneFace(2,3,7,6);
  450.     OneFace(3,0,4,7);
  451. end;
  452.  
  453. procedure TCubeSpin.DrawCube;
  454. Var dc  :HDC;
  455.     I   :Integer;
  456. begin
  457.   RotateCube;
  458.   Canvas.Brush.Color := Color;
  459.   if (cdoDblBuf in fOptions) Then
  460.      BMPDraw
  461.   Else
  462.     With Canvas Do Begin
  463.       If fForceErase or (cdoErase in fOptions) Then
  464.          FillRect(ClientRect);
  465.       Pen.Color := clBlack;
  466.       if (cdoFaces in fOptions) Then
  467.          DrawFaces(Canvas)
  468.       Else
  469.          DrawEdges(Canvas.Handle);
  470.     End;
  471.   fForceErase := False;
  472. end;
  473.  
  474. procedure TCubeSpin.BMPDraw;
  475. Var
  476.   ScreenDC, BMPDC: HDC;
  477.   SaveBMP: HBITMAP;
  478.   I :Integer;
  479.   CliRect :TRect;
  480. begin
  481.   CliRect := ClientRect;
  482. {  ScreenDC := pDraw.Canvas.Handle; {GetDC(0); }
  483.   BMPDC    := CreateCompatibleDC(Canvas.Handle);
  484.   try
  485.     SaveBMP  := SelectObject(BMPDC, CubeBMP);
  486.     try
  487.       BMPCanvas.Handle := BMPdc;
  488.       { Clear the contents of the bitmap }
  489.       If fForceErase or (cdoErase in fOptions) Then
  490.          FillRect(BMPdc, CliRect, Canvas.Brush.Handle);
  491.  
  492.     if (cdoFaces in fOptions) Then
  493.        DrawFaces(BMPCanvas)
  494.     Else
  495.        DrawEdges(BMPdc);
  496.  
  497.       { Paint the BMP onto the canvas and release }
  498.       Canvas.CopyRect(CliRect, BMPCanvas, Rect(0,0,ClientWidth,ClientHeight));
  499.     finally
  500.       SelectObject(BMPDC, SaveBMP);
  501.     End;
  502.   Finally
  503.     DeleteDC(BMPDC);
  504.     { ReleaseDC(0, ScreenDC); }
  505.   end;
  506. end;
  507.  
  508. Constructor TCubeSpin.Create(AOwner:TComponent);
  509. Begin
  510.   Inherited Create(AOwner);
  511.   fSpinInc := 5;
  512.   fXSpinOn := True;
  513.   fYSpinOn := False;
  514.   fZSpinOn := True;
  515.   fOptions := [cdoErase, cdoHide, cdoDblBuf, cdoFaces, cdoColor, cdoShade];
  516.   InitSin;
  517.   BMPCanvas := TCanvas.Create;
  518.   Probs := TStringList.Create;
  519.   {SetSize; }
  520. End;
  521.  
  522. Destructor TCubeSpin.Destroy;
  523. begin
  524.   If CubeBMP <> 0 Then
  525.      DeleteObject(CubeBMP);
  526.   BMPCanvas.Free;
  527.   Probs.Free;
  528.   Inherited Destroy;
  529. end;
  530.  
  531. { Builds a cube of the proper size, and allocates a
  532.   bitmap of the correct size for double buffering }
  533. Procedure TCubeSpin.SetSize;
  534. Var I        :Integer;
  535. begin
  536.   Vertices[0] := Point3d(-1,-1,-1);
  537.   Vertices[1] := Point3d(-1, 1,-1);
  538.   Vertices[2] := Point3d( 1, 1,-1);
  539.   Vertices[3] := Point3d( 1,-1,-1);
  540.   Vertices[4] := Point3d(-1,-1, 1);
  541.   Vertices[5] := Point3d(-1, 1, 1);
  542.   Vertices[6] := Point3d( 1, 1, 1);
  543.   Vertices[7] := Point3d( 1,-1, 1);
  544.   If ClientWidth <= ClientHeight Then
  545.      ScaleMe := ClientWidth div 4
  546.   Else
  547.      ScaleMe := ClientHeight div 4;
  548.   For I := 0 to High(Vertices) do
  549.       with Vertices[I] do Begin
  550.            X := X * ScaleMe;
  551.            Y := Y * ScaleMe;
  552.            Z := Z * ScaleMe;
  553.       End;
  554.   Perspective := 8;
  555.   XP := ClientWidth div 2;
  556.   YP := ClientHeight div 2;
  557.   ZScale := ScaleMe * Perspective;  { Downscale Z-Axis values by this }
  558.  
  559.   { Create a bitmap to handle smooth redraws }
  560.   If CubeBMP <> 0 Then
  561.      DeleteObject(CubeBMP);
  562.   If Parent <> Nil Then
  563.      CubeBMP := CreateCompatibleBitmap(Canvas.Handle, ClientWidth, ClientHeight);
  564.   fForceErase := True;
  565. end;
  566.  
  567. Procedure TCubeSpin.SetAngles( AX,AY,AZ :Integer);
  568. Begin
  569.   If (AngleZ = AZ) and (AngleY = AY) and (AngleX = AX) Then
  570.      Exit;
  571.   AngleX := AX MOD 360;
  572.   AngleY := AY MOD 360;
  573.   AngleZ := AZ MOD 360;
  574.   If AngleX < 0 Then Inc(AngleX, 360);
  575.   If AngleY < 0 Then Inc(AngleY, 360);
  576.   If AngleZ < 0 Then Inc(AngleZ, 360);
  577.   Invalidate; { Request a Redraw }
  578.   If Assigned(fOnSpin) Then
  579.      fOnSpin(Self);
  580. end;
  581.  
  582. procedure TCubeSpin.SetXSpin( newValue :Integer);
  583. Begin
  584.   If newValue = AngleX then Exit;
  585.   SetAngles( newValue, AngleY, AngleZ);
  586. End;
  587.  
  588. procedure TCubeSpin.SetYSpin( newValue :Integer);
  589. Begin
  590.   If newValue = AngleY then Exit;
  591.   SetAngles( AngleX, newValue, AngleZ);
  592. End;
  593.  
  594. procedure TCubeSpin.SetZSpin( newValue :Integer);
  595. Begin
  596.   If newValue = AngleZ then Exit;
  597.   SetAngles( AngleX, AngleY, newValue);
  598. End;
  599.  
  600. procedure TCubeSpin.SetOptions( newValue :TCubeDispOpts);
  601. Begin
  602.   if cdoFaces in newValue Then { Faces requires hidden line removal }
  603.      Include(newValue, cdoHide);
  604.   if newValue = fOptions Then Exit;
  605.   fOptions := newValue;
  606.   Invalidate;
  607. End;
  608.  
  609. procedure TCubeSpin.SetContinuous( newValue:Boolean);
  610. Begin
  611.   If newValue = fContinuous then Exit;
  612.   fContinuous := newValue;
  613.   If fContinuous Then Begin
  614.     fTimer := TTimer.Create(Self);
  615.     fTimer.Interval := 1;
  616.     fTimer.OnTimer := TimerElapse;
  617.     fTimer.Enabled := True;
  618.   End Else Begin
  619.     fTimer.Free;
  620.     fTimer := Nil;
  621.   End;
  622. End;
  623.  
  624. { Suppress Windows normal background erasure.
  625.   If we're double buffering, then we always paint the whole
  626.   area, so erasing the background would cause unnecessary
  627.   flicker.
  628.   If we're not double buffering, then we let the normal
  629.   erase occur (which DOES cause flicker), unless the
  630.   user has turned off erasing.
  631. }
  632. procedure TCubeSpin.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  633. Begin
  634. {  if (cdoDblBuf in fOptions) Then }
  635.      Message.Result := 1
  636. {  Else
  637.      Inherited; }
  638. End;
  639.  
  640. procedure TCubeSpin.WMEnterIdle(var Message: TWMEnterIdle);
  641. Var AX,AY,AZ :Integer;
  642. Begin
  643.   If fContinuous Then Begin
  644.      AX := AngleX;
  645.      AY := AngleY;
  646.      AZ := AngleZ;
  647.      If fXSpinOn Then Inc(AX, fSpinInc);
  648.      If fYSpinOn Then Inc(AY, fSpinInc);
  649.      If fZSpinOn Then Inc(AZ, fSpinInc);
  650.      SetAngles( AX, AY, AZ);
  651.   End;
  652. End;
  653.  
  654. { Trap the Windows message requesting our size change,
  655.   let it, then recreate the bitmap drawing buffer,
  656.   resize the cube, and request a redraw }
  657. procedure TCubeSpin.WMSize(var Message: TWMSize);
  658. Begin
  659.   Inherited;
  660.   if Message.SizeType in [SIZE_MAXHIDE,SIZE_MAXSHOW] Then
  661.      Exit;  { Not our window that was resized }
  662.   SetSize;
  663.   Invalidate;
  664. end;
  665.  
  666. procedure TCubeSpin.TimerElapse(Sender: TObject);
  667. Var AX,AY,AZ :Integer;
  668. Begin
  669.   If fContinuous Then Begin
  670.      AX := AngleX;
  671.      AY := AngleY;
  672.      AZ := AngleZ;
  673.      If fXSpinOn Then Inc(AX, fSpinInc);
  674.      If fYSpinOn Then Inc(AY, fSpinInc);
  675.      If fZSpinOn Then Inc(AZ, fSpinInc);
  676.      SetAngles( AX, AY, AZ);
  677.   End;
  678. End;
  679.  
  680. end.
  681.