QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Programs v
computing color gradients / color transitions demo

Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Threaded Mode
computing color gradients / color transitions demo
madscijr Offline
Mini-Mod
***
Posts: 1,215
Threads: 162
Joined: Apr 2022
Reputation: 34
#1
04-29-2025, 09:16 PM (This post was last modified: 04-29-2025, 10:02 PM by madscijr. Edit Reason: minor code cleanup )
This started out as trying to make "the perfect rainbow" LOL, in RGB and HSL, 
but I ended up with a handy function, 
GetChannelDeltas which receives Color1~&, Color2~&, NumSteps% 
and returns dr!, dg! db! - delta values to smoothly & evenly transition from color1 to color2 in the specified number of steps.

Code: (Select All)
_Title "Color gradient + spectrum test v0.26" ' madscijr 2025-04-28
SpectrumTest
System

' /////////////////////////////////////////////////////////////////////////////

Sub SpectrumTest
    Dim xmin, ymin As Integer
    Dim xmax, ymax As Integer
    ReDim arrColor(-1) As _Unsigned Long
    Dim RowNum, NextRow As Integer
    Dim m$
    Dim LabelLen As Integer
    Dim MaxRows, MaxCols As Integer
    Dim in$

    xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1
    Screen _NewImage(xmax, ymax, 32): Cls , _RGB32(0, 0, 0): _ScreenMove 0, 0
    MaxRows = (_Height / _FontHeight) - 1
    MaxCols = (_Width / _FontWidth) - 1
    LabelLen = 24

    ' HEADING
    m$ = "PALETTE": m$ = Left$(m$ + String$(LabelLen, " "), LabelLen)
    RowNum = 1: ColNum = 1: Locate RowNum, ColNum: Color _RGB32(255, 255, 255), _RGB32(255, 0, 0): Print m$;

    m$ = "COLORS": m$ = Left$(m$ + String$(MaxCols - LabelLen, " "), MaxCols - LabelLen)
    RowNum = 1: Locate RowNum, LabelLen + 1: Color _RGB32(255, 255, 255), _RGB32(0, 0, 255): Print m$;

    m$ = "Madsci RGB Spectrum"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long: AddSpectrumColors arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Madsci RGB spectrum #2"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long: AddSpectrum2Colors arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Madsci HSL Spectrum"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long: GetMadsciHslSpectrum arrColor(), 24
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Sprezzo HSL Spectrum"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long: GetSprezzoHslSpectrum arrColor(), 24
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Madsci grayscale"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long: AddGrayscaleColors arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight
   
    m$ = "Gray to Yellow"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cGray, arrColor()
    AddColor cYellow, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Gray to Yellow To Cyan"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cGray, arrColor()
    AddColor cYellow, arrColor()
    AddColor cCyan, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "White to Yellow To Red"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cWhite, arrColor()
    AddColor cYellow, arrColor()
    AddColor cRed, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Cyan to Blue"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cCyan, arrColor()
    AddColor cBlue, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "White to Black"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cWhite, arrColor()
    AddColor cBlack, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Yellow to Black"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cYellow, arrColor()
    AddColor cBlack, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Orange to Magenta"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cTrueOrange, arrColor()
    AddColor cMagenta, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    m$ = "Dim Gray to Dark Gray"
    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)
    ReDim arrColor(-1) As _Unsigned Long
    AddColor cDimGray, arrColor()
    AddColor cDarkGray, arrColor()
    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;
    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight
    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight
    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight
    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight
    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0): RowNum = MaxRows - 1: Locate RowNum, 1
    Print "THAT'S ALL FOLKS! PRESS ANY KEY TO EXIT";
    Sleep: _KeyClear: Screen 0

End Sub ' SpectrumTest

' /////////////////////////////////////////////////////////////////////////////
' Draws colors in array arrColor across current 32-bit hires screen
' as blocks (no transition between colors)
' of width (TotalWidth / {# elements in arrColor}
' at position xpos,ypos across width TotalWidth in a bar Totalheight high.

Sub DrawColorBlocks (arrColor() As _Unsigned Long, xpos As Integer, ypos As Integer, TotalWidth As Integer, TotalHeight As Integer)
    Dim cx As Integer
    Dim width As Integer
    Dim height As Integer
    Dim index As Integer
    If UBound(arrColor) > 0 Then
        width = TotalWidth / (UBound(arrColor) + 1)
        height = TotalHeight
        cx = xpos
        For index = LBound(arrColor) To UBound(arrColor)
            DrawRectSolid cx, ypos, width, height, arrColor(index) ' PLOT NEXT COLOR
            cx = cx + width ' MOVE TO NEXT PIXEL TO THE RIGHT
        Next index
    End If
End Sub ' DrawColorBlocks

' /////////////////////////////////////////////////////////////////////////////
' Draws colors in array arrColor across current 32-bit hires screen
' with a continuous transition between each color,
' at position xpos,ypos across width TotalWidth in a bar Totalheight high.

' Usage:
' DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight

Sub DrawContinuousColor (arrColor() As _Unsigned Long, xpos As Integer, ypos As Integer, TotalWidth As Integer, TotalHeight As Integer)
    Dim cx As Integer
    Dim width As Integer
    Dim height As Integer
    Dim index As Integer
    Dim c1~&, c2~&, c~&
    Dim r, g, b As Integer
    Dim rc!, gc!, bc!
    Dim dr!, dg!, db!
    Dim x1 As Integer
    Dim NumSteps%

    If UBound(arrColor) > 0 Then
        width = TotalWidth / (UBound(arrColor) + 1)
        height = TotalHeight
        cx = xpos
        For index = LBound(arrColor) To UBound(arrColor)
            ' GET START COLOR
            c1~& = arrColor(index)

            ' GET NEXT COLOR
            If index < UBound(arrColor) Then
                c2~& = arrColor(index + 1)
            Else
                c2~& = arrColor(LBound(arrColor))
            End If

            ' DETERMINE HOW MUCH EACH CHANNEL MUST CHANGE TO REACH NEXT START COLOR IN width STEPS
            rc! = _Cast(Single, _Red32(arrColor(index)))
            gc! = _Cast(Single, _Green32(arrColor(index)))
            bc! = _Cast(Single, _Blue32(arrColor(index)))
            GetChannelDeltas c1~&, c2~&, width, dr!, dg!, db!

            ' PLOT COLORS BETWEEN START COLOR AND NEXT START COLOR
            For x1 = cx To (cx + width) - 1
                ' GET NEXT COLOR
                r = _Cast(Long, rc!)
                g = _Cast(Long, gc!)
                b = _Cast(Long, bc!)

                c~& = _RGB32(r, g, b)

                ' PLOT NEXT COLOR
                Line (x1, ypos)-(x1, (ypos + TotalHeight) - 1), c~&

                ' ADJUST CHANNELS TO PROGRESS TOWARD NEXT COLOR
                rc! = rc! + dr!
                If rc! < 0 Then
                    rc! = 0
                ElseIf rc! > 255 Then
                    rc! = 255
                End If

                gc! = gc! + dg!
                If gc! < 0 Then
                    gc! = 0
                ElseIf gc! > 255 Then
                    gc! = 255
                End If

                bc! = bc! + db!
                If bc! < 0 Then
                    bc! = 0
                ElseIf bc! > 255 Then
                    bc! = 255
                End If

            Next x1

            ' MOVE TO THE RIGHT TO NEXT DIVISION
            cx = cx + width
        Next index
    End If
End Sub ' DrawContinuousColor

' ################################################################################################################################################################
' BEGIN MISC FUNCTIONS
' ################################################################################################################################################################

' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)

' Usage:
' DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor

Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
    Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid

' /////////////////////////////////////////////////////////////////////////////
' Quick/dirty blunt force way to format a single value to a string
' with a certain # of decimal places. I'm sure this can be done in an
' easier way but had no internet when I wrote this and am tired! :-p

