Posts: 3,008
Threads: 357
Joined: Apr 2022
Reputation:
282
This seems to be close to what you're looking for. Maybe? To be honest, I'm not entirely certain what you're looking for now. LOL! 
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...4#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...6#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 As _Unsigned Long OC, BC
OC = Point(x, y) 'original color
If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then 'we're going to blend
PSet (x, y), Kolor
BC = Point(x, y) 'blended color
End If
Filler x, y, Kolor, OC, BC
End Sub
Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Or Kolor = BC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = BC Then Exit Do
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = BC Then Exit Do
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = BC Then _Continue
If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC, BC
Next
For i = l To r
If Point(i, y - 1) = BC Then _Continue
If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then Filler i, y - 1, Kolor, OC, BC
Next
End Sub ' Fill
' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' reply #8
' https://qb64phoenix.com/forum/showthread...3#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...+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...+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...+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...0#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...0#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-...en-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-...en-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
' ################################################################################################################################################################
And remember, Steve Fill is (RIGHT CLICK), not (MIDDLE CLICK).
But this choses the color where you decide to paint as the original color, and it colors all surrounding colors that same color.
For alpha images, it also records the blended color you create so that it won't run endlessly looping and painting itself over and over as the colors blend together.
Seems fairly speedy to me, without breaking as it goes along. All I can say is test it out. It's a wee bit more complicated that the original (which was only supposed to blend 0 alpha areas), but it seems like it might be what you're looking for?
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
04-25-2025, 02:27 AM
(This post was last modified: 04-25-2025, 03:22 AM by madscijr.)
I think we need a facepalm smily for the forums.
![[Image: IMG-5542.jpg]](https://i.ibb.co/jkLWfZ3C/IMG-5542.jpg)
Maybe a double facepalm!
![[Image: IMG-5549.png]](https://i.ibb.co/v4b19VkY/IMG-5549.png)
To start, I deserve one for getting the mousebuttons wrong.
And another one for the convoluted / confused explanation ("spec").
All apologies!
I'm basically looking for a "paintbucket" tool like in Microsoft Paint!
Why couldn't I just have thought of the obvious description?
![[Image: IMG-5544.png]](https://i.ibb.co/TxwVZzB1/IMG-5544.png)
best free image hosting
Oy vey
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
(04-25-2025, 01:52 AM)SMcNeill Wrote: This seems to be close to what you're looking for. Maybe?
To be honest, I'm not entirely certain what you're looking for now. LOL! Yep, Paintbucket
(04-25-2025, 01:52 AM)SMcNeill Wrote: And remember, Steve Fill is (RIGHT CLICK), not (MIDDLE CLICK). Fixed it, thanks. DOH!
(04-25-2025, 01:52 AM)SMcNeill Wrote: Seems fairly speedy to me, without breaking as it goes along.
All I can say is test it out.
It's a wee bit more complicated that the original (which was only supposed to blend 0 alpha areas),
but it seems like it might be what you're looking for? It works! Now if only I could remember what I was going to use these draw routines for to begin with! 
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
MainMenu
System
' /////////////////////////////////////////////////////////////////////////////
Sub MainMenu
Dim in$
Do
Print "1. BPlus paint3"
Print "2. Steve Fill"
Print "3. Petr Paint2"
Print "4. FillTest (Compare all 3 fills.)"
Print "5. DrawTest (test of different shape + drawing routines)"
Input "1-5 or Q to quit"; in$
in$ = UCase$(Left$(_Trim$(in$), 1))
Select Case in$
Case "1": FillBPlus
Case "2": FillSteve
Case "3": FillPetr
Case "4": FillTest
Case "5": DrawTest
End Select
_KeyClear
Screen 0
If in$ = "Q" Then Exit Do
Loop
End Sub ' MainMenu
' /////////////////////////////////////////////////////////////////////////////
' 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, oldIndex As Integer ' pointer to the current color
Dim c~&
' INIT SCREEN
_Title "FillTest"
Screen _NewImage(1024, 768, 32): _Delay .25: _ScreenMove 0, 0
' GET COLORS
AddTestColors arrColor(): index = LBound(arrColor) + 1: oldIndex = index
' 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: Petr Paint2 ";
Locate 5, 1: Print " RIGHT-CLICK: Steve Fill ";
Color _RGB32(255, 255, 0), _RGB32(0, 0, 0)
Locate 7, 1: Print "--------------------------";
Locate 8, 1: Print "0 - 9 = plot a point ";
Locate 9, 1: Print "Space = next fill color ";
Locate 10, 1: Print "Enter = redraw ";
Locate 11, 1: Print "Esc = exit ";
Locate 12, 1: Print "--------------------------";
' TEST FILL
Do Until k& = 13 Or k& = 27
' SHOW LOCATION + COLOR
Color _RGB32(160, 160, 160), _RGB32(0, 0, 0)
Locate 13, 1: Print "fill at : " + _ToStr$(x) + "," + _ToStr$(y)
Locate 14, 1: Print "fill color (" + Left$(_ToStr$(index) + " ", 2) + "): "
If index > LBound(arrColor) Then c~& = arrColor(index)
Color c~&, c~&
Locate 14, 18: Print " ";
Color _RGB32(160, 160, 160), _RGB32(0, 0, 0)
Locate 14, 24: print "(" + _
"r=" + right$(" " + _ToStr$(_RED32(c~&)), 3) + ", " + _
"g=" + right$(" " + _ToStr$(_GREEN32(c~&)), 3) + ", " + _
"b=" + right$(" " + _ToStr$(_BLUE32(c~&)), 3) + ", " + _
"a=" + right$(" " + _ToStr$(_ALPHA32(c~&)), 3) + ")";
k& = _KeyHit
' 0-9 = 48 49 50 51 52 53 54 55 56 57
If k& = 32 Then
' Spacebar
index = index + 1
If index > UBound(arrColor) Then
index = LBound(arrColor)
End If
ElseIf k& = 49 Then
'DrawCircle 0, mx, my, 1, 1, c~&, c~&
Line (mx, my)-(mx, my), c~&
ElseIf k& = 50 Then
DrawCircle 0, mx, my, 1, 1, c~&, c~&
ElseIf k& = 51 Then
DrawCircle 0, mx, my, 2, 1, c~&, c~&
ElseIf k& = 52 Then
DrawCircle 0, mx, my, 4, 1, c~&, c~&
ElseIf k& = 53 Then
DrawCircle 0, mx, my, 8, 1, c~&, c~&
ElseIf k& = 54 Then
DrawCircle 0, mx, my, 16, 1, c~&, c~&
ElseIf k& = 55 Then
DrawCircle 0, mx, my, 32, 1, c~&, c~&
ElseIf k& = 56 Then
DrawCircle 0, mx, my, 64, 1, c~&, c~&
ElseIf k& = 57 Then
DrawCircle 0, mx, my, 128, 1, c~&, c~&
ElseIf k& = 48 Then
DrawCircle 0, mx, my, 256, 1, c~&, c~&
'DrawCircle imgDraw&, iX, iY, iRadius, iThickness, fgColor, bgColor
End If
While _MouseInput
index = index - _MouseWheel
If index < LBound(arrColor) Then
index = UBound(arrColor)
ElseIf index > UBound(arrColor) Then
index = LBound(arrColor)
End If
Wend
' Did color change?
If index <> oldIndex Then
' get color from array or if index = lbound use random color
If index = LBound(arrColor) Then
c~& = _RGBA32( _
RandomNumber%(0, 255), _
RandomNumber%(0, 255), _
RandomNumber%(0, 255), _
RandomNumber%(0, 255) )
Else
c~& = arrColor(index)
End If
oldIndex = index
End If
mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1): mb2 = _MouseButton(2): mb3 = _MouseButton(3)
' BPlus
If mb1 Then paint3 mx, my, c~&
' Steve
If mb2 Then Fill mx, my, c~&
' Petr
If mb3 Then Paint2 mx, my, c~&
_Limit 200
Loop
If k& = 27 Then Exit Do
k& = 0
Loop
End Sub ' FillTest
' ################################################################################################################################################################
' # BEGIN BPlus's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' https://qb64phoenix.com/forum/showthread...4#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...6#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 As _Unsigned Long OC, BC
OC = Point(x, y) 'original color
If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then 'we're going to blend
PSet (x, y), Kolor
BC = Point(x, y) 'blended color
End If
Filler x, y, Kolor, OC, BC
End Sub
Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Or Kolor = BC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = BC Then Exit Do
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = BC Then Exit Do
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = BC Then _Continue
If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC, BC
Next
For i = l To r
If Point(i, y - 1) = BC Then _Continue
If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then Filler i, y - 1, Kolor, OC, BC
Next
End Sub ' Fill
' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' reply #8
' https://qb64phoenix.com/forum/showthread...3#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 = STEVE FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "B = BPLUS FILL"
in$ = in$ + _IIf(Len(in$) > 0, delim$, "") + "P = PETR 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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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)
iX = mx: iY = my
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 = mx + RandomNumber%(-150, 150)
y1 = my + RandomNumber%(-150, 150)
x2 = mx + RandomNumber%(-150, 150)
y2 = my + RandomNumber%(-150, 150)
x3 = mx + RandomNumber%(-150, 150)
y3 = my + RandomNumber%(-150, 150)
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)
iX = mx: iY = my
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 = mx + RandomNumber%(-100, 100)
y1 = my + RandomNumber%(-100, 100)
x2 = mx + RandomNumber%(-100, 100)
y2 = my + RandomNumber%(-100, 100)
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)
iX = mx: iY = my
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 = STEVE FILL
_Source imgDraw&
arrNotColor(1) = Point(mx, my)
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
_Dest imgDraw&
' DOESN'T FILL EMPTY:
Fill mx, my, fgColor ' Steve
End If
ElseIf _Button(KeyCode_B) Then
If iLastKeyCode% <> KeyCode_B Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_B: LastKey$ = ""
' B = BPLUS FILL
_Source imgDraw&
arrNotColor(1) = Point(mx, my)
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
_Dest imgDraw&
' WORKS BUT SLOW:
paint3 mx, my, fgColor ' BPLUS
End If
ElseIf _Button(KeyCode_P) Then
If iLastKeyCode% <> KeyCode_P Then
' Remember last key pressed to prevent holding it down
iLastKeyCode% = KeyCode_P: LastKey$ = ""
' P = PETR FILL
_Source imgDraw&
arrNotColor(1) = Point(mx, my)
fgColor = GetRandomColorExcept~&(arrColor(), arrNotColor())
_Dest imgDraw&
' DOESN'T FILL EMPTY:
Paint2 mx, my, fgColor ' Petr
''OLD PAINT METHOD, NOT REALLY PAINTBUCKET:
'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...+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...+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...+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...0#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...0#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~&
' added this cuz the others either feel too red or too yellow!
Function cTrueOrange~& ()
cTrueOrange = _RGB32(255, 100, 0)
End Function ' cTrueOrange~&
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 cTrueOrange, 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-...en-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-...en-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
' ################################################################################################################################################################
Posts: 3,008
Threads: 357
Joined: Apr 2022
Reputation:
282
04-25-2025, 11:36 AM
(This post was last modified: 04-25-2025, 01:29 PM by SMcNeill.)
For speed comparison:
Code: (Select All)
Screen _NewImage(800, 800, 32)
Circle (400, 400), 400, _RGB32(255, 255, 255) 'white circle
t# = Timer
For i = 1 To 100
Paint (400, 400), _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _RGB32(255, 255, 255)
Next
t1# = Timer
For i = 1 To 100
Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next
t2# = Timer
Print Using "###.### second Paint"; t1# - t#
Print Using "###.### second Fill"; t2# - t1#
Sub Fill (x, y, Kolor As _Unsigned Long)
Dim As _Unsigned Long OC, BC
OC = Point(x, y) 'original color
If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then 'we're going to blend
PSet (x, y), Kolor
BC = Point(x, y) 'blended color
End If
Filler x, y, Kolor, OC, BC
End Sub
Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Or Kolor = BC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = BC Then Exit Do
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = BC Then Exit Do
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = BC Then _Continue
If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC, BC
Next
For i = l To r
If Point(i, y - 1) = BC Then _Continue
If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then Filler i, y - 1, Kolor, OC, BC
Next
End Sub ' Fill
Notice that this is considerably slower than the built-in PAINT routine. This also has to keep track of blending and alpha and match original colors and other stuff as well, so it's designed more for versatility than speed. For a photoshop type paint fill, I imagine this would be fine. As a fill routine for a game or something that's going to be called repeatedly in a loop, I'd think you'd want to find something more efficient.
I'm not certain exactly certain what you might need it for, but it's the first example of an alpha-blending fill that I think I've seen on the forums here. If anyone has something comparable, I'd love to see it myself, just to study different techniques and ideas behind how to do something like this quickly and efficiently.
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
I think it would be ideal to add a parameter like EnableBlend% to the fill function, where if _TRUE, do the fancy alpha blend stuff, else do it simpler & quicker.
Most immediately I wanted a fill for one of those color wheel screensaver animations, so will want speed before alpha, but I think the alpha will come in handy for other projects.
Thanks for all your help and code with this!
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
04-25-2025, 06:49 PM
(This post was last modified: 04-25-2025, 08:49 PM by madscijr.
Edit Reason: tag Petr!
)
I added the EnableBlend% parameter to disable the blend check and it's twice as fast.
@Petr's fill (paint2) was fastest after native paint, though I still don't understand what he's doing.
Here's a test of all of them:
Code: (Select All) ' Paint vs Fill speed comparison by Steve, v2 by madscijr
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33725#pid33725
Screen _NewImage(800, 800, 32)
Circle (400, 400), 400, _RGB32(255, 255, 255) 'white circle
TestNum% = 0
TextCols% = (_Width / _FontWidth) - 1
NumTests% = 5
TestNum% = TestNum% + 1
t0# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Paint (400, 400), _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _RGB32(255, 255, 255)
Next i
TestNum% = TestNum% + 1
t1# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_FALSE)"
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _FALSE
Next i
TestNum% = TestNum% + 1
t2# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_TRUE) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _TRUE
Next i
TestNum% = TestNum% + 1
t3# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint2) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Paint2 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i
TestNum% = TestNum% + 1
t4# = Timer
' only test 1x, or else we'll be here all day!
For i = 1 To 1
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint3) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 1 "
paint3 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i
t5# = Timer
Locate 1, 1: Print Left$("Test complete" + String$(TextCols%, " "), TextCols%)
Locate 2, 1: Print Left$("Results for 100 fills:" + String$(TextCols%, " "), TextCols%)
Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
Locate 3, 2: Print Using "###.### seconds Paint "; t1# - t0#
Locate 4, 2: Print Using "###.### seconds Fill EnableBlend%=_FALSE "; t2# - t1#
Locate 5, 2: Print Using "###.### seconds Fill EnableBlend%=_TRUE "; t3# - t2#
Locate 6, 2: Print Using "###.### seconds Paint2 "; t4# - t3#
Locate 7, 2: Print Using "###.### seconds Paint3 "; (t5# - t4#) * 100
' ################################################################################################################################################################
' # BEGIN BPlus's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' 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
' 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
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill, Super Moderator
' 4/23/2025 8:55 PM
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, _FALSE '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, EnableBlend%)
Dim As _Unsigned Long OC, BC
OC = Point(x, y) 'original color
If EnableBlend% = _TRUE Then
' blend is enabled
If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then ' we're going to blend
PSet (x, y), Kolor
BC = Point(x, y) ' blended color
End If
BlendFiller x, y, Kolor, OC, BC
Else
Filler x, y, Kolor, OC
End If
End Sub ' Fill
' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill (opaque)
Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC
Next
For i = l To r
If Point(i, y - 1) = OC Then Filler i, y - 1, Kolor, OC
Next
End Sub ' Filler
' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill with blending colors w/alpha < 255
Sub BlendFiller (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Or Kolor = BC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = BC Then Exit Do
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = BC Then Exit Do
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = BC Then _Continue
If Point(i, y + 1) = OC Then BlendFiller i, y + 1, Kolor, OC, BC
Next
For i = l To r
If Point(i, y - 1) = BC Then _Continue
If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then BlendFiller i, y - 1, Kolor, OC, BC
Next
End Sub ' BlendFiller
' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Petr, Mini-Mod
' 4/24/2025 9:42 AM
' https://qb64phoenix.com/forum/showthread.php?tid=1507
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
' ################################################################################################################################################################
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
04-25-2025, 07:36 PM
(This post was last modified: 04-26-2025, 01:09 AM by madscijr.
Edit Reason: updated Sub PaintMask to eliminate unnecessary _COPYIMAGE step; added results to post
)
I had a "bright idea" to use _CLEARCOLOR on all known colors in use except the background color, to create a temp image that Paint operates on (that way it doesn't overwrite the other colors) and copies the result back over the original image (see Sub PaintMask on line 125), but it's still not faster than your Fill w/o alpha or @Petr's paint2. Oh well, it was worth a try right?
Below is the test code with all 6 methods.
Results for 100 fills:
Method Time for 100 fills
-------------- ------------------
Paint 0.879 seconds
Fill w/o blend 2.695 seconds
Fill w/blend 5.711 seconds
Paint2 1.816 seconds!!!
Paint3 862.500 seconds (time for 1 test * 100)
PaintMask 5.055 seconds
Code: (Select All) ' Paint vs Fill speed comparison
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33725#pid33725
Screen _NewImage(800, 800, 32)
Cls , _RGB32(0, 0, 0)
Circle (400, 400), 400, _RGB32(255, 255, 255) 'white circle
TestNum% = 0
TextCols% = (_Width / _FontWidth) - 1
NumTests% = 6
TestNum% = TestNum% + 1
t0# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Paint (400, 400), _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _RGB32(255, 255, 255)
Next i
TestNum% = TestNum% + 1
t1# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_FALSE)"
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _FALSE
Next i
TestNum% = TestNum% + 1
t2# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_TRUE) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _TRUE
Next i
TestNum% = TestNum% + 1
t3# = Timer
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint2) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
Paint2 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i
TestNum% = TestNum% + 1
t4# = Timer
' only test 1x, or else we'll be here all day!
For i = 1 To 1
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint3) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 1 "
paint3 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i
TestNum% = TestNum% + 1
t5# = Timer
ReDim arrColor(0 To 0) As _Unsigned Long
AddColor _RGB32(0, 0, 0), arrColor()
AddColor _RGB32(255, 255, 255), arrColor()
For i = 1 To 100
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (PaintMask) "
Locate 2, 1: Print "Fill " + Right$(" " + _ToStr$(i), 3) + " of 100 "
PaintMask 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), arrColor()
Next i
t6# = Timer
Locate 1, 1: Print Left$("Test complete" + String$(TextCols%, " "), TextCols%)
Locate 2, 1: Print Left$("Results for 100 fills:" + String$(TextCols%, " "), TextCols%)
Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
Locate 3, 2: Print Using "###.### seconds Paint "; t1# - t0#
Locate 4, 2: Print Using "###.### seconds Fill EnableBlend%=_FALSE "; t2# - t1#
Locate 5, 2: Print Using "###.### seconds Fill EnableBlend%=_TRUE "; t3# - t2#
Locate 6, 2: Print Using "###.### seconds Paint2 "; t4# - t3#
Locate 7, 2: Print Using "###.### seconds Paint3 "; (t5# - t4#) * 100
Locate 8, 2: Print Using "###.### seconds PaintMask "; t6# - t5#
' ################################################################################################################################################################
' # BEGIN madscijr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Does a paintbucket fill with paint
' using _CLEARCOLOR to protect unwanted colors
' from being painted over.
' Receives arrIgnoreColors() an array of "protected" colors
' which are removed from temp image with _CLEARCOLOR,
' First we look at point x0, y0 to get the target color,
' then _CLEARCOLOR all the colors in arrIgnoreColors()
' then _PUTIMAGE to a temp image, paint does fill on that,
' then _PUTIMAGE that back to the original.
' * v2 eliminates a temp image we didn't need.
' Prequisites:
' _SOURCE & _DEST must be set to the target image.
' -----------------------------------------------------------------------------
' NOTES:
' The _CLEARCOLOR statement sets a specific color to be treated as
' transparent when an image is later put (via _PUTIMAGE) onto another image.
' Syntax: _CLEARCOLOR {color&|_NONE}[, Dest_Handle&]
' The _SETALPHA statement sets the alpha channel transparency level of some
' or all of the pixels of an image.
' Syntax: _SETALPHA alpha&[, color1&][ TO colour2&] [, imageHandle&]
' -----------------------------------------------------------------------------
' Example usage:
' ReDim arrIgnoreColors(0 To 0) As _Unsigned Long ' array of colors
' AddColor ColorValue&, arrIgnoreColors()
' PaintMask x0, y0, FillColor~&, arrIgnoreColors()
Sub PaintMask (x0, y0, FillColor~&, arrIgnoreColors() As _Unsigned Long)
Dim imgSource&
Dim imgFill&
Dim index%
Dim bgColor~&
' Reference original image
imgSource& = _Dest
' Get target color
bgColor~& = Point(x0, y0)
If bgColor~& <> FillColor~& Then
' Clear any colors not the target color or fill color
For index% = LBound(arrIgnoreColors) To UBound(arrIgnoreColors)
If arrIgnoreColors(index%) <> FillColor~& Then
If arrIgnoreColors(index%) <> bgColor~& Then
_ClearColor arrIgnoreColors(index%), imgSource&
End If
End If
Next index%
' Create fill target
InitImage imgFill&, _Width(imgSource&), _Height(imgSource&), _RGB32(0, 0, 0, 0)
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgSource&, imgFill&
' Fill in fill target
_Dest imgFill&
'PAINT [STEP] (column%, row%), fillColor[, borderColor%]
Paint (x0, y0), FillColor~&, _RGB32(0, 0, 0, 0)
' Copy fill target onto main image
'_PUTIMAGE , sourceHandle&, destHandle& 'size full source to fit full destination area
_PutImage , imgFill&, imgSource& 'size full source to fit full destination area
' Point back at main image
_Source imgSource&
_Dest imgSource&
' Undo _CLEARCOLOR
_ClearColor _None, imgSource&
'_ClearColor _RGB32(0, 0, 0, 0), imgSource& ' re-add the color we use for transparent?
' Cleanup
FreeImage imgFill&
End If
End Sub ' PaintMask
' ################################################################################################################################################################
' # END madscijr's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN BPlus's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' 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
' 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
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' SMcNeill, Super Moderator
' 4/23/2025 8:55 PM
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, _FALSE '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, EnableBlend%)
Dim As _Unsigned Long OC, BC
OC = Point(x, y) 'original color
If EnableBlend% = _TRUE Then
' blend is enabled
If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then ' we're going to blend
PSet (x, y), Kolor
BC = Point(x, y) ' blended color
End If
BlendFiller x, y, Kolor, OC, BC
Else
Filler x, y, Kolor, OC
End If
End Sub ' Fill
' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill (opaque)
Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC
Next
For i = l To r
If Point(i, y - 1) = OC Then Filler i, y - 1, Kolor, OC
Next
End Sub ' Filler
' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill with blending colors w/alpha < 255
Sub BlendFiller (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
Dim l, r, i
If Kolor = OC Or Kolor = BC Then Exit Sub
l = x: r = x 'find left/right to fill
Do Until l = 0
If Point(l - 1, y) = BC Then Exit Do
If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
Loop 'find the left boundry
Do Until r = _Width - 1
If Point(r + 1, y) = BC Then Exit Do
If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
Loop 'find the right boundry
Line (l, y)-(r, y), Kolor, BF
For i = l To r
If Point(i, y + 1) = BC Then _Continue
If Point(i, y + 1) = OC Then BlendFiller i, y + 1, Kolor, OC, BC
Next
For i = l To r
If Point(i, y - 1) = BC Then _Continue
If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then BlendFiller i, y - 1, Kolor, OC, BC
Next
End Sub ' BlendFiller
' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################
' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Petr, Mini-Mod
' 4/24/2025 9:42 AM
' https://qb64phoenix.com/forum/showthread.php?tid=1507
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 UTILITY FUNCTIONS
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' Append color ColorValue to array arrColor
Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor
' /////////////////////////////////////////////////////////////////////////////
' 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
' ################################################################################################################################################################
' END UTILITY FUNCTIONS
' ################################################################################################################################################################
Posts: 440
Threads: 44
Joined: Jul 2022
Reputation:
43
@Madscijr
hi, I find very interesting this thread but I have loosen my understaning about the goal of your research...
an empower paint bucket useful in a graphic drawing tool?
a tool to substitute the PALETTE commands in 32bits graphic mode?
a blending tool ?
is it for a graphic app like paint/gimp/photoshop ?
is it for a graphic engine building at fly the images and models?
I think, IMHO, that there are so many features and tools to invent regarding the set goal. But what is the set goal? I missed this one.
In DOS programming time for movement and sprites it was useful use GET/PUT with AND / OR / XOR to get transparency and blending effects. The same I see used in Windows (until win 95) with the same BASIC keywords and some masking tecniques.
But with alpha channel and hardware images you can get more and more, and also using OpenGl. So I think that a graphic engine on fly works well using GPU, while for basic graphic engine and paintlike tools the CPU is enough, but for professional and speedy results we must think about GPU.
In what direction do you want to look at? Your choice will select the answer.
Posts: 1,035
Threads: 139
Joined: Apr 2022
Reputation:
23
04-27-2025, 08:36 PM
(This post was last modified: 04-27-2025, 08:59 PM by madscijr.)
This is mainly just a fast paintbucket tool to fill in areas. The palette substitution was just part of an idea I had to harness the PAINT command for that purpose, but Petr and Steve's algorithms are faster. I was just curious about the alpha. The Paint2 and Fill functions do what I want, so I think we're done here, thanks!
Posts: 26
Threads: 6
Joined: Mar 2025
Reputation:
1
04-29-2025, 02:56 AM
(This post was last modified: 04-29-2025, 02:56 AM by CMR.)
Slightly relevant to the topic, is there a quick way to fill in a _NEWIMAGE with a color?
|
