ccube.pas

Delphi实效编程百例的随书源代码 这是其中的操作系统部分

  Begin
    MinZ := Low(V);
    MaxZ := Low(V);
    For I := Low(V)+1 to High(V) do Begin
        If VRotated[V[I]].Z < VRotated[V[MinZ]].Z Then
           MinZ := I;
        If VRotated[V[I]].Z > VRotated[V[MaxZ]].Z Then
           MaxZ := I;
    End;
    { Faces flat to observer get highest value,
      Faces on edge get lowest.  This will actually make
      the back face bright, but who cares since it's never seen.
      }
    Result := Abs(VRotated[V[MinZ]].Z - VRotated[V[MaxZ]].Z);
    { Use LongInt for intermediate calc,
      When descaled, longest distance is 2
    }
    Result := 255 - LongInt(Result) * 64 Div ScaleMe;
    If Result < 0 Then Result := 0;
  End;
  procedure OneFace(V1,V2,V3,V4:Integer);
  Var  I :Integer;
  Begin
    If HideV in [V1,V2,V3,V4] Then Exit; { Hidden }
    if cdoShade in Options Then Begin
       I := Intensity([V1,V2,V3,V4]); { How bright }
       if cdoColor in Options Then
          C.Brush.Color := RGB(I div 2,I div 4,I)
       Else
          C.Brush.Color := RGB(I, I, I);  { Gray Scale }
    End Else Begin
       if cdoColor in Options Then
          C.Brush.Color := RGB(V1*64,V2*64,V3*64)
       Else Begin
          I := (V1 * 64 + V2 * 16 + V3) Mod 256;
          C.Brush.Color := RGB(I, I, I);
       End;
    End;
    {C.Brush.Color := RGB((A SHR 1) and 255, A and 63, -A and 63);}
    C.Polygon([ MapPt(V1), MapPt(V2), MapPt(V3), MapPt(V4) ]);
  End;
begin
    OneFace(0,1,2,3);  { Draw the Top }
    OneFace(4,5,6,7);  { Draw the Bottom }
    OneFace(0,1,5,4);  { Draw the Sides }
    OneFace(1,2,6,5);
    OneFace(2,3,7,6);
    OneFace(3,0,4,7);
end;

procedure TCubeSpin.DrawCube;

begin
  RotateCube;
  Canvas.Brush.Color := Color;
  if (cdoDblBuf in fOptions) Then
     BMPDraw
  Else
    With Canvas Do Begin
      If fForceErase or (cdoErase in fOptions) Then
         FillRect(ClientRect);
      Pen.Color := clBlack;
      if (cdoFaces in fOptions) Then
         DrawFaces(Canvas)
      Else
         DrawEdges(Canvas.Handle);
    End;
  fForceErase := False;
end;

procedure TCubeSpin.BMPDraw;
Var
  BMPDC: HDC;
  SaveBMP: HBITMAP;
  CliRect :TRect;