Function FormatSingle2$ (sngVal As Single, iPlaces As Integer)
    Dim sResult$, sVal$: Dim iPos%
    sVal$ = _ToStr$(sngVal)
    iPos% = InStr(1, sVal$, ".")
    If iPos% = 0 Then
        sResult$ = sVal$
        If iPlaces > 0 Then sResult$ = sResult$ + "." + String$(iPlaces, "0")
    Else
        sResult$ = Left$(sVal$, iPos% - 1)
        If iPlaces > 0 Then sResult$ = sResult$ + "." + Left$(Mid$(sVal$, iPos% + 1, iPlaces) + String$(iPlaces, "0"), iPlaces)
    End If
    FormatSingle2$ = sResult$
End Function ' FormatSingle2$

' /////////////////////////////////////////////////////////////////////////////
' Receives an initial color and a final color to transition to,
' and the # of steps/frames to transition, and returns the color channel
' deltas to smoothly transition to the final color in that many steps.

' Receives:
' c1~& = color to start from
' c2~& = color to arrive at
' NumSteps% = # of steps/frames for transition

' Returns (byref) the color channel deltas for a single step/frame:
' dr! = red color channel delta
' dg! = green "
' db! = blue "

' Usage:
' GetChannelDeltas c1~&, c2~&, NumSteps%, dr!, dg!, db!

Sub GetChannelDeltas (c1~&, c2~&, NumSteps%, dr!, dg!, db!)
    Dim r1&, g1&, b1& ' current color
    Dim r2&, g2&, b2& ' new color
    Dim rDiff&, gDiff&, bDiff& ' diff between each color channel for old/new colors
    Dim MaxDiff&

    ' Get rgb of old color
    r1& = _Red32(c1~&): g1& = _Green32(c1~&): b1& = _Blue32(c1~&)

    ' Get rgb of new color
    r2& = _Red32(c2~&): g2& = _Green32(c2~&): b2& = _Blue32(c2~&)

    ' get differences for each color channel
    rDiff& = r2& - r1&
    gDiff& = g2& - g1&
    bDiff& = b2& - b1&

    ' Get the ratio of change necessary to reach the target value between r,g,b
    ' That which needs the greatest change is 1 (100%)
    ' Those which need less change are a fraction of the greatest
    If Abs(rDiff&) >= Abs(gDiff&) And Abs(rDiff&) >= Abs(bDiff&) Then
        MaxDiff& = Abs(rDiff&)
        pr! = 1 * _IIf(r1& < r2&, 1, -1)
        pg! = (Abs(gDiff&) / Abs(rDiff&)) * _IIf(g1& < g2&, 1, -1)
        pb! = (Abs(bDiff&) / Abs(rDiff&)) * _IIf(b1& < b2&, 1, -1)
    ElseIf Abs(gDiff&) >= Abs(rDiff&) And Abs(gDiff&) >= Abs(bDiff&) Then
        MaxDiff& = Abs(gDiff&)
        pr! = (Abs(rDiff&) / Abs(gDiff&)) * _IIf(r1& < r2&, 1, -1)
        pg! = 1 * _IIf(g1& < g2&, 1, -1)
        pb! = (Abs(bDiff&) / Abs(gDiff&)) * _IIf(b1& < b2&, 1, -1)
    Else
        MaxDiff& = Abs(bDiff&)
        pr! = (Abs(rDiff&) / Abs(bDiff&)) * _IIf(r1& < r2&, 1, -1)
        pg! = (Abs(gDiff&) / Abs(bDiff&)) * _IIf(g1& < g2&, 1, -1)
        pb! = 1 * _IIf(b1& < b2&, 1, -1)
    End If

    ' Now determine how much to change each color channel each step (e.g., frame)
    ' to evenly arrive at new color when total steps or total time are complete
    dr! = (MaxDiff& * pr!) / NumSteps%
    dg! = (MaxDiff& * pg!) / NumSteps%
    db! = (MaxDiff& * pb!) / NumSteps%

End Sub ' GetChannelDeltas

' /////////////////////////////////////////////////////////////////////////////
' Splits a string in$ by delimeter delimiter$
' into an array result$().

' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.

' Split in$ into pieces, chopping at every occurrence of delimiter$.
' Multiple consecutive occurrences of delimiter$ are treated as a single instance.
' The chopped pieces are stored in result$().

' delimiter$ must be one character long.
' result$() must have been REDIMmed previously.

' Modified to handle multi-character delimiters

Sub split (in$, delimiter$, result$())
    Dim start As Integer
    Dim finish As Integer
    Dim iDelimLen As Integer
    ReDim result$(-1)

    iDelimLen = Len(delimiter$)

    start = 1
    Do
        While Mid$(in$, start, iDelimLen) = delimiter$
            start = start + iDelimLen
            If start > Len(in$) Then
                Exit Sub
            End If
        Wend
        finish = InStr(start, in$, delimiter$)
        If finish = 0 Then
            finish = Len(in$) + 1
        End If

        ReDim _Preserve result$(0 To UBound(result$) + 1)

        result$(UBound(result$)) = Mid$(in$, start, finish - start)
        start = finish + 1
    Loop While start <= Len(in$)
End Sub ' split

' ################################################################################################################################################################
' END MISC FUNCTIONS
' ################################################################################################################################################################

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RGB COLOR FUNCTIONS #RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Function cRed~& ()
    cRed = _RGB32(255, 0, 0)
End Function

Function cOrangeRed~& ()
    cOrangeRed = _RGB32(255, 69, 0)
End Function

' added this because cOrangeRed feels too red
' and cDarkOrange & cOrange too yellow
Function cTrueOrange~& ()
    cTrueOrange = _RGB32(255, 100, 0)
End Function

Function cDarkOrange~& ()
    cDarkOrange = _RGB32(255, 140, 0)
End Function

Function cOrange~& ()
    cOrange = _RGB32(255, 165, 0)
End Function

Function cGold~& ()
    cGold = _RGB32(255, 215, 0)
End Function

Function cYellow~& ()
    cYellow = _RGB32(255, 255, 0)
End Function

' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
    cOliveDrab1 = _RGB32(192, 255, 62)
End Function

Function cLime~& ()
    cLime = _RGB32(0, 255, 0)
End Function

Function cMediumSpringGreen~& ()
    cMediumSpringGreen = _RGB32(0, 250, 154)
End Function

' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
    cSpringGreen = _RGB32(0, 255, 160)
End Function

Function cCyan~& ()
    cCyan = _RGB32(0, 255, 255)
End Function

Function cDeepSkyBlue~& ()
    cDeepSkyBlue = _RGB32(0, 191, 255)
End Function

Function cDodgerBlue~& ()
    cDodgerBlue = _RGB32(30, 144, 255)
End Function

Function cSeaBlue~& ()
    cSeaBlue = _RGB32(0, 64, 255)
End Function

Function cBlue~& ()
    cBlue = _RGB32(0, 0, 255)
End Function

Function cBluePurple~& ()
    cBluePurple = _RGB32(64, 0, 255)
End Function

Function cDeepPurple~& ()
    cDeepPurple = _RGB32(96, 0, 255)
End Function

Function cPurple~& ()
    cPurple = _RGB32(128, 0, 255)
End Function

Function cPurpleRed~& ()
    cPurpleRed = _RGB32(128, 0, 192)
End Function

Function cDarkRed~& ()
    cDarkRed = _RGB32(160, 0, 64)
End Function

Function cBrickRed~& ()
    cBrickRed = _RGB32(192, 0, 32)
End Function

Function cDarkGreen~& ()
    cDarkGreen = _RGB32(0, 100, 0)
End Function

Function cGreen~& ()
    cGreen = _RGB32(0, 128, 0)
End Function

Function cOliveDrab~& ()
    cOliveDrab = _RGB32(107, 142, 35)
End Function

