QB64 Phoenix Edition
SUB that draws boxes with rounded corners. - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: SUB that draws boxes with rounded corners. (/showthread.php?tid=3032)

Pages: 1 2 3


RE: SUB that draws boxes with rounded corners. - DANILIN - 09-14-2024

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]

Plus all complete automation of labyrinth
https://qb64phoenix.com/forum/showthread.php?tid=2761&pid=28378#pid28378


RE: SUB that draws boxes with rounded corners. - bplus - 09-14-2024

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?


RE: SUB that draws boxes with rounded corners. - Dav - 09-15-2024

@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


RE: SUB that draws boxes with rounded corners. - bplus - 09-15-2024

I think it's possible specially given the recent work on circle fills.

I sure didn't need to do arcs and Paint fills!


RE: SUB that draws boxes with rounded corners. - Pete - 09-15-2024

CSS$ = "border-radius"

For everything else, there's SCREEN 0.

Pete


RE: SUB that draws boxes with rounded corners. - Dav - 09-15-2024

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



RE: SUB that draws boxes with rounded corners. - bplus - 09-15-2024

+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!


RE: SUB that draws boxes with rounded corners. - Dav - 09-15-2024

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… Big Grin

- Dav


RE: SUB that draws boxes with rounded corners. - vince - 09-15-2024

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



RE: SUB that draws boxes with rounded corners. - SMcNeill - 09-15-2024

(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. Wink