rounded rectangles and buttons

[James D Jarvis]

This little program is a demo for simple  rounded rectangle routines. It'll draw buttons too (but i didn't code them to be clickable here).

Code: (Select All)

'simple rounded rectangles
Screen _NewImage(800, 480, 32)
Dim Shared klr(0 To 255) As _Unsigned Long
buildrefcolors
rbrect 1, 1, 798, 462, 4, 2, klr(4), klr(16) 'the demo screen is in a rounded rectangle
roundrect 20, 20, 100, 50, 12, klr(12)
_PrintString (150, 20), "roundrect  at 20,20  100 wide and 50 high, corner radius 12"

roundrect 20, 100, 100, 50, 200, klr(6)
_PrintString (150, 100), "roundrect  at 20,100  100 wide and 50 high, corner radius 200"
_PrintString (150, 117), "       the radius is trimmed down if is larger than height or width"

rbrect 20, 200, 100, 20, 5, 3, klr(12), klr(22)
_PrintString (150, 200), "round bordered rectangle at 20,200 40 wide adn 20 high, corner radius 5"
_PrintString (150, 217), "border thickness of 3"

rbrect_button 20, 250, 100, 30, 6, 4, klr(11), klr(22), "A Button"
_PrintString (150, 250), "Rounded bordered rectangle as a button image , "
_PrintString (150, 267), "similar to above but text is inserted and centered in sub"
rbrect_button 20, 320, 100, 30, 300, 3, klr(11), klr(22), "Second Btn"
_PrintString (150, 320), "same as above but with over-sized radius to get round sides"

Sub rbrect_button (xx, yy, ww, hh, r, brd, c1, c2, txt$)
    _PrintMode _KeepBackground
    rbrect xx, yy, ww, hh, r, brd, c1, c2
    bpw = _PrintWidth(txt$)
    bph = _FontHeight
    cx = (xx * 2 + ww) / 2
    tx = cx - bpw / 2
    ty = yy + hh / 2 - bph / 2
    _PrintString (tx, ty), txt$
End Sub

Sub rbrect (xx, yy, ww, HH, r, brdt, c1 As _Unsigned Long, c2 As _Unsigned Long)

    roundrect xx, yy, ww, HH, r, c1
    roundrect xx + brdt, yy + brdt, ww - (brdt * 2), HH - (brdt * 2), r - Int(brdt / 2), c2

End Sub
Sub roundrect (xx, yy, ww, HH, r, c As _Unsigned Long)
    dr = r
    If dr > ww / 2 Then dr = ww / 2 - 1
    If dr > HH / 2 Then dr = HH / 2 - 1
    x1 = xx: x2 = xx + ww - 1
    y1 = yy: y2 = yy + HH - 1
     'draw the circles at each corner inside the rectangle coordiates
    CircleFill x1 + dr, y1 + dr, dr, c
    CircleFill x2 - dr, y1 + dr, dr, c
    CircleFill x1 + dr, y2 - dr, dr, c
    CircleFill x2 - dr, y2 - dr, dr, c
    'connect them with properly sized rectangles
    Line (x1 + dr, y1)-(x2 - dr, y2), c, BF
    Line (x1, y1 + dr)-(x2, y2 - dr), c, BF
End Sub

Sub buildrefcolors
    'reference colors
    'very slightly cooled EGA palette
    _Source tiles&
    klr(0) = Point(1, 1)
    'very slightly cooled EGA palette
    klr(1) = _RGB32(0, 0, 170) 'ega_blue
    klr(2) = _RGB32(0, 170, 0) 'ega_green
    klr(3) = _RGB32(0, 170, 170) 'ega_cyan
    klr(4) = _RGB(170, 0, 0) 'ega_red
    klr(5) = _RGB32(170, 0, 170) 'ega_magenta
    klr(6) = _RGB32(170, 85, 0) 'ega_brown
    klr(7) = _RGB32(170, 170, 170) 'ega_litgray
    klr(8) = _RGB32(85, 85, 85) 'ega_gray
    klr(9) = _RGB32(85, 85, 250) 'ega_ltblue
    klr(10) = _RGB32(85, 250, 85) 'ega_ltgreen
    klr(11) = _RGB32(85, 250, 250) 'ega_ltcyan
    klr(12) = _RGB32(250, 85, 85) 'ega_ltred
    klr(13) = _RGB32(250, 85, 250) 'ega_ltmagenta
    klr(14) = _RGB32(250, 250, 85) 'ega_yellow
    klr(15) = _RGB(250, 250, 250) 'ega_white
    'filling the rest with greyscale
    For c = 16 To 255
        klr(c) = _RGB32(c, c, c)
    Next c
End Sub


Sub CircleFill (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
    'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
    Dim Radius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    Radius = Abs(R)
    RadiusError = -Radius
    X = Radius
    Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    ' 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 (CX - X, CY)-(CX + X, CY), C, BF

    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend

End Sub