Function cLightPink~& ()
    cLightPink = _RGB32(255, 182, 193)
End Function

Function cHotPink~& ()
    cHotPink = _RGB32(255, 105, 180)
End Function

Function cDeepPink~& ()
    cDeepPink = _RGB32(255, 20, 147)
End Function

Function cMagenta~& ()
    cMagenta = _RGB32(255, 0, 255)
End Function

Function cBlack~& ()
    cBlack = _RGB32(0, 0, 0)
End Function

Function cDimGray~& ()
    cDimGray = _RGB32(105, 105, 105)
End Function

Function cGray~& ()
    cGray = _RGB32(128, 128, 128)
End Function

Function cDarkGray~& ()
    cDarkGray = _RGB32(169, 169, 169)
End Function

Function cSilver~& ()
    cSilver = _RGB32(192, 192, 192)
End Function

Function cLightGray~& ()
    cLightGray = _RGB32(211, 211, 211)
End Function

Function cGainsboro~& ()
    cGainsboro = _RGB32(220, 220, 220)
End Function

Function cWhiteSmoke~& ()
    cWhiteSmoke = _RGB32(245, 245, 245)
End Function

Function cWhite~& ()
    cWhite = _RGB32(255, 255, 255)
End Function

Function cDarkBrown~& ()
    cDarkBrown = _RGB32(128, 64, 0)
End Function

Function cLightBrown~& ()
    cLightBrown = _RGB32(196, 96, 0)
End Function

Function cKhaki~& ()
    cKhaki = _RGB32(240, 230, 140)
End Function

Function cEmpty~& ()
    cEmpty = _RGB32(0, 0, 0, 0)
End Function

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RGB COLOR FUNCTIONS @RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST ALPHA COLORS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cDimGrayAlpha~& (alpha&)
    cDimGrayAlpha = _RGB32(105, 105, 105, alpha&)
End Function

Function cGrayAlpha~& (alpha&)
    cGrayAlpha = _RGB32(128, 128, 128, alpha&)
End Function

Function cDarkGrayAlpha~& (alpha&)
    cDarkGrayAlpha = _RGB32(169, 169, 169, alpha&)
End Function

Function cSilverAlpha~& (alpha&)
    cSilverAlpha = _RGB32(192, 192, 192, alpha&)
End Function

Function cLightGrayAlpha~& (alpha&)
    cLightGrayAlpha = _RGB32(211, 211, 211, alpha&)
End Function

Function cGainsboroAlpha~& (alpha&)
    cGainsboroAlpha = _RGB32(220, 220, 220, alpha&)
End Function

Function cWhiteSmokeAlpha~& (alpha&)
    cWhiteSmokeAlpha = _RGB32(245, 245, 245, alpha&)
End Function

Function cWhiteAlpha~& (alpha&)
    cWhiteAlpha = _RGB32(255, 255, 255, alpha&)
End Function
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST ALPHA COLORS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' ################################################################################################################################################################
' BEGIN COLOR ARRAY FUNCTIONS #COLR
' ################################################################################################################################################################

' /////////////////////////////////////////////////////////////////////////////
' Append color ColorValue to array arrColor

Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
    ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
    arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor

' /////////////////////////////////////////////////////////////////////////////
' Adds colors colors to array arrColor().
' the first 8 colors are solid (alpha=255)
' the last  8 colors are transparent (alpha = parameter alpha&)

Sub AddTestColors (arrColor() As _Unsigned Long)
    ' SOLID:
    AddColor cRed, arrColor()
    AddColor cTrueOrange, arrColor()
    AddColor cYellow, arrColor()
    AddColor cLime, arrColor()
    AddColor cCyan, arrColor()
    AddColor cBlue, arrColor()
    AddColor cMagenta, arrColor()
    AddColor cBlack, arrColor()

    ' TRANSPARENT:
    Dim alpha&: alpha& = 256
    alpha& = alpha& - 30
    AddColor cDimGrayAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cGrayAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cDarkGrayAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cSilverAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cLightGrayAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cGainsboroAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cWhiteSmokeAlpha~&(alpha&), arrColor()
    alpha& = alpha& - 30
    AddColor cWhiteAlpha~&(alpha&), arrColor()
End Sub ' AddTestColors

' /////////////////////////////////////////////////////////////////////////////
' Adds rainbow colors to array arrColor().
' madscijr attempt #2 to pick evenly distributed colors across spectrum

Sub AddSpectrum2Colors (arrColor() As _Unsigned Long)
    AddColor _RGB32(255, 0, 0), arrColor()
    AddColor _RGB32(255, 69, 0), arrColor()
    AddColor _RGB32(255, 100, 0), arrColor()
    AddColor _RGB32(255, 140, 0), arrColor()
    AddColor _RGB32(255, 165, 0), arrColor()
    AddColor _RGB32(255, 215, 0), arrColor()
    AddColor _RGB32(255, 255, 0), arrColor()
    AddColor _RGB32(192, 255, 62), arrColor()
    AddColor _RGB32(128, 255, 24), arrColor()
    AddColor _RGB32(0, 255, 0), arrColor()
    AddColor _RGB32(0, 196, 0), arrColor()
    AddColor _RGB32(0, 224, 64), arrColor()
    AddColor _RGB32(0, 255, 112), arrColor()
    AddColor _RGB32(0, 255, 136), arrColor()
    AddColor _RGB32(0, 255, 255), arrColor()
    AddColor _RGB32(0, 191, 255), arrColor()
    AddColor _RGB32(30, 144, 255), arrColor()
    AddColor _RGB32(0, 64, 255), arrColor()
    AddColor _RGB32(0, 0, 255), arrColor()
    AddColor _RGB32(80, 0, 255), arrColor()
    AddColor _RGB32(96, 0, 255), arrColor()
    AddColor _RGB32(128, 0, 255), arrColor()
    AddColor _RGB32(160, 0, 192), arrColor()
    AddColor _RGB32(224, 0, 96), arrColor()
    AddColor _RGB32(255, 0, 32), arrColor()
End Sub ' AddSpectrum2Colors

' /////////////////////////////////////////////////////////////////////////////
' Adds rainbow colors to array arrColor().
' madscijr attempt #1 to pick evenly distributed colors across spectrum

Sub AddSpectrumColors (arrColor() As _Unsigned Long)
    AddColor cRed, arrColor()
    AddColor cOrangeRed, arrColor()
    AddColor cDarkOrange, arrColor()
    AddColor cOrange, arrColor()
    AddColor cGold, arrColor()
    AddColor cYellow, arrColor()
    AddColor cOliveDrab1, arrColor()
    AddColor cLime, arrColor()
    AddColor cMediumSpringGreen, arrColor()
    AddColor cSpringGreen, arrColor()
    AddColor cCyan, arrColor()
    AddColor cDeepSkyBlue, arrColor()
    AddColor cDodgerBlue, arrColor()
    AddColor cSeaBlue, arrColor()
    AddColor cBlue, arrColor()
    AddColor cBluePurple, arrColor()
    AddColor cDeepPurple, arrColor()
    AddColor cPurple, arrColor()
    AddColor cPurpleRed, arrColor()
End Sub ' AddSpectrumColors

' /////////////////////////////////////////////////////////////////////////////
' Adds grayscale colors to array arrColor().

Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
    AddColor cDimGray, arrColor()
    AddColor cGray, arrColor()
    AddColor cDarkGray, arrColor()
    AddColor cSilver, arrColor()
    AddColor cLightGray, arrColor()
    AddColor cGainsboro, arrColor()
    AddColor cWhiteSmoke, arrColor()
    AddColor cWhite, arrColor() '* 2
    AddColor cWhiteSmoke, arrColor()
    AddColor cGainsboro, arrColor()
    AddColor cLightGray, arrColor()
    AddColor cSilver, arrColor()
    AddColor cDarkGray, arrColor()
    AddColor cGray, arrColor()
End Sub ' AddGrayscaleColors

' /////////////////////////////////////////////////////////////////////////////

Sub GetMadsciHslSpectrum (arrColor() As _Unsigned Long, NumDivisions As Integer)
    Dim hue#, dhue#, sat#, dsat#
    Dim c~&
    Dim iLoop%
    If NumDivisions <> 0 Then ' protect against divide by 0
        hue# = 0
        dhue# = 360 / NumDivisions
        sat# = 100
        dsat# = 0
        For iLoop% = 1 To NumDivisions
            ' GENERATE + ADD NEXT COLOR
            c~& = _HSBA32(hue#, sat#, 100, 100)
            AddColor c~&, arrColor()

            ' INCREMENT COLOR
            hue# = hue# + dhue#
            If hue# > 359 Then
                hue# = 0
            End If
            sat# = sat# + dsat#
            If sat# <= 0 Then
                sat# = 0: dsat# = -dsat#
            ElseIf sat# >= 100 Then
                sat# = 100: dsat# = -dsat#
            End If
        Next iLoop%
    End If
End Sub ' GetMadsciHslSpectrum

' /////////////////////////////////////////////////////////////////////////////
' Sprezzo modified to use hpRGB function
' https://qb64phoenix.com/forum/showthread.php?tid=3624&pid=33637#pid33637
'
' Sprezzo, Junior Member
' 4/19/2025 11:36 PM
' ey bud, try this for a color wheel.
' i promise you wont find it elsewhere unless the AI already scraped me

Sub GetSprezzoHslSpectrum (arrColor() As _Unsigned Long, NumDivisions As Integer)
    Dim hue#, dhue#, sat#, dsat#
    Dim c~&
    Dim iLoop%

    If NumDivisions <> 0 Then ' protect against divide by 0
        hue# = 0
        dhue# = 360 / NumDivisions
        sat# = 0
        dsat# = 100 / (NumDivisions * -.25)

        For iLoop% = 1 To NumDivisions
            ' GENERATE + ADD NEXT COLOR
            c~& = hpRGB~&(hue# / 360, .25) ' THIS
            AddColor c~&, arrColor()

            ' INCREMENT COLOR
            hue# = hue# + dhue#
            If hue# > 359 Then
                hue# = 0
            End If
            sat# = sat# + dsat#
            If sat# <= 0 Then
                sat# = 0: dsat# = -dsat#
            ElseIf sat# >= 100 Then
                sat# = 100: dsat# = -dsat#
            End If
        Next iLoop%
    End If
End Sub ' GetSprezzoHslSpectrum
Function hpRGB~& (h As Double, p As Double)
    Const pi = 3.14159
    Dim As Double r0, g0, b0
    Dim As Double r, g, b
    Dim As Double x, f, m, hh
    hh = h ^ 1.5
    x = pi * (hh + 1 / 2)
    r0 = Abs(Sin(x))
    g0 = Abs(Sin(x - pi / 3))
    b0 = Abs(Sin(x + pi / 3))
    f = p * (1 - r0 - g0 - b0)
    r = r0 + f
    g = g0 + f
    b = b0 + f
    m = 1 / Max3##(r, g, b)
    r = r * m
    g = g * m
    b = b * m
    If (r < 0) Then r = 0
    If (g < 0) Then g = 0
    If (b < 0) Then b = 0
    hpRGB~& = _RGB32(r * 255, g * 255, b * 255, 255)
End Function ' hpRGB~&
Function Max3## (x As Double, y As Double, z As Double)
    Dim TheReturn As Double
    TheReturn = x
    If (y > TheReturn) Then TheReturn = y
    If (z > TheReturn) Then TheReturn = z
    Max3## = TheReturn
End Function ' Max3##

' /////////////////////////////////////////////////////////////////////////////
' Returns a random color chosen from array of color values arrColor().

' Usage:
' c~& = GetRandomColor~& (arrColor())

Function GetRandomColor~& (arrColor() As _Unsigned Long)
    Dim index As Integer
    index = RandomNumber%(LBound(arrColor), UBound(arrColor))
    GetRandomColor~& = arrColor(index)
End Function ' GetRandomColor~&

' /////////////////////////////////////////////////////////////////////////////
' Returns a random color chosen from array of color values arrColor(),
' but makes sure it isn't a color in array arrNotColor().

' Usage:
' c~& = GetRandomColorExcept~& (arrColor(), arrNotColor())

Function GetRandomColorExcept~& (arrColor() As _Unsigned Long, arrNotColor() As _Unsigned Long)
    Dim index1, index2 As Integer
    Dim c~&
    Dim bFound As Integer
    Dim iCount As Integer: iCount = 0 ' count # of tries
    Dim iMax As Integer: iMax = 1000 ' if we don't find it in 1000 tries, just exit
    Do
        index1 = RandomNumber%(LBound(arrColor), UBound(arrColor))
        c~& = arrColor(index1)
        bFound = _TRUE
        For index2 = LBound(arrNotColor) To UBound(arrNotColor)
            If arrNotColor(index2) = c~& Then bFound = _FALSE: Exit For
        Next index2
        If bFound = _TRUE Then Exit Do
        iCount = iCount + 1: If iCount > iMax Then c~& = _FALSE: Exit Do ' if we haven't found it by now, give up!
    Loop
    GetRandomColorExcept~& = c~&
End Function ' GetRandomColor~&

' ################################################################################################################################################################
' END COLOR ARRAY FUNCTIONS @COLR
' ################################################################################################################################################################
Find
Reply
Sprezzo Offline
Junior Member
**
Posts: 16
Threads: 1
Joined: Apr 2022
Reputation: 6
#2
04-30-2025, 03:46 AM (This post was last modified: 04-30-2025, 04:04 AM by Sprezzo.)
hey madsci, i modified your code - it now has another custom baby of mine with three modes for linear, gaussian, or trigonometric interpolation for color mixing.

you probably noticed by now you won't get the right rainbow using HSL alone, however the little factor h^1.5 in the original function i gave gets you close, but forget that. its much better to start with 6 or 12 principal colors and interpolate between those. (probably what youre doing now?) it's hard to compare the new weighting schemes though, so i'll throw in some screenshots at the bottom. they will look almost identical. i'd say download all three and use a viewer to quickly flip between the three so the differences stand out.

Code: (Select All)
_Title "Color gradient + spectrum test v0.26" ' madscijr 2025-04-28



Dim Shared As _Unsigned Long RainbowSpec(1 To 6)

RainbowSpec(1) = _RGB32(255 * 1.00, 255 * 0.00, 255 * 0.00, 255)

RainbowSpec(2) = _RGB32(255 * 1.00, 255 * 0.50, 255 * 0.00, 255)

RainbowSpec(3) = _RGB32(255 * 1.00, 255 * 1.00, 255 * 0.00, 255)

RainbowSpec(4) = _RGB32(255 * 0.00, 255 * 1.00, 255 * 0.00, 255)

RainbowSpec(5) = _RGB32(255 * 0.00, 255 * 0.00, 255 * 1.00, 255)

RainbowSpec(6) = _RGB32(255 * 0.50, 255 * 0.00, 255 * 1.00, 255)



SpectrumTest

System



' /////////////////////////////////////////////////////////////////////////////



Sub SpectrumTest

    Dim xmin, ymin As Integer

    Dim xmax, ymax As Integer

    ReDim arrColor(-1) As _Unsigned Long

    Dim RowNum, NextRow As Integer

    Dim m$

    Dim LabelLen As Integer

    Dim MaxRows, MaxCols As Integer

    Dim in$



    xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1

    Screen _NewImage(xmax, ymax, 32): Cls , _RGB32(0, 0, 0): _ScreenMove 0, 0

    MaxRows = (_Height / _FontHeight) - 1

    MaxCols = (_Width / _FontWidth) - 1

    LabelLen = 24



    ' HEADING

    m$ = "PALETTE": m$ = Left$(m$ + String$(LabelLen, " "), LabelLen)

    RowNum = 1: ColNum = 1: Locate RowNum, ColNum: Color _RGB32(255, 255, 255), _RGB32(255, 0, 0): Print m$;



    m$ = "COLORS": m$ = Left$(m$ + String$(MaxCols - LabelLen, " "), MaxCols - LabelLen)

    RowNum = 1: Locate RowNum, LabelLen + 1: Color _RGB32(255, 255, 255), _RGB32(0, 0, 255): Print m$;



    m$ = "Madsci RGB Spectrum"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long: AddSpectrumColors arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Madsci RGB spectrum #2"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long: AddSpectrum2Colors arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Madsci HSL Spectrum"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long: GetMadsciHslSpectrum arrColor(), 24

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Sprezzo HSL Spectrum"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long: GetSprezzoHslSpectrum arrColor(), 24

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Madsci grayscale"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long: AddGrayscaleColors arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Gray to Yellow"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cGray, arrColor()

    AddColor cYellow, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Gray to Yellow To Cyan"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cGray, arrColor()

    AddColor cYellow, arrColor()

    AddColor cCyan, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "White to Yellow To Red"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cWhite, arrColor()

    AddColor cYellow, arrColor()

    AddColor cRed, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Cyan to Blue"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cCyan, arrColor()

    AddColor cBlue, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "White to Black"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cWhite, arrColor()

    AddColor cBlack, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Yellow to Black"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cYellow, arrColor()

    AddColor cBlack, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Orange to Magenta"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cTrueOrange, arrColor()

    AddColor cMagenta, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    m$ = "Dim Gray to Dark Gray"

    m$ = Right$(String$(LabelLen, " ") + m$ + ": ", LabelLen)

    ReDim arrColor(-1) As _Unsigned Long

    AddColor cDimGray, arrColor()

    AddColor cDarkGray, arrColor()

    RowNum = RowNum + 2: Locate RowNum, ColNum: Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Print m$;

    xpos = Len(m$) * _FontWidth: ypos = (RowNum - 1) * _FontHeight

    TotalWidth = (_DesktopWidth - xpos) - (_FontWidth * 10): TotalHeight = _FontHeight

    DrawColorBlocks arrColor(), xpos, ypos, TotalWidth, TotalHeight

    RowNum = RowNum + 1: ypos = (RowNum - 1) * _FontHeight

    DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0): RowNum = MaxRows - 1: Locate RowNum, 1

    Print "THAT'S ALL FOLKS! PRESS ANY KEY TO EXIT";

    Sleep: _KeyClear: Screen 0



End Sub ' SpectrumTest



' /////////////////////////////////////////////////////////////////////////////

' Draws colors in array arrColor across current 32-bit hires screen

' as blocks (no transition between colors)

' of width (TotalWidth / {# elements in arrColor}

' at position xpos,ypos across width TotalWidth in a bar Totalheight high.



Sub DrawColorBlocks (arrColor() As _Unsigned Long, xpos As Integer, ypos As Integer, TotalWidth As Integer, TotalHeight As Integer)

    Dim cx As Integer

    Dim width As Integer

    Dim height As Integer

    Dim index As Integer

    If UBound(arrColor) > 0 Then

        width = TotalWidth / (UBound(arrColor) + 1)

        height = TotalHeight

        cx = xpos

        For index = LBound(arrColor) To UBound(arrColor)

            DrawRectSolid cx, ypos, width, height, arrColor(index) ' PLOT NEXT COLOR

            cx = cx + width ' MOVE TO NEXT PIXEL TO THE RIGHT

        Next index

    End If

End Sub ' DrawColorBlocks



' /////////////////////////////////////////////////////////////////////////////

' Draws colors in array arrColor across current 32-bit hires screen

' with a continuous transition between each color,

' at position xpos,ypos across width TotalWidth in a bar Totalheight high.



' Usage:

' DrawContinuousColor arrColor(), xpos, ypos, TotalWidth, TotalHeight



Sub DrawContinuousColor (arrColor() As _Unsigned Long, xpos As Integer, ypos As Integer, TotalWidth As Integer, TotalHeight As Integer)

    Dim cx As Integer

    Dim width As Integer

    Dim height As Integer

    Dim index As Integer

    Dim c1~&, c2~&, c~&

    Dim r, g, b As Integer

    Dim rc!, gc!, bc!

    Dim dr!, dg!, db!

    Dim x1 As Integer

    Dim NumSteps%



    If UBound(arrColor) > 0 Then

        width = TotalWidth / (UBound(arrColor) + 1)

        height = TotalHeight

        cx = xpos

        For index = LBound(arrColor) To UBound(arrColor)

            ' GET START COLOR

            c1~& = arrColor(index)



            ' GET NEXT COLOR

            If index < UBound(arrColor) Then

                c2~& = arrColor(index + 1)

            Else

                c2~& = arrColor(LBound(arrColor))

            End If



            ' DETERMINE HOW MUCH EACH CHANNEL MUST CHANGE TO REACH NEXT START COLOR IN width STEPS

            rc! = _Cast(Single, _Red32(arrColor(index)))

            gc! = _Cast(Single, _Green32(arrColor(index)))

            bc! = _Cast(Single, _Blue32(arrColor(index)))

            GetChannelDeltas c1~&, c2~&, width, dr!, dg!, db!



            ' PLOT COLORS BETWEEN START COLOR AND NEXT START COLOR

            For x1 = cx To (cx + width) - 1

                ' GET NEXT COLOR

                r = _Cast(Long, rc!)

                g = _Cast(Long, gc!)

                b = _Cast(Long, bc!)



                c~& = _RGB32(r, g, b)



                ' PLOT NEXT COLOR

                Line (x1, ypos)-(x1, (ypos + TotalHeight) - 1), c~&



                ' ADJUST CHANNELS TO PROGRESS TOWARD NEXT COLOR

                rc! = rc! + dr!

                If rc! < 0 Then

                    rc! = 0

                ElseIf rc! > 255 Then

                    rc! = 255

                End If



                gc! = gc! + dg!

                If gc! < 0 Then

                    gc! = 0

                ElseIf gc! > 255 Then

                    gc! = 255

                End If



                bc! = bc! + db!

                If bc! < 0 Then

                    bc! = 0

                ElseIf bc! > 255 Then

                    bc! = 255

                End If



            Next x1



            ' MOVE TO THE RIGHT TO NEXT DIVISION

            cx = cx + width

        Next index

    End If

End Sub ' DrawContinuousColor



' ################################################################################################################################################################

' BEGIN MISC FUNCTIONS

' ################################################################################################################################################################



' /////////////////////////////////////////////////////////////////////////////

' DRAW A 2-D RECTANGLE (SOLID)



' Usage:

' DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor



Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)

    Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, BF ' Draw a solid rectangle

