unit ThreeD;

interface

  Uses
    Graphics, Types;

  Procedure Cylinder(Canvas : TCanvas;
                     Rect : TRect;
                     Color : TColor;
                     Vertical : Boolean;
                     Strength : Double = 1.0);

  // The wide part is always the bottom or the left.
  Procedure Cone(Canvas : TCanvas; Rect : TRect; Color : TColor; Vertical : Boolean);


implementation

  Uses
    Gradient, ColorTools;

  Const
    ReflectBrightness = 0.25;
    ShadowDarkness = 0.25;

  Function Whiter(Color : Word; By : Double = ReflectBrightness) : Word;
    Begin
      Result := Round($ff00 - (($ff00 - Color) * (1 - By)))
    End;

  Function Blacker(Color : Word; By : Double = ShadowDarkness) : Word;
    Begin
      Result := Round(Color * (1 - By))
    End;

  Procedure Cylinder(Canvas : TCanvas; Rect : TRect; Color : TColor; Vertical : Boolean; Strength : Double);
    Var
      Vert : TTriVertexArray;
      Mesh : TGradientRectArray;
      Colors : TSplitColor;
      Red, Blue, Green : Word;
      Left, Width, Top, Height : Integer;
      ReflectBy, DarkenBy : Double;
    Begin
      ReflectBy := ReflectBrightness * Strength;
      DarkenBy := ShadowDarkness * Strength;
      If Rect.Top <= Rect.Bottom Then
        Begin
          Top := Rect.Top;
          Height := Rect.Bottom - Rect.Top
        End
      Else
        Begin
          Top := Rect.Bottom;
          Height := Rect.Top - Rect.Bottom
        End;
      If Rect.Left <= Rect.Right Then
        Begin
          Left := Rect.Left;
          Width := Rect.Right - Rect.Left
        End
      Else
        Begin
          Left := Rect.Right;
          Width := Rect.Left - Rect.Right
        End;
      Colors.Color := ColorToRGB(Color);
      Red := Colors.Bytes[cbRed] * 256;
      Green := Colors.Bytes[cbGreen] * 256;
      Blue := Colors.Bytes[cbBlue] * 256;
      SetLength(Vert, 6);
      Vert[0].Red := Red;
      Vert[0].Green := Green;
      Vert[0].Blue := Blue;
      Vert[1].Red := Whiter(Red, ReflectBy);
      Vert[1].Green := Whiter(Green, ReflectBy);
      Vert[1].Blue := Whiter(Blue, ReflectBy);
      Vert[2] := Vert[1];
      Vert[3] := Vert[0];
      Vert[4] := Vert[3];
      Vert[5].Red := Blacker(Red, DarkenBy);
      Vert[5].Green := Blacker(Green, DarkenBy);
      Vert[5].Blue := Blacker(Blue, DarkenBy);
      Vert[0].X := Left;
      Vert[0].Y := Top;
      If Vertical Then
        Begin
          Vert[1].X := Left + Width Div 4;
          Vert[1].Y := Top + Height;
          Vert[2].X := Left + Width Div 4;
          Vert[2].Y := Top;
          Vert[3].X := Left + Width Div 2;
          Vert[3].Y := Top + Height;
          Vert[4].X := Left + Width Div 2;
          Vert[4].Y := Top
        End
      Else
        Begin
          Vert[1].X := Left + Width;
          Vert[1].Y := Top + Height Div 4;
          Vert[2].X := Left;
          Vert[2].Y := Top + Height Div 4;
          Vert[3].X := Left + Width;
          Vert[3].Y := Top + Height Div 2;
          Vert[4].X := Left;
          Vert[4].Y := Top + Height Div 2
        End;
      Vert[5].X := Left + Width;
      Vert[5].Y := Top + Height;
      // I should be able to use one combined mesh and one call to
      // GradientFill.  That works for the horizontal cylinders, but not the
      // vertical ones!  I don't know why not.
      SetLength(Mesh, 1);
      Mesh[0].UpperLeft := 0;
      Mesh[0].LowerRight := 1;
      GradientFill(Canvas.Handle, Vert, Mesh, Not Vertical);
      Mesh[0].UpperLeft := 2;
      Mesh[0].LowerRight := 3;
      GradientFill(Canvas.Handle, Vert, Mesh, Not Vertical);
      Mesh[0].UpperLeft := 4;
      Mesh[0].LowerRight := 5;
      GradientFill(Canvas.Handle, Vert, Mesh, Not Vertical)
    End;

  Procedure Cone(Canvas : TCanvas; Rect : TRect; Color : TColor; Vertical : Boolean);
    Procedure Swap(Var A, B : Integer);
      Var
        C : Integer;
      Begin
        C := A;
        A := B;
        B := C
      End;
    Procedure VerticalLineBase;
      Var
        BaseRect : TRect;
      Begin
        BaseRect.Top := Succ(Rect.Top);
        BaseRect.Left := Rect.Left;
        BaseRect.Bottom := Rect.Bottom;
        BaseRect.Right := Rect.Left+1;
        Cylinder(Canvas, BaseRect, Color, False)
      End;
    Var
      Vert : TTriVertexArray;
      Mesh : TGradientTriangleArray;
      Colors : TSplitColor;
      Red, Blue, Green : Word;
      DrawPoint, DrawBase : Boolean;
    Begin
      If (Rect.Left = Rect.Right) Or (Rect.Top = Rect.Bottom) Then
        Exit;
      DrawPoint := False;
      DrawBase := False;
      Colors.Color := ColorToRGB(Color);
      Red := Colors.Bytes[cbRed] * 256;
      Green := Colors.Bytes[cbGreen] * 256;
      Blue := Colors.Bytes[cbBlue] * 256;
      SetLength(Vert, 5);
      SetLength(Mesh, 3);
      Vert[0].Red := Red;
      Vert[0].Green := Green;
      Vert[0].Blue := Blue;
      Vert[1].Red := Whiter(Red);
      Vert[1].Green := Whiter(Green);
      Vert[1].Blue := Whiter(Blue);
      Vert[2] := Vert[1];
      Vert[3] := Vert[0];
      Vert[4].Red := Blacker(Red);
      Vert[4].Green := Blacker(Green);
      Vert[4].Blue := Blacker(Blue);
      If Vertical Then
        Begin
          If Rect.Left > Rect.Right Then
            Swap(Rect.Left, Rect.Right);
          Dec(Rect.Left);
          If Rect.Top < Rect.Bottom Then
            Dec(Rect.Top);
          Vert[0].X := Rect.Left;
          Vert[0].Y := Rect.Bottom;
          Vert[1].X := (Rect.Left + Rect.Right + 1) Div 2;
          Vert[1].Y := Rect.Top;
          Vert[2].X := (Rect.Left * 3 + Rect.Right + 2) Div 4;
          Vert[2].Y := Rect.Bottom;
          Vert[3].X := Vert[1].X;
          Vert[3].Y := Rect.Bottom;
          Vert[4].X := Rect.Right;
          Vert[4].Y := Rect.Bottom;
          //  Canvas.Pixels[Vert[1].X, Vert[1].Y] := ColorTools.Whiter(Color, ReflectBrightness)
        End
      Else
        Begin
          If Rect.Top > Rect.Bottom Then
            Swap(Rect.Top, Rect.Bottom);
          If Rect.Right + 1 = Rect.Left Then
            Swap(Rect.Right, Rect.Left);
          If Rect.Left < Rect.Right Then
            Begin
              { Pointing right }
              If (Rect.Right - Rect.Left) > 1 Then
                Begin
                  Dec(Rect.Right);
                  DrawPoint := True
                End
            End
          Else
            Begin
              { Pointing left }
              If (Rect.Left - Rect.Right) > 1 Then
                Begin
                  Dec(Rect.Left);
                  DrawBase := True
                End
            End;
          Dec(Rect.Top);
          Vert[0].X := Rect.Left;
          Vert[0].Y := Rect.Top;
          Vert[1].X := Rect.Right;
          Vert[1].Y := (Rect.Top + Rect.Bottom + 1) Div 2;
          Vert[2].X := Rect.Left;
          Vert[2].Y := (Rect.Top * 3 + Rect.Bottom + 2) Div 4;
          Vert[3].X := Rect.Left;
          Vert[3].Y := Vert[1].Y;
          Vert[4].X := Rect.Left;
          Vert[4].Y := Rect.Bottom;
          If DrawPoint Then
            Canvas.Pixels[Vert[1].X, Vert[1].Y] := ColorTools.Whiter(Color, ReflectBrightness)
          Else If DrawBase Then
            VerticalLineBase
        End;
      Mesh[0].Vertex1 := 0;
      Mesh[0].Vertex2 := 1;
      Mesh[0].Vertex3 := 2;
      Mesh[1].Vertex1 := 2;
      Mesh[1].Vertex2 := 1;
      Mesh[1].Vertex3 := 3;
      Mesh[2].Vertex1 := 3;
      Mesh[2].Vertex2 := 1;
      Mesh[2].Vertex3 := 4;
      GradientFill(Canvas.Handle, Vert, Mesh)
    End;

End.