09-14-2024, 09:03 PM
I ran Dav, Steve and my versions they all suck for transparent colors but Steve's looks best.
Sorry Danilin, just seeing your entry now, Rho's too buried to chase down.
Mine fails to hold Paint for transparent colors plus the edges overlap like crazy on the arcs.
It's curious they don't bleed into the whole screen, but only into a full rectangle?
Sorry Danilin, just seeing your entry now, Rho's too buried to chase down.
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"
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$ <> ""
End
Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)
'x1/y1, y1/y2 = placement of box
'r = radius of rounded corner
'clr~& = color of box
'fill = 1 for filled, 0 for just an edge
If fill = 1 Then
Line (x1, y1 + r)-(x2, y2 - r), clr~&, BF 'middle
Line (x1 + r, y1)-(x2 - r, y2), clr~&, BF '(ditto)
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 arc
For angle = 180 To 270
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x3 + r, y3 + r)-(x3, y3), clr~&, BF
Else
PSet (x3, y3), clr~&
End If
Next
'top right corner arc
For angle = 270 To 360
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y1 + r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x2 - r, y1 + r)-(x3, y3), clr~&, BF
Else
PSet (x3, y3), clr~&
End If
Next
'bottom left corner arc
For angle = 90 To 180
x3 = (x1 + r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x1 + r, y2 - r)-(x3, y3), clr~&, BF
Else
PSet (x3, y3), clr~&
End If
Next
'bottom right corner
For angle = 0 To 90
x3 = (x2 - r) + r * Cos(_D2R(angle))
y3 = (y2 - r) + r * Sin(_D2R(angle))
If fill = 1 Then
Line (x2 - r, y2 - r)-(x3, y3), clr~&, BF
Else
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)-(x1, y1 - r), 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 SubMine fails to hold Paint for transparent colors plus the edges overlap like crazy on the arcs.
It's curious they don't bleed into the whole screen, but only into a full rectangle?
b = b + ...