+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Help Me! (https://qb64phoenix.com/forum/forumdisplay.php?fid=10)
+---- Thread: flood fill ? (/showthread.php?tid=3631)
flood fill ? - madscijr - 04-23-2025
I was playing with drawing some things and have one question - to do a flood fill, the paint command accepts a border color where it stops.
However it overwrites everything else. how do you get it to stop at any color where the alpha value > 0 ?
Or else does someone have a fast flood fill routine that does that?
Any help appreciated...
Code: (Select All)
_Title "Shapes drawing demo test #1 by madscijr"
' Q: How can you make paint on line 713 stop at any color with alpha > 0 or is NOT _RGB32(0, 0, 0, 0) ?
' KEYCODES FOR _BUTTON (EXCEPT WHERE STATED)
Const KeyCode_Escape = 2
Const KeyCode_F1 = 60
Const KeyCode_F2 = 61
Const KeyCode_F3 = 62
Const KeyCode_F4 = 63
Const KeyCode_F5 = 64
Const KeyCode_F6 = 65
Const KeyCode_F7 = 66
Const KeyCode_F8 = 67
Const KeyCode_F9 = 68
Const KeyCode_F10 = 17408 '_KEYDOWN CODE, NOT _BUTTON CODE
Const KeyCode_F11 = 88
Const KeyCode_F12 = 89
Const KeyCode_PrintScreen = -44 '_KEYHIT CODE, NOT _BUTTON CODE
Const KeyCode_ScrollLock = 71
Const KeyCode_PauseBreak = 31053 '_KEYHIT CODE, NOT _BUTTON CODE
Const KeyCode_Tilde = 42
Const KeyCode_1 = 3
Const KeyCode_2 = 4
Const KeyCode_3 = 5
Const KeyCode_4 = 6
Const KeyCode_5 = 7
Const KeyCode_6 = 8
Const KeyCode_7 = 9
Const KeyCode_8 = 10
Const KeyCode_9 = 11
Const KeyCode_0 = 12
Const KeyCode_Minus = 13
Const KeyCode_Equal = 14
Const KeyCode_BkSp = 15
Const KeyCode_Ins = 339
Const KeyCode_Home = 328
Const KeyCode_PgUp = 330
Const KeyCode_Del = 340
Const KeyCode_End = 336
Const KeyCode_PgDn = 338
Const KeyCode_NumLock = 326
Const KeyCode_KeypadSlash = 310
Const KeyCode_KeypadMultiply = 56
Const KeyCode_KeypadMinus = 75
Const KeyCode_Keypad7Home = 72
Const KeyCode_Keypad8Up = 73
Const KeyCode_Keypad9PgUp = 74
Const KeyCode_KeypadPlus = 79
Const KeyCode_Keypad4Left = 76
Const KeyCode_Keypad5 = 77
Const KeyCode_Keypad6Right = 78
Const KeyCode_Keypad1End = 80
Const KeyCode_Keypad2Down = 81
Const KeyCode_Keypad3PgDn = 82
Const KeyCode_KeypadEnter = 285
Const KeyCode_Keypad0Ins = 83
Const KeyCode_KeypadPeriodDel = 84
Const KeyCode_Tab = 16
Const KeyCode_Q = 17
Const KeyCode_W = 18
Const KeyCode_E = 19
Const KeyCode_R = 20
Const KeyCode_T = 21
Const KeyCode_Y = 22
Const KeyCode_U = 23
Const KeyCode_I = 24
Const KeyCode_O = 25
Const KeyCode_P = 26
Const KeyCode_BracketLeft = 27
Const KeyCode_BracketRight = 28
Const KeyCode_Backslash = 44
Const KeyCode_CapsLock = 59
Const KeyCode_A = 31
Const KeyCode_S = 32
Const KeyCode_D = 33
Const KeyCode_F = 34
Const KeyCode_G = 35
Const KeyCode_H = 36
Const KeyCode_J = 37
Const KeyCode_K = 38
Const KeyCode_L = 39
Const KeyCode_Semicolon = 40
Const KeyCode_Apostrophe = 41
Const KeyCode_Enter = 29
Const KeyCode_ShiftLeft = 43
Const KeyCode_Z = 45
Const KeyCode_X = 46
Const KeyCode_C = 47
Const KeyCode_V = 48
Const KeyCode_B = 49
Const KeyCode_N = 50
Const KeyCode_M = 51
Const KeyCode_Comma = 52
Const KeyCode_Period = 53
Const KeyCode_Slash = 54
Const KeyCode_ShiftRight = 55
Const KeyCode_Up = 329
Const KeyCode_Left = 332
Const KeyCode_Down = 337
Const KeyCode_Right = 334
Const KeyCode_CtrlLeft = 30
Const KeyCode_WinLeft = 348
Const KeyCode_AltLeft = -30764 ' _KEYHIT CODE NOT _BUTTON CODE
Const KeyCode_Spacebar = 58
Const KeyCode_AltRight = -30765 ' _KEYHIT CODE NOT _BUTTON CODE
Const KeyCode_WinRight = 349
Const KeyCode_Menu = 350
Const KeyCode_CtrlRight = 286
DrawTest
System
' /////////////////////////////////////////////////////////////////////////////
Sub DrawTest
Dim iLastKeyCode%: iLastKeyCode% = 0 ' for reading keys with _BUTTON
Dim bFinished As Integer: bFinished = _FALSE
Dim k$, LastKey$: LastKey$ = ""
ReDim arrColor(0 To 0) As _Unsigned Long
ReDim arrGray(0 To 0) As _Unsigned Long
ReDim arrNotColor(0 To 1) As _Unsigned Long
Dim index As Integer
Dim xmin, ymin As Integer
Dim xmax, ymax As Integer
Dim iX, iY, iSize, iSizeW, iSizeH, iRadius, iThickness, iWeight, iStyle, x1, y1, x2, y2, x3, y3 As Integer
Dim x!, y!, radius!, thickness!
Dim fgColor, bgColor As _Unsigned Long
Dim ScreenColor As _Unsigned Long
Dim iLoop As Integer
Dim delim$: delim$ = Chr$(9)
ReDim arrHelp(-1) As String
Dim in$
Dim ColNum, RowNum, NextCol, bStartOdd, MsgRow As Integer
Dim MaxCols, MaxRows, MaxLen As Integer
Dim iCharCode As Integer
Dim imgHelp&
Dim imgDraw&
' MOUSE VARS
Dim PointerSize As Integer
Dim MouseColor~&
Dim mx, my As Integer ' mouse pointer
Dim iWheel As Integer ' mouse wheel
Dim bButton1 As Integer
Dim bButton2 As Integer
Dim bButton3 As Integer
Dim bOldButton1 As Integer
Dim bOldButton2 As Integer
Dim bOldButton3 As Integer
Dim bClickButton1 As Integer
Dim bClickButton2 As Integer
Dim bClickButton3 As Integer
Dim imgMouse&
' INTIALIZE
Randomize Timer
xmin = 0: ymin = 0: xmax = 800: ymax = 600 'xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1
ScreenColor = cBlack
AddSpectrumColors arrColor()
AddGrayscaleColors arrGray()
arrNotColor(0) = ScreenColor: arrNotColor(1) = ScreenColor
PointerSize = 10: MouseColor~& = cWhite
iCharCode = 64
' INIT MOUSE STATE
bOldButton1 = _FALSE
bOldButton2 = _FALSE
bOldButton3 = _FALSE
bClickButton1 = _FALSE
bClickButton2 = _FALSE
bClickButton3 = _FALSE
' INIT HELP
in$ = ""
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "1 = BOX OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "2 = SOLID BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "3 = RECTANGLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "4 = CIRCLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "5 = CIRCLE OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "6 = RECTANGLE OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "7 = SOLID RECTANGLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "8 = SQUARE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "9 = OUTLINE BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "0 = STYLED OUTLINE BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "A = TRIANGLE FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "C = THICK CIRCLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "L = THICK LINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "T = TEXT"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "F = FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "HOME = CLEAR SCREEN"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "ESC = QUIT"
split in$, delim$, arrHelp()
' PAD WITH SPACES SO ALL ARE EQUAL LENGTH
MaxLen = 0
For index = LBound(arrHelp) To UBound(arrHelp)
If Len(arrHelp(index)) > MaxLen Then MaxLen = Len(arrHelp(index))
Next index
For index = LBound(arrHelp) To UBound(arrHelp)
If Len(arrHelp(index)) < MaxLen Then arrHelp(index) = Left$(arrHelp(index) + String$(MaxLen, " "), MaxLen)
Next index
' INIT SCREEN
Screen _NewImage(xmax, ymax, 32)
_Display
_ScreenMove 0, 0
_Dest 0: Cls , ScreenColor
MaxCols = (xmax / _FontWidth)
MaxRows = (ymax / _FontHeight)
' INIT LAYERS
InitImage imgDraw&, xmax, ymax, cEmpty
InitImage imgHelp&, xmax, ymax, cEmpty
InitImage imgMouse&, xmax, ymax, cEmpty
_Dest imgDraw&: Cls , cEmpty
' SHOW MENU CHOICES AT TOP
_Dest imgHelp&: Cls , cEmpty
RowNum = 1: ColNum = 1: ColCount = 0
For index = LBound(arrHelp) To UBound(arrHelp)
If RowNum > MaxRows Then Exit For
ColCount = ColCount + 1
' ALTERNATE COLORS
If IsOdd%(RowNum) Then
If IsOdd(ColCount) Then
Color cWhite, cDarkGray ' cDarkGray cGray cSilver cWhite
Else
Color cBlack, cSilver
End If
Else
If IsOdd(ColCount) Then
Color cBlack, cSilver
Else
Color cBlack, cDarkGray ' cDarkGray cGray cSilver cWhite
End If
End If
Locate RowNum, ColNum
Print " " + arrHelp(index) + " ";
If index < UBound(arrHelp) Then
ColNum = ColNum + Len(arrHelp(index)) + 2
NextCol = ColNum + Len(arrHelp(index + 1)) + 2
If NextCol > MaxCols Then
ColNum = 1: RowNum = RowNum + 1: ColCount = 0
End If
End If
Next index
RowNum = RowNum + 1: MsgRow = RowNum
RowNum = RowNum + 1: ymin = RowNum * _FontHeight
' MAIN LOOP
Do
' GET MOUSE COORDINATES
While _MouseInput: Wend
mx = _MouseX
my = _MouseY
If mx < xmin Then
mx = xmin
ElseIf mx > xmax Then
mx = xmax
End If
If my < ymin Then
my = ymin
ElseIf my > ymax Then
my = ymax
End If
' DRAW CROSSHAIR FOR MOUSE
_Dest imgMouse&: Cls , cEmpty
Line (mx - (PointerSize / 2), my)-(mx + (PointerSize / 2), my), MouseColor~&
Line (mx, my - (PointerSize / 2))-(mx, my + (PointerSize / 2)), MouseColor~&
'' GET MOUSE WHEEL INPUT
'While _MouseInput
' iR = iR + _MouseWheel * 5
' If iR < iMinR Then
' iR = iMinR
' ElseIf iR > iMaxR Then
' iR = iMaxR
' End If
'Wend
' READ BUTTONS
bButton1 = _MouseButton(1)
bButton2 = _MouseButton(2)
bButton3 = _MouseButton(3)
ToggleButtonState bButton1, bOldButton1, bClickButton1
ToggleButtonState bButton2, bOldButton2, bClickButton2
ToggleButtonState bButton3, bOldButton3, bClickButton3
' BUTTONS CHANGE COLOR
If bClickButton1 = _TRUE Then
iC = iC + 1: If iC > iMaxColor Then iC = iMinColor
ElseIf bClickButton2 = _TRUE Then
iC = iC - 1: If iC < iMinColor Then iC = iMaxColor
ElseIf bClickButton3 = _TRUE Then
iC = iMinColor
End If
' DO ANY DRAWING ON DRAW LAYER
_Dest imgDraw&
' PROCESS KEYBOARD INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape) Then
' ESC = QUIT
iLastKeyCode% = KeyCode_Escape
bFinished = _TRUE
ElseIf _Button(KeyCode_1) Then
If iLastKeyCode% <> KeyCode_1 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_1: LastKey$ = ""
' 1 = BOX OUTLINE
iSize = RandomNumber%(100, 200)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawBoxOutline iX, iY, iSize, fgColor
in$ = left$( _
"DrawBoxOutline " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_2) Then
If iLastKeyCode% <> KeyCode_2 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_2: LastKey$ = ""
' 2 = SOLID BOX
iSize = RandomNumber%(100, 200)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawBoxSolid iX, iY, iSize, fgColor
in$ = left$( _
"DrawBoxSolid " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_3) Then
If iLastKeyCode% <> KeyCode_3 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_3: LastKey$ = ""
' 3 = RECTANGLE
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRect imgDraw&, iX, iY, iSizeW, iSizeH, fgColor, bgColor
in$ = left$( _
"DrawRect " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_4) Then
If iLastKeyCode% <> KeyCode_4 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_4: LastKey$ = ""
' 4 = CIRCLE
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iRadius = RandomNumber%(75, 125)
iThickness = RandomNumber%(10, 20)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawCircle imgDraw&, iX, iY, iRadius, iThickness, fgColor, bgColor
in$ = left$( _
"DrawCircle " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_5) Then
If iLastKeyCode% <> KeyCode_5 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_5: LastKey$ = ""
' 5 = CIRCLE OUTLINE
iRadius = RandomNumber%(125, 175)
iX = RandomNumber%(xmin, xmax - iRadius)
iY = RandomNumber%(ymin, ymax - iRadius)
iThickness = RandomNumber%(25, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawCircleOutline imgDraw&, iX, iY, iRadius, iThickness, fgColor
in$ = left$( _
"**FAILS?** DrawCircleOutline " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cRed: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_6) Then
If iLastKeyCode% <> KeyCode_6 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_6: LastKey$ = ""
' 6 = RECTANGLE OUTLINE
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
in$ = left$( _
"DrawRectOutline " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_7) Then
If iLastKeyCode% <> KeyCode_7 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_7: LastKey$ = ""
' 7 = SOLID RECTANGLE
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
in$ = left$( _
"DrawRectSolid " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_8) Then
If iLastKeyCode% <> KeyCode_8 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_8: LastKey$ = ""
' 8 = SQUARE
iSize = RandomNumber%(100, 150)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawSquare imgDraw&, iX, iY, iSize, fgColor, bgColor
in$ = left$( _
"**FAILS?** DrawSquare " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cRed: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_9) Then
If iLastKeyCode% <> KeyCode_9 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_9: LastKey$ = ""
' 9 = OUTLINE BOX
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iSize = RandomNumber%(100, 150)
index = RandomNumber%(LBound(arrColor), UBound(arrColor)): fgColor = arrColor(index)
iWeight = RandomNumber%(6, 12)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawOutlineBox iX, iY, iSize, fgColor, iWeight
in$ = left$( _
"DrawOutlineBox " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"iWeight=" + _ToStr$(iWeight) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_0) Then
If iLastKeyCode% <> KeyCode_0 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_0: LastKey$ = ""
' 0 = STYLED OUTLINE BOX
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iSize = RandomNumber%(90, 130)
index = RandomNumber%(LBound(arrGray), UBound(arrGray)): fgColor = arrGray(index)
iStyle = RandomNumber%(0, 255)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawStyledOutlineBox iX, iY, iSize, fgColor, iStyle
in$ = left$( _
"DrawStyledOutlineBox " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"iStyle=" + _ToStr$(iStyle) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_A) Then
If iLastKeyCode% <> KeyCode_A Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_A: LastKey$ = ""
' A = TRIANGLE FILL
x1 = RandomNumber%(xmin, xmax - iSize)
y1 = RandomNumber%(ymin, ymax - iSize)
x2 = RandomNumber%(xmin, xmax - iSize)
y2 = RandomNumber%(ymin, ymax - iSize)
x3 = RandomNumber%(xmin, xmax - iSize)
y3 = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
TriangleFill x1, y1, x2, y2, x3, y3, fgColor
in$ = left$( _
"TriangleFill " + _
"x1=" + _ToStr$(x1) + ", " + _
"y1=" + _ToStr$(y1) + ", " + _
"x2=" + _ToStr$(x2) + ", " + _
"y2=" + _ToStr$(y2) + ", " + _
"x3=" + _ToStr$(x3) + ", " + _
"y3=" + _ToStr$(y3) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_C) Then
If iLastKeyCode% <> KeyCode_C Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_C: LastKey$ = ""
' C = THICK CIRCLE
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iRadius = RandomNumber%(50, 100)
iThickness = RandomNumber%(15, 30)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
ThickCircle iX, iY, iRadius, iThickness, fgColor
in$ = left$( _
"ThickCircle " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_L) Then
If iLastKeyCode% <> KeyCode_L Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_L: LastKey$ = ""
' L = THICK LINE
x1 = RandomNumber%(xmin, xmax - iSize)
y1 = RandomNumber%(ymin, ymax - iSize)
x2 = RandomNumber%(xmin, xmax - iSize)
y2 = RandomNumber%(ymin, ymax - iSize)
iThickness = RandomNumber%(1, 5)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
ThickLine x1, y1, x2, y2, iThickness, fgColor
in$ = left$( _
"ThickLine " + _
"x1=" + _ToStr$(x1) + ", " + _
"y1=" + _ToStr$(y1) + ", " + _
"x2=" + _ToStr$(x2) + ", " + _
"y2=" + _ToStr$(y2) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_T) Then
If iLastKeyCode% <> KeyCode_T Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_T: LastKey$ = ""
' T = TEXT
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iCharCode = iCharCode + 1: If iCharCode > 90 Then iCharCode = 65
iSize = RandomNumber%(1, 8)
in$ = String$(iSize, Chr$(iCharCode))
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
Color fgColor, bgColor
_PrintString (iX, iY), in$
in$ = left$( _
"Color " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + " : " + _
"_PrintString " + _
"(" + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"), " + _
"in$=" + chr$(34) + in$ + chr$(34) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_F) Then
If iLastKeyCode% <> KeyCode_F Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_F: LastKey$ = ""
' F = FILL
iX = mx
iY = my
arrNotColor(1) = fgColor ' use previous shape's color as border color
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
Paint (iX, iY), bgColor, fgColor ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
End If
ElseIf _Button(KeyCode_Home) Or _Button(KeyCode_Keypad7Home) Then
If iLastKeyCode% <> KeyCode_Home Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Home: LastKey$ = ""
' HOME = CLS
_Dest imgDraw&: Cls , cEmpty
End If
Else
' Clear last keycode pressed (since it wasn't any of those)
iLastKeyCode% = 0
' -----------------------------------------------------------------------------
' SEE IF ANY OTHER KEYS WERE PRESSED USING InKey$
' -----------------------------------------------------------------------------
k$ = InKey$
If Len(k$) Then
' Remember last InKey$ pressed
LastKey$ = k$
Else
' Clear last key pressed
LastKey$ = ""
End If
End If
_KeyClear ' CLEAR KEYBOARD BUFFER
' DRAW LAYERS
_Dest 0: Cls , ScreenColor
_PutImage , imgDraw&, 0
_PutImage , imgHelp&, 0
_PutImage , imgMouse&, 0
If bFinished = _TRUE Then Exit Do
_Display
Loop Until _KeyDown(27)
' RELEASE OBJECTS FROM MEMORY
Screen 0
FreeImage imgDraw&
FreeImage imgHelp&
FreeImage imgMouse&
' RESTORE DISPLAY
_AutoDisplay
End Sub ' DrawTest
' ################################################################################################################################################################
' BEGIN SHAPE DRAWING ROUTINES #SHAPE #DRAW
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
'DrawBoxOutline iX, iY, iSize, fgColor
Sub DrawBoxOutline (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, B ' Draw box outline
End Sub ' DrawBoxOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (SOLID)
' https://www.qb64.org/wiki/LINE
' Renamed DrawBox/DrawBoxLine to DrawSolidBox
'DrawBoxSolid iX, iY, iSize, fgColor
Sub DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, BF ' Draw a solid box
End Sub ' DrawBoxSolid
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
Sub DrawCircle (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Dim iLoop As Integer
Dim iNextRadius As Integer
Dim iRadiusError As Integer
Dim iNextX As Integer
Dim iNextY As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw circle fill
If bgColor <> cEmpty Then
iNextRadius = Abs(iRadius)
iRadiusError = -iNextRadius
iNextX = iNextRadius
iNextY = 0
If iNextRadius = 0 Then
PSet (iX, iY), bgColor
Else
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (iX - iNextX, iY)-(iX + iNextX, iY), bgColor, BF
While iNextX > iNextY
iRadiusError = iRadiusError + iNextY * 2 + 1
If iRadiusError >= 0 Then
If iNextX <> iNextY + 1 Then
Line (iX - iNextY, iY - iNextX)-(iX + iNextY, iY - iNextX), bgColor, BF
Line (iX - iNextY, iY + iNextX)-(iX + iNextY, iY + iNextX), bgColor, BF
End If
iNextX = iNextX - 1
iRadiusError = iRadiusError - iNextX * 2
End If
iNextY = iNextY + 1
Line (iX - iNextX, iY - iNextY)-(iX + iNextX, iY - iNextY), bgColor, BF
Line (iX - iNextX, iY + iNextY)-(iX + iNextX, iY + iNextY), bgColor, BF
Wend
End If
End If
' Draw circle outline
If fgColor <> cEmpty Then
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
iNextRadius = iRadius
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End If
End Sub ' DrawCircle
' /////////////////////////////////////////////////////////////////////////////
'DrawCircleOutline 0, iX, iY, iRadius, iThickness, fgColor
Sub DrawCircleOutline (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long)
Dim iNextRadius As Integer
Dim iLoop As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Initialize
iNextRadius = iRadius
' Draw circle
If Radius = 0 Then
PSet (iX, iY), fgColor
Else
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End Sub ' DrawCircleOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE) WITH A SOLID LINE
'DrawOutlineBox iX%, iY%, iSize2%, iColor~&, iWeight2%
Sub DrawOutlineBox (iX%, iY%, iSize2%, iColor~&, iWeight2%)
Dim iFromX%
Dim iFromY%
Dim iToX%
Dim iToY%
iSize% = iSize2% - 1
iWeight% = iWeight2% - 1
If iWeight% = 0 Then
' TOP LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' BOTTOM LINE
iFromX% = iX%
iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' LEFT LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' RIGHT LINE
iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
ElseIf iWeight% > 0 Then
' TOP LINE
For iFromY% = iY% To (iY% + iWeight%)
iFromX% = iX%
'iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' BOTTOM LINE
For iFromY% = ((iY% + iSize%) - iWeight%) To (iY% + iSize%)
iFromX% = iX%
'iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' LEFT LINE
For iFromX% = iX% To (iX% + iWeight%)
'iFromX% = iX%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
' RIGHT LINE
For iFromX% = ((iX% + iSize%) - iWeight%) To (iX% + iSize%)
'iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
End If
End Sub ' DrawOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE
'DrawRect 0, iX, iY, iSizeW, iSizeH, fgColor, bgColor
Sub DrawRect (img&, iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
'If img& < -1 Then
If img& <= 0 Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw fill (bgColor)
If bgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), bgColor, BF ' Draw a solid rectangle
End If
' Draw outline (fgColor)
If fgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End If
End If
End Sub ' DrawRect
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (OUTLINE)
'DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectOutline (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, B ' Draw rectangle outline
End Sub ' DrawRectOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
'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
' /////////////////////////////////////////////////////////////////////////////
'DrawSquare 0, x1, y1, size, fgcolor, bgcolor
Sub DrawSquare (img&, x1%, y1%, size%, fgcolor~&, bgcolor~&)
Dim x2%, y2%
If img& < -1 Then
_Dest img& ': Cls , cEmpty
x2% = (x1% + size%) - 1
y2% = (y1% + size%) - 1
Line (x1%, y1%)-(x2%, y1%), fgcolor~&, , 65535
Line (x2%, y1%)-(x2%, y2%), fgcolor~&, , 65535
Line (x2%, y2%)-(x1%, y2%), fgcolor~&, , 65535
Line (x1%, y2%)-(x1%, y1%), fgcolor~&, , 65535
If bgcolor~& <> cEmpty Then
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (x1% + 1, y1% + 1), bgcolor~&, fgcolor~&
End If
End If
End Sub ' Draw Square
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
' The style parameter 0-255 doesn't seem to have a solid line?
' For that, use DrawOutlineBox.
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
' B creates a box outline with each side parallel to the program screen sides. BF creates a filled box.
' The style% signed INTEGER value sets a dotted pattern to draw the line or rectangle outline.
'DrawStyledOutlineBox iX%, iY%, iSize%, iColor~&, iStyle%
Sub DrawStyledOutlineBox (iX%, iY%, iSize%, iColor~&, iStyle%)
Line (iX%, iY%)-(iX% + (iSize% - 1), iY% + (iSize% - 1)), iColor~&, B , iStyle%
End Sub ' DrawStyledOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' Frees image if it exists
' and makes sure it isn't the current screen and _DEST
'FreeImage img
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then
If _ScreenImage = ThisImage& Then Screen 0
If _Dest = ThisImage& Then _Dest 0
_FreeImage ThisImage&
End If
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
' Initializes an image
' (if it already exists, frees it up and re-instantiates)
'InitImage img, iWidth, iHeight, bgColor
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'ThickCircle x!, y!, radius!, thickness!, colour~&
Sub ThickCircle (x As Single, y As Single, radius As Single, thickness As Single, colour As _Unsigned Long)
Dim rp As Single, rm As Single, rp2 As Single, rm2 As Single
Dim sm As Single, rpi2 As Single, rmi2 As Single, sp As Single
Dim i As Single
rp = radius + thickness / 2
rm = radius - thickness / 2
rp2 = rp ^ 2
rm2 = rm ^ 2
For i = -rp To -rm Step .2
rpi2 = rp2 - i ^ 2
sp = Sqr(rpi2)
Line (x + i, y)-(x + i, y + sp), colour, BF
Line (x + i, y)-(x + i, y - sp), colour, BF
Next
For i = -rm To 0 Step .2
rpi2 = rp2 - i ^ 2
rmi2 = rm2 - i ^ 2
sm = Sqr(rmi2)
sp = Sqr(rpi2)
Line (x + i, y + sm)-(x + i, y + sp), colour, BF
Line (x - i, y + sm)-(x - i, y + sp), colour, BF
Line (x + i, y - sm)-(x + i, y - sp), colour, BF
Line (x - i, y - sm)-(x - i, y - sp), colour, BF
Next
For i = rm To rp Step .2
rpi2 = rp2 - i ^ 2
sp = Sqr(rpi2)
Line (x + i, y)-(x + i, y + sp), colour, BF
Line (x + i, y)-(x + i, y - sp), colour, BF
Next
End Sub ' ThickCircle
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'ThickLine x1, y1, x2, y2, thk, kolor~&
Sub ThickLine (x1, y1, x2, y2, thk, kolor As _Unsigned Long)
'draw a line of thickness thk on color klr from x1,y1 to x2,y2
'orientation of line is set in the middle of line thickness
Static tempimage As Long, m As _MEM
If tempimage = 0 Then tempimage = _NewImage(1, 1, 32): m = _MemImage(tempimage)
$Checking:Off
_MemPut m, m.OFFSET, kolor
$Checking:On
cang = _Atan2((y2 - y1), (x2 - x1)) 'get the angle from x1,y1 to x2,y2
ta = cang + _Pi(.5)
tb = ta + _Pi
tax1 = x1 + (thk / 2) * Cos(ta): tay1 = y1 + (thk / 2) * Sin(ta)
tax4 = x1 + (thk / 2) * Cos(tb): tay4 = y1 + (thk / 2) * Sin(tb)
tax2 = x2 + (thk / 2) * Cos(ta): tay2 = y2 + (thk / 2) * Sin(ta)
tax3 = x2 + (thk / 2) * Cos(tb): tay3 = y2 + (thk / 2) * Sin(tb)
_MapTriangle (0, 0)-(0, 0)-(0, 0), tempimage To(tax1, tay1)-(tax2, tay2)-(tax4, tay4)
_MapTriangle (0, 0)-(0, 0)-(0, 0), tempimage To(tax2, tay2)-(tax3, tay3)-(tax4, tay4)
End Sub ' ThickLine
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'TriangleFill x1, y1, x2, y2, x3, y3, fgColor~&
Sub TriangleFill (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
$Checking:Off
Static a&, m As _MEM
If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
_MemPut m, m.OFFSET, K
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
$Checking:On
End Sub ' TriangleFill
' ################################################################################################################################################################
' END SHAPE DRAWING ROUTINES @SHAPE @DRAW
' ################################################################################################################################################################
' SOME FLOOD FILL STUFF TO TRY LATER?
'' /////////////////////////////////////////////////////////////////////////////
'' QIX
'' https://qb64phoenix.com/forum/showthread.php?tid=1201&pid=10820#pid10820
'' From: james2464
'' Date 11-28-2022, 10:36 PM
'
'' using paint for flood fills
'Sub claimfillfast (x, y, c~&)
' c~& = _RGB(30, 30, 30)
' k = q(1).xx: j = q(1).yy
'
' ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
' Paint (k, j), c~&
'
' 'fill black with blue
' For j = 41 To 439
' For k = 121 To 519
' c(16) = Point(k, j)
' If c(16) = c(0) Then
' PSet (k, j), c(4)
' bluetot = bluetot + 1
' End If
' Next k
' Next j
'
' 'fill gray with black
' k = q(1).xx: j = q(1).yy
' Paint (k, j), c(0), c(1)
'End Sub ' claimfillfast
'
'' /////////////////////////////////////////////////////////////////////////////
'' QIX
'' https://qb64phoenix.com/forum/showthread.php?tid=1201&pid=10820#pid10820
'' From: james2464
'' Date 11-28-2022, 10:36 PM
'
'' using paint for flood fills
'Sub claimfillslow (x, y, c~&)
' 'start at qix
' c~& = _RGB(30, 30, 30)
' k = q(1).xx: j = q(1).yy
'
' ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
' Paint (k, j), c~&
'
' 'fill black with red
' For j = 41 To 439
' For k = 121 To 519
' c(16) = Point(k, j)
' If c(16) = c(0) Then
' PSet (k, j), c(5)
' redtot = redtot + 1
' End If
' Next k
' Next j
'
' 'fill gray with black
' k = q(1).xx: j = q(1).yy
' Paint (k, j), c(0), c(1)
'End Sub ' claimfillslow
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RGB COLOR FUNCTIONS #RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RGB COLOR FUNCTIONS @RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN COLOR ARRAY FUNCTIONS #COLR
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Used by Sub AddColors
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
' /////////////////////////////////////////////////////////////////////////////
' Used by Sub AddSpectrumColors and Sub AddgrayscaleColors
Sub AddColors (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long, HowMany As Long)
Dim iLoop As Integer
For iLoop = 1 To HowMany
AddColor ColorValue, arrColor()
Next iLoop
End Sub ' AddColors
' /////////////////////////////////////////////////////////////////////////////
' Adds rainbow colors to array arrColor().
Sub AddSpectrumColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cRed, arrColor(), iNum
AddColors cOrangeRed, arrColor(), iNum
AddColors cDarkOrange, arrColor(), iNum
AddColors cOrange, arrColor(), iNum
AddColors cGold, arrColor(), iNum
AddColors cYellow, arrColor(), iNum
AddColors cChartreuse, arrColor(), iNum
AddColors cOliveDrab1, arrColor(), iNum
AddColors cLime, arrColor(), iNum
AddColors cMediumSpringGreen, arrColor(), iNum
AddColors cSpringGreen, arrColor(), iNum
AddColors cCyan, arrColor(), iNum
AddColors cDeepSkyBlue, arrColor(), iNum
AddColors cDodgerBlue, arrColor(), iNum
AddColors cSeaBlue, arrColor(), iNum
AddColors cBlue, arrColor(), iNum
AddColors cBluePurple, arrColor(), iNum
AddColors cDeepPurple, arrColor(), iNum
AddColors cPurple, arrColor(), iNum
AddColors cPurpleRed, arrColor(), iNum
End Sub ' AddSpectrumColors
' /////////////////////////////////////////////////////////////////////////////
' Adds grayscale colors to array arrColor().
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' /////////////////////////////////////////////////////////////////////////////
' Returns a random color chosen from array of color values arrColor().
'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().
'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
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = _TRUE
Else
IsEven% = _FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = _TRUE
Else
IsOdd% = _FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' For tracking mouse buttons
Sub ToggleButtonState (bButton As Integer, bOldButton As Integer, bClickButton As Integer)
If bButton = _TRUE Then
If bOldButton = _FALSE Then
bClickButton = _TRUE
bOldButton = _TRUE
Else
bClickButton = _FALSE
End If
Else
bOldButton = _FALSE
bClickButton = _FALSE
End If
End Sub ' ToggleButtonState
' ################################################################################################################################################################
' END GENERAL PURPOSE ROUTINES @GEN
' ################################################################################################################################################################RE: flood fill ? - bplus - 04-23-2025
Looks like only solid border colors work. here is my test:
Code: (Select All)
Screen _NewImage(800, 600, 32)
x = 200: y = 200
Circle (x, y), 100, _RGB32(0, 0, 0, 100) ' circle border color
Paint (x, y), _RGB32(255, 0, 0), _RGB32(0, 0, 0, 100) ' to circle border
Print "test alpha border"
Print "Yuck! zzz... press any for solid border"
Sleep
Cls
Print "test solid border color"
Circle (x, y), 100, _RGB32(0, 0, 255) ' circle border color
Paint (x, y), _RGB32(255, 0, 0), _RGB32(0, 0, 255) ' to circle border
Print "OK!"I notice in Wiki bordercolor% is an integer or long, need unsigned long to handle alphas.
RE: flood fill ? - madscijr - 04-24-2025
Thanks for your reply!
(04-23-2025, 11:06 PM)bplus Wrote: Looks like only solid border colors work. here is my test:Yep, which is not what I'm looking for... Have you seen any good "flood fill" examples?
...
I notice in Wiki bordercolor% is an integer or long, need unsigned long to handle alphas.
Code: (Select All)
Screen _NewImage(800, 600, 32)
_ScreenMove 0, 0
Cls , _RGB32(0, 0, 0)
' clear screen and draw circles
Cls , _RGB32(0, 0, 0)
x = 0: y = 0
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 0, 0) ' red
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 255, 0) ' green
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 0, 255) ' blue
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 255, 255) ' cyan
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 255, 0) ' yellow
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 0, 255) ' magenta
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Locate 10, 1
Input "press Enter to try fill with paint with border _RGB32(0, 0, 0, 100)"; in$
' How to fill in the background only, ie specify anything EXCEPT the background color as "border"?
x = 10: Paint (x, y), _RGB32(255, 255, 255), _RGB32(0, 0, 0, 100)
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Locate 10, 1
Input "press Enter to continue"; in$
' clear screen and draw circles
Cls , _RGB32(0, 0, 0)
x = 0: y = 0
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 0, 0) ' red
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 255, 0) ' green
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 0, 255) ' blue
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(0, 255, 255) ' cyan
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 255, 0) ' yellow
x = x + 100: y = y + 75: Circle (x, y), 50, _RGB32(255, 0, 255) ' magenta
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Locate 10, 1
Input "press Enter to try fill with paint with border _RGB32(0, 0, 255) "; in$
' Just fill in the background?
x = 10: Paint (x, y), _RGB32(255, 255, 255), _RGB32(0, 0, 255) ' to circle border
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255): Locate 10, 1
Input "Done. Press Enter to exit"; in$
SystemRE: flood fill ? - bplus - 04-24-2025
I have a different kind of paint, Paint3 that fills the color it lands on to do the painting, any other color stops the paint like a border
Code: (Select All)
Option _Explicit
_Title "PAINT3 test" 'b+ 2020-06-26
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
Dim i, mb, mx, my
For i = 1 To 50
Line (Rnd * 800, Rnd * 600)-(Rnd * 800, Rnd * 600), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
Circle (Rnd * 800, Rnd * 600), Rnd * 50 + 10, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
Next
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then paint3 mx, my, &HFFFFFFFF
_Limit 200
Loop Until _KeyDown(27)
Sub paint3 (x0, y0, fill As _Unsigned Long) ' needs max, min functions
Dim fillColor As _Unsigned Long, W, H, parentF, tick, ystart, ystop, xstart, xstop, x, y
fillColor = Point(x0, y0)
'PRINT fillColor
W = _Width - 1: H = _Height - 1
Dim temp(W, H)
temp(x0, y0) = 1: parentF = 1
PSet (x0, y0), fill
While parentF = 1
parentF = 0: tick = tick + 1
ystart = max(y0 - tick, 0): ystop = min(y0 + tick, H)
y = ystart
While y <= ystop
xstart = max(x0 - tick, 0): xstop = min(x0 + tick, W)
x = xstart
While x <= xstop
If Point(x, y) = fillColor And temp(x, y) = 0 Then
If temp(max(0, x - 1), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(min(x + 1, W), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(x, max(y - 1, 0)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(x, min(y + 1, H)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
End If
End If
x = x + 1
Wend
y = y + 1
Wend
Wend
End Sub
Function min (n1, n2)
If n1 > n2 Then min = n2 Else min = n1
End Function
Function max (n1, n2)
If n1 < n2 Then max = n2 Else max = n1
End FunctionRE: flood fill ? - SMcNeill - 04-24-2025
How about something as simple as this quick demo that I wrote:
Code: (Select All)
$Color:32
Screen _NewImage(1280, 720, 32)
Circle (640, 360), 350, Red
Circle (800, 500), 100, Blue
Paint (800, 500), Blue, Blue
Sleep 'so we can see that the blue circle is inside the red one.
Fill 640, 360, Red 'fill all transparent pixels red
Sleep
System
Sub Fill (x, y, Kolor As _Unsigned Long)
l = x - 1: r = x + 1 'find left/right to fill
Do Until Point(l, y) <> 0 _OrElse l = 0: l = l - 1: Loop 'find the left boundry
Do Until Point(r, y) <> 0 _OrElse r = _Width - 1: r = r + 1: Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l + 1 To r - 1
If Point(i, y + 1) = 0 Then Fill i, y + 1, Kolor
If Point(i, y - 1) = 0 Then Fill i, y - 1, Kolor
Next
End Sub
Notice that it only fills transparent (_RGBA(0,0,0,0)) pixels and colors them the fill color.
RE: flood fill ? - SMcNeill - 04-24-2025
For all 0 alpha colors (as I just went back and noticed in your original post), simply check for POINT(i, y+1) < &H01000000~&
That'll cover all the 0 alpha color ranges.
RE: flood fill ? - madscijr - 04-24-2025
Thanks guys, I look forward to running these when I'm back at the old PC!
RE: flood fill ? - Petr - 04-24-2025
https://qb64phoenix.com/forum/showthread.php?tid=1507
TESTED ALSO WITH ALPHA:
Code: (Select All)
Screen _NewImage(1024, 768, 32)
$Color:32
Do
Cls , Red
For c = 1 To 40
Circle (Rnd * 980, Rnd * 740), Rnd * 100 + 10, _RGBA32(25 * Rnd, 75 * Rnd, 127 * Rnd, 100 + 155 * Rnd)
X = Rnd * 1024
Y = Rnd * 768
Lwidth = Rnd * 100
Lheight = Rnd * 100
Line (X, Y)-(X + Lwidth, Y + Lheight), _RGBA32(55 * Rnd, 145 * Rnd, 255 * Rnd, Rnd * 255), BF
Next
_Delay .1
_MouseMove 512, 384
Do Until K& = 27
K& = _KeyHit
While _MouseInput: Wend
If _MouseButton(1) Then Paint2 _MouseX, _MouseY, DarkBlue
Loop
K& = 0
Loop
Sub Paint2 (x, y, c~&)
W = _Width: H = _Height
Virtual = _NewImage(W, H, 32)
Dim m As _MEM, n As _MEM, Bck As _Unsigned Long
m = _MemImage(_Source)
n = _MemImage(Virtual)
'create mask (2 color image)
position& = (y * W + x) * 4
_MemGet m, m.OFFSET + position&, Bck
Clr2~& = _RGB32(_Red32(Bck) - 1, _Green32(Bck) - 1, _Blue32(Bck) - 1, _Alpha32(Bck) - 1)
D& = 0
Do Until D& = n.SIZE
CLR~& = _MemGet(m, m.OFFSET + D&, _Unsigned Long)
If CLR~& = Bck~& Then _MemPut n, n.OFFSET + D&, CLR~& Else _MemPut n, n.OFFSET + D&, Clr2~&
D& = D& + 4
Loop
d = _Dest
_Dest Virtual
Paint (x, y), c~&, Clr2~&
_Dest d
_ClearColor Clr2~&, Virtual
_PutImage , Virtual, d
_MemFree m
_MemFree n
_FreeImage Virtual
End Sub
RE: flood fill ? - madscijr - 04-24-2025
Okay, I tried all your code - thanks everyone!
I put them inside a test program to do an "apples to apples" comparison, here's what I'm seeing:
- Steve's Fill is fast, but if you try filling the same area with different colors a few times, eventually the other non-clicked colors get overwritten.
- BPlus's paint3 preserves the un-clicked colors, but is slow for large areas.
- Petr's Paint2 was fast using his code unchanged, but when I tried calling Paint2 from my test code, it doesn't seem to work - it just draws a dot wherever you click the mouse. I don't really understand the mem stuff he is doing, so haven't been able to figure that out.
Run the test program below which lets you test all 3 in one place. Mouse wheel/space changes color (grayscale colors have alpha values < 255), left/middle/right click to fill with BPlus, Steve, Petr's respectively, Enter resets screen, Esc exits (or cancels fill if BPlus's is taking too long).
Questions:
- How to get Steve's fill to stop overwriting non-clicked colors?
- Can BPlus's be sped up?
- How to get Petr's to work inside my routine?
- Can we get it to do a blend fill with alpha values < 255?
Thanks again
Code: (Select All)
Option _Explicit
_Title "Shapes drawing demo - fill test by bplus, steve, petr, madscijr"
' KEYCODES FOR _BUTTON (EXCEPT WHERE STATED)
Const KeyCode_Escape = 2
Const KeyCode_F1 = 60
Const KeyCode_F2 = 61
Const KeyCode_F3 = 62
Const KeyCode_F4 = 63
Const KeyCode_F5 = 64
Const KeyCode_F6 = 65
Const KeyCode_F7 = 66
Const KeyCode_F8 = 67
Const KeyCode_F9 = 68
Const KeyCode_F10 = 17408 '_KEYDOWN CODE, NOT _BUTTON CODE
Const KeyCode_F11 = 88
Const KeyCode_F12 = 89
Const KeyCode_PrintScreen = -44 '_KEYHIT CODE, NOT _BUTTON CODE
Const KeyCode_ScrollLock = 71
Const KeyCode_PauseBreak = 31053 '_KEYHIT CODE, NOT _BUTTON CODE
Const KeyCode_Tilde = 42
Const KeyCode_1 = 3
Const KeyCode_2 = 4
Const KeyCode_3 = 5
Const KeyCode_4 = 6
Const KeyCode_5 = 7
Const KeyCode_6 = 8
Const KeyCode_7 = 9
Const KeyCode_8 = 10
Const KeyCode_9 = 11
Const KeyCode_0 = 12
Const KeyCode_Minus = 13
Const KeyCode_Equal = 14
Const KeyCode_BkSp = 15
Const KeyCode_Ins = 339
Const KeyCode_Home = 328
Const KeyCode_PgUp = 330
Const KeyCode_Del = 340
Const KeyCode_End = 336
Const KeyCode_PgDn = 338
Const KeyCode_NumLock = 326
Const KeyCode_KeypadSlash = 310
Const KeyCode_KeypadMultiply = 56
Const KeyCode_KeypadMinus = 75
Const KeyCode_Keypad7Home = 72
Const KeyCode_Keypad8Up = 73
Const KeyCode_Keypad9PgUp = 74
Const KeyCode_KeypadPlus = 79
Const KeyCode_Keypad4Left = 76
Const KeyCode_Keypad5 = 77
Const KeyCode_Keypad6Right = 78
Const KeyCode_Keypad1End = 80
Const KeyCode_Keypad2Down = 81
Const KeyCode_Keypad3PgDn = 82
Const KeyCode_KeypadEnter = 285
Const KeyCode_Keypad0Ins = 83
Const KeyCode_KeypadPeriodDel = 84
Const KeyCode_Tab = 16
Const KeyCode_Q = 17
Const KeyCode_W = 18
Const KeyCode_E = 19
Const KeyCode_R = 20
Const KeyCode_T = 21
Const KeyCode_Y = 22
Const KeyCode_U = 23
Const KeyCode_I = 24
Const KeyCode_O = 25
Const KeyCode_P = 26
Const KeyCode_BracketLeft = 27
Const KeyCode_BracketRight = 28
Const KeyCode_Backslash = 44
Const KeyCode_CapsLock = 59
Const KeyCode_A = 31
Const KeyCode_S = 32
Const KeyCode_D = 33
Const KeyCode_F = 34
Const KeyCode_G = 35
Const KeyCode_H = 36
Const KeyCode_J = 37
Const KeyCode_K = 38
Const KeyCode_L = 39
Const KeyCode_Semicolon = 40
Const KeyCode_Apostrophe = 41
Const KeyCode_Enter = 29
Const KeyCode_ShiftLeft = 43
Const KeyCode_Z = 45
Const KeyCode_X = 46
Const KeyCode_C = 47
Const KeyCode_V = 48
Const KeyCode_B = 49
Const KeyCode_N = 50
Const KeyCode_M = 51
Const KeyCode_Comma = 52
Const KeyCode_Period = 53
Const KeyCode_Slash = 54
Const KeyCode_ShiftRight = 55
Const KeyCode_Up = 329
Const KeyCode_Left = 332
Const KeyCode_Down = 337
Const KeyCode_Right = 334
Const KeyCode_CtrlLeft = 30
Const KeyCode_WinLeft = 348
Const KeyCode_AltLeft = -30764 ' _KEYHIT CODE NOT _BUTTON CODE
Const KeyCode_Spacebar = 58
Const KeyCode_AltRight = -30765 ' _KEYHIT CODE NOT _BUTTON CODE
Const KeyCode_WinRight = 349
Const KeyCode_Menu = 350
Const KeyCode_CtrlRight = 286
FillTest
System
' /////////////////////////////////////////////////////////////////////////////
' TEST FILL METHODS
Sub FillTest
Dim x, y, r, nr As Integer ' circles
Dim mb1, mb2, mb3 As Integer ' mouse buttons
Dim mx, my As Long ' mouse
Dim k&: k& = 0 ' key
ReDim arrColor(0 To 0) As _Unsigned Long ' array of colors
Dim index As Integer ' pointer to the current color
' INIT SCREEN
_Title "FillTest"
Screen _NewImage(1024, 768, 32): _Delay .25: _ScreenMove 0, 0
' GET COLORS
AddTestColors arrColor(): index = LBound(arrColor) + 1
' TEST FILL
Do
' DRAW CIRCLES
Cls , _RGB32(0, 0, 0)
r = 50: x = 50: y = 50
Do
Do
Circle (x, y), r, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
x = x + (r * 2)
If x + r > _Width Then Exit Do
Loop
nr = r + 50 ' new row circles bigger by 50px
y = y + r + nr ' get next y pos
r = nr ' save radius
x = r ' start at left
If y + r > _Height Then Exit Do
Loop
' INSTRUCTIONS
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print " CLICK TO FILL ";
Locate 2, 1: Print "--------------------------";
Color _RGB32(0, 255, 255), _RGB32(0, 0, 0)
Locate 3, 1: Print " LEFT-CLICK: BPlus paint3 (press Esc to cancel)";
Locate 4, 1: Print "MIDDLE-CLICK: Steve Fill ";
Locate 5, 1: Print " RIGHT-CLICK: Petr Paint2 ";
Color _RGB32(255, 255, 0), _RGB32(0, 0, 0)
Locate 7, 1: Print "--------------------------";
Locate 8, 1: Print "Space = next fill color ";
Locate 9, 1: Print "Enter = redraw ";
Locate 10, 1: Print "Esc = exit ";
Locate 11, 1: Print "--------------------------";
' TEST FILL
'c~& = &HFFFFFFFF
Do Until k& = 13 Or k& = 27
' SHOW LOCATION + COLOR
Color _RGB32(160, 160, 160), _RGB32(0, 0, 0)
Locate 12, 1: Print "fill at : " + _ToStr$(x) + "," + _ToStr$(y)
Locate 13, 1: Print "fill color (" + Left$(_ToStr$(index) + " ", 2) + "): "
Color arrColor(index), arrColor(index)
Locate 13, 18: Print " ";
Color _RGB32(160, 160, 160), _RGB32(0, 0, 0)
Locate 13, 24: print "(" + _
"r=" + right$(" " + _ToStr$(_RED32(arrColor(index))), 3) + ", " + _
"g=" + right$(" " + _ToStr$(_GREEN32(arrColor(index))), 3) + ", " + _
"b=" + right$(" " + _ToStr$(_BLUE32(arrColor(index))), 3) + ", " + _
"a=" + right$(" " + _ToStr$(_ALPHA32(arrColor(index))), 3) + ")";
k& = _KeyHit
If k& = 32 Then index = index + 1: If index > UBound(arrColor) Then index = LBound(arrColor) + 1
While _MouseInput
index = index - _MouseWheel
If index <= LBound(arrColor) Then
index = UBound(arrColor)
ElseIf index > UBound(arrColor) Then
index = LBound(arrColor) + 1
End If
Wend
mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1): mb2 = _MouseButton(2): mb3 = _MouseButton(3)
' BPlus
If mb1 Then paint3 mx, my, arrColor(index)
' Steve
If mb2 Then Fill mx, my, arrColor(index)
' Petr
If mb3 Then Paint2 mx, my, arrColor(index)
_Limit 200
Loop
If k& = 27 Then Exit Do
k& = 0
Loop
End Sub ' FillTest
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim in$
Do
Print "1. BPlus paint3"
Print "2. Steve Fill"
Print "3. Petr Paint2"
Print "4. madscijr DrawTest"
Input "1-4 or Q to quit"; in$
in$ = UCase$(Left$(_Trim$(in$), 1))
Select Case in$
Case "1": FillBPlus: Screen 0
Case "2": FillSteve: Screen 0
Case "3": FillPetr: Screen 0
Case "4": DrawTest: Screen 0
Case "Q": Exit Do
End Select
Loop
End Sub ' Main
' ################################################################################################################################################################
' # BEGIN BPlus's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33694#pid33694
' From: bplus, Mini-Mod
' 4/23/2025 8:53 PM
' I have a different kind of paint, Paint3 that fills the color
' it lands on to do the painting, any other color stops the
' paint like a border
Sub FillBPlus
_Title "PAINT3 test" 'b+ 2020-06-26
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove 0, 0
Dim i, mb, mx, my
For i = 1 To 50
Line (Rnd * 800, Rnd * 600)-(Rnd * 800, Rnd * 600), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
Circle (Rnd * 800, Rnd * 600), Rnd * 50 + 10, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
Next
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Click an area of the screen to fill";
Locate 2, 1: Print "Press Esc to exit";
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then paint3 mx, my, &HFFFFFFFF
_Limit 200
Loop Until _KeyDown(27)
End Sub ' FillBPlus
' /////////////////////////////////////////////////////////////////////////////
' madscijr added check for Esc key to cancel
Sub paint3 (x0, y0, MyFill As _Unsigned Long) ' needs GetMax, GetMin functions
Dim fillColor As _Unsigned Long, W, H, parentF, tick, ystart, ystop, xstart, xstop, x, y
fillColor = Point(x0, y0)
'PRINT fillColor
W = _Width - 1: H = _Height - 1
Dim temp(W, H)
temp(x0, y0) = 1: parentF = 1
PSet (x0, y0), MyFill
Dim k&: k& = 0 ' madscijr
While parentF = 1
parentF = 0: tick = tick + 1
ystart = GetMax(y0 - tick, 0): ystop = GetMin(y0 + tick, H)
y = ystart
While y <= ystop
xstart = GetMax(x0 - tick, 0): xstop = GetMin(x0 + tick, W)
x = xstart
While x <= xstop
If Point(x, y) = fillColor And temp(x, y) = 0 Then
If temp(GetMax(0, x - 1), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
ElseIf temp(GetMin(x + 1, W), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
ElseIf temp(x, GetMax(y - 1, 0)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
ElseIf temp(x, GetMin(y + 1, H)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
End If
End If
x = x + 1
k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
Wend
If k& = 27 Then Exit While ' madscijr
y = y + 1
k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
Wend
If k& = 27 Then Exit While ' madscijr
k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
Wend
End Sub ' paint3
' /////////////////////////////////////////////////////////////////////////////
Function GetMin (n1, n2)
If n1 > n2 Then GetMin = n2 Else GetMin = n1
End Function
' /////////////////////////////////////////////////////////////////////////////
Function GetMax (n1, n2)
If n1 < n2 Then GetMax = n2 Else GetMax = n1
End Function
' ################################################################################################################################################################
' # END BPlus's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Steve's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33696#pid33696
' SMcNeill, Super Moderator
' 4/23/2025 8:55 PM
' How about something as simple as this quick demo that I wrote:
' Notice that it only fills transparent (_RGBA(0,0,0,0)) pixels
' and colors them the fill color.
' SMcNeill, Super Moderator
' 4/23/2025 9:56 PM
' For all 0 alpha colors (as I just went back and noticed in your original post),
' simply check for POINT(i, y+1) < &H01000000~&
' That'll cover all the 0 alpha color ranges. Wink
Sub FillSteve
$Color:32
Screen _NewImage(1280, 720, 32)
_ScreenMove 0, 0
Circle (640, 360), 350, Red
Circle (800, 500), 100, Blue
Paint (800, 500), Blue, Blue
Locate 1, 1
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Print "Press any key to fill"
Sleep ' so we can see that the blue circle is inside the red one.
Fill 640, 360, Red 'fill all transparent pixels red
Locate 1, 1
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Print "Press any key to exit"
Sleep
End Sub ' FillSteve
' /////////////////////////////////////////////////////////////////////////////
Sub Fill (x, y, Kolor As _Unsigned Long)
Dim l
Dim r
Dim i
l = x - 1: r = x + 1 'find left/right to fill
Do Until Point(l, y) <> 0 _OrElse l = 0: l = l - 1: Loop 'find the left boundry
Do Until Point(r, y) <> 0 _OrElse r = _Width - 1: r = r + 1: Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l + 1 To r - 1
If Point(i, y + 1) = 0 Then Fill i, y + 1, Kolor
If Point(i, y - 1) = 0 Then Fill i, y - 1, Kolor
Next
End Sub ' Fill
' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' reply #8
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33703#pid33703
' Petr, Mini-Mod
' 4/24/2025 9:42 AM
'
' https://qb64phoenix.com/forum/showthread.php?tid=1507
' TESTED ALSO WITH ALPHA:
Sub FillPetr
Dim c
Dim X
Dim Y
Dim Lwidth
Dim Lheight
Dim K&
Screen _NewImage(1024, 768, 32)
$Color:32
_ScreenMove 0, 0
Do
Cls , Red
For c = 1 To 40
Circle (Rnd * 980, Rnd * 740), Rnd * 100 + 10, _RGBA32(25 * Rnd, 75 * Rnd, 127 * Rnd, 100 + 155 * Rnd)
X = Rnd * 1024
Y = Rnd * 768
Lwidth = Rnd * 100
Lheight = Rnd * 100
Line (X, Y)-(X + Lwidth, Y + Lheight), _RGBA32(55 * Rnd, 145 * Rnd, 255 * Rnd, Rnd * 255), BF
Next c
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Click an area of the screen to fill";
Locate 2, 1: Print "Press Enter to redraw screen";
Locate 3, 1: Print "Press Esc to exit";
_Delay .1
_MouseMove 512, 384
Do Until K& = 13 Or K& = 27
K& = _KeyHit
While _MouseInput: Wend
If _MouseButton(1) Then Paint2 _MouseX, _MouseY, DarkBlue
Loop
If K& = 27 Then Exit Do
K& = 0
Loop
End Sub ' FillPetr
' /////////////////////////////////////////////////////////////////////////////
Sub Paint2 (x, y, c~&)
Dim W
Dim H
Dim Virtual As Long
Dim position&
Dim Clr2~&
Dim D&
Dim CLR~&
W = _Width: H = _Height
Virtual = _NewImage(W, H, 32)
Dim m As _MEM, n As _MEM, Bck As _Unsigned Long
m = _MemImage(_Source)
n = _MemImage(Virtual)
'create mask (2 color image)
position& = (y * W + x) * 4
_MemGet m, m.OFFSET + position&, Bck
Clr2~& = _RGB32(_Red32(Bck) - 1, _Green32(Bck) - 1, _Blue32(Bck) - 1, _Alpha32(Bck) - 1)
D& = 0
Do Until D& = n.SIZE
CLR~& = _MemGet(m, m.OFFSET + D&, _Unsigned Long)
If CLR~& = Bck~& Then _MemPut n, n.OFFSET + D&, CLR~& Else _MemPut n, n.OFFSET + D&, Clr2~&
D& = D& + 4
Loop
D& = _Dest
_Dest Virtual
Paint (x, y), c~&, Clr2~&
_Dest D&
_ClearColor Clr2~&, Virtual
_PutImage , Virtual, D&
_MemFree m
_MemFree n
_FreeImage Virtual
End Sub ' Paint2
' ################################################################################################################################################################
' # END Petr's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SHAPES TEST
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub DrawTest
Dim iLastKeyCode%: iLastKeyCode% = 0 ' for reading keys with _BUTTON
Dim bFinished As Integer: bFinished = _FALSE
Dim k$, LastKey$: LastKey$ = ""
ReDim arrColor(0 To 0) As _Unsigned Long
ReDim arrGray(0 To 0) As _Unsigned Long
ReDim arrNotColor(0 To 1) As _Unsigned Long
Dim index As Integer
Dim xmin, ymin As Integer
Dim xmax, ymax As Integer
Dim iX, iY, iSize, iSizeW, iSizeH, iRadius, iThickness, iWeight, iStyle, x1, y1, x2, y2, x3, y3 As Integer
Dim x!, y!, radius!, thickness!
Dim fgColor, bgColor As _Unsigned Long
Dim ScreenColor As _Unsigned Long
Dim iLoop As Integer
Dim delim$: delim$ = Chr$(9)
ReDim arrHelp(-1) As String
Dim in$
Dim ColNum, RowNum, NextCol, bStartOdd, MsgRow As Integer
Dim MaxCols, MaxRows, MaxLen, ColCount As Integer
Dim iCharCode As Integer
Dim imgHelp&
Dim imgDraw&
' MOUSE VARS
Dim PointerSize As Integer
Dim MouseColor~&
Dim mx, my As Integer ' mouse pointer
Dim iWheel As Integer ' mouse wheel
Dim bButton1 As Integer
Dim bButton2 As Integer
Dim bButton3 As Integer
Dim bOldButton1 As Integer
Dim bOldButton2 As Integer
Dim bOldButton3 As Integer
Dim bClickButton1 As Integer
Dim bClickButton2 As Integer
Dim bClickButton3 As Integer
Dim imgMouse&
' INTIALIZE
Randomize Timer
xmin = 0: ymin = 0: xmax = 800: ymax = 600 'xmax = _DesktopWidth - 1: ymax = _DesktopHeight - 1
ScreenColor = cBlack
AddSpectrumColors arrColor()
AddGrayscaleColors arrGray()
arrNotColor(0) = ScreenColor: arrNotColor(1) = ScreenColor
PointerSize = 10: MouseColor~& = cWhite
iCharCode = 64
' INIT MOUSE STATE
bOldButton1 = _FALSE
bOldButton2 = _FALSE
bOldButton3 = _FALSE
bClickButton1 = _FALSE
bClickButton2 = _FALSE
bClickButton3 = _FALSE
' INIT HELP
in$ = ""
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "1 = BOX OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "2 = SOLID BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "3 = RECTANGLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "4 = CIRCLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "5 = CIRCLE OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "6 = RECTANGLE OUTLINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "7 = SOLID RECTANGLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "8 = SQUARE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "9 = OUTLINE BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "0 = STYLED OUTLINE BOX"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "A = TRIANGLE FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "C = THICK CIRCLE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "L = THICK LINE"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "T = TEXT"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "F = FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "HOME = CLEAR SCREEN"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "ESC = QUIT"
split in$, delim$, arrHelp()
' PAD WITH SPACES SO ALL ARE EQUAL LENGTH
MaxLen = 0
For index = LBound(arrHelp) To UBound(arrHelp)
If Len(arrHelp(index)) > MaxLen Then MaxLen = Len(arrHelp(index))
Next index
For index = LBound(arrHelp) To UBound(arrHelp)
If Len(arrHelp(index)) < MaxLen Then arrHelp(index) = Left$(arrHelp(index) + String$(MaxLen, " "), MaxLen)
Next index
' INIT SCREEN
Screen _NewImage(xmax, ymax, 32)
_Display
_ScreenMove 0, 0
_Dest 0: Cls , ScreenColor
MaxCols = (xmax / _FontWidth)
MaxRows = (ymax / _FontHeight)
' INIT LAYERS
InitImage imgDraw&, xmax, ymax, cEmpty
InitImage imgHelp&, xmax, ymax, cEmpty
InitImage imgMouse&, xmax, ymax, cEmpty
_Dest imgDraw&: Cls , cEmpty
' SHOW MENU CHOICES AT TOP
_Dest imgHelp&: Cls , cEmpty
RowNum = 1: ColNum = 1: ColCount = 0
For index = LBound(arrHelp) To UBound(arrHelp)
If RowNum > MaxRows Then Exit For
ColCount = ColCount + 1
' ALTERNATE COLORS
If IsOdd%(RowNum) Then
If IsOdd(ColCount) Then
Color cWhite, cDarkGray ' cDarkGray cGray cSilver cWhite
Else
Color cBlack, cSilver
End If
Else
If IsOdd(ColCount) Then
Color cBlack, cSilver
Else
Color cBlack, cDarkGray ' cDarkGray cGray cSilver cWhite
End If
End If
Locate RowNum, ColNum
Print " " + arrHelp(index) + " ";
If index < UBound(arrHelp) Then
ColNum = ColNum + Len(arrHelp(index)) + 2
NextCol = ColNum + Len(arrHelp(index + 1)) + 2
If NextCol > MaxCols Then
ColNum = 1: RowNum = RowNum + 1: ColCount = 0
End If
End If
Next index
RowNum = RowNum + 1: MsgRow = RowNum
RowNum = RowNum + 1: ymin = RowNum * _FontHeight
' MAIN LOOP
Do
' GET MOUSE COORDINATES
While _MouseInput: Wend
mx = _MouseX
my = _MouseY
If mx < xmin Then
mx = xmin
ElseIf mx > xmax Then
mx = xmax
End If
If my < ymin Then
my = ymin
ElseIf my > ymax Then
my = ymax
End If
' DRAW CROSSHAIR FOR MOUSE
_Dest imgMouse&: Cls , cEmpty
Line (mx - (PointerSize / 2), my)-(mx + (PointerSize / 2), my), MouseColor~&
Line (mx, my - (PointerSize / 2))-(mx, my + (PointerSize / 2)), MouseColor~&
'' GET MOUSE WHEEL INPUT
'While _MouseInput
' iR = iR + _MouseWheel * 5
' If iR < iMinR Then
' iR = iMinR
' ElseIf iR > iMaxR Then
' iR = iMaxR
' End If
'Wend
' READ BUTTONS
bButton1 = _MouseButton(1)
bButton2 = _MouseButton(2)
bButton3 = _MouseButton(3)
ToggleButtonState bButton1, bOldButton1, bClickButton1
ToggleButtonState bButton2, bOldButton2, bClickButton2
ToggleButtonState bButton3, bOldButton3, bClickButton3
'' BUTTONS CHANGE COLOR
'If bClickButton1 = _TRUE Then
' iC = iC + 1: If iC > iMaxColor Then iC = iMinColor
'ElseIf bClickButton2 = _TRUE Then
' iC = iC - 1: If iC < iMinColor Then iC = iMaxColor
'ElseIf bClickButton3 = _TRUE Then
' iC = iMinColor
'End If
' DO ANY DRAWING ON DRAW LAYER
_Dest imgDraw&
' PROCESS KEYBOARD INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape) Then
' ESC = QUIT
iLastKeyCode% = KeyCode_Escape
bFinished = _TRUE
ElseIf _Button(KeyCode_1) Then
If iLastKeyCode% <> KeyCode_1 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_1: LastKey$ = ""
' 1 = BOX OUTLINE
iSize = RandomNumber%(100, 200)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawBoxOutline iX, iY, iSize, fgColor
in$ = left$( _
"DrawBoxOutline " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_2) Then
If iLastKeyCode% <> KeyCode_2 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_2: LastKey$ = ""
' 2 = SOLID BOX
iSize = RandomNumber%(100, 200)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawBoxSolid iX, iY, iSize, fgColor
in$ = left$( _
"DrawBoxSolid " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_3) Then
If iLastKeyCode% <> KeyCode_3 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_3: LastKey$ = ""
' 3 = RECTANGLE
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRect imgDraw&, iX, iY, iSizeW, iSizeH, fgColor, bgColor
in$ = left$( _
"DrawRect " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_4) Then
If iLastKeyCode% <> KeyCode_4 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_4: LastKey$ = ""
' 4 = CIRCLE
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iRadius = RandomNumber%(75, 125)
iThickness = RandomNumber%(10, 20)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawCircle imgDraw&, iX, iY, iRadius, iThickness, fgColor, bgColor
in$ = left$( _
"DrawCircle " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_5) Then
If iLastKeyCode% <> KeyCode_5 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_5: LastKey$ = ""
' 5 = CIRCLE OUTLINE
iRadius = RandomNumber%(125, 175)
iX = RandomNumber%(xmin, xmax - iRadius)
iY = RandomNumber%(ymin, ymax - iRadius)
iThickness = RandomNumber%(25, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawCircleOutline imgDraw&, iX, iY, iRadius, iThickness, fgColor
in$ = left$( _
"**FAILS?** DrawCircleOutline " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cRed: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_6) Then
If iLastKeyCode% <> KeyCode_6 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_6: LastKey$ = ""
' 6 = RECTANGLE OUTLINE
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
in$ = left$( _
"DrawRectOutline " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_7) Then
If iLastKeyCode% <> KeyCode_7 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_7: LastKey$ = ""
' 7 = SOLID RECTANGLE
iX = RandomNumber%(xmin, xmax - iSizeW)
iY = RandomNumber%(ymin, ymax - iSizeH)
iSizeW = RandomNumber%(100, 200)
iSizeH = RandomNumber%(50, 100)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawRectSolid iX, iY, iSizeW, iSizeH, fgColor
in$ = left$( _
"DrawRectSolid " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSizeW=" + _ToStr$(iSizeW) + ", " + _
"iSizeH=" + _ToStr$(iSizeH) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_8) Then
If iLastKeyCode% <> KeyCode_8 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_8: LastKey$ = ""
' 8 = SQUARE
iSize = RandomNumber%(100, 150)
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawSquare imgDraw&, iX, iY, iSize, fgColor, bgColor
in$ = left$( _
"**FAILS?** DrawSquare " + _
"imgDraw&, " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cRed: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_9) Then
If iLastKeyCode% <> KeyCode_9 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_9: LastKey$ = ""
' 9 = OUTLINE BOX
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iSize = RandomNumber%(100, 150)
index = RandomNumber%(LBound(arrColor), UBound(arrColor)): fgColor = arrColor(index)
iWeight = RandomNumber%(6, 12)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawOutlineBox iX, iY, iSize, fgColor, iWeight
in$ = left$( _
"DrawOutlineBox " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"iWeight=" + _ToStr$(iWeight) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_0) Then
If iLastKeyCode% <> KeyCode_0 Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_0: LastKey$ = ""
' 0 = STYLED OUTLINE BOX
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iSize = RandomNumber%(90, 130)
index = RandomNumber%(LBound(arrGray), UBound(arrGray)): fgColor = arrGray(index)
iStyle = RandomNumber%(0, 255)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
DrawStyledOutlineBox iX, iY, iSize, fgColor, iStyle
in$ = left$( _
"DrawStyledOutlineBox " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iSize=" + _ToStr$(iSize) + ", " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"iStyle=" + _ToStr$(iStyle) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_A) Then
If iLastKeyCode% <> KeyCode_A Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_A: LastKey$ = ""
' A = TRIANGLE FILL
x1 = RandomNumber%(xmin, xmax - iSize)
y1 = RandomNumber%(ymin, ymax - iSize)
x2 = RandomNumber%(xmin, xmax - iSize)
y2 = RandomNumber%(ymin, ymax - iSize)
x3 = RandomNumber%(xmin, xmax - iSize)
y3 = RandomNumber%(ymin, ymax - iSize)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
TriangleFill x1, y1, x2, y2, x3, y3, fgColor
in$ = left$( _
"TriangleFill " + _
"x1=" + _ToStr$(x1) + ", " + _
"y1=" + _ToStr$(y1) + ", " + _
"x2=" + _ToStr$(x2) + ", " + _
"y2=" + _ToStr$(y2) + ", " + _
"x3=" + _ToStr$(x3) + ", " + _
"y3=" + _ToStr$(y3) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_C) Then
If iLastKeyCode% <> KeyCode_C Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_C: LastKey$ = ""
' C = THICK CIRCLE
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iRadius = RandomNumber%(50, 100)
iThickness = RandomNumber%(15, 30)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
ThickCircle iX, iY, iRadius, iThickness, fgColor
in$ = left$( _
"ThickCircle " + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"iRadius=" + _ToStr$(iRadius) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_L) Then
If iLastKeyCode% <> KeyCode_L Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_L: LastKey$ = ""
' L = THICK LINE
x1 = RandomNumber%(xmin, xmax - iSize)
y1 = RandomNumber%(ymin, ymax - iSize)
x2 = RandomNumber%(xmin, xmax - iSize)
y2 = RandomNumber%(ymin, ymax - iSize)
iThickness = RandomNumber%(1, 5)
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
ThickLine x1, y1, x2, y2, iThickness, fgColor
in$ = left$( _
"ThickLine " + _
"x1=" + _ToStr$(x1) + ", " + _
"y1=" + _ToStr$(y1) + ", " + _
"x2=" + _ToStr$(x2) + ", " + _
"y2=" + _ToStr$(y2) + ", " + _
"iThickness=" + _ToStr$(iThickness) + ", " + _
"fgColor=" + _ToStr$(fgColor) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_T) Then
If iLastKeyCode% <> KeyCode_T Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_T: LastKey$ = ""
' T = TEXT
iX = RandomNumber%(xmin, xmax - iSize)
iY = RandomNumber%(ymin, ymax - iSize)
iCharCode = iCharCode + 1: If iCharCode > 90 Then iCharCode = 65
iSize = RandomNumber%(1, 8)
in$ = String$(iSize, Chr$(iCharCode))
arrNotColor(1) = ScreenColor
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
arrNotColor(1) = fgColor
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
Color fgColor, bgColor
_PrintString (iX, iY), in$
in$ = left$( _
"Color " + _
"fgColor=" + _ToStr$(fgColor) + ", " + _
"bgColor=" + _ToStr$(bgColor) + " : " + _
"_PrintString " + _
"(" + _
"iX=" + _ToStr$(iX) + ", " + _
"iY=" + _ToStr$(iY) + ", " + _
"), " + _
"in$=" + chr$(34) + in$ + chr$(34) + _
string$(MaxCols-1, " "), MaxCols-1)
Color cWhite, cBlue: Locate MsgRow, 1: Print in$;
End If
ElseIf _Button(KeyCode_F) Then
If iLastKeyCode% <> KeyCode_F Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_F: LastKey$ = ""
' F = FILL
iX = mx
iY = my
arrNotColor(1) = fgColor ' use previous shape's color as border color
bgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
Paint (iX, iY), bgColor, fgColor ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
End If
ElseIf _Button(KeyCode_Home) Or _Button(KeyCode_Keypad7Home) Then
If iLastKeyCode% <> KeyCode_Home Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_Home: LastKey$ = ""
' HOME = CLS
_Dest imgDraw&: Cls , cEmpty
End If
Else
' Clear last keycode pressed (since it wasn't any of those)
iLastKeyCode% = 0
' -----------------------------------------------------------------------------
' SEE IF ANY OTHER KEYS WERE PRESSED USING InKey$
' -----------------------------------------------------------------------------
k$ = InKey$
If Len(k$) Then
' Remember last InKey$ pressed
LastKey$ = k$
Else
' Clear last key pressed
LastKey$ = ""
End If
End If
_KeyClear ' CLEAR KEYBOARD BUFFER
' DRAW LAYERS
_Dest 0: Cls , ScreenColor
_PutImage , imgDraw&, 0
_PutImage , imgHelp&, 0
_PutImage , imgMouse&, 0
If bFinished = _TRUE Then Exit Do
_Display
Loop Until _KeyDown(27)
' RELEASE OBJECTS FROM MEMORY
Screen 0
FreeImage imgDraw&
FreeImage imgHelp&
FreeImage imgMouse&
' RESTORE DISPLAY
_AutoDisplay
End Sub ' DrawTest
' ################################################################################################################################################################
' END SHAPES TEST
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SHAPE DRAWING ROUTINES #SHAPE #DRAW
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
'DrawBoxOutline iX, iY, iSize, fgColor
Sub DrawBoxOutline (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, B ' Draw box outline
End Sub ' DrawBoxOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (SOLID)
' https://www.qb64.org/wiki/LINE
' Renamed DrawBox/DrawBoxLine to DrawSolidBox
'DrawBoxSolid iX, iY, iSize, fgColor
Sub DrawBoxSolid (iX As Integer, iY As Integer, iSize As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + (iSize - 1), iY + (iSize - 1)), fgColor, BF ' Draw a solid box
End Sub ' DrawBoxSolid
' /////////////////////////////////////////////////////////////////////////////
' bplus: The Gold Standard is even better than THE QB64 CIRCLE sub in this respect!
' https://forum.qb64.org/index.php?topic=1044.135
' from Steve Gold standard
' Renamed fcirc to DrawCircleSolid
' Not as fast as DrawCircleTopLeft but pretty fast.
' Example:
' Screen _NewImage(800, 600, 32)
' _ScreenMove 250, 60
' For r = 250 To 0 Step -60
' DrawCircleSolid 400, 300, r, _RGBA(255, 255, 255, 100)
' Next r
'DrawCircle 0, iX, iY, iRadius, iThickness, fgColor, bgColor
Sub DrawCircle (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
Dim iLoop As Integer
Dim iNextRadius As Integer
Dim iRadiusError As Integer
Dim iNextX As Integer
Dim iNextY As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw circle fill
If bgColor <> cEmpty Then
iNextRadius = Abs(iRadius)
iRadiusError = -iNextRadius
iNextX = iNextRadius
iNextY = 0
If iNextRadius = 0 Then
PSet (iX, iY), bgColor
Else
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (iX - iNextX, iY)-(iX + iNextX, iY), bgColor, BF
While iNextX > iNextY
iRadiusError = iRadiusError + iNextY * 2 + 1
If iRadiusError >= 0 Then
If iNextX <> iNextY + 1 Then
Line (iX - iNextY, iY - iNextX)-(iX + iNextY, iY - iNextX), bgColor, BF
Line (iX - iNextY, iY + iNextX)-(iX + iNextY, iY + iNextX), bgColor, BF
End If
iNextX = iNextX - 1
iRadiusError = iRadiusError - iNextX * 2
End If
iNextY = iNextY + 1
Line (iX - iNextX, iY - iNextY)-(iX + iNextX, iY - iNextY), bgColor, BF
Line (iX - iNextX, iY + iNextY)-(iX + iNextX, iY + iNextY), bgColor, BF
Wend
End If
End If
' Draw circle outline
If fgColor <> cEmpty Then
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
iNextRadius = iRadius
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End If
End Sub ' DrawCircle
' /////////////////////////////////////////////////////////////////////////////
'DrawCircleOutline 0, iX, iY, iRadius, iThickness, fgColor
Sub DrawCircleOutline (img&, iX As Integer, iY As Integer, iRadius As Integer, iThickness As Integer, fgColor As _Unsigned Long)
Dim iNextRadius As Integer
Dim iLoop As Integer
If (img& <= 0) And (iThickness > 0) And (fgColor <> cEmpty) Then
' Select target image
_Dest img& ': Cls , cEmpty
' Initialize
iNextRadius = iRadius
' Draw circle
If iRadius = 0 Then
PSet (iX, iY), fgColor
Else
For iLoop = 1 To iThickness
' DRAW CIRCLE
' CIRCLE (x, y), radius, color
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (iX, iY), iNextRadius, fgColor
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
'Circle (iX, iY), 4, cRed
iNextRadius = iNextRadius - 1
If iNextRadius = 0 Then
PSet (iX, iY), fgColor
Exit For
End If
Next iLoop
End If
End If
End Sub ' DrawCircleOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE) WITH A SOLID LINE
'DrawOutlineBox iX%, iY%, iSize2%, iColor~&, iWeight2%
Sub DrawOutlineBox (iX%, iY%, iSize2%, iColor~&, iWeight2%)
Dim iFromX%
Dim iFromY%
Dim iToX%
Dim iToY%
Dim iSize%
Dim iWeight%
iSize% = iSize2% - 1
iWeight% = iWeight2% - 1
If iWeight% = 0 Then
' TOP LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' BOTTOM LINE
iFromX% = iX%
iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' LEFT LINE
iFromX% = iX%
iFromY% = iY%
iToX% = iX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
' RIGHT LINE
iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
ElseIf iWeight% > 0 Then
' TOP LINE
For iFromY% = iY% To (iY% + iWeight%)
iFromX% = iX%
'iFromY% = iY%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' BOTTOM LINE
For iFromY% = ((iY% + iSize%) - iWeight%) To (iY% + iSize%)
iFromX% = iX%
'iFromY% = iY% + iSize%
iToX% = iX% + iSize%
iToY% = iFromY%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromY%
' LEFT LINE
For iFromX% = iX% To (iX% + iWeight%)
'iFromX% = iX%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
' RIGHT LINE
For iFromX% = ((iX% + iSize%) - iWeight%) To (iX% + iSize%)
'iFromX% = iX% + iSize%
iFromY% = iY%
iToX% = iFromX%
iToY% = iY% + iSize%
Line (iFromX%, iFromY%)-(iToX%, iToY%), iColor~&, BF
Next iFromX%
End If
End Sub ' DrawOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE
'DrawRect 0, iX, iY, iSizeW, iSizeH, fgColor, bgColor
Sub DrawRect (img&, iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long, bgColor As _Unsigned Long)
'If img& < -1 Then
If img& <= 0 Then
' Select target image
_Dest img& ': Cls , cEmpty
' Draw fill (bgColor)
If bgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), bgColor, BF ' Draw a solid rectangle
End If
' Draw outline (fgColor)
If fgColor <> cEmpty Then
Line (iX, iY)-(iX + (iSizeW - 1), iY + (iSizeH - 1)), fgColor, B ' Draw rectangle outline
End If
End If
End Sub ' DrawRect
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (OUTLINE)
'DrawRectOutline iX, iY, iSizeW, iSizeH, fgColor
Sub DrawRectOutline (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, B ' Draw rectangle outline
End Sub ' DrawRectOutline
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
'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
' /////////////////////////////////////////////////////////////////////////////
'DrawSquare 0, x1, y1, size, fgcolor, bgcolor
Sub DrawSquare (img&, x1%, y1%, size%, fgcolor~&, bgcolor~&)
Dim x2%, y2%
If img& < -1 Then
_Dest img& ': Cls , cEmpty
x2% = (x1% + size%) - 1
y2% = (y1% + size%) - 1
Line (x1%, y1%)-(x2%, y1%), fgcolor~&, , 65535
Line (x2%, y1%)-(x2%, y2%), fgcolor~&, , 65535
Line (x2%, y2%)-(x1%, y2%), fgcolor~&, , 65535
Line (x1%, y2%)-(x1%, y1%), fgcolor~&, , 65535
If bgcolor~& <> cEmpty Then
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (x1% + 1, y1% + 1), bgcolor~&, fgcolor~&
End If
End If
End Sub ' Draw Square
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX (OUTLINE)
' https://www.qb64.org/wiki/LINE
' The style parameter 0-255 doesn't seem to have a solid line?
' For that, use DrawOutlineBox.
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
' B creates a box outline with each side parallel to the program screen sides. BF creates a filled box.
' The style% signed INTEGER value sets a dotted pattern to draw the line or rectangle outline.
'DrawStyledOutlineBox iX%, iY%, iSize%, iColor~&, iStyle%
Sub DrawStyledOutlineBox (iX%, iY%, iSize%, iColor~&, iStyle%)
Line (iX%, iY%)-(iX% + (iSize% - 1), iY% + (iSize% - 1)), iColor~&, B , iStyle%
End Sub ' DrawStyledOutlineBox
' /////////////////////////////////////////////////////////////////////////////
' Frees image if it exists
' and makes sure it isn't the current screen and _DEST
'FreeImage img
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then
If _ScreenImage = ThisImage& Then Screen 0
If _Dest = ThisImage& Then _Dest 0
_FreeImage ThisImage&
End If
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
' Initializes an image
' (if it already exists, frees it up and re-instantiates)
'InitImage img, iWidth, iHeight, bgColor
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'ThickCircle x!, y!, radius!, thickness!, colour~&
Sub ThickCircle (x As Single, y As Single, radius As Single, thickness As Single, colour As _Unsigned Long)
Dim rp As Single, rm As Single, rp2 As Single, rm2 As Single
Dim sm As Single, rpi2 As Single, rmi2 As Single, sp As Single
Dim i As Single
rp = radius + thickness / 2
rm = radius - thickness / 2
rp2 = rp ^ 2
rm2 = rm ^ 2
For i = -rp To -rm Step .2
rpi2 = rp2 - i ^ 2
sp = Sqr(rpi2)
Line (x + i, y)-(x + i, y + sp), colour, BF
Line (x + i, y)-(x + i, y - sp), colour, BF
Next
For i = -rm To 0 Step .2
rpi2 = rp2 - i ^ 2
rmi2 = rm2 - i ^ 2
sm = Sqr(rmi2)
sp = Sqr(rpi2)
Line (x + i, y + sm)-(x + i, y + sp), colour, BF
Line (x - i, y + sm)-(x - i, y + sp), colour, BF
Line (x + i, y - sm)-(x + i, y - sp), colour, BF
Line (x - i, y - sm)-(x - i, y - sp), colour, BF
Next
For i = rm To rp Step .2
rpi2 = rp2 - i ^ 2
sp = Sqr(rpi2)
Line (x + i, y)-(x + i, y + sp), colour, BF
Line (x + i, y)-(x + i, y - sp), colour, BF
Next
End Sub ' ThickCircle
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'ThickLine x1, y1, x2, y2, thk, kolor~&
Sub ThickLine (x1, y1, x2, y2, thk, kolor As _Unsigned Long)
'draw a line of thickness thk on color klr from x1,y1 to x2,y2
'orientation of line is set in the middle of line thickness
Static tempimage As Long, m As _MEM
Dim cang
Dim ta
Dim tb
Dim tax1
Dim tay1
Dim tax4
Dim tay4
Dim tax2
Dim tay2
Dim tax3
Dim tay3
If tempimage = 0 Then tempimage = _NewImage(1, 1, 32): m = _MemImage(tempimage)
$Checking:Off
_MemPut m, m.OFFSET, kolor
$Checking:On
cang = _Atan2((y2 - y1), (x2 - x1)) 'get the angle from x1,y1 to x2,y2
ta = cang + _Pi(.5)
tb = ta + _Pi
tax1 = x1 + (thk / 2) * Cos(ta): tay1 = y1 + (thk / 2) * Sin(ta)
tax4 = x1 + (thk / 2) * Cos(tb): tay4 = y1 + (thk / 2) * Sin(tb)
tax2 = x2 + (thk / 2) * Cos(ta): tay2 = y2 + (thk / 2) * Sin(ta)
tax3 = x2 + (thk / 2) * Cos(tb): tay3 = y2 + (thk / 2) * Sin(tb)
_MapTriangle (0, 0)-(0, 0)-(0, 0), tempimage To(tax1, tay1)-(tax2, tay2)-(tax4, tay4)
_MapTriangle (0, 0)-(0, 0)-(0, 0), tempimage To(tax2, tay2)-(tax3, tay3)-(tax4, tay4)
End Sub ' ThickLine
' /////////////////////////////////////////////////////////////////////////////
' From: SMcNeill, Super Moderator
' Date: 01-02-2024, 08:19 AM
' https://qb64phoenix.com/forum/showthread.php?tid=2372&highlight=line+thickness
'TriangleFill x1, y1, x2, y2, x3, y3, fgColor~&
Sub TriangleFill (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
$Checking:Off
Static a&, m As _MEM
If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
_MemPut m, m.OFFSET, K
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
$Checking:On
End Sub ' TriangleFill
' ################################################################################################################################################################
' END SHAPE DRAWING ROUTINES @SHAPE @DRAW
' ################################################################################################################################################################
' SOME FLOOD FILL STUFF TO TRY LATER?
'' /////////////////////////////////////////////////////////////////////////////
'' QIX
'' https://qb64phoenix.com/forum/showthread.php?tid=1201&pid=10820#pid10820
'' From: james2464
'' Date 11-28-2022, 10:36 PM
'
'' using paint for flood fills
'Sub claimfillfast (x, y, c~&)
' c~& = _RGB(30, 30, 30)
' k = q(1).xx: j = q(1).yy
'
' ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
' Paint (k, j), c~&
'
' 'fill black with blue
' For j = 41 To 439
' For k = 121 To 519
' c(16) = Point(k, j)
' If c(16) = c(0) Then
' PSet (k, j), c(4)
' bluetot = bluetot + 1
' End If
' Next k
' Next j
'
' 'fill gray with black
' k = q(1).xx: j = q(1).yy
' Paint (k, j), c(0), c(1)
'End Sub ' claimfillfast
'
'' /////////////////////////////////////////////////////////////////////////////
'' QIX
'' https://qb64phoenix.com/forum/showthread.php?tid=1201&pid=10820#pid10820
'' From: james2464
'' Date 11-28-2022, 10:36 PM
'
'' using paint for flood fills
'Sub claimfillslow (x, y, c~&)
' 'start at qix
' c~& = _RGB(30, 30, 30)
' k = q(1).xx: j = q(1).yy
'
' ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
' Paint (k, j), c~&
'
' 'fill black with red
' For j = 41 To 439
' For k = 121 To 519
' c(16) = Point(k, j)
' If c(16) = c(0) Then
' PSet (k, j), c(5)
' redtot = redtot + 1
' End If
' Next k
' Next j
'
' 'fill gray with black
' k = q(1).xx: j = q(1).yy
' Paint (k, j), c(0), c(1)
'End Sub ' claimfillslow
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RGB COLOR FUNCTIONS #RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
'cWhite = _RGB32(254, 254, 254)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
'cEmpty~& = -1
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RGB COLOR FUNCTIONS @RGB
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST ALPHA COLORS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function cDimGrayAlpha~& (alpha&)
cDimGrayAlpha = _RGB32(105, 105, 105, alpha&)
End Function ' cDimGrayAlpha~&
Function cGrayAlpha~& (alpha&)
cGrayAlpha = _RGB32(128, 128, 128, alpha&)
End Function ' cGrayAlpha~&
Function cDarkGrayAlpha~& (alpha&)
cDarkGrayAlpha = _RGB32(169, 169, 169, alpha&)
End Function ' cDarkGrayAlpha~&
Function cSilverAlpha~& (alpha&)
cSilverAlpha = _RGB32(192, 192, 192, alpha&)
End Function ' cSilverAlpha~&
Function cLightGrayAlpha~& (alpha&)
cLightGrayAlpha = _RGB32(211, 211, 211, alpha&)
End Function ' cLightGrayAlpha~&
Function cGainsboroAlpha~& (alpha&)
cGainsboroAlpha = _RGB32(220, 220, 220, alpha&)
End Function ' cGainsboroAlpha~&
Function cWhiteSmokeAlpha~& (alpha&)
cWhiteSmokeAlpha = _RGB32(245, 245, 245, alpha&)
End Function ' cWhiteSmokeAlpha~&
Function cWhiteAlpha~& (alpha&)
cWhiteAlpha = _RGB32(255, 255, 255, alpha&)
End Function ' cWhiteAlpha~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST ALPHA COLORS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN COLOR ARRAY FUNCTIONS #COLR
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Used by Sub AddColors
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
' /////////////////////////////////////////////////////////////////////////////
' Used by Sub AddSpectrumColors and Sub AddgrayscaleColors
Sub AddColors (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long, HowMany As Long)
Dim iLoop As Integer
For iLoop = 1 To HowMany
AddColor ColorValue, arrColor()
Next iLoop
End Sub ' AddColors
' /////////////////////////////////////////////////////////////////////////////
' 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)
Dim iNum As Integer
iNum = 1
' SOLID:
AddColors cRed, arrColor(), iNum
AddColors cOrange, arrColor(), iNum
AddColors cYellow, arrColor(), iNum
AddColors cLime, arrColor(), iNum
AddColors cCyan, arrColor(), iNum
AddColors cBlue, arrColor(), iNum
AddColors cMagenta, arrColor(), iNum
AddColors cBlack, arrColor(), iNum
' TRANSPARENT:
Dim alpha&: alpha& = 256
alpha& = alpha& - 30
AddColors cDimGrayAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cGrayAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cDarkGrayAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cSilverAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cLightGrayAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cGainsboroAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cWhiteSmokeAlpha~&(alpha&), arrColor(), iNum
alpha& = alpha& - 30
AddColors cWhiteAlpha~&(alpha&), arrColor(), iNum
'dim iLoop as integer
'for iLoop = 1 to 8
' alpha& = alpha& - 30
' AddColors cWhiteAlpha~&(alpha&), arrColor(), iNum
'next iLoop
End Sub ' AddTestColors
' /////////////////////////////////////////////////////////////////////////////
' Adds rainbow colors to array arrColor().
Sub AddSpectrumColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cRed, arrColor(), iNum
AddColors cOrangeRed, arrColor(), iNum
AddColors cDarkOrange, arrColor(), iNum
AddColors cOrange, arrColor(), iNum
AddColors cGold, arrColor(), iNum
AddColors cYellow, arrColor(), iNum
AddColors cChartreuse, arrColor(), iNum
AddColors cOliveDrab1, arrColor(), iNum
AddColors cLime, arrColor(), iNum
AddColors cMediumSpringGreen, arrColor(), iNum
AddColors cSpringGreen, arrColor(), iNum
AddColors cCyan, arrColor(), iNum
AddColors cDeepSkyBlue, arrColor(), iNum
AddColors cDodgerBlue, arrColor(), iNum
AddColors cSeaBlue, arrColor(), iNum
AddColors cBlue, arrColor(), iNum
AddColors cBluePurple, arrColor(), iNum
AddColors cDeepPurple, arrColor(), iNum
AddColors cPurple, arrColor(), iNum
AddColors cPurpleRed, arrColor(), iNum
End Sub ' AddSpectrumColors
' /////////////////////////////////////////////////////////////////////////////
' Adds grayscale colors to array arrColor().
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' /////////////////////////////////////////////////////////////////////////////
' Returns a random color chosen from array of color values arrColor().
'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().
'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
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN GENERAL PURPOSE ROUTINES #GEN
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = _TRUE
Else
IsEven% = _FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns _TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = _TRUE
Else
IsOdd% = _FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' 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
' /////////////////////////////////////////////////////////////////////////////
' For tracking mouse buttons
Sub ToggleButtonState (bButton As Integer, bOldButton As Integer, bClickButton As Integer)
If bButton = _TRUE Then
If bOldButton = _FALSE Then
bClickButton = _TRUE
bOldButton = _TRUE
Else
bClickButton = _FALSE
End If
Else
bOldButton = _FALSE
bClickButton = _FALSE
End If
End Sub ' ToggleButtonState
' ################################################################################################################################################################
' END GENERAL PURPOSE ROUTINES @GEN
' ################################################################################################################################################################RE: flood fill ? - SMcNeill - 04-25-2025
A few things to note about this code, which broked my poor brain.
1) Your are mapping your instructions wrong.
Mousebutton(1) is the left button.
Mousebutton(2) is the right button.
MouseButton(3) is the middle button.
Instructions say : STEVE IS MIDDLE BUTTON..
Code say: ' Steve
If mb2 Then Fill mx, my, arrColor(index)
So... Steve Fill is the right mouse button.
Petr fill is middle mouse button.
And why does Steve's Fill not fill?
Because of your specifications that you asked for with your opening post:
Quote:how do you get it to stop at any color where the alpha value > 0
Steve's Fill was designed to work on _RGBA32(0,0,0,0) colors, and not fill anything else. You start out with a CLS , _RGB32(0,0,0) statement which fills the entire screen with BLACK with 255 ALPHA, and I designed it so that it stops at "any color where the alpha value > 0"...
That's why it poops points. It basically is doing a PSET for you at the point you click on (there's no check for that, so you always get one free pixel colored before the check for that transparent background kicks in). The Fill routine I wrote isn't going to work in this scenario at all, just because you're completely changing what it was asked to do. You asked for a fill for 0 alpha, to stop when alpha is > 0... and then you paint the whole screen 255 alpha.
It's not going to work like that unless you go in and tweak the color checking routines first.
Seems like you need to decide what exactly you want to do, before you start trying to create code to do something that you're not wanting done.