Binaryworld - RotatePicture - Rotate a 256-color bitmap by any angle (super-optimize ... [ VB -> Graphics ]

' This structure holds Bitmap information
Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

' This structure holds SAFEARRAY info
Private Type SafeArray2
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  cElements1 As Long
  lLbound1 As Long
  cElements2 As Long
  lLbound2 As Long
End Type

' API declares
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As _
  Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal _
  hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

' Rotate a 256-color bitmap by any angle:
' sourcePB is the source PictureBox control (may be hidden)
' destPB is the destination PictureBox control
' XC, YC are the coordinates of the rotation center
' ANGLE is the rotation angle in degrees

' this improved version scans only a portion of the image, and builds
' remaining points using simmetry. This algorithm is particularly efficient
' when the
' center of the rotation is inside the bitmap, the best performances are
' achieved
' when it is near to the center of the bitmap. Moreover, this code saves some
' CPU time by using pre-calculated values for SIN, COS, and SQR functions.

' IMPORTANT: the source and destination PictureBox control must initially
' contain the *same* bitmap, to ensure that size and color palette
' are correctly initialized.

' Example:
'  'Load the same image in both source (hidden) and destination controls
'  Picture1.Picture = LoadPicture("d:\winnt\gone fishing.bmp")
'  Picture2.Picture = LoadPicture("d:\winnt\gone fishing.bmp")
'  ' Rotate by 360°
'  Dim a As Single
'  For a = 0 To 360 Step 5
'    RotatePicture2 Picture1, Picture2, 50, 50, a
'  Next

Private Sub RotatePicture2(sourcePB As PictureBox, destPB As PictureBox, _
  xc As Long, yc As Long, degrees As Single)

  ' all angles are expressed in 1/10000ths of radians
  Const PI As Long = 31416
  Const HALFPI As Long = 15707
  Const DOUBLEPI As Long = 62831

  Const SQRTABLE_MAX As Long = 40000

  Static sinTable() As Single
  Static atnTable() As Long
  Static sqrTable() As Single
  Static initialized As Boolean

  ' these are used to address the pixel using matrices
  Dim pict1() As Byte
  Dim pict2() As Byte
  Dim p1 As SafeArray2, p2 As SafeArray2
  Dim bmp1 As BITMAP, bmp2 As BITMAP
  ' these are used by the rotating algorithm
  Dim radians As Long
  Dim angle As Long
  Dim angle0 As Long
  Dim distance As Single
  Dim distanceSquared As Long
  Dim deltaX As Long, deltaY As Long
  Dim deltaXSquared As Single, deltaX10000 As Long
  Dim x As Long, y As Long
  Dim dx As Long, dy As Long
  Dim x0 As Long, y0 As Long
  Dim xx As Long, yy As Long
  Dim xStart As Long, xEnd As Long
  Dim yStart As Long, yEnd As Long
  Dim bmWidth1 As Long
  Dim bmHeight1 As Long

  ' Initialize sin,cos,sqr tables
  If Not initialized Then
    initialized = True

    Dim i As Long
    ' evaluate a table of sin for 360+90 degrees
    ' with a precision of 1/10000 of a radian
    ' this permits to reuse the same table for cosine, too
    ' since COX(x) = SIN(x + 90°)
    ReDim sinTable(0 To 62831 + 15709) As Single
    For i = 0 To UBound(sinTable)
      sinTable(i) = Sin(i / 10000)
    Next

    ' evaluate a table for Atn(x)*10000 for x=[0,1], with steps of 0,0001
    ReDim atnTable(0 To 10000) As Long
    For i = LBound(atnTable) To UBound(atnTable)
      atnTable(i) = Atn(i / 10000) * 10000#
    Next

    ' evaluate a table for Sqr(i)
    ReDim sqrTable(SQRTABLE_MAX) As Single
    For i = 0 To SQRTABLE_MAX
      sqrTable(i) = Sqr(i)
    Next
  End If

  ' get bitmap info
  GetObjectAPI sourcePB.Picture, Len(bmp1), bmp1
  GetObjectAPI destPB.Picture, Len(bmp2), bmp2

  If bmp1.bmPlanes <> 1 Or bmp1.bmBitsPixel <> 8 Or bmp2.bmPlanes <> 1 Or _
    bmp2.bmBitsPixel <> 8 Then
    MsgBox "This routine supports 256-color bitmaps only", vbCritical
    Exit Sub
  End If

  ' have the local matrices point to bitmap pixels
  With p1
    .cbElements = 1
    .cDims = 2
    .lLbound1 = 0
    .cElements1 = bmp1.bmHeight
    .lLbound2 = 0
    .cElements2 = bmp1.bmWidthBytes
    .pvData = bmp1.bmBits
  End With
  CopyMemory ByVal VarPtrArray(pict1), VarPtr(p1), 4

  With p2
    .cbElements = 1
    .cDims = 2
    .lLbound1 = 0
    .cElements1 = bmp2.bmHeight
    .lLbound2 = 0
    .cElements2 = bmp2.bmWidthBytes
    .pvData = bmp2.bmBits
  End With
  CopyMemory ByVal VarPtrArray(pict2), VarPtr(p2), 4

  ' convert the angle into 1/10000ths of radians
  ' subtracting 628310000 ensure that when radians is used in the
  ' subtraction in the loop, it produces a positive number
  radians = degrees / (180 / 3.14159) * 10000& - 628310000

  ' we have several cases, depending on where XC falls
  ' compared to the center of the image
  If xc < bmp2.bmWidth \ 2 Then
    xStart = xc
    xEnd = bmp2.bmWidth - 1
  Else
    xStart = 0
    xEnd = xc
  End If

  If yc < bmp2.bmHeight \ 2 Then
    yStart = yc
    yEnd = bmp2.bmWidth - 1
  Else
    yStart = 0
    yEnd = yc
  End If

  ' the main loop of this routine scans a squared portion
  ' of the image whose corners falls on the rotation center
  ' Of the four squares that touch the rotation center, here
  ' we choose the one with the highest number of pixels
  ' withing the image

  If xEnd - xStart > yEnd - yStart Then
    If yStart = 0 Then
      yStart = yEnd - (xEnd - xStart)
    Else
      yEnd = yStart + (xEnd - xStart)
    End If
  Else
    If xStart = 0 Then
      xStart = xEnd - (yEnd - yStart)
    Else
      xEnd = xStart + (yEnd - yStart)
    End If
  End If

  bmWidth1 = bmp1.bmWidth
  bmHeight1 = bmp1.bmHeight

  ' rotate the picture

  For x = xStart To xEnd
    ' these values are loop invariant for the following For-Next
    deltaX = x - xc
    deltaXSquared = deltaX * deltaX
    deltaX10000 = deltaX * 10000

    For y = yStart To yEnd
      deltaY = y - yc

      ' evaluate the arc-tangent of (deltaY/deltaX)
      ' many IFs are required, since the atnTable() array only
      ' covers the range [0,1] - if (deltaY/deltaX) is > 1 we
      ' must use its reciprocal deltaX/deltaY
      If deltaX > 0 Then
        If deltaY >= 0 Then
          If deltaY < deltaX Then
            angle = atnTable((deltaY * 10000) \ deltaX)
          Else
            angle = HALFPI - atnTable(deltaX10000 \ deltaY)
          End If
        Else
          If -deltaY < deltaX Then
            angle = -atnTable((deltaY * -10000) \ deltaX)
          Else
            angle = -HALFPI + atnTable(-deltaX10000 \ deltaY)
          End If
        End If
      ElseIf deltaX < 0 Then
        If deltaY > 0 Then
          If deltaY < -deltaX Then
            angle = PI - atnTable((deltaY * -10000) \ deltaX)
          Else
            angle = HALFPI + atnTable(-deltaX10000 \ deltaY)
          End If
        Else
          If deltaY > deltaX Then
            angle = PI + atnTable((deltaY * 10000) \ deltaX)
          Else
            angle = -HALFPI - atnTable(deltaX10000 \ deltaY)
          End If
        End If
      Else
        If deltaY >= 0 Then
          angle = HALFPI
        Else
          angle = -HALFPI
        End If
      End If
      ' --- end of arc-tangent evaluation

      ' "angle" is the angle of the segment that goes from
      ' the center to (x,y) - since we wish to evaluate the
      ' color of this point, we must check the point in the
      ' original bitmap that has the same distance from the
      ' center but with a different angle

      ' evaluate the distance of (x,y) from the rotation
      ' center, using if possible the value already stored
      ' in sqrTable()
      distanceSquared = deltaXSquared + deltaY * deltaY
      If distanceSquared <= SQRTABLE_MAX Then
        distance = sqrTable(distanceSquared)
      Else
        distance = Sqr(distanceSquared)
      End If

      ' the old point in the original bitmap has same
      ' distance but a different angle
      angle0 = (angle - radians) Mod DOUBLEPI

      ' evaluate the x,y offset of the old point from
      ' the rotation center
      dx = distance * sinTable(angle0 + HALFPI) ' really cosine
      dy = distance * sinTable(angle0)

      ' if (x,y) falls within the image
      If x >= 0 And x < bmWidth1 And y >= 0 And y < bmHeight1 Then
        ' (x0,y0) is the corresponding point in the original bitmap
        x0 = xc + dx
        y0 = yc + dy
        ' if (x0,y0) falls within the bitmap boundaries, copy the pixel
        ' else, set the (x,y) pixel to zero (background color)
        If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
          pict2(x, y) = pict1(x0, y0)
        Else
          pict2(x, y) = 0
        End If

        ' this is the point simmetrical to the rotation center - this
        ' block is within the outer If clause because the simmetrical
        ' point can be within the bitmap only if (x,y) was within the
        ' bitmap too
        xx = xc - deltaX
        yy = yc - deltaY
        If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
          x0 = xc - dx
          y0 = yc - dy
          If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 _
            Then
            pict2(xx, yy) = pict1(x0, y0)
          Else
            pict2(xx, yy) = 0
          End If
        End If

      End If

      ' now deal with the pixel 90° ahead of the one in (x,y)
      xx = xc + deltaY
      yy = yc - deltaX
      If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
        x0 = xc + dy
        y0 = yc - dx
        If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
          pict2(xx, yy) = pict1(x0, y0)
        Else
          pict2(xx, yy) = 0
        End If
      End If

      ' now deal with the pixel 270° ahead of the one in (x,y)
      xx = xc - deltaY
      yy = yc + deltaX
      If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
        x0 = xc - dy
        y0 = yc + dx
        If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
          pict2(xx, yy) = pict1(x0, y0)
        Else
          pict2(xx, yy) = 0
        End If
      End If
    Next
  Next

  ' release arrays
  CopyMemory ByVal VarPtrArray(pict1), 0&, 4
  CopyMemory ByVal VarPtrArray(pict2), 0&, 4

  ' show the rotated bitmap
  destPB.Refresh

End Sub

' Support routine

Private Function VarPtrArray(arr As Variant) As Long
  CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4
End Function