04-29-2022, 09:20 PM
(This post was last modified: 04-30-2022, 12:36 AM by 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