Simple Linear Gradient

[nimdays]

Left to right linear gradient without multiplication.
There's no need to calculate all rows since they are equal(only the first one)

Code: Select all

function draw_lrgrad(c1 as ulong,c2 as ulong,x as integer,y as integer,_
                     w as integer,h as integer,sw as integer,dst as ulong ptr)as integer
    '''''''''''''''''
    if c1 = c2 or dst = 0 then return 0
    
    dim as ubyte r1,g1,b1,r2,g2,b2
    '1st color
    r1 = (c1 shr 16) and 255
    g1 = (c1 shr 8) and 255
    b1 = c1 and 255
    '2nd color
    r2 = (c2 shr 16) and 255
    g2 = (c2 shr 8) and 255
    b2 = c2 and 255
    
    dim as single sr,sg,sb,cr,cg,cb
    'get the step
    sr = (r2-r1)/w
    sg = (g2-g1)/w
    sb = (b2-b1)/w
    
    cr = r1
    cg = g1
    cb = b1
    
    dim as ulong ptr p = @dst[y*sw+x],p1 = p 'save the 1st row
    if p = 0 then return 0
    
    screenlock()
    'update the 1st row 1st
    for x1 as integer = 0 to w-1
        p[x1] = (cr shl 16) or (cg shl 8) or cb
        cr += sr
        cg += sg
        cb += sb
    next x1
    p += sw '2nd row
    'update the 2nd row to the last row
    for y1 as integer = 1 to h-1
        for x1 as integer = 0 to w-1
            p[x1] = p1[x1] 'just use the 1st row
        next x1
        p += sw
    next y1
    screenunlock()
    
    return 1
end function

const sw = 800,sh = 600,sd = 32
screenres sw,sh,sd
dim as ulong ptr p = screenptr()

draw_lrgrad(&hff0000,&hff00,50,50,500,500,sw,p)

sleep

[dodicat]

Thanks nimdays.
I cannot beat your speed, but a variation:

Code: Select all

#define mk(a,b) a or b shl 16

Function contrast(c As Ulong,z As Long=Timer) As Ulong 'for superimposing colours
    Randomize z
    #define Intrange(f,l) Int(Rnd*((l+1)-(f)))+(f)
    Dim As Ubyte r=Cptr(Ubyte Ptr,@c)[2],g=Cptr(Ubyte Ptr,@c)[1],b=Cptr(Ubyte Ptr,@c)[0],r2,g2,b2
    Do
        r2=Intrange(0,255):g2=IntRange(0,255):b2=IntRange(0,255)
    Loop Until Abs(r-r2)>120 Andalso Abs(g-g2)>120 Andalso Abs(b-b2)>120
    Return Rgb(r2,g2,b2)
End Function


Function draw_crossgrad(c1 As Ulong,c2 As Ulong,x As Integer,y As Integer,_
    w As Integer,h As Integer,p As Integer,row As Any Ptr)As Integer
    Dim As Integer pitch=Loword(p) Shl 2
    #define map(a,b,_x_,c,d) (((d)-(c))*((_x_)-(a))\((b)-(a))+(c))
    #define putpixel(_x,_y,colour)  *Cptr(Ulong Ptr,row+ (_y)*pitch+ (_x) Shl 2)  =(colour)
    #define clip xx>=0 And xx<Loword(p) And yy>=0 And yy<Hiword(p)
    Dim As Ubyte r1=Cptr(Ubyte Ptr,@c1)[2]
    Dim As Ubyte g1=Cptr(Ubyte Ptr,@c1)[1]
    Dim As Ubyte b1=Cptr(Ubyte Ptr,@c1)[0]
    Dim As Ubyte r2=Cptr(Ubyte Ptr,@c2)[2]
    Dim As Ubyte g2=Cptr(Ubyte Ptr,@c2)[1]
    Dim As Ubyte b2=Cptr(Ubyte Ptr,@c2)[0]
    Dim As Long r,g,b
    For yy As Long=y To y+h
        For xx As Long=x To x+w
            r=map(x,(x+w),xx,r1,r2)
            g=map(x,(x+w),xx,g1,g2)
            b=map(x,(x+w),xx,b1,b2)
            r+=map(y,(y+h),yy,r1,r2)
            g+=map(y,(y+h),yy,g1,g2)
            b+=map(y,(y+h),yy,b1,b2)
            If clip Then putpixel(xx,yy,Rgb(r\2,g\2,b\2))
        Next xx
    Next yy
    Return 0
End Function

'============================================               
Screen 20,32             
Dim As Integer x,y
Screeninfo x,y


Dim As Long mx,my,mb,flag,ctr
Dim As Ulong clr1=&hff0000,clr2=&hff00
Do
  if ctr<21 then ctr+=1
    Getmouse mx,my,,mb
    Screenlock 
    Cls
    draw_crossgrad(clr1,clr2,mx-250,my-250,500,500,mk(x,y),Screenptr)
    If mb And flag=0 and ctr>20 Then
        flag=1
        clr1=Rgb(Rnd*255,Rnd*255,Rnd*255)
        clr2=contrast(clr1)
    End If
    Screenunlock
    Sleep 1,1
    flag=mb
Loop Until Len(Inkey)

Sleep
 

[UEZ]

Here a very simple circle gradient center color version:

Code: Select all

'Coded by UEZ build 2020-05-16
#Include "fbgfx.bi"
Using FB

#Define Rad (Acos(-1) / 180)

Const iW = 600, iH = 600

Sub _CircleGradientCenterColor(x As Short, y As Short, radius As UShort, sc As Ulong, ec As Ulong, pImg As Any Ptr = 0)
	Union Col
		As Ulong argb
		Type
			As Ubyte b, g, r, a
		End Type
	End Union
	Dim As Col StartCol, EndCol
	StartCol.argb = sc
	EndCol.argb = ec
	Dim As Single r = StartCol.r, g = StartCol.g, b = StartCol.b
	Dim As Single dr = (EndCol.r - r) / radius, dg = (EndCol.g - g) / radius, db = (EndCol.b - b) / radius, a, e = 20 / radius
	For i As Single = 0 To radius - 1
		r += dr
		g += dg
		b += db
		For j As Single = 0 To 360 Step e
			a = j * Rad
			Pset pImg, (x + Sin(a) * i, y + Cos(a) * i), Rgba(r, g, b, &hF0)
		Next
	Next
End Sub

Screenres iW, iH, 32, 2, GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
ScreenSet 1, 0

Windowtitle("Circle Gradient Center Color")


Dim As short radius = 250


_CircleGradientCenterColor(iW / 2, iH / 2, radius, &hFFFFFF80, &hFF400000)

Flip

Do
	
	Sleep(10)
Loop Until Len(Inkey())

[MrSwiss]

Here is my take on gradient, however:

• horizontal or vertical (using a Boolean)
• full ARGB range (32bit color)
• either: to screen | or: to image (default: screen)
• uses a Color-Union (instead of all the shifting & anding)
• uses a color array (stores whole lines colors, once init. only!)
• no pointer arithmetic (is error prone)

OK, not so simple any longer:

Code: Select all

' Gradient_Sub.bas -- (c) 2020-05-15, MrSwiss
'
' compile: -s gui
'

'#Define debug                           ' uncomment to see: step values

Sub Gradient( _                         ' horiuontal or vertical gradient
    ByVal sx    As UShort, _            ' x-axsis start
    ByVal sy    As UShort, _            ' y-axsis start
    ByVal ex    As UShort, _            ' x-axsis end
    ByVal ey    As UShort, _            ' y-axsis end
    ByVal clr1  As ULong,  _            ' start color
    ByVal clr2  As ULong,  _            ' end color
    ByVal horiz As Boolean = TRUE, _    ' default: h-line | FALSE = v-line
    ByVal ptrg  As ULong Ptr = 0 _      ' default: screen | alt: image ptr
    )
    Union Color_u
        As ULong    clr
        As UByte    cc(0 To 3)
    End Union
    
    If sx > ex Then Swap sx, ex
    If sy > ey Then Swap sy, ey
    
    Dim As UShort   iw = ex - sx, ih = ey - sy
    Dim As Color_u  c1u, c2u, c3u       ' 3 x Color_u
    
    c1u.clr = clr1 : c2u.clr = clr2 : c3u.clr = c1u.clr ' initial assign
    
    If horiz Then
        Dim As Single _
            st_a = (c2u.cc(3) - c1u.cc(3)) / iw, _  ' calculate step(s)
            st_r = (c2u.cc(2) - c1u.cc(2)) / iw, _
            st_g = (c2u.cc(1) - c1u.cc(1)) / iw, _
            st_b = (c2u.cc(0) - c1u.cc(0)) / iw, _
            sa = c1u.cc(3), sr = c1u.cc(2), _   ' initialize temp. values
            sg = c1u.cc(1), sb = c1u.cc(0)
        Dim As ULong    ca(sx To ex)    ' equivalent to one h-line colors
    
        For y As UInteger = sy To ey
            Var doit = cbool(IIf(y = sy, TRUE, FALSE))
            For x As UInteger = sx To ex
                If x = sx AndAlso doit Then ' one line only
                    For idx As UInteger = sx To ex  ' horizontal-line
                        ca(idx) = c3u.clr   ' assign to array
                        sa += st_a : sr += st_r ' update them all
                        sg += st_g : sb += st_b
                        c3u.cc(3) = sa : c3u.cc(2) = sr ' assign new alpha/red
                        c3u.cc(1) = sg : c3u.cc(0) = sb ' assign new green/blue
                    Next
                End If
                Pset ptrg, (x, y), ca(x)
            Next
        Next
        ' debugging only
        #Ifdef debug
            Draw String ptrg, (70,  70), "st_a: " + Str(st_a)
            Draw String ptrg, (70,  90), "st_r: " + Str(st_r)
            Draw String ptrg, (70, 110), "st_g: " + Str(st_g)
            Draw String ptrg, (70, 130), "st_b: " + Str(st_b)
        #endif  ' debug
    Else
        Dim As Single _
            st_a = (c2u.cc(3) - c1u.cc(3)) / ih, _  ' calculate step(s)
            st_r = (c2u.cc(2) - c1u.cc(2)) / ih, _
            st_g = (c2u.cc(1) - c1u.cc(1)) / ih, _
            st_b = (c2u.cc(0) - c1u.cc(0)) / ih, _
            sa = c1u.cc(3), sr = c1u.cc(2), _   ' initialize temp. values
            sg = c1u.cc(1), sb = c1u.cc(0)
        Dim As ULong    ca(sy To ey)    ' equivalent to one v-line colors
    
        For y As UInteger = sy To ey
            If y = sy Then              ' one line only
                For idx As UInteger = sy To ey  ' vertical-line
                    ca(idx) = c3u.clr   ' assign to array
                    sa += st_a : sr += st_r ' update them all
                    sg += st_g : sb += st_b
                    c3u.cc(3) = sa : c3u.cc(2) = sr ' assign new alpha/red
                    c3u.cc(1) = sg : c3u.cc(0) = sb ' assign new green/blue
                Next
            End If
            Var tc = ca(y)
            For x As UInteger = sx To ex
                PSet ptrg, (x, y), tc
            Next
        Next
        ' debugging only
        #Ifdef debug
            Draw String ptrg, (70,  70), "st_a: " + Str(st_a)
            Draw String ptrg, (70,  90), "st_r: " + Str(st_r)
            Draw String ptrg, (70, 110), "st_g: " + Str(st_g)
            Draw String ptrg, (70, 130), "st_b: " + Str(st_b)
        #endif  ' debug
    End If
End Sub

' ===== DEMO =====
Const As ULong  black = &hFF000000, white = &hFFFFFFFF  ' colors
Const As UShort scr_w = 1024, scr_h = 768, _    ' screen
                scr_cd = 32, scr_pg = 2, scr_flg = 64

ScreenRes(scr_w, scr_h, scr_cd, scr_pg, scr_flg)
ScreenSet(1, 0)
Color(black, white) : Cls               ' black on white background
Width scr_w \ 8, scr_h \ 16             ' large Font: 8 x 16

Dim As UShort brdr = 50

Gradient(brdr, brdr, scr_w - brdr, scr_h - brdr, &hFFFF0000, &hBF00FF7F)
Draw String (70, scr_h - 86), "press a key to continue ..."
Flip : Sleep
Gradient(brdr, brdr, scr_w - brdr, scr_h - brdr, &hFFFF0000, &hBF00FF7F, FALSE)
Draw String (70, scr_h - 86), "press a key to EXIT ..."
Flip : Sleep
' ===== END - DEMO =====    ' ----- EOF -----

[nimdays]

Thanks all