3 Concepts, same Result

Source-code only - please, don't post questions here.
MrSwiss
Posts: 2679
Joined: Jun 02, 2013 9:27
Location: Switzerland

3 Concepts, same Result

Postby MrSwiss » Jul 21, 2018 13:45

While it sometimes appears, that there is a *established*, *best* solution to a particular
problem, there may be other *more favorable* solutions, in a differing context.

In below code snippets, the Union solution appears to be somewhat clumsy, on its own.
However, in the context of a library (where the Union is external to procedures) it may
be the best solution.
Similar, to the pointer method, in cases where only one channel is needed (but could
also be done, by a simple #Define ... depending on context).
Last but not least, the Macro method which may look familiar to those, having roots in
assembly programming (shifting & masking), which is probably fastest, on its own.

All 3 of them are capable of being made reversible, however some might need additio-
nal temp. variables (namely the pointer method). The first code (with demo) shows
the Getter's, while the second (without demo), shows the Setter's (inverted process).

[edit] new title, to better reflect the main purpose [/edit]

first:

Code: Select all

' 3-Methods_sameResult.bas -- 2018-07-20, by MrSwiss
'
' compile: -s console
'

Sub Get_ChanU( _                        ' get individual channels from color32 (ULong)
    ByVal clr   As ULong, _             ' color to be split into channels (input)
    ByRef a     As UByte = 0, _         ' alpha-channel (return)
    ByRef r     As UByte = 0, _         ' red-channel (return)
    ByRef g     As UByte = 0, _         ' green-channel (return)
    ByRef b     As UByte = 0 _          ' blue-channel (return)
    )
    Union cl_                           ' define the union itself
        As ULong    c
        Type
            As UByte b, g, r, a         ' LSB to MSB (little endian)
        End Type
    End Union
    ' below: use of the union
    Dim As cl_  ret                     ' define one instance of union
    ret.c = clr                         ' load it with input color
    a = ret.a                           ' get & assign results ...
    r = ret.r
    g = ret.g
    b = ret.b
End Sub

Sub Get_ChanP( _                        ' get individual channels from color32 (ULong)
    ByVal clr   As ULong, _             ' color to be split into channels (input)
    ByRef a     As UByte = 0, _         ' alpha-channel (return)
    ByRef r     As UByte = 0, _         ' red-channel (return)
    ByRef g     As UByte = 0, _         ' green-channel (return)
    ByRef b     As UByte = 0 _          ' blue-channel (return)
    )
    a = CPtr(UByte Ptr, @clr)[3]        ' MSB
    r = CPtr(UByte Ptr, @clr)[2]
    g = CPtr(UByte Ptr, @clr)[1]
    b = CPtr(UByte Ptr, @clr)[0]        ' LSB
End Sub

Sub Get_ChanM( _                        ' get individual channels from color32 (ULong)
    ByVal clr   As ULong, _             ' color to be split into channels (input)
    ByRef a     As UByte = 0, _         ' alpha-channel (return)
    ByRef r     As UByte = 0, _         ' red-channel (return)
    ByRef g     As UByte = 0, _         ' green-channel (return)
    ByRef b     As UByte = 0 _          ' blue-channel (return)
    )
    a = clr Shr 24 And 255              ' MSB   (255 = &hFF = &b11111111)
    r = clr Shr 16 And 255
    g = clr Shr  8 And 255
    b = clr And 255                     ' LSB
End Sub


Const As ULong  red = &hFFFF0000, green = &h7F00FF00, blue = &h3F0000FF
' variables used ...
Dim As UByte    ac = 0, rc = 0, gc = 0, bc = 0
Dim As String   sa(1 To 6) => { "color in HEX:  ", "alpha-channel: ", _
                                "red-channel:   ", "green-channel: ", _
                                "blue-channel:  ", "  aarrggbb" }

'Get_ChanM(red, ac, rc, gc, bc)          ' macro method (ASM like: shift & mask)
'Get_ChanP(red, ac, rc, gc, bc)          ' pointer casting method
Get_ChanU(red, ac, rc, gc, bc)          ' union method
Print sa(1); Hex(red, 8); sa(6)
Print sa(2); ac; ", "; Hex(ac, 2)
Print sa(3); rc; ", "; Hex(rc, 2)
Print sa(4); gc; ", "; Hex(gc, 2)
Print sa(5); bc; ", "; Hex(bc, 2)
Print
ac = 0 : rc = 0 : gc = 0 : bc = 0       ' reset channel-UByte's

'Get_ChanM(green, ac, rc, gc, bc)
Get_ChanP(green, ac, rc, gc, bc)
'Get_ChanU(green, ac, rc, gc, bc)
Print sa(1); Hex(green, 8); sa(6)
Print sa(2); ac; ", "; Hex(ac, 2)
Print sa(3); rc; ", "; Hex(rc, 2)
Print sa(4); gc; ", "; Hex(gc, 2)
Print sa(5); bc; ", "; Hex(bc, 2)
Print
ac = 0 : rc = 0 : gc = 0 : bc = 0

Get_ChanM(blue, ac, rc, gc, bc)
'Get_ChanP(blue, ac, rc, gc, bc)
'Get_ChanU(blue, ac, rc, gc, bc)
Print sa(1); Hex(blue, 8); sa(6)
Print sa(2); ac; ", "; Hex(ac, 2)
Print sa(3); rc; ", "; Hex(rc, 2)
Print sa(4); gc; ", "; Hex(gc, 2)
Print sa(5); bc; ", "; Hex(bc, 2)
Print

Erase(sa)                               ' destroy string array

Sleep

second:

Code: Select all

' 3-Methods_sameResult_2.bas -- 2018-07-21, by MrSwiss
'
' compile: -s console
'

Function Set_ChanU( _                   ' set individual channels to color32 (ULong)
    ByVal a     As UByte = 255, _       ' alpha-channel (input), default = opaque
    ByVal r     As UByte = 0, _         ' red-channel (input)
    ByVal g     As UByte = 0, _         ' green-channel (input)
    ByVal b     As UByte = 0 _          ' blue-channel (input)
    ) As ULong                          ' assembled 32bit color
    Union cl_                           ' define the union itself
        As ULong    c
        Type
            As UByte b, g, r, a         ' LSB to MSB (little endian)
        End Type
    End Union
    ' below: use of the union
    Dim As cl_  ret                     ' define one instance of union
    ret.a = a
    ret.r = r
    ret.g = g
    ret.b = b
    Return ret.c
End Function

Function Set_ChanP( _                   ' set individual channels to color32 (ULong)
    ByVal a     As UByte = 255, _       ' alpha-channel (input), default = opaque
    ByVal r     As UByte = 0, _         ' red-channel (input)
    ByVal g     As UByte = 0, _         ' green-channel (input)
    ByVal b     As UByte = 0 _          ' blue-channel (input)
    ) As ULong                          ' assembled 32bit color
    Dim As ULong    clr                 ' temp. variable needed!
    CPtr(UByte Ptr, @clr)[3] = a        ' MSB
    CPtr(UByte Ptr, @clr)[2] = r
    CPtr(UByte Ptr, @clr)[1] = g
    CPtr(UByte Ptr, @clr)[0] = b        ' LSB
    Return clr
End Function

Function Set_ChanM( _                   ' set individual channels to color32 (ULong)
    ByVal a     As UByte = 255, _       ' alpha-channel (input), default = opaque
    ByVal r     As UByte = 0, _         ' red-channel (input)
    ByVal g     As UByte = 0, _         ' green-channel (input)
    ByVal b     As UByte = 0 _          ' blue-channel (input)
    ) As ULong                          ' assembled 32bit color
    Return (a Shl 24) + (r Shl 16) + (g Shl 8) + b
End Function
Last edited by MrSwiss on Jul 23, 2018 16:31, edited 1 time in total.
dodicat
Posts: 5015
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: 3 Methods, same Result

Postby dodicat » Jul 21, 2018 17:24

The Fourth Kind.
Looks like, but essentially a path to The Third Kind.

Code: Select all

 

sub getcolour(c as ulong,byref r as ubyte,byref g as ubyte,byref b as ubyte,byref a as ubyte)
    g=hibyte(c)
    b=lobyte(c)
    r=lobyte(hiword(c))
    a=hibyte(hiword(c))
end sub




dim as ubyte r,g,b,a

getcolour(rgba(1,2,3,4),r,g,b,a)
print r,g,b,a

getcolour(rgba(255,2,255,255),r,g,b,a)
print r,g,b,a

getcolour(rgba(255,255,255,55),r,g,b,a)
print r,g,b,a

getcolour(rgba(55,5,255,155),r,g,b,a)
print r,g,b,a

'loop tester
dim as ubyte r1,g1,b1,a1
for n as long=1 to 1000000
    r1=rnd*255
    g1=rnd*255
    b1=rnd*255
    a1=rnd*255
 getcolour(rgba(r1,g1,b1,a1),r,g,b,a)
 if r1<>r or g1<>g or b1<>b or a1<>a then print "Error"
next

 print "done"
sleep
 
dodicat
Posts: 5015
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: 3 Methods, same Result

Postby dodicat » Jul 23, 2018 11:54

A Fifth Kind

Code: Select all

 #include "crt.bi"
function getcolour(c as ulong) as ubyte ptr
    static as ubyte u(3)
    memcpy(@u(0),@c,4)
    swap u(0),u(2)
    return @u(0)   'u[0]=r u[1]=g u[2]=b u[4]=alpha
    end function

Function map(a As Single,b As Single,x As Single,c As Single,d As Single) As Single
    Return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
End Function


Screen 19,32
Dim As Any Ptr i=Imagecreate(800,600)
Dim As Long start =0,fin=160,flag=1
Dim As Long r,g,b
lbl:
'brief colour chart
For y As Long=0 To 600
    For x As Long=start To fin
        Select Case  flag
        Case 1
            r=255
            g=map(0,600,y,0,255)
            b=map(0,600,y,0,255)
        Case 2
            r=map(0,600,y,0,255)
            g=255
            b=map(0,600,y,0,255)
        Case 3
            r=map(0,600,y,0,255)
            g=map(0,600,y,0,255)
            b=255
        Case 4
            r=map(0,600,y,0,255)
            g=map(0,600,y,0,255)
            b=map(0,600,y,0,255)
        End Select
         Pset i,(x,y),Rgb(r,g,b)
    Next
Next
flag+=1
start+=160:fin+=160
If flag<=4 Then Goto lbl

Dim As Long mx,my
Dim As Ubyte Ptr u
Do
    Getmouse mx,my
    Screenlock
    Cls
    Put(0,0),i
    If mx<640 Then u=getcolour(Point(mx,my)) Else u=getcolour(Rgb(0,0,0))
   
    Line(640,0)-(800,200),   Rgb(u[0],0,0),bf
    Line(640,200)-(800,400), Rgb(0,u[1],0),bf
    Line(640,400)-(800,600), Rgb(0,0,u[2]),bf
    windowtitle "rgb("+right("000"+ str(u[0]),3)+","+right("000"+str(u[1]),3)+","+right("000"+str(u[2]),3)+")"
    Screenunlock
    Sleep 1,1
Loop Until Len(Inkey)


   
MrSwiss
Posts: 2679
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: 3 Concepts, same Result

Postby MrSwiss » Jul 23, 2018 14:47

@dodicat,

you seem to misunderstand something here:
your methods may be different but, the conceps however, are traceable to one of the
methods outlined in the original post (the fifth is sort of Union, first method, again),
as you've also indicated, that the fourth by consequence, leads to the third ...

It was never intended to become a:
  • implementation contest
  • speed trial thread
As we both know: there are many ways, to skin a cat ...
Re-titled the thread, to better explain its purpose ...

Just to proof the point your last one recoded, to equal type/signature:

Code: Select all

#include "crt.bi"
 
Sub getcolour( _
    ByVal clr   As ULong, _
    ByRef a     As UByte, _
    ByRef r     As UByte, _
    ByRef g     As UByte, _
    ByRef b     As UByte _
    )
    Static As UByte u(0 To 3)
    memcpy(@u(0), @clr, 4)
    a = u(3)
    r = u(2)
    g = u(1)
    b = u(0)
End Sub

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests