Posts: 88
Threads: 8
Joined: May 2022
Reputation:
3
09-14-2024, 08:46 PM
(This post was last modified: 09-14-2024, 08:55 PM by DANILIN.)
Similar program is written with zero much shorter
Code: (Select All) Screen 12: Randomize Timer: pi = 3.1416 ' boxes.bas
For j = 1 To 1978 ' Danilin
xp = Int(Rnd * 600): yp = Int(Rnd * 400)
xb = Int(Rnd * 300) + 20: yb = Int(Rnd * 200) + 20
c = Int(Rnd * 16) + 1: r = Int(Rnd * 36) + 12
For i = 0 To r Step .3
Circle (xp, yp), i, 7 ', pi / 2, pi
Circle (xp + xb, yp), i, 8 ', 0, pi / 2
Circle (xp, yp + yb), i, 9 ', pi, 3 * pi / 2
Circle (xp + xb, yp + yb), i, 10 ', 3 * pi / 2, 0
_Delay .0022: Next
Line (xp, yp)-(xp + xb, yp + yb), c, BF
Line (xp, yp)-(xp - r, yp + yb), 1, BF
Line (xp, yp)-(xp + xb, yp - r), 6, BF
Line (xp + xb, yp)-(xp + xb + r, yp + yb), 7, BF
Line (xp, yp + yb)-(xp + xb, yp + yb + r), 2, BF
Print: _Delay .1
Next
![[Image: boxes.png]](https://i.ibb.co/ZL8w0pf/boxes.png)
Plus all complete automation of labyrinth
https://qb64phoenix.com/forum/showthread...8#pid28378
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: 3,981
Threads: 177
Joined: Apr 2022
Reputation:
220
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.
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 Sub
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?
b = b + ...
Posts: 730
Threads: 120
Joined: Apr 2022
Reputation:
106
@bplus: I hadn't even considered transparency. You're right, my corners are off when using transparency. It made me see some corner errors in my routine.
Hmm, this sounds like something fun to try and work out. I'll give it a go and get transparency working.
- Dav
Posts: 3,981
Threads: 177
Joined: Apr 2022
Reputation:
220
09-15-2024, 01:01 AM
(This post was last modified: 09-15-2024, 01:06 AM by bplus.)
I think it's possible specially given the recent work on circle fills.
I sure didn't need to do arcs and Paint fills!
b = b + ...
Posts: 2,180
Threads: 222
Joined: Apr 2022
Reputation:
104
CSS$ = "border-radius"
For everything else, there's SCREEN 0.
Pete
Shoot first and shoot people who ask questions, later.
Posts: 730
Threads: 120
Joined: Apr 2022
Reputation:
106
Problem is when pixels get overwritten using transparency the corner color goes off the way I was writting them, so here I'm using an array to keep track if a pixels was written before Looks a lot better this way...
- Dav
Code: (Select All)
'========
'RBOX.BAS v1.01
'========
'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), 1 '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
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
Posts: 3,981
Threads: 177
Joined: Apr 2022
Reputation:
220
09-15-2024, 01:21 AM
(This post was last modified: 09-15-2024, 01:24 AM by bplus.)
+1 Wow that was fast! and nice way to keep lines from overlapping!
I think calcs from one corner can be translated to other 3 corners, but still that was a fast fix!
b = b + ...
Posts: 730
Threads: 120
Joined: Apr 2022
Reputation:
106
09-15-2024, 01:25 AM
(This post was last modified: 09-15-2024, 01:30 AM by Dav.)
I dimmed the filled array so large because of the random x/x generation going on, and boxes are being written off screen. Doesn’t need to be that large probably.
EDIT: the edge only boxes look a little off, will have to check that out tomorrow. Wife asks no more programming tonight. Will be browsing the forum on my iPad though… 
- Dav
Posts: 301
Threads: 16
Joined: Apr 2022
Reputation:
51
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
Posts: 2,701
Threads: 328
Joined: Apr 2022
Reputation:
217
(09-14-2024, 09:03 PM)bplus Wrote: I ran Dav, Steve and my versions they all suck for transparent colors but Steve's looks best.
Mine just had one line of overlap, and that was easily fixed:
Code: (Select All)
Screen _NewImage(640, 480, 32)
$Color:32
For i = 1 To 20 'Fixed for transparent colors
RoundRectFill 100, 100, 400, 400, 15, &H33AA0000
Next
Sleep
Cls , 0
For i = 1 To 20
RoundRect 100, 100, 400, 400, 15, &H33AA0000
Next
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 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
All of them work just fine, with transparent colors if you follow this simple setup:
1) Make a temp 32-bit screen. Turn blending off on it.
2) Draw your image to that screen. Turn blending on, on that screen.
3) Copy that screen to where you want it to be with _PUTIMAGE.
4) Free the temp image if you don't need to use it anymore.
Not everyone thinks, codes, or needs to worry about writing code that works with transparent images. If you ever run across a routine that does what you need it to do, but falls that *tiny* step short, just follow the process above. Draw to a temp screen with blending off, then put to the main screen with blending on.
It's a much easier process than trying to rework complex math formulas or roll your own from scratch a lot of times. 
|