End Sub ' DrawRectSolid



' /////////////////////////////////////////////////////////////////////////////

' Quick/dirty blunt force way to format a single value to a string

' with a certain # of decimal places. I'm sure this can be done in an

' easier way but had no internet when I wrote this and am tired! :-p



Function FormatSingle2$ (sngVal As Single, iPlaces As Integer)

    Dim sResult$, sVal$: Dim iPos%

    sVal$ = _ToStr$(sngVal)

    iPos% = InStr(1, sVal$, ".")

    If iPos% = 0 Then

        sResult$ = sVal$

        If iPlaces > 0 Then sResult$ = sResult$ + "." + String$(iPlaces, "0")

    Else

        sResult$ = Left$(sVal$, iPos% - 1)

        If iPlaces > 0 Then sResult$ = sResult$ + "." + Left$(Mid$(sVal$, iPos% + 1, iPlaces) + String$(iPlaces, "0"), iPlaces)

    End If

    FormatSingle2$ = sResult$

End Function ' FormatSingle2$



' /////////////////////////////////////////////////////////////////////////////

' Receives an initial color and a final color to transition to,

' and the # of steps/frames to transition, and returns the color channel

' deltas to smoothly transition to the final color in that many steps.



' Receives:

' c1~& = color to start from

' c2~& = color to arrive at

