Making a grayscale version with RC6 that preserve the alpha channel
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!
Code:
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
Re: Making a grayscale version with RC6 that preserve the alpha channel
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.
Re: Making a grayscale version with RC6 that preserve the alpha channel
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:
Code:
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
Re: Making a grayscale version with RC6 that preserve the alpha channel
If you wish to customize the grayscale formula (or for other color transformations) I would do something like this
Code:
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
Re: Making a grayscale version with RC6 that preserve the alpha channel
Thank you for your showing me how to do it!!
2 Attachment(s)
Re: Making a grayscale version with RC6 that preserve the alpha channel
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? :-)
Attachment 192898
Edit: Ok, I found out that it works by difference...
Re: Making a grayscale version with RC6 that preserve the alpha channel
Can you show me how to achieve the same result without the offset?
Re: Making a grayscale version with RC6 that preserve the alpha channel
Quote:
Originally Posted by
tmighty2
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:
Code:
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
