Making a grayscale version with RC6 that preserve the alpha channel

[tmighty2]

Hello!

I am unable to fix the following problem on my own so far despite like 10 hours of trying it:

There is a very good example of an edge detection algorithm by Olaf Schmidt here:

I was searching for a grayscale function, and I wanted to use the one shown in this project.
The grayscale function in this project discards the alpha channel while I must preserve it in my project.

I tried change to the function to preserve the alpha channel, but I am experiencing an overflow problem.
I am not sure if the math formula is actually correct and it's only a VB6 problem, or if my approach is generally faulty.

I have not been able to fix the overflow problem in the following attempt.
Can somebody help me resolve it?

Thank you!

Public Function Grayscale(SrcSrf As cCairoSurface) As cCairoSurface
Dim x As Long, y As Long, xL As Long, Src() As Byte, Dst() As Byte, DstL() As Long
  
  Static SqrLut(0 To 255, 0 To 255) As Long, LogLut(2 To 130052) As Byte, LLut&(0 To 255)
  If LogLut(130052) = 0 Then 'init the lookup-tables (for squared deltas, logarithmic scaling and 32Bit-GreyValues)
    For y = 0 To 255: For x = 0 To 255: SqrLut(x, y) = (x - y) ^ 2 + 1: Next x, y
    For x = 2 To 130052: LogLut(x) = Log(x) * 23 - 16: Next 'in a normal Roberts, we would use Sqr() instead of Log()
    For x = 0 To 255: LLut(x) = (x + 256 * x + 65536 * x) Or &HFF000000: Next
  End If

  SrcSrf.BindToArray Src
  Set Grayscale = Cairo.CreateSurface(SrcSrf.Width, SrcSrf.Height)
      Grayscale.BindToArray Dst
      Grayscale.BindToArrayLong DstL

        For y = 1 To UBound(Src, 2)
            xL = 1
            For x = 4 To UBound(Src, 1) Step 4
                'Calculate the gray value
                Dim grayValue As Long
                grayValue = LogLut(SqrLut(Src(x, y), Src(x - 4, y - 1)) + _
                SqrLut(Src(x - 4, y), Src(x, y - 1)))
                
                'Put the gray values into the rgb channels
                DstL(xL, y) = (grayValue + 256 * grayValue + 65536 * grayValue) ' grayscale for R, G, B
                
                ' Preserve the alpha value of the source array
                DstL(xL, y) = CDbl(DstL(xL, y)) Or CDbl((Src(x + 3, y))) * CDbl(&H1000000)   ' Alpha value of original source
                
                xL = xL + 1
            Next x
        Next y

 
  SrcSrf.ReleaseArray Src
  Grayscale.ReleaseArray Dst
  Grayscale.ReleaseArrayLong DstL

End Function

[VanGoghGaming]

Wherever you multiply by an integer constant (less than 32768}, add an ampersand after it for implicit conversion to Long. That should take care of your overflow problem.

[Schmidt]

The explicit "greyscale-looping" was only for demonstration-purposes (on "non-alpha-Bitmaps").

There is an easier way to accomplish grey-output of Icon- or Image-Resources via CC-Operators:

Private Sub Form_Load()
  Cairo.ImageList.AddIconFromResourceFile "ico", "shell32", 167
  
  Dim CC As cCairoContext
  Set CC = Cairo.CreateSurface(800, 600).CreateContext
      CC.Paint 1, Cairo.CreateCheckerPattern
      
      CC.RenderSurfaceContent "ico", 10, 10 'first we render the resource with the default-operator (CAIRO_OPERATOR_OVER)
      
      CC.Operator = Cairo_OPERATOR_HSL_LUMINOSITY 'for grey-output one can the switch to the HSL-Luminance-Operator
        CC.RenderSurfaceContent "ico", 100, 10
      CC.Operator = CAIRO_OPERATOR_OVER 'reset the CC to the default-render-operator
      
  Set Picture = CC.Surface.Picture
End Sub

Olaf

[reexre]

If you wish to customize the grayscale formula (or for other color transformations) I would do something like this

Public Function Grayscale(SrcSrf As cCairoSurface) As cCairoSurface
    Dim Y As Long, Src() As Byte, Dst() As Byte
    Dim Gray      As Double
    Dim R#, G#, B#
    Dim X0&, X1&, X2&, X3&
    
    SrcSrf.BindToArray Src
    Set Grayscale = Cairo.CreateSurface(SrcSrf.Width, SrcSrf.Height)
    Grayscale.BindToArray Dst

    For Y = 0 To UBound(Src, 2)
        For X0 = 0 To UBound(Src, 1) Step 4
            X1 = X0 + 1&
            X2 = X0 + 2&
            X3 = X0 + 3&

            R = Src(X2, Y)
            G = Src(X1, Y)
            B = Src(X0, Y)

            '// GRAYSCALE formula Customization: //
            'Gray = (R + G + B) * 0.3333333                'Simple Mean
            'Gray = (0.3 * R + 0.59 * G + 0.11 * B)        'A common formula in image processors
            'https://en.wikipedia.org/wiki/Grayscale#Luma_coding_in_video_systems
             Gray = (0.299 * R + 0.587 * G + 0.114 * B)    '(BT.601)  slightly different [Common/Favorite]
            'Gray = (0.2126 * R + 0.7152 * G + 0.0722 * B) '(BT.709)
            'Gray = (0.2627 * R + 0.6780 * G + 0.0593 * B) '(BT.2100)

            Dst(X2, Y) = Gray 'R
            Dst(X1, Y) = Gray 'G
            Dst(X0, Y) = Gray 'B
            Dst(X3, Y) = Src(X3, Y)     'Alpha (Preserved)

        Next X0
    Next Y

    SrcSrf.ReleaseArray Src
    Grayscale.ReleaseArray Dst

End Function

[tmighty2]

Thank you for your showing me how to do it!!

[tmighty2]

Olaf, thank you. What is happening if the offset is not applied? I tried to render the same image at the same position, and I was not greyscaled but colored instead.
I drew the same image with 1 pixel offset, it was still colored.
Only after I applied an offset of 3 pixels, it started becoming grayscale.
Is that because the function requires some pixels around it to work?
You knew about it and expected me to stumble over it, right? :-)



Edit: Ok, I found out that it works by difference...

[tmighty2]

Can you show me how to achieve the same result without the offset?

[Schmidt]

Can you show me how to achieve the same result without the offset?

If you try to render on "uncleared, non-solid background" and want to render over it,
"masking-out" the target-area with vbWhite beforehand, should help:

Private Sub Form_Load()
  Cairo.ImageList.AddIconFromResourceFile "ico", "shell32", 167
  
  Dim CC As cCairoContext
  Set CC = Cairo.CreateSurface(800, 600).CreateContext
        CC.Paint 1, Cairo.CreateCheckerPattern
      
        CC.RenderSurfaceContent "ico", 10, 10
      
        RenderDisabledIco CC, Cairo.ImageList("ico"), 30, 30

  Set Picture = CC.Surface.Picture
End Sub

Private Sub RenderDisabledIco(CC As cCairoContext, Srf As cCairoSurface, x, y)
      CC.SetSourceColor vbWhite
      CC.MaskSurface Srf, x, y
      CC.Operator = Cairo_OPERATOR_HSL_LUMINOSITY
        CC.RenderSurfaceContent Srf, x, y
      CC.Operator = CAIRO_OPERATOR_OVER
End Sub

Olaf