' NumSteps% = # of steps/frames for transition



' Returns (byref) the color channel deltas for a single step/frame:

' dr! = red color channel delta

' dg! = green "

' db! = blue "



' Usage:

' GetChannelDeltas c1~&, c2~&, NumSteps%, dr!, dg!, db!



Sub GetChannelDeltas (c1~&, c2~&, NumSteps%, dr!, dg!, db!)

    Dim r1&, g1&, b1& ' current color

    Dim r2&, g2&, b2& ' new color

    Dim rDiff&, gDiff&, bDiff& ' diff between each color channel for old/new colors

    Dim MaxDiff&



    ' Get rgb of old color

    r1& = _Red32(c1~&): g1& = _Green32(c1~&): b1& = _Blue32(c1~&)



    ' Get rgb of new color

    r2& = _Red32(c2~&): g2& = _Green32(c2~&): b2& = _Blue32(c2~&)



    ' get differences for each color channel

    rDiff& = r2& - r1&

    gDiff& = g2& - g1&

    bDiff& = b2& - b1&



    ' Get the ratio of change necessary to reach the target value between r,g,b

    ' That which needs the greatest change is 1 (100%)

    ' Those which need less change are a fraction of the greatest

    If Abs(rDiff&) >= Abs(gDiff&) And Abs(rDiff&) >= Abs(bDiff&) Then

        MaxDiff& = Abs(rDiff&)

        pr! = 1 * _IIf(r1& < r2&, 1, -1)

        pg! = (Abs(gDiff&) / Abs(rDiff&)) * _IIf(g1& < g2&, 1, -1)

        pb! = (Abs(bDiff&) / Abs(rDiff&)) * _IIf(b1& < b2&, 1, -1)

    ElseIf Abs(gDiff&) >= Abs(rDiff&) And Abs(gDiff&) >= Abs(bDiff&) Then

        MaxDiff& = Abs(gDiff&)

        pr! = (Abs(rDiff&) / Abs(gDiff&)) * _IIf(r1& < r2&, 1, -1)

        pg! = 1 * _IIf(g1& < g2&, 1, -1)

        pb! = (Abs(bDiff&) / Abs(gDiff&)) * _IIf(b1& < b2&, 1, -1)

    Else

        MaxDiff& = Abs(bDiff&)

        pr! = (Abs(rDiff&) / Abs(bDiff&)) * _IIf(r1& < r2&, 1, -1)

        pg! = (Abs(gDiff&) / Abs(bDiff&)) * _IIf(g1& < g2&, 1, -1)

        pb! = 1 * _IIf(b1& < b2&, 1, -1)

    End If



    ' Now determine how much to change each color channel each step (e.g., frame)

    ' to evenly arrive at new color when total steps or total time are complete

    dr! = (MaxDiff& * pr!) / NumSteps%

    dg! = (MaxDiff& * pg!) / NumSteps%

    db! = (MaxDiff& * pb!) / NumSteps%



End Sub ' GetChannelDeltas



' /////////////////////////////////////////////////////////////////////////////

' Splits a string in$ by delimeter delimiter$

' into an array result$().



' Split and join strings

' https://www.qb64.org/forum/index.php?topic=1073.0

'

' FROM luke, QB64 Developer

' Date: February 15, 2019, 04:11:07 AM

'

' Given a string of words separated by spaces (or any other character),

' splits it into an array of the words. I've no doubt many people have

' written a version of this over the years and no doubt there's a million

' ways to do it, but I thought I'd put mine here so we have at least one

' version. There's also a join function that does the opposite

' array -> single string.

'

' Code is hopefully reasonably self explanatory with comments and a little demo.

' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.



' Split in$ into pieces, chopping at every occurrence of delimiter$.

' Multiple consecutive occurrences of delimiter$ are treated as a single instance.

' The chopped pieces are stored in result$().



' delimiter$ must be one character long.

' result$() must have been REDIMmed previously.



' Modified to handle multi-character delimiters



Sub split (in$, delimiter$, result$())

    Dim start As Integer

    Dim finish As Integer

    Dim iDelimLen As Integer

    ReDim result$(-1)



    iDelimLen = Len(delimiter$)



    start = 1

    Do

        While Mid$(in$, start, iDelimLen) = delimiter$

            start = start + iDelimLen

            If start > Len(in$) Then

                Exit Sub

            End If

        Wend

        finish = InStr(start, in$, delimiter$)

        If finish = 0 Then

            finish = Len(in$) + 1

        End If



        ReDim _Preserve result$(0 To UBound(result$) + 1)



        result$(UBound(result$)) = Mid$(in$, start, finish - start)

        start = finish + 1

    Loop While start <= Len(in$)

End Sub ' split



' ################################################################################################################################################################

' END MISC FUNCTIONS

' ################################################################################################################################################################



' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' BEGIN RGB COLOR FUNCTIONS #RGB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



Function cRed~& ()

    cRed = _RGB32(255, 0, 0)

End Function



Function cOrangeRed~& ()

    cOrangeRed = _RGB32(255, 69, 0)

End Function



' added this because cOrangeRed feels too red

' and cDarkOrange & cOrange too yellow

Function cTrueOrange~& ()

    cTrueOrange = _RGB32(255, 100, 0)

End Function



Function cDarkOrange~& ()

    cDarkOrange = _RGB32(255, 140, 0)

End Function



Function cOrange~& ()

    cOrange = _RGB32(255, 165, 0)

End Function



Function cGold~& ()

    cGold = _RGB32(255, 215, 0)

End Function



Function cYellow~& ()

    cYellow = _RGB32(255, 255, 0)

End Function



' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:

Function cOliveDrab1~& ()

    cOliveDrab1 = _RGB32(192, 255, 62)

End Function



Function cLime~& ()

    cLime = _RGB32(0, 255, 0)

End Function



Function cMediumSpringGreen~& ()

    cMediumSpringGreen = _RGB32(0, 250, 154)

End Function



' ADDED THIS FOR THE GAUGE COLOR:

Function cSpringGreen~& ()

    cSpringGreen = _RGB32(0, 255, 160)

End Function



Function cCyan~& ()

    cCyan = _RGB32(0, 255, 255)

End Function



Function cDeepSkyBlue~& ()

    cDeepSkyBlue = _RGB32(0, 191, 255)

End Function



Function cDodgerBlue~& ()

    cDodgerBlue = _RGB32(30, 144, 255)

End Function



Function cSeaBlue~& ()

    cSeaBlue = _RGB32(0, 64, 255)

End Function



Function cBlue~& ()

    cBlue = _RGB32(0, 0, 255)

End Function



Function cBluePurple~& ()

    cBluePurple = _RGB32(64, 0, 255)

End Function



Function cDeepPurple~& ()

    cDeepPurple = _RGB32(96, 0, 255)

End Function



Function cPurple~& ()

    cPurple = _RGB32(128, 0, 255)

End Function



Function cPurpleRed~& ()

    cPurpleRed = _RGB32(128, 0, 192)

End Function



Function cDarkRed~& ()

    cDarkRed = _RGB32(160, 0, 64)

End Function



Function cBrickRed~& ()

    cBrickRed = _RGB32(192, 0, 32)

End Function



Function cDarkGreen~& ()

    cDarkGreen = _RGB32(0, 100, 0)

End Function



Function cGreen~& ()

    cGreen = _RGB32(0, 128, 0)

End Function



Function cOliveDrab~& ()

    cOliveDrab = _RGB32(107, 142, 35)

End Function



Function cLightPink~& ()

    cLightPink = _RGB32(255, 182, 193)

End Function