begin
  CliRect := ClientRect;
{  ScreenDC := pDraw.Canvas.Handle; {GetDC(0); }
  BMPDC    := CreateCompatibleDC(Canvas.Handle);
  try
    SaveBMP  := SelectObject(BMPDC, CubeBMP);
    try
      BMPCanvas.Handle := BMPdc;
      { Clear the contents of the bitmap }
      If fForceErase or (cdoErase in fOptions) Then
         FillRect(BMPdc, CliRect, Canvas.Brush.Handle);

    if (cdoFaces in fOptions) Then
       DrawFaces(BMPCanvas)
    Else
       DrawEdges(BMPdc);

      { Paint the BMP onto the canvas and release }
      Canvas.CopyRect(CliRect, BMPCanvas, Rect(0,0,ClientWidth,ClientHeight));
    finally
      SelectObject(BMPDC, SaveBMP);
    End;
  Finally
    DeleteDC(BMPDC);
    { ReleaseDC(0, ScreenDC); }
  end;
end;

Constructor TCubeSpin.Create(AOwner:TComponent);
Begin
  Inherited Create(AOwner);
  fSpinInc := 1;
  fXSpinOn := True;
  fYSpinOn := False;
  fZSpinOn := True;
  fOptions := [cdoErase, cdoHide, cdoDblBuf, cdoFaces, cdoColor, cdoShade];
  InitSin;
  BMPCanvas := TCanvas.Create;
  Probs := TStringList.Create;
  {SetSize; }
End;

Destructor TCubeSpin.Destroy;
begin
  If CubeBMP <> 0 Then
     DeleteObject(CubeBMP);
  BMPCanvas.Free;
  Probs.Free;
  Inherited Destroy;
end;

{ Builds a cube of the proper size, and allocates a
  bitmap of the correct size for double buffering }
Procedure TCubeSpin.SetSize;
Var I        :Integer;
begin
  Vertices[0] := Point3d(-1,-1,-1);
  Vertices[1] := Point3d(-1, 1,-1);
  Vertices[2] := Point3d( 1, 1,-1);
  Vertices[3] := Point3d( 1,-1,-1);
  Vertices[4] := Point3d(-1,-1, 1);
  Vertices[5] := Point3d(-1, 1, 1);
  Vertices[6] := Point3d( 1, 1, 1);
  Vertices[7] := Point3d( 1,-1, 1);
  If ClientWidth <= ClientHeight Then
     ScaleMe := ClientWidth div 4
  Else
     ScaleMe := ClientHeight div 4;
  For I := 0 to High(Vertices) do
      with Vertices[I] do Begin
           X := X * ScaleMe;
           Y := Y * ScaleMe;
           Z := Z * ScaleMe;
      End;
  Perspective := 8;
  XP := ClientWidth div 2;
  YP := ClientHeight div 2;
  ZScale := ScaleMe * Perspective;  { Downscale Z-Axis values by this }

  { Create a bitmap to handle smooth redraws }
  If CubeBMP <> 0 Then
     DeleteObject(CubeBMP);
  If Parent <> Nil Then
     CubeBMP := CreateCompatibleBitmap(Canvas.Handle, ClientWidth, ClientHeight);
  fForceErase := True;
end;

Procedure TCubeSpin.SetAngles( AX,AY,AZ :Integer);
Begin
  If (AngleZ = AZ) and (AngleY = AY) and (AngleX = AX) Then
     Exit;
  AngleX := AX MOD 360;
  AngleY := AY MOD 360;
  AngleZ := AZ MOD 360;
  If AngleX < 0 Then Inc(AngleX, 360);
  If AngleY < 0 Then Inc(AngleY, 360);
  If AngleZ < 0 Then Inc(AngleZ, 360);
  Invalidate; { Request a Redraw }
  If Assigned(fOnSpin) Then
     fOnSpin(Self);
end;

procedure TCubeSpin.SetXSpin( newValue :Integer);
Begin
  If newValue = AngleX then Exit;
  SetAngles( newValue, AngleY, AngleZ);
End;

procedure TCubeSpin.SetYSpin( newValue :Integer);
Begin
  If newValue = AngleY then Exit;
  SetAngles( AngleX, newValue, AngleZ);
End;

procedure TCubeSpin.SetZSpin( newValue :Integer);
Begin
  If newValue = AngleZ then Exit;
  SetAngles( AngleX, AngleY, newValue);
End;

procedure TCubeSpin.SetOptions( newValue :TCubeDispOpts);
Begin
  if cdoFaces in newValue Then { Faces requires hidden line removal }
     Include(newValue, cdoHide);
  if newValue = fOptions Then Exit;
  fOptions := newValue;
  Invalidate;
End;

procedure TCubeSpin.SetContinuous( newValue:Boolean);
Begin
  If newValue = fContinuous then Exit;
  fContinuous := newValue;
  If fContinuous Then Begin
    fTimer := TTimer.Create(Self);
    fTimer.Interval := 20;
    fTimer.OnTimer := TimerElapse;
    fTimer.Enabled := True;
  End Else Begin
    fTimer.Free;
    fTimer := Nil;
  End;
End;

{ Suppress Windows normal background erasure.
  If we're double buffering, then we always paint the whole
  area, so erasing the background would cause unnecessary
  flicker.
  If we're not double buffering, then we let the normal
  erase occur (which DOES cause flicker), unless the
  user has turned off erasing.
}
procedure TCubeSpin.WMEraseBkgnd(var Message: TWMEraseBkgnd);
Begin
{  if (cdoDblBuf in fOptions) Then }
     Message.Result := 1
{  Else
     Inherited; }
End;

procedure TCubeSpin.WMEnterIdle(var Message: TWMEnterIdle);
Var AX,AY,AZ :Integer;
Begin
  If fContinuous Then Begin
     AX := AngleX;
     AY := AngleY;
     AZ := AngleZ;
     If fXSpinOn Then Inc(AX, fSpinInc);
     If fYSpinOn Then Inc(AY, fSpinInc);
     If fZSpinOn Then Inc(AZ, fSpinInc);
     SetAngles( AX, AY, AZ);
  End;
End;

{ Trap the Windows message requesting our size change,
  let it, then recreate the bitmap drawing buffer,
  resize the cube, and request a redraw }
procedure TCubeSpin.WMSize(var Message: TWMSize);
Begin
  Inherited;
  if Message.SizeType in [SIZE_MAXHIDE,SIZE_MAXSHOW] Then
     Exit;  { Not our window that was resized }
  SetSize;
  Invalidate;
end;

procedure TCubeSpin.TimerElapse(Sender: TObject);
Var AX,AY,AZ :Integer;
Begin
  If fContinuous Then Begin
     AX := AngleX;
     AY := AngleY;
     AZ := AngleZ;
     If fXSpinOn Then Inc(AX, fSpinInc);
     If fYSpinOn Then Inc(AY, fSpinInc);
     If fZSpinOn Then Inc(AZ, fSpinInc);
     SetAngles( AX, AY, AZ);
  End;
End;

end.