Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
09-15-2024, 11:53 AM
(This post was last modified: 09-15-2024, 11:57 AM by Dav.)
(09-15-2024, 05:43 AM)vince Wrote: is this gonna be another 10 page arms race? let me throw mine in then
Code: (Select All) sub cboxf (x, y, w, h, r, c as _unsigned long)
x0 = r
y0 = 0
e = -r
do while y0 < x0
if e <= 0 then
y0 = y0 + 1
line (x + r - x0, y + r - y0) - (x + w - r + x0, y + r - y0), c, bf
line (x + r - x0, y + h - r + y0) - (x + w - r + x0, y + h - r + y0), c, bf
e = e + 2*y0
else
line (x + r - y0, y + r - x0) - (x + w - r + y0, y + r - x0), c, bf
line (x + r - y0, y + h - r + x0) - (x + w - r + y0, y + h - r + x0), c, bf
x0 = x0 - 1
e = e - 2*x0
end if
loop
line (x, y + r)-step(w, h - 2*r), c, bf
end sub
Nice one, @vince! Fast too. +1 from me,
I like the think border yours can do, Steve. The one pixel edge mine does isn't very useful now that I think of it, ecxect maybe putting a highlight around a filled one.
- Dav
Posts: 3,925
Threads: 175
Joined: Apr 2022
Reputation:
213
09-15-2024, 12:38 PM
(This post was last modified: 09-15-2024, 01:08 PM by bplus.)
Quote:Mine just had one line of overlap,
No the top and bottom edges had tons of overlap:
b = b + ...
Posts: 3,925
Threads: 175
Joined: Apr 2022
Reputation:
213
09-15-2024, 01:16 PM
(This post was last modified: 09-15-2024, 01:20 PM by bplus.)
+1 @Vince fills are great but need a submission for jut rounded boxes without fills. I look at vince version and no longer even want to try my own fix (almost)
Dav's fills look good too but I just noticed the rounded corners in the non filled edges have overlap.
Mine still sucks as not fixed yet and Steve's still has overlap on the top and bottom edges but lines to rectanagle at base of rounded edges are fixed = removed.
Code: (Select All) _Title "Rounded Rectangles: test with transparent colors" 'b+ 2024-09-14 mod Dav's
' adding Steve and my versions for comparison
Randomize Timer
Screen _NewImage(1000, 700, 32)
_ScreenMove 150, 0
'this demo draws random boxes with round corners...
_Title "Test Dav's with transparent colors, press key for bplus version"
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
Rbox x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150), Int(Rnd * 2)
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until InKey$ <> ""
Cls
_Title "Test bplus 'Rectircle' with transparent colors, press escape for Steve's version"
Do
x1 = Int(Rnd * _Width): x2 = 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
Rectircle x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150), Int(Rnd * 2)
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until _KeyDown(27)
Cls
_KeyClear
_Title "Test Steve's with transparent colors, any key to vince test"
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
If Int(Rnd * 2) Then
RoundRectFill x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
Else
RoundRect x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
End If
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until InKey$ <> ""
Cls
_KeyClear
_Title "Test vince with transparent colors"
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
cboxf x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until _KeyDown(27)
End
Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)
' x1/y1, y2/y2 = placement of box
' r = radius of rounded corner
' clr~& = color of box
' fill = 1 for filled, 0 for just an edge
ReDim filled(_Width + x2, _Height + y2) As Integer
If fill = 1 Then
Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top
Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom
Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left
Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right
Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle
Else
Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top
Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom
Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left
Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right
End If
'top left corner
For angle = 180 To 270
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then
PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
PSet (x3, y3), clr~&
End If
Next
'top right corner
For angle = 270 To 360
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then
PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
PSet (x3, y3), clr~&
End If
Next
'bottom left corner
For angle = 90 To 180
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then
PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
PSet (x3, y3), clr~&
End If
Next
'bottom right corner
For angle = 0 To 90
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then
PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
PSet (x3, y3), clr~&
End If
Next
End Sub
' OK this name is stupid!!!
' this sub uses Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long) ' this does not check raStart and raStop like arcC does
Sub Rectircle (cx, cy, w, h, r, c As _Unsigned Long, Fill) 'assume default single
' cx, cy is the middle of the Squircle
' a square with arc circle corners
' w, h = rectangle width and height
' r = radius of circular arc (as opposed to elliptical arc
' c is color
'so r needs to be < .5 * s ie if r = .5 * s then it's just a circle
'likewise? if r = 0 then just a square
Dim temp&, xo, yo, p, pd2, p32, xConst, yConst
Static sd& ' so dont have to free image after each use
sd& = _Dest ' save dest
temp& = _NewImage(w + 1, h + 1, 32) ' create a drawing area side of square
_Dest temp&
xo = w / 2: yo = h / 2 ' middles
p = _Pi: pd2 = p / 2: p32 = p * 3 / 2
xConst = .5 * (w - 2 * r) ' looks like this is first needed number to get the 4 origins for the arcs from xm y center
yConst = .5 * (h - 2 * r)
'4 arcs
arc xo - xConst, yo - yConst, r, p, p32, c
arc xo + xConst, yo - yConst, r, p32, 0, c
arc xo + xConst, yo + yConst, r, 0, pd2, c
arc xo - xConst, yo + yConst, r, pd2, p, c
'4 lines
Line (xo - xConst, yo - yConst - r)-(xo + xConst, yo - yConst - r), c
Line (xo - xConst, yo + yConst + r)-(xo + xConst, yo + yConst + r), c
Line (xo - xConst - r, yo - yConst)-(xo - xConst - r, yo + yConst), c
Line (xo + xConst + r, yo - yConst)-(xo + xConst + r, yo + yConst), c
If Fill Then Paint (xo, yo), c, c
_Dest sd&
_PutImage (cx - xo, cy - yo), temp&, sd&
End Sub
' will Squircle work with simpler arc sub? the angles are pretty well set
Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long) ' this does not check raStart and raStop like arcC does
Dim al, a
'x, y origin, r = radius, c = color
'raStart is first angle clockwise from due East = 0 degrees
' arc will start drawing there and clockwise until raStop angle reached
If raStop < raStart Then
arc x, y, r, raStart, _Pi(2), c
arc x, y, r, 0, raStop, c
Else
' modified to easier way suggested by Steve
'Why was the line method not good? I forgot.
al = _Pi * r * r * (raStop - raStart) / _Pi(2)
For a = raStart To raStop Step 1 / al
PSet (x + r * Cos(a), y + r * Sin(a)), c
Next
End If
End Sub
Sub arcC (x, y, r, raBegin, raEnd, c As _Unsigned Long) ' updated 2021-09-09
' raStart is first angle clockwise from due East = 0 degrees
' arc will start drawing there and clockwise until raStop angle reached
'x, y origin, r = radius, c = color
Dim p, p2 ' update 2021-09-09 save some time by doing _pi function once
p = _Pi: p2 = p * 2
Dim raStart, raStop, dStart, dStop, al, a
' Last time I tried to use this SUB it hung the program, possible causes:
' Make sure raStart and raStop are between 0 and 2pi.
' This sub does not have to be recursive, use GOSUB to do drawing to execute arc in one call.
'make copies before changing
raStart = raBegin: raStop = raEnd
While raStart < 0: raStart = raStart + p2: Wend
While raStart >= p2: raStart = raStart - p2: Wend
While raStop < 0: raStop = raStop + p2: Wend
While raStop >= p2: raStop = raStop - p2: Wend
If raStop < raStart Then
dStart = raStart: dStop = p2 - .00001
GoSub drawArc
dStart = 0: dStop = raStop
GoSub drawArc
Else
dStart = raStart: dStop = raStop
GoSub drawArc
End If
Exit Sub
drawArc:
al = p * r * r * (dStop - dStart) / p2
For a = dStart To dStop Step 1 / al
PSet (x + r * Cos(a), y + r * Sin(a)), c
Next
Return
End Sub
Sub RoundRect (x As Single, y As Single, x1 As Single, y1 As Single, r As Single, c As _Unsigned Long)
Dim a As Single, b As Single, e As Single
'Draw the 4 straight lines first
Line (x, y + r)-(x, y1 - r), c
Line (x1, y + r)-(x1, y1 - r), c
Line (x + r, y)-(x1 - r, y), c
Line (x + r, y1)-(x1 - r, y1), c
a = r: b = 0: e = -a
'And then draw the rounded circle portions of the RoundRect
Do While a >= b
PSet (x + r - b, y + r - a), c: PSet (x1 - r + b, y + r - a), c
PSet (x + r - a, y + r - b), c: PSet (x1 - r + a, y + r - b), c
PSet (x + r - b, y1 - r + a), c: PSet (x1 - r + b, y1 - r + a), c
PSet (x + r - a, y1 - r + b), c: PSet (x1 - r + a, y1 - r + b), c
b = b + 1: e = e + b + b
If e > 0 Then a = a - 1: e = e - a - a
Loop
End Sub
Sub RoundRectFill (x As Single, y As Single, x1 As Single, y1 As Single, r As Single, c As _Unsigned Long)
Dim a As Single, b As Single, e As Single
Line (x, y + r + 1)-(x1, y1 - r - 1), c, BF
a = r: b = 0: e = -a
Do While a >= b
Line (x + r - b, y + r - a)-(x1 - r + b, y + r - a), c, BF
Line (x + r - a, y + r - b)-(x1 - r + a, y + r - b), c, BF
Line (x + r - b, y1 - r + a)-(x1 - r + b, y1 - r + a), c, BF
Line (x + r - a, y1 - r + b)-(x1 - r + a, y1 - r + b), c, BF
b = b + 1: e = e + b + b
If e > 0 Then a = a - 1: e = e - a - a
Loop
End Sub
Sub cboxf (x, y, w, h, r, c As _Unsigned Long)
x0 = r
y0 = 0
e = -r
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x + r - x0, y + r - y0)-(x + w - r + x0, y + r - y0), c, BF
Line (x + r - x0, y + h - r + y0)-(x + w - r + x0, y + h - r + y0), c, BF
e = e + 2 * y0
Else
Line (x + r - y0, y + r - x0)-(x + w - r + y0, y + r - x0), c, BF
Line (x + r - y0, y + h - r + x0)-(x + w - r + y0, y + h - r + x0), c, BF
x0 = x0 - 1
e = e - 2 * x0
End If
Loop
Line (x, y + r)-Step(w, h - 2 * r), c, BF
End Sub
b = b + ...
Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
Updated mine to get ride of the edge overlap. May add thick line edges next time, I like those thicker edges. Planning to use this for menus.
- Dav
Code: (Select All)
'========
'RBOX.BAS v1.02
'========
'Draws a box with rounded corners, filled or unfilled.
'Coded by Dav, SEP/2024
Randomize Timer
Screen _NewImage(1000, 700, 32)
' This demo draws random boxes with round corners...
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
Rbox x1, y1, x2, y2, radius, _RGBA(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 255), Int(Rnd * 2)
_Limit 30
Loop Until InKey$ <> ""
End
Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)
' x1/y1, y2/y2 = placement of box
' r = radius of rounded corner
' clr~& = color of box
' fill = 1 for filled, 0 for just an edge
ReDim filled(_Width + x2, _Height + y2) As Integer
If fill = 1 Then
Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top
Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom
Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left
Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right
Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle
Else
Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top
Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom
Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left
Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right
End If
'top left corner
For angle = 180 To 270
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'top right corner
For angle = 270 To 360
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'bottom left corner
For angle = 90 To 180
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'bottom right corner
For angle = 0 To 90
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
End Sub
Posts: 3,925
Threads: 175
Joined: Apr 2022
Reputation:
213
Yep! looks good @Dav
b = b + ...
Posts: 719
Threads: 103
Joined: Apr 2022
Reputation:
14
(09-14-2024, 05:16 PM)SMcNeill Wrote: The problem is always finding it when you need it. There's just soooo much quality stuff by everyone, that it's hard to remember it all, This is a case where tying in an ai tool like ChatGPT could come in handy as a search engine for this site (or even on the desktop, as long as it can be limited to a certain folder). Describe what you want, and it'll find it, and even throw in a few suggestions.
Posts: 86
Threads: 8
Joined: May 2022
Reputation:
3
09-15-2024, 04:01 PM
(This post was last modified: 11-07-2024, 05:12 PM by DANILIN.)
People! Export it to visual qbjs.org
Run & Share your transparent Spec effects
My Example without transparent
Plus all complete automation of labyrinth
https://qb64phoenix.com/forum/showthread...0#pid28390
daboxes.bas (Size: 730 bytes / Downloads: 3)
online https://qbjs.org/?mode=auto&src=https://...p?aid=3814
Write name of program in 1st line to copy & paste & save filename.bas
Insert program pictures: press print-screen-shot button
Open paint & Paste & Save as PNG
Add picture file to program topic
Russia looks world from future. Big data is peace data.
I never recommend anything & always write only about myself
Posts: 297
Threads: 16
Joined: Apr 2022
Reputation:
51
09-15-2024, 09:10 PM
(This post was last modified: 09-15-2024, 09:41 PM by vince.)
(09-15-2024, 01:16 PM)bplus Wrote: +1 @Vince fills are great but need a submission for jut rounded boxes without fills.
Code: (Select All) sub cbox (x, y, w, h, r, c as _unsigned long)
x0 = r
y0 = 0
e = -r
do while y0 < x0
pset (x + r - x0, y + r - y0),c
pset (x + w - r + x0, y + r - y0), c
pset (x + r - x0, y + h - r + y0), c
pset (x + w - r + x0, y + h - r + y0), c
pset (x + r - y0, y + r - x0), c
pset (x + w - r + y0, y + r - x0), c
pset (x + r - y0, y + h - r + x0), c
pset (x + w - r + y0, y + h - r + x0), c
if e <= 0 then
y0 = y0 + 1
e = e + 2*y0
else
x0 = x0 - 1
e = e - 2*x0
end if
loop
line (x, y + r + 1)-step(0, h - 2*r - 2), c, bf
line (x + w, y + r + 1)-step(0, h - 2*r - 2), c, bf
line (x + r + 1, y)-step(w - 2*r - 2, 0), c, bf
line (x + r + 1, y + h)-step(w - 2*r - 2, 0), c, bf
end sub
Posts: 3,925
Threads: 175
Joined: Apr 2022
Reputation:
213
09-15-2024, 10:39 PM
(This post was last modified: 09-15-2024, 10:41 PM by bplus.)
Excellent @vince
Here is what I have for final(?) 3 tests with transparent colors:
Code: (Select All) _Title "Rounded Rectangles: test final(?) 3 versions with transparent colors" 'b+ 2024-09-14 mod Dav's
' adding Steve and vince which put mine to shame :)
Randomize Timer
Screen _NewImage(1000, 700, 32)
_ScreenMove 150, 0
'this demo draws random boxes with round corners...
_Title "Test Dav's with transparent colors, press key for Steve's version"
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
Rbox x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150), Int(Rnd * 2)
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until InKey$ <> ""
Cls
_KeyClear
_Title "Test Steve's with transparent colors, any key to vince test"
Do
x1 = Int(Rnd * _Width): x2 = x1 + 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = y1 + 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
If Int(Rnd * 2) Then
RoundRectFill x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
Else
RoundRect x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
End If
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until InKey$ <> ""
Cls
_KeyClear
_Title "Test vince with transparent colors"
Do
x1 = Int(Rnd * _Width): x2 = 120 + Int(Rnd * 100)
y1 = Int(Rnd * _Height): y2 = 120 + Int(Rnd * 100)
radius = 20 + Int(Rnd * 30)
If Int(Rnd * 2) Then
cboxf x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
Else
cbox x1, y1, x2, y2, radius, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 150)
End If
_Limit 30
cntr% = cntr% + 1
If cntr% Mod 50 = 49 Then Cls
Loop Until _KeyDown(27)
Sub Rbox (x1, y1, x2, y2, r, clr~&, fill) ' Dav fixed overlapping in fills and finally corners 2024-09-15
' x1/y1, y2/y2 = placement of box
' r = radius of rounded corner
' clr~& = color of box
' fill = 1 for filled, 0 for just an edge
ReDim filled(_Width + x2, _Height + y2) As Integer
If fill = 1 Then
Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top
Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom
Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left
Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right
Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle
Else
Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top
Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom
Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left
Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right
End If
'top left corner
For angle = 180 To 270
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'top right corner
For angle = 270 To 360
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y1 + r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'bottom left corner
For angle = 90 To 180
If fill = 1 Then
For radius = 0 To r
x3 = (x1 + r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
'bottom right corner
For angle = 0 To 90
If fill = 1 Then
For radius = 0 To r
x3 = (x2 - r) + radius * Cos(_D2R(angle))
y3 = (y2 - r) + radius * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
Next
Else
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
End If
Next
End Sub
' Steve fix one overlapping set of lines 2024-09-15
Sub RoundRect (x As Single, y As Single, x1 As Single, y1 As Single, r As Single, c As _Unsigned Long)
Dim a As Single, b As Single, e As Single
'Draw the 4 straight lines first
Line (x, y + r)-(x, y1 - r), c
Line (x1, y + r)-(x1, y1 - r), c
Line (x + r, y)-(x1 - r, y), c
Line (x + r, y1)-(x1 - r, y1), c
a = r: b = 0: e = -a
'And then draw the rounded circle portions of the RoundRect
Do While a >= b
PSet (x + r - b, y + r - a), c: PSet (x1 - r + b, y + r - a), c
PSet (x + r - a, y + r - b), c: PSet (x1 - r + a, y + r - b), c
PSet (x + r - b, y1 - r + a), c: PSet (x1 - r + b, y1 - r + a), c
PSet (x + r - a, y1 - r + b), c: PSet (x1 - r + a, y1 - r + b), c
b = b + 1: e = e + b + b
If e > 0 Then a = a - 1: e = e - a - a
Loop
End Sub
Sub RoundRectFill (x As Single, y As Single, x1 As Single, y1 As Single, r As Single, c As _Unsigned Long)
Dim a As Single, b As Single, e As Single
Line (x, y + r + 1)-(x1, y1 - r - 1), c, BF
a = r: b = 0: e = -a
Do While a >= b
Line (x + r - b, y + r - a)-(x1 - r + b, y + r - a), c, BF
Line (x + r - a, y + r - b)-(x1 - r + a, y + r - b), c, BF
Line (x + r - b, y1 - r + a)-(x1 - r + b, y1 - r + a), c, BF
Line (x + r - a, y1 - r + b)-(x1 - r + a, y1 - r + b), c, BF
b = b + 1: e = e + b + b
If e > 0 Then a = a - 1: e = e - a - a
Loop
End Sub
Sub cboxf (x, y, w, h, r, c As _Unsigned Long) ' vince 2024-09-15
x0 = r
y0 = 0
e = -r
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x + r - x0, y + r - y0)-(x + w - r + x0, y + r - y0), c, BF
Line (x + r - x0, y + h - r + y0)-(x + w - r + x0, y + h - r + y0), c, BF
e = e + 2 * y0
Else
Line (x + r - y0, y + r - x0)-(x + w - r + y0, y + r - x0), c, BF
Line (x + r - y0, y + h - r + x0)-(x + w - r + y0, y + h - r + x0), c, BF
x0 = x0 - 1
e = e - 2 * x0
End If
Loop
Line (x, y + r)-Step(w, h - 2 * r), c, BF
End Sub
Sub cbox (x, y, w, h, r, c As _Unsigned Long) ' vince 2024-09-15
x0 = r
y0 = 0
e = -r
Do While y0 < x0
PSet (x + r - x0, y + r - y0), c
PSet (x + w - r + x0, y + r - y0), c
PSet (x + r - x0, y + h - r + y0), c
PSet (x + w - r + x0, y + h - r + y0), c
PSet (x + r - y0, y + r - x0), c
PSet (x + w - r + y0, y + r - x0), c
PSet (x + r - y0, y + h - r + x0), c
PSet (x + w - r + y0, y + h - r + x0), c
If e <= 0 Then
y0 = y0 + 1
e = e + 2 * y0
Else
x0 = x0 - 1
e = e - 2 * x0
End If
Loop
Line (x, y + r + 1)-Step(0, h - 2 * r - 2), c, BF
Line (x + w, y + r + 1)-Step(0, h - 2 * r - 2), c, BF
Line (x + r + 1, y)-Step(w - 2 * r - 2, 0), c, BF
Line (x + r + 1, y + h)-Step(w - 2 * r - 2, 0), c, BF
End Sub
Are we ready for time trials
b = b + ...
Posts: 297
Threads: 16
Joined: Apr 2022
Reputation:
51
(09-15-2024, 10:39 PM)bplus Wrote: Are we ready for time trials I officially forfeit, so I guess Steve wins again
|