Function cHotPink~& ()

    cHotPink = _RGB32(255, 105, 180)

End Function



Function cDeepPink~& ()

    cDeepPink = _RGB32(255, 20, 147)

End Function



Function cMagenta~& ()

    cMagenta = _RGB32(255, 0, 255)

End Function



Function cBlack~& ()

    cBlack = _RGB32(0, 0, 0)

End Function



Function cDimGray~& ()

    cDimGray = _RGB32(105, 105, 105)

End Function



Function cGray~& ()

    cGray = _RGB32(128, 128, 128)

End Function



Function cDarkGray~& ()

    cDarkGray = _RGB32(169, 169, 169)

End Function



Function cSilver~& ()

    cSilver = _RGB32(192, 192, 192)

End Function



Function cLightGray~& ()

    cLightGray = _RGB32(211, 211, 211)

End Function



Function cGainsboro~& ()

    cGainsboro = _RGB32(220, 220, 220)

End Function



Function cWhiteSmoke~& ()

    cWhiteSmoke = _RGB32(245, 245, 245)

End Function



Function cWhite~& ()

    cWhite = _RGB32(255, 255, 255)

End Function



Function cDarkBrown~& ()

    cDarkBrown = _RGB32(128, 64, 0)

End Function



Function cLightBrown~& ()

    cLightBrown = _RGB32(196, 96, 0)

End Function



Function cKhaki~& ()

    cKhaki = _RGB32(240, 230, 140)

End Function



Function cEmpty~& ()

    cEmpty = _RGB32(0, 0, 0, 0)

End Function



' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' END RGB COLOR FUNCTIONS @RGB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' BEGIN TEST ALPHA COLORS

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Function cDimGrayAlpha~& (alpha&)

    cDimGrayAlpha = _RGB32(105, 105, 105, alpha&)

End Function



Function cGrayAlpha~& (alpha&)

    cGrayAlpha = _RGB32(128, 128, 128, alpha&)

End Function



Function cDarkGrayAlpha~& (alpha&)

    cDarkGrayAlpha = _RGB32(169, 169, 169, alpha&)

End Function



Function cSilverAlpha~& (alpha&)

    cSilverAlpha = _RGB32(192, 192, 192, alpha&)

End Function



Function cLightGrayAlpha~& (alpha&)

    cLightGrayAlpha = _RGB32(211, 211, 211, alpha&)

End Function



Function cGainsboroAlpha~& (alpha&)

    cGainsboroAlpha = _RGB32(220, 220, 220, alpha&)

End Function



Function cWhiteSmokeAlpha~& (alpha&)

    cWhiteSmokeAlpha = _RGB32(245, 245, 245, alpha&)

End Function



Function cWhiteAlpha~& (alpha&)

    cWhiteAlpha = _RGB32(255, 255, 255, alpha&)

End Function

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' END TEST ALPHA COLORS

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



' ################################################################################################################################################################

' BEGIN COLOR ARRAY FUNCTIONS #COLR

' ################################################################################################################################################################



' /////////////////////////////////////////////////////////////////////////////

' Append color ColorValue to array arrColor



Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)

    ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long

    arrColor(UBound(arrColor)) = ColorValue

End Sub ' AddColor



' /////////////////////////////////////////////////////////////////////////////

' Adds colors colors to array arrColor().

' the first 8 colors are solid (alpha=255)

' the last  8 colors are transparent (alpha = parameter alpha&)



Sub AddTestColors (arrColor() As _Unsigned Long)

    ' SOLID:

    AddColor cRed, arrColor()

    AddColor cTrueOrange, arrColor()

    AddColor cYellow, arrColor()

    AddColor cLime, arrColor()

    AddColor cCyan, arrColor()

    AddColor cBlue, arrColor()

    AddColor cMagenta, arrColor()

    AddColor cBlack, arrColor()



    ' TRANSPARENT:

    Dim alpha&: alpha& = 256

    alpha& = alpha& - 30

    AddColor cDimGrayAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cGrayAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cDarkGrayAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cSilverAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cLightGrayAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cGainsboroAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cWhiteSmokeAlpha~&(alpha&), arrColor()

    alpha& = alpha& - 30

    AddColor cWhiteAlpha~&(alpha&), arrColor()

End Sub ' AddTestColors



' /////////////////////////////////////////////////////////////////////////////

' Adds rainbow colors to array arrColor().

' madscijr attempt #2 to pick evenly distributed colors across spectrum



Sub AddSpectrum2Colors (arrColor() As _Unsigned Long)

    AddColor _RGB32(255, 0, 0), arrColor()

    AddColor _RGB32(255, 69, 0), arrColor()

    AddColor _RGB32(255, 100, 0), arrColor()

    AddColor _RGB32(255, 140, 0), arrColor()

    AddColor _RGB32(255, 165, 0), arrColor()

    AddColor _RGB32(255, 215, 0), arrColor()

    AddColor _RGB32(255, 255, 0), arrColor()

    AddColor _RGB32(192, 255, 62), arrColor()

    AddColor _RGB32(128, 255, 24), arrColor()

    AddColor _RGB32(0, 255, 0), arrColor()

    AddColor _RGB32(0, 196, 0), arrColor()

    AddColor _RGB32(0, 224, 64), arrColor()

    AddColor _RGB32(0, 255, 112), arrColor()

    AddColor _RGB32(0, 255, 136), arrColor()

    AddColor _RGB32(0, 255, 255), arrColor()

    AddColor _RGB32(0, 191, 255), arrColor()

    AddColor _RGB32(30, 144, 255), arrColor()

    AddColor _RGB32(0, 64, 255), arrColor()

    AddColor _RGB32(0, 0, 255), arrColor()

    AddColor _RGB32(80, 0, 255), arrColor()

    AddColor _RGB32(96, 0, 255), arrColor()

    AddColor _RGB32(128, 0, 255), arrColor()

    AddColor _RGB32(160, 0, 192), arrColor()

    AddColor _RGB32(224, 0, 96), arrColor()

    AddColor _RGB32(255, 0, 32), arrColor()

End Sub ' AddSpectrum2Colors



' /////////////////////////////////////////////////////////////////////////////

' Adds rainbow colors to array arrColor().

' madscijr attempt #1 to pick evenly distributed colors across spectrum



Sub AddSpectrumColors (arrColor() As _Unsigned Long)

    AddColor cRed, arrColor()

    AddColor cOrangeRed, arrColor()

    AddColor cDarkOrange, arrColor()

    AddColor cOrange, arrColor()

    AddColor cGold, arrColor()

    AddColor cYellow, arrColor()

    AddColor cOliveDrab1, arrColor()

    AddColor cLime, arrColor()

    AddColor cMediumSpringGreen, arrColor()

    AddColor cSpringGreen, arrColor()

    AddColor cCyan, arrColor()

    AddColor cDeepSkyBlue, arrColor()

    AddColor cDodgerBlue, arrColor()

    AddColor cSeaBlue, arrColor()

    AddColor cBlue, arrColor()

    AddColor cBluePurple, arrColor()

    AddColor cDeepPurple, arrColor()

    AddColor cPurple, arrColor()

    AddColor cPurpleRed, arrColor()

End Sub ' AddSpectrumColors



' /////////////////////////////////////////////////////////////////////////////

' Adds grayscale colors to array arrColor().



Sub AddGrayscaleColors (arrColor() As _Unsigned Long)

    AddColor cDimGray, arrColor()

    AddColor cGray, arrColor()

    AddColor cDarkGray, arrColor()

    AddColor cSilver, arrColor()

    AddColor cLightGray, arrColor()

    AddColor cGainsboro, arrColor()

    AddColor cWhiteSmoke, arrColor()

    AddColor cWhite, arrColor() '* 2

    AddColor cWhiteSmoke, arrColor()

    AddColor cGainsboro, arrColor()

    AddColor cLightGray, arrColor()

    AddColor cSilver, arrColor()

    AddColor cDarkGray, arrColor()

    AddColor cGray, arrColor()

