Dang new code box colors started! Cool!
Here is my raw, uncut, unedited, undemo'd listing of drawing subs and functions I store in a file called 000Handy.bas with allot of other stuff
As the program or app calls for, I pick out what I need and copy/paste and often alter the sub for the particular application.
Should save you some time from having to reinvent the wheel for something, but that is fun too!
Rectircle is making it's first appearance in forums here in this thread. I watched a math video on the "Squircle" and said I can do that with circles and lines, before Sprezzo AKA STxAxTIC AKA Bill comes and says it's not the same as a Squircle, I say now, I know but the math is so freak'n complex and I just want something like a rounded button I can draw. BTW just to distiguish from Squircle I called it Rectircle. That demo coming soon, then some more (better because easier to use) arrows then some demo's of individual subs or combined.
EDIT 2022-05-01: I started updating these procedures with comments to help explain what the are about.
Here is my raw, uncut, unedited, undemo'd listing of drawing subs and functions I store in a file called 000Handy.bas with allot of other stuff
As the program or app calls for, I pick out what I need and copy/paste and often alter the sub for the particular application.
Code: (Select All)
'================================================================================================ Color stuff
Function qb~& (n As Long) ' ye ole QB colors 0 to 15
Select Case n
Case 0: qb~& = &HFF000000
Case 1: qb~& = &HFF000088
Case 2: qb~& = &HFF008800
Case 3: qb~& = &HFF008888
Case 4: qb~& = &HFF880000
Case 5: qb~& = &HFF880088
Case 6: qb~& = &HFF888800
Case 7: qb~& = &HFFCCCCCC
Case 8: qb~& = &HFF888888
Case 9: qb~& = &HFF0000FF
Case 10: qb~& = &HFF00FF00
Case 11: qb~& = &HFF00FFFF
Case 12: qb~& = &HFFFF0000
Case 13: qb~& = &HFFFF00FF
Case 14: qb~& = &HFFFFFF00
Case 15: qb~& = &HFFFFFFFF
End Select
End Function
Function rclr~& () ' Random color
rclr~& = _RGB32(irnd(64, 255), irnd(64, 255), irnd(64, 255), irnd(0, 255))
End Function
' for breaking down a color c to red, green, blue components outRed, outGrn , outBlu, outAlp
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub
' Given 2 colors get the color that is fr## = fraction of the difference between the first color and 2nd.
Function Ink~& (c1 As _Unsigned Long, c2 As _Unsigned Long, fr##)
Dim R1, G1, B1, A1, R2, G2, B2, A2
cAnalysis c1, R1, G1, B1, A1
cAnalysis c2, R2, G2, B2, A2
Ink~& = _RGB32(R1 + (R2 - R1) * fr##, G1 + (G2 - G1) * fr##, B1 + (B2 - B1) * fr##, A1 + (A2 - A1) * fr##)
End Function
Sub changePlasma () ' this creates a wonderful sequence of colors cN, pR, pG, pB are Shared
cN = cN + 1 ' might want to keep cN single and increment by .5, .1.. depending on needs
Color _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Sub
Sub resetPlasma ' this sets up to use changePlasma pR, pG, pB are Shared
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
End Sub
'often I need it as Function as opposed color setting SUB
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##) ' same as Ink~& only by RGB components and a function return of color
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##) ' sets color between r1, g1, b1 and r2 g2, b2 fr## of difference
Color _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Sub
' shorthand quick color
Function rgba~& (n) ' New (even less typing!) New Color System 1000 colors with up to 3 digits
Dim s4$, r As Long, g As Long, b As Long, a As Long
s4$ = Right$("0000" + LTrim$(Str$(n)), 4)
r = Val(Mid$(s4$, 1, 1)): If r Then r = 28 * r + 3
g = Val(Mid$(s4$, 2, 1)): If g Then g = 28 * g + 3
b = Val(Mid$(s4$, 3, 1)): If b Then b = 28 * b + 3
a = Val(Mid$(s4$, 4, 1)): If a Then a = 28 * a + 3
rgba~& = _RGBA32(r, g, b, a)
End Function
'=========================================================================================================== drawing
Sub ArrowTo (BaseX As Long, BaseY As Long, rAngle As Double, lngth As Long, colr As _Unsigned Long)
Dim As Long x1, y1, x2, y2, x3, y3
x1 = BaseX + lngth * Cos(rAngle)
y1 = BaseY + lngth * Sin(rAngle)
x2 = BaseX + .8 * lngth * Cos(rAngle - _Pi(.05))
y2 = BaseY + .8 * lngth * Sin(rAngle - _Pi(.05))
x3 = BaseX + .8 * lngth * Cos(rAngle + _Pi(.05))
y3 = BaseY + .8 * lngth * Sin(rAngle + _Pi(.05))
Line (BaseX, BaseY)-(x1, y1), colr
Line (x1, y1)-(x2, y2), colr
Line (x1, y1)-(x3, y3), colr
End Sub
'use radians
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 ArcRing (x0, y0, outerR, innerR, raStart, raEnd, colr As _Unsigned Long)
Dim Pi2, Pi32, PiH, P, raS, raE, ck1, y, x, d, ra
Pi2 = _Pi(2)
Pi32 = _Pi(1.5)
PiH = _Pi(.5)
P = _Pi
raS = raStart ' checking raStart and raEnd to behave as expected
While raS >= Pi2
raS = raS - Pi2
Wend
While raS < 0
raS = raS + Pi2
Wend
raE = raEnd
While raE < 0
raE = raE + Pi2
Wend
While raE >= Pi2
raE = raE - Pi2
Wend
If raE > raS Then ck1 = -1
For y = y0 - outerR To y0 + outerR
For x = x0 - outerR To x0 + outerR
d = Sqr((x - x0) * (x - x0) + (y - y0) * (y - y0))
If d >= innerR And d <= outerR Then 'within 2 radii
'angle of x, y to x0, y0
If x - x0 <> 0 And y - y0 <> 0 Then
ra = _Atan2(y - y0, x - x0)
If ra < 0 Then ra = ra + Pi2
ElseIf x - x0 = 0 Then
If y >= y0 Then ra = _Pi / 2 Else ra = Pi32
ElseIf y - y0 = 0 Then
If x >= x0 Then ra = 0 Else ra = PI
End If
If ck1 Then 'raEnd > raStart
If ra >= raS And ra <= raE Then
PSet (x, y), colr
End If
Else 'raEnd < raStart, raEnd is falls before raStart clockwise so fill through 2 * PI
If ra >= raS And ra < Pi2 Then
PSet (x, y), colr
Else
If ra >= 0 And ra <= raE Then
PSet (x, y), colr
End If
End If
End If
End If
Next
Next
End Sub
'draw lines from origin to arc on sides
' this sub uses: Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long)
Sub pieSlice (x, y, r, raStart, raStop, c As _Unsigned Long)
Dim px As Single, py As Single
arc x, y, r, raStart, raStop, c ' this does not check raStart and raStop like arcC does
px = x + r * Cos(raStart): py = y + r * Sin(raStart)
Line (x, y)-(px, py), c
px = x + r * Cos(raStop): py = y + r * Sin(raStop)
Line (x, y)-(px, py), c
End Sub
' 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
Sub arcC (x, y, r, raBegin, raEnd, c As _Unsigned Long) ' updated 2021-09-09 checks raBegin and raEnd
' 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
'from Steve Gold standard
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
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
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
'update 2020-01-24 to include PD2 inside the sub
Sub thic (x1, y1, x2, y2, thick, K As _Unsigned Long)
Dim PD2 As Double, t2 As Single, a As Single, x3 As Single, y3 As Single, x4 As Single, y4 As Single
Dim x5 As Single, y5 As Single, x6 As Single, y6 As Single
PD2 = 1.570796326794897
t2 = thick / 2
If t2 < 1 Then t2 = 1
a = _Atan2(y2 - y1, x2 - x1)
x3 = x1 + t2 * Cos(a + PD2)
y3 = y1 + t2 * Sin(a + PD2)
x4 = x1 + t2 * Cos(a - PD2)
y4 = y1 + t2 * Sin(a - PD2)
x5 = x2 + t2 * Cos(a + PD2)
y5 = y2 + t2 * Sin(a + PD2)
x6 = x2 + t2 * Cos(a - PD2)
y6 = y2 + t2 * Sin(a - PD2)
ftri x6, y6, x4, y4, x3, y3, K
ftri x3, y3, x5, y5, x6, y6, K
End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
'update 2019-12-16 needs updated fTri 2019-12-16
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
ftri x1, y1, x2, y2, x3, y3, K
ftri x3, y3, x4, y4, x1, y1, K
End Sub
' my original fTri that never had a problem with
' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub ftri0 (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long, a&
D = _Dest
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
'Andy Amaya's triangle fill modified for QB64, use if color already set
Sub filltri (xx1, yy1, xx2, yy2, xx3, yy3)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single
Dim slope1 As Single, slope2 As Single, length As Single, x As Single, lastx%, y As Single
Dim slope3 As Single
'make copies before swapping
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then Swap x1, x2: Swap y1, y2
If x3 < x1 Then Swap x1, x3: Swap y1, y3
If x3 < x2 Then Swap x2, x3: Swap y2, y3
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / length
For x = 0 To length
Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
lastx% = Int(x + x1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1: length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / length
For x = 0 To length
If Int(x + x2) <> lastx% Then
Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
End If
Next
End If
End Sub
Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long
pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
x1 = x + rInner * Cos(radAngleOffset)
y1 = y + rInner * Sin(radAngleOffset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
ftri x1, y1, x2, y2, x3, y3, K
'triangles leaked
Line (x1, y1)-(x2, y2), K
Line (x2, y2)-(x3, y3), K
Line (x3, y3)-(x1, y1), K
x1 = x3: y1 = y3
Next
Paint (x, y), K, K
End Sub
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub drwBtn (x, y, s$) '200 x 50
Line (x, y)-Step(200, 50), _RGB32(0, 0, 0), BF
Line (x, y)-Step(197, 47), _RGB32(255, 255, 255), BF
Line (x + 1, y + 1)-Step(197, 47), &HFFBABABA, BF
Color _RGB32(0, 0, 0), &HFFBABABA
_PrintString (x + 100 - 4 * Len(s$), y + 17), s$
'this works pretty good for a menu of buttons to get menu number
'FUNCTION getButtonNumberChoice% (choice$())
' 'this sub uses drwBtn
' ub = UBOUND(choice$)
' FOR b = 0 TO ub ' drawing a column of buttons at xmax - 210 starting at y = 10
' drwBtn xmax - 210, b * 60 + 10, choice$(b)
' NEXT
' DO
' WHILE _MOUSEINPUT: WEND
' mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
' IF mb THEN
' IF mx > xmax - 210 AND mx <= xmax - 10 THEN
' FOR b = 0 TO ub
' IF my >= b * 60 + 10 AND my <= b * 60 + 60 THEN
' LINE (xmax - 210, 0)-(xmax, ymax), bColor, BF
' getInput% = b: EXIT FUNCTION
' END IF
' NEXT
' BEEP
' ELSE
' BEEP
' END IF
' END IF
' _LIMIT 60
' LOOP
'END FUNCTION
End Sub
Sub drawGridSq (x, y, sq, n) ' square nxn cells
Dim d As Long, i As Long
d = sq * n
For i = 0 To n
Line (x + sq * i, y)-(x + sq * i, y + d)
Line (x, y + sq * i)-(x + d, y + sq * i)
Next
End Sub
Sub drawGrid (x, y, xs, ys, xn, yn) ' top left x, y, x side, y side, number of x, nmber of y
Dim As Long i, dx, dy
dx = xs * xn: dy = ys * yn
For i = 0 To xn
Line (x + xs * i, y)-(x + xs * i, y + dy)
Next
For i = 0 To yn
Line (x, y + ys * i)-(x + dx, y + ys * i)
Next
End Sub
Sub drawLandscape
'needs midInk, irnd
Dim i As Long, startH As Single, rr As Long, gg As Long, bb As Long
Dim mountain As Long, Xright As Single, y As Single, upDown As Single, range As Single
Dim lastx As Single, X As Long
'the sky
For i = 0 To ymax
midInk 0, 0, 128, 128, 128, 200, i / ymax
Line (0, i)-(xmax, i)
Next
'the land
startH = ymax - 200
rr = 70: gg = 70: bb = 90
For mountain = 1 To 6
Xright = 0
y = startH
While Xright < xmax
' upDown = local up / down over range, change along Y
' range = how far up / down, along X
upDown = (Rnd * .8 - .35) * (mountain * .5)
range = Xright + irnd&(15, 25) * 2.5 / mountain
lastx = Xright - 1
For X = Xright To range
y = y + upDown
Color _RGB(rr, gg, bb)
Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
lastx = X
Next
Xright = range
Wend
rr = irnd&(rr - 15, rr): gg = irnd&(gg - 15, gg): bb = irnd&(bb - 25, bb)
If rr < 0 Then rr = 0
If gg < 0 Then gg = 0
If bb < 0 Then bb = 0
startH = startH + irnd&(5, 20)
Next
End Sub
Sub ln (x1, y1, x2, y2, c As _Unsigned Long)
Line (x1, y1)-(x2, y2), c
End Sub
Sub rec (x1, y1, x2, y2, c As _Unsigned Long)
Line (x1, y1)-(x2, y2), c, B
End Sub
Sub frec (x1, y1, w, h, c As _Unsigned Long)
Line (x1, y1)-Step(w, h), c, BF
End Sub
'there is a better way so there is no guessing the stepper size
Sub Ellipse (CX, CY, xRadius As Long, yRadius As Long, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' xRadius = x axis radius
' yRadius = y axis radius
' C = fill color
Dim a, x, y, sq, delta, lastDelta
If xRadius = 0 And yRadius = 0 Then Exit Sub
If xRadius = 0 Then
Line (CX, CY + yRadius)-(CX, CY - yRadius), C
ElseIf yRadius = 0 Then
Line (CX + xRadius, CY)-(CX - xRadius, CY), C
Else
If xRadius >= yRadius Then
a = yRadius / xRadius: sq = xRadius * xRadius
For x = 0 To xRadius
If x = 0 Then
lastDelta = Sqr(sq - x * x) * a
Else
delta = Sqr(sq - x * x) * a
Line (CX + (x - 1), CY + lastDelta)-(CX + x, CY + delta), C
Line (CX + (x - 1), CY - lastDelta)-(CX + x, CY - delta), C
Line (CX - (x - 1), CY + lastDelta)-(CX - x, CY + delta), C
Line (CX - (x - 1), CY - lastDelta)-(CX - x, CY - delta), C
lastDelta = delta
End If
Next
Else
a = xRadius / yRadius: sq = yRadius * yRadius
For y = 0 To yRadius
If y = 0 Then
lastDelta = Sqr(sq - y * y) * a
Else
delta = Sqr(sq - y * y) * a
Line (CX + lastDelta, CY + (y - 1))-(CX + delta, CY + y), C
Line (CX - lastDelta, CY + (y - 1))-(CX - delta, CY + y), C
Line (CX + lastDelta, CY - (y - 1))-(CX + delta, CY - y), C
Line (CX - lastDelta, CY - (y - 1))-(CX - delta, CY - y), C
lastDelta = delta
End If
Next
End If
End If
End Sub
Sub fEllipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
'thanks STxAxTIC from Toolbox
Sub EllipseTilt (CX, CY, a, b, ang, C As _Unsigned Long)
Dim k, i, j
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis major radius
' b = semiminor axis minor radius
' ang = clockwise orientation of semimajor axis in radians (0 default)
' C = fill color
For k = 0 To 6.283185307179586 + .025 Step .025 'not sure about the stepper it should depend on a and b
i = a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = -a * Cos(k) * Sin(ang) + b * Sin(k) * Cos(ang)
i = i + CX
j = -j + CY
If k <> 0 Then
Line -(i, j), C
Else
PSet (i, j), C
End If
Next
End Sub
'relace toolbox code 2019-12-16
'this needs RotoZoom3 to rotate image and EllipseFill to make the image BUT it can now scale it also!
Sub fTiltEllipse (destH As Long, ox As Long, oy As Long, majorRadius As Long, minorRadius As Long, radianAngle As Single, c As _Unsigned Long)
'setup isolated area, draw fFlatEllipse and then RotoZoom the image into destination
'ox, oy is center of ellipse
'majorRadius is 1/2 the lonest axis
'minorRadius is 1/2 the short axis
'radianAngle is the Radian Angle of Tilt
'c is of course color
Dim sd&, temp&
sd& = _Dest
temp& = _NewImage(2 * majorRadius, 2 * minorRadius, 32)
_Dest temp&
_DontBlend temp& '<< test 12-16
'fEllipse majorRadius, minorRadius, majorRadius, minorRadius, c
fEllipse majorRadius, minorRadius, majorRadius, minorRadius, c
_Blend temp& '<< test 12-16
_Dest destH
RotoZoom3 ox, oy, temp&, 1, 1, radianAngle
_FreeImage temp&
_Dest sd&
End Sub
Sub RotoZoom (X As Long, Y As Long, Image As Long, Scale As Single, degreesRotation As Single)
Dim px(3) As Single, py(3) As Single, W&, H&, sinr!, cosr!, i&, x2&, y2&
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-degreesRotation / 57.2957795131): cosr! = Cos(-degreesRotation / 57.2957795131)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
'modified 2020-03-02 _seamless added, rotation convert to radians, fixed xScale and yScale for drawn image size in 000Graphics\Spike\...
Sub RotoZoom3 (X As Long, Y As Long, Image As Long, xScale As Single, yScale As Single, radianRotation As Single) ' 0 at end means no scaling of x or y
Dim px(3) As Single: Dim py(3) As Single
Dim W&, H&, sinr!, cosr!, i&, x2&, y2&
W& = _Width(Image&): H& = _Height(Image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-radianRotation): cosr! = Cos(-radianRotation)
For i& = 0 To 3
x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle _Seamless(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle _Seamless(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
'needs min and max
Sub paint3 (x0, y0, fill As _Unsigned Long) ' needs max, min functions
Dim fillColor As _Unsigned Long, W, H, parentF, tick, ystart, ystop, xstart, xstop, x, y
fillColor = Point(x0, y0)
'PRINT fillColor
W = _Width - 1: H = _Height - 1
Dim temp(W, H)
temp(x0, y0) = 1: parentF = 1
PSet (x0, y0), fill
While parentF = 1
parentF = 0: tick = tick + 1
ystart = max(y0 - tick, 0): ystop = min(y0 + tick, H)
y = ystart
While y <= ystop
xstart = max(x0 - tick, 0): xstop = min(x0 + tick, W)
x = xstart
While x <= xstop
If Point(x, y) = fillColor And temp(x, y) = 0 Then
If temp(max(0, x - 1), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(min(x + 1, W), y) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(x, max(y - 1, 0)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
ElseIf temp(x, min(y + 1, H)) Then
temp(x, y) = 1: parentF = 1: PSet (x, y), fill
End If
End If
x = x + 1
Wend
y = y + 1
Wend
Wend
End SubShould save you some time from having to reinvent the wheel for something, but that is fun too!
Rectircle is making it's first appearance in forums here in this thread. I watched a math video on the "Squircle" and said I can do that with circles and lines, before Sprezzo AKA STxAxTIC AKA Bill comes and says it's not the same as a Squircle, I say now, I know but the math is so freak'n complex and I just want something like a rounded button I can draw. BTW just to distiguish from Squircle I called it Rectircle. That demo coming soon, then some more (better because easier to use) arrows then some demo's of individual subs or combined.
EDIT 2022-05-01: I started updating these procedures with comments to help explain what the are about.
b = b + ...