End Sub ' AddGrayscaleColors



' /////////////////////////////////////////////////////////////////////////////



Sub GetMadsciHslSpectrum (arrColor() As _Unsigned Long, NumDivisions As Integer)

    Dim hue#, dhue#, sat#, dsat#

    Dim c~&

    Dim iLoop%

    If NumDivisions <> 0 Then ' protect against divide by 0

        hue# = 0

        dhue# = 360 / NumDivisions

        sat# = 100

        dsat# = 0

        For iLoop% = 1 To NumDivisions

            ' GENERATE + ADD NEXT COLOR

            c~& = _HSBA32(hue#, sat#, 100, 100)

            AddColor c~&, arrColor()



            ' INCREMENT COLOR

            hue# = hue# + dhue#

            If hue# > 359 Then

                hue# = 0

            End If

            sat# = sat# + dsat#

            If sat# <= 0 Then

                sat# = 0: dsat# = -dsat#

            ElseIf sat# >= 100 Then

                sat# = 100: dsat# = -dsat#

            End If

        Next iLoop%

    End If

End Sub ' GetMadsciHslSpectrum



' /////////////////////////////////////////////////////////////////////////////

' Sprezzo modified to use hpRGB function

' https://qb64phoenix.com/forum/showthread...7#pid33637

'

' Sprezzo, Junior Member

' 4/19/2025 11:36 PM

' ey bud, try this for a color wheel.

' i promise you wont find it elsewhere unless the AI already scraped me



Sub GetSprezzoHslSpectrum (arrColor() As _Unsigned Long, NumDivisions As Integer)

    Dim hue#, dhue#, sat#, dsat#

    Dim c~&

    Dim iLoop%



    If NumDivisions <> 0 Then ' protect against divide by 0

        hue# = 0

        dhue# = 360 / NumDivisions

        sat# = 0

        dsat# = 100 / (NumDivisions * -.25)



        For iLoop% = 1 To NumDivisions

            ' GENERATE + ADD NEXT COLOR

            ' c~& = hpRGB~&(hue# / 360, .25) ' THIS

            c~& = rainbow~&(hue# / 360)

            AddColor c~&, arrColor()



            ' INCREMENT COLOR

            hue# = hue# + dhue#

            If hue# > 359 Then

                hue# = 0

            End If

            sat# = sat# + dsat#

            If sat# <= 0 Then

                sat# = 0: dsat# = -dsat#

            ElseIf sat# >= 100 Then

                sat# = 100: dsat# = -dsat#

            End If

        Next iLoop%

    End If

End Sub ' GetSprezzoHslSpectrum

'Function hpRGB~& (h As Double, p As Double)

'    Const pi = 3.14159

'    Dim As Double r0, g0, b0

'    Dim As Double r, g, b

'    Dim As Double x, f, m, hh

'    hh = h ^ 1.5

'    x = pi * (hh + 1 / 2)

'    r0 = Abs(Sin(x))

'    g0 = Abs(Sin(x - pi / 3))

'    b0 = Abs(Sin(x + pi / 3))

'    f = p * (1 - r0 - g0 - b0)

'    r = r0 + f

'    g = g0 + f

'    b = b0 + f

'    m = 1 / Max3##(r, g, b)

'    r = r * m

'    g = g * m

'    b = b * m

'    If (r < 0) Then r = 0

'    If (g < 0) Then g = 0

'    If (b < 0) Then b = 0

'    hpRGB~& = _RGB32(r * 255, g * 255, b * 255, 255)

'End Function ' hpRGB~&

'Function Max3## (x As Double, y As Double, z As Double)

'    Dim TheReturn As Double

'    TheReturn = x

'    If (y > TheReturn) Then TheReturn = y

'    If (z > TheReturn) Then TheReturn = z

'    Max3## = TheReturn

'End Function ' Max3##



' /////////////////////////////////////////////////////////////////////////////

' Returns a random color chosen from array of color values arrColor().



' Usage:

' c~& = GetRandomColor~& (arrColor())



Function GetRandomColor~& (arrColor() As _Unsigned Long)

    Dim index As Integer

    index = RandomNumber%(LBound(arrColor), UBound(arrColor))

    GetRandomColor~& = arrColor(index)

End Function ' GetRandomColor~&



' /////////////////////////////////////////////////////////////////////////////

' Returns a random color chosen from array of color values arrColor(),

' but makes sure it isn't a color in array arrNotColor().



' Usage:

' c~& = GetRandomColorExcept~& (arrColor(), arrNotColor())



Function GetRandomColorExcept~& (arrColor() As _Unsigned Long, arrNotColor() As _Unsigned Long)

    Dim index1, index2 As Integer

    Dim c~&

    Dim bFound As Integer

    Dim iCount As Integer: iCount = 0 ' count # of tries

    Dim iMax As Integer: iMax = 1000 ' if we don't find it in 1000 tries, just exit

    Do

        index1 = RandomNumber%(LBound(arrColor), UBound(arrColor))

        c~& = arrColor(index1)

        bFound = _TRUE

        For index2 = LBound(arrNotColor) To UBound(arrNotColor)

            If arrNotColor(index2) = c~& Then bFound = _FALSE: Exit For

        Next index2

        If bFound = _TRUE Then Exit Do

        iCount = iCount + 1: If iCount > iMax Then c~& = _FALSE: Exit Do ' if we haven't found it by now, give up!

    Loop

    GetRandomColorExcept~& = c~&

End Function ' GetRandomColor~&



' ################################################################################################################################################################

' END COLOR ARRAY FUNCTIONS @COLR

' ################################################################################################################################################################



Function rainbow~& (h As Double)

    rainbow~& = hMultiGrad~&(h, RainbowSpec())

End Function



Function hMultiGrad~& (h As Double, ShadeArray() As _Unsigned Long)

    Dim As Integer w, j

    Dim As Double r, g, b, wt, f, k

    w = UBound(ShadeArray)

    For j = 1 To w

        k = h * w - (j - 1)

        If (k > w / 2) Then k = k - w

        If (k < -w / 2) Then k = k + w

        If (1 = 1) Then ' linear

            f = 1 - Abs(k)

            If (f < 0) Then f = 0

        ElseIf (0 = 1) Then ' gauss

            f = Exp(-2 * k ^ 2)

        ElseIf (0 = 1) Then ' cosine

            f = Cos(2 * Pi * k / w)

            If (f < 0) Then f = 0 Else f = f ^ 2

        End If

        r = r + f * _Red32(ShadeArray(j))

        g = g + f * _Green32(ShadeArray(j))

        b = b + f * _Blue32(ShadeArray(j))

        wt = wt + f

    Next

    hMultiGrad~& = _RGB32(r / wt, g / wt, b / wt, 255)

End Function

[Image: linear.png]

[Image: gaussian.png]

[Image: trig.png]
Find
Reply
madscijr Offline
Mini-Mod
***
Posts: 1,215
Threads: 162
Joined: Apr 2022
Reputation: 34
#3
04-30-2025, 04:17 AM
It's beautiful! Can't wait to play with the code, thanks!
Find
Reply


Possibly Related Threads…
Thread Author Replies Views Last Post
  WinAPI Mouse Demo Pete 0 183 12-20-2025, 06:40 PM
Last Post: Pete
  Hyperlink Demo in SCREEN 0 Pete 2 361 11-02-2025, 07:13 PM
Last Post: madscijr
  color wheel animation / screensaver madscijr 3 1,032 04-20-2025, 07:20 PM
Last Post: madscijr
  Email Demo (from 6/6/2014) SMcNeill 0 594 11-13-2023, 06:39 AM
Last Post: SMcNeill
  Qix Demo james2464 4 1,091 11-23-2022, 07:01 PM
Last Post: johnno56

Forum Jump:


Users browsing this thread: 1 Guest(s)