04-29-2022, 04:54 PM (This post was last modified: 05-01-2022, 11:26 PM by bplus.)
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.
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 Sub
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.
04-29-2022, 07:19 PM (This post was last modified: 04-30-2022, 11:41 PM by bplus.
Edit Reason: Apologies I posted old code for Squircle that was since modified
)
OK since I wrote this test demo I changed the name Squicle (which I luv and attracted me to video) to rectircle (which I don't like and can't even remember how to spell it!) The reason as I said was not to mistake the math Squircle with my humble graphics button or window frame thingy.
Code: (Select All)
Option _Explicit 'maje sure test subs will be OK with this
_Title "Draw Squircle testing" ' b+ 2021-09-08
' revisit arc drawing: arc3 had a recent complaint about previous arc code that did not check raBegin and ra end
' so I updated arc#3 to arcC as 000Handy already has a simpler arc drawing sub probably the one I was complaining
Const xmax = 1024, ymax = 700
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim r
Do
For r = 0 To 250 Step 10
Cls
Rectircle xmax / 2, ymax / 2, 500, 500, r, &HFFFFFF00, 0
Locate 3, 5: Print "Area ="; _Pi * r ^ 2 + 5 * (500 - 2 * r) ^ 2
Print , "r ="; r
_Display
_Limit 5
Next
For r = 250 To 0 Step -2
Cls
Rectircle xmax / 2, ymax / 2, 500, 500, r, &HFFFFFF00, 1
Locate 3, 5: Print "Area ="; _Pi * r ^ 2 + 5 * (500 - 2 * r) ^ 2
Print , "r ="; r
_Display
_Limit 50
Next
Loop
' 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
04-30-2022, 10:01 PM (This post was last modified: 05-01-2022, 02:52 AM by bplus.
Edit Reason: Found another arrow
)
4 Arrow styles
Code: (Select All)
Option _Explicit
_Title "Arrow drawing" 'B+ started 2019-06-23
' mods 2022 for TailArrow, BlockArrow and LineArrow
Randomize Timer
Const xmax = 500, ymax = 500
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 100
_Delay .5
Dim a, l
l = 50
For a = 0 To 2 * _Pi Step _Pi / 6
Cls
TailArrow 250, 250, a, l
Circle (250, 250), l + 10
Print "TailArrow:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
If a = 0 Then _Delay 1
l = l + 10
_Limit 1
Next
Cls
l = 25
For a = 0 To 3
Cls
BlockArrow 250, 250, a, l, &HFFFFFF00
Line (250 - .5 * l - 5, 250 - .5 * l - 5)-(250 + .5 * l + 5, 250 + .5 * l + 5), , B
Print "BlockArrow:"
Print "Angle, Length:"; a * 90, l
l = l + 25
_Limit 1
Next
_Delay 2
Cls
l = 10
For a = 0 To 2 * _Pi Step _Pi(2 / 12)
Cls
LineArrow 250, 250, a, l, &HFF008800
Line (250 - .5 * l - 5, 250 - .5 * l - 5)-(250 + .5 * l + 5, 250 + .5 * l + 5), , B
Print "LineArrow:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
l = l + 10
If a = 0 Then _Delay 1
_Limit 1
Next
_Delay 2
Cls
l = 10
For a = 0 To 2 * _Pi Step _Pi(2 / 12)
Cls
ArrowTo 250, 250, a, l, &HFF0000FF
Print "ArrowTo:"
Print "Angle, Length:"; Int(_R2D(a) + .5), l
Circle (250, 250), l + 5
l = l + 10
If a = 0 Then _Delay 1
_Limit 1
Next
Print "End of demo"
' For this arrow x0, y0 is at the point of the head, the shaft is drawn back from that for angle at lngth length.
' this arrow mimics an archery arrow with feathers on end, colors are constant.
Sub TailArrow (x0, y0, rAngle, lngth)
'This sub uses many other subs:
' Sub drawLink (x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
' Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
' Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim x1, y1, x2, y2, pi, i As Integer
pi = 3.14159265
x2 = x0 - lngth * Cos(rAngle)
y2 = y0 - lngth * Sin(rAngle)
drawLink x0, y0, .001 * lngth, x2, y2, .01 * lngth, &HFF00BB00
Line (x0, y0)-(x2, y2), &HFF00BB00
x2 = x0 - .1 * lngth * Cos(rAngle - .2 * pi)
y2 = y0 - .1 * lngth * Sin(rAngle - .2 * pi)
x1 = x0 - .1 * lngth * Cos(rAngle + .2 * pi)
y1 = y0 - .1 * lngth * Sin(rAngle + .2 * pi)
ftri x0, y0, x1, y1, x2, y2, &HFFFF8800
For i = .8 * lngth To lngth Step 3
x1 = x0 - i * Cos(rAngle)
y1 = y0 - i * Sin(rAngle)
x2 = x1 - .1 * lngth * Cos(rAngle - .25 * pi)
y2 = y1 - .1 * lngth * Sin(rAngle - .25 * pi)
Line (x1, y1)-(x2, y2), &HFF0000FF
x2 = x1 - .1 * lngth * Cos(rAngle + .25 * pi)
y2 = y1 - .1 * lngth * Sin(rAngle + .25 * pi)
Line (x1, y1)-(x2, y2), &HFF0000FF
Next
End Sub
' This is a blocklike arrow to use instead of a tile any size, any color: cx, cy is center of square.
' It can be only draw in East = 0, South = 1, West = 2, North = 3 Directions for ESWN03 variable.
' Assuming want to put inside a square = sqrSize and of cource c is for color.
Sub BlockArrow (cX, cY, ESWN03, sqrSize, c As _Unsigned Long) ' 4 directions East, South, West, North 0,1,2,3
'This sub needs:
' Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim m14, m13, m12, m23, m34, x0, y0
m14 = sqrSize * .25
m13 = sqrSize * .3333
m12 = sqrSize * .5
m23 = sqrSize * .6667
m34 = sqrSize * .75
x0 = cX - m12
y0 = cY - m12
Select Case ESWN03
Case 0 'east
Line (x0, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m23, y0, x0 + sqrSize, y0 + m12, x0 + m23, y0 + sqrSize, c
Case 1
Line (x0 + m13, y0)-Step(m13, m23), c, BF
ftri x0, y0 + m23, x0 + m12, y0 + sqrSize, x0 + sqrSize, y0 + m23, c
Case 2
Line (x0 + m13, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m13, y0, x0, y0 + m12, x0 + m13, y0 + sqrSize, c
Case 3
Line (x0 + m13, y0 + m13)-Step(m13, m23), c, BF
ftri x0, y0 + m13, x0 + m12, y0, x0 + sqrSize, y0 + m13, c
End Select
End Sub
' simplest arrow, xc, yc are at center of shaft of length lngth at angle ra (radian angle)
Sub LineArrow (xc, yc, ra, lngth, c As _Unsigned Long)
Dim x1, y1, x2, y2
x1 = xc + .5 * lngth * (Cos(ra))
y1 = yc + .5 * lngth * (Sin(ra))
x2 = xc + .5 * lngth * (Cos(ra - _Pi))
y2 = yc + .5 * lngth * (Sin(ra - _Pi))
Line (x1, y1)-(x2, y2), c
x2 = x1 + .2 * lngth * (Cos(ra - _Pi(3 / 4)))
y2 = y1 + .2 * lngth * (Sin(ra - _Pi(3 / 4)))
Line (x1, y1)-(x2, y2), c
x2 = x1 + .2 * lngth * (Cos(ra + _Pi(3 / 4)))
y2 = y1 + .2 * lngth * (Sin(ra + _Pi(3 / 4)))
Line (x1, y1)-(x2, y2), c
End Sub
' This version of arrow, x, y are at tail end and arrow point in rAngle (radians) for length of lngth
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
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
ftri x1, y1, x2, y2, x4, y4, c
ftri x3, y3, x4, y4, x1, y1, c
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
I am enclosing the arrows in boxes or circles to give you an idea of area needed for laying out in your application.
Well in case you haven't seen enough color pickers here is another. I run it independent of the QB64 program I am putting together and design colors and give them Const names and paste them in off Clipboard:
Code: (Select All)
_Title "Color CONST for _RGBA32(red, green, blue, alpha)" 'B+ 2019-05-19
'2019-05-26 update this for mouse inputs
'>>>>>>>>>>>> test your colors here
'>>>>>>>>>>>> then create and name Hex string CONSTs if you want to the Clipboard
'sample clipping
Const Purple = &HFFB400B4
Const Red = &HFFFA3232
Screen _NewImage(800, 600, 32)
_ScreenMove _Middle
If _Clipboard$ <> "" Then
Input "Clear clipboard? enter y for yes "; w$
If w$ = "y" Then _Clipboard$ = ""
End If
r = 128: g = 128: b = 128: a = 128
Color &HFFDDDDDD, 0
Do
Cls
MakeConst$ = "&H" + Right$(String$(8, "0") + Hex$(_RGBA32(r, g, b, a)), 8)
slider 16, 10, r, "Red"
slider 16, 60, g, "Green"
slider 16, 110, b, "Blue"
slider 16, 160, a, "Alpha"
_PrintString (250, 260), "Press c to create CONST for Clipboard"
_PrintString (210, 280), "Use this Hex string for color CONST: " + MakeConst$
Line (90, 300)-(710, 590), , B
Line (100, 310)-(700, 580), Val(MakeConst$), BF
While _MouseInput: Wend
mb = _MouseButton(1)
If mb Then 'clear it
mx = _MouseX: my = _MouseY
If mx >= 16 And mx <= 784 Then
If my >= 10 And my <= 50 Then
r = _Round((mx - 16) / 3)
ElseIf my >= 60 And my <= 100 Then
g = _Round((mx - 16) / 3)
ElseIf my >= 110 And my <= 150 Then
b = _Round((mx - 16) / 3)
ElseIf my >= 160 And my <= 200 Then
a = _Round((mx - 16) / 3)
End If
End If
End If
k$ = InKey$
If k$ = "q" Then Exit Do
If k$ = "c" Then
Locate 16, 30
Input "Enter name for your color CONST "; cname$
_Clipboard$ = _Clipboard$ + Chr$(10) + "CONST " + cname$ + " = " + MakeConst$
End If
_Display
_Limit 60
Loop
Sub slider (x, y, value, label$)
Select Case label$
Case "Red": c~& = &HFFFF0000
Case "Green": c~& = &HFF008800
Case "Blue": c~& = &HFF0000FF
Case "Alpha": c~& = &H88FFFFFF
End Select
Line (x, y)-Step(768, 40), c~&, B
Line (x, y)-Step(3 * value, 40), c~&, BF
s$ = label$ + " = " + _Trim$(Str$(value))
_PrintString (x + 384 - 4 * Len(s$), y + 12), s$
End Sub
NOT A COMPLAINT: I noticed Rotozoom distorts images a tiny bit. This wouldn't matter at all in many applications, and I wouldn't notice at all in a quick moving video game. But I was using this to rotate a small image in 90 degree increments. and that's when I noticed the distortion. Would it be due to how the _seamless tag works with maptriangle? Or is it likely just a minor rounding error with the floating point math?
Yes, @James D Jarvis I have noticed too, specially something with fine set of parallel lines or was it perpendiculars? I think it is rounding errors when the math deals with turning the lines at different angles, some angles remain clean and some get distorted. If you or anyone could clean that up I'd be eternally grateful.
Yes, @James D Jarvis I have noticed too, specially something with fine set of parallel lines or was it perpendiculars? I think it is rounding errors when the math deals with turning the lines at different angles, some angles remain clean and some get distorted. If you or anyone could clean that up I'd be eternally grateful.
Thankyou for your feedback
I noticed it when rotating small precise tiles I was using to build a larger tiled image.
It might be as simple as the point of rotation. The sub uses the middle of the image for rotation (which is completely sane and useful most of the time) but as it introduces a division than means sometimes the center calculated is a half pixel value that really isn't the center of the image. Not sure if rotating from a corner would or wouldn't change this. (I'm not even sure if I'm on the right approach of course.)
05-02-2022, 04:57 PM (This post was last modified: 05-02-2022, 05:00 PM by bplus.)
@James D Jarvis,
Here is possibly the original Galleon Rotozoom:
Code: (Select All)
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
That is what I have in my 000Handy.bas post I made earlier. I am not sure I think I modified it for Radian Rotation Angle and Galleon might have done it in degrees. Yes, try the Wiki lookup for _MapTriangle it has the original Galleon RotoZoom, it might work out better?
Code: (Select All)
SUB RotoZoom (X AS LONG, Y AS LONG, Image AS LONG, Scale AS SINGLE, Rotation AS SINGLE)
DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
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(-Rotation / 57.2957795131): cosr! = COS(-Rotation / 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
Looks like I just labeled the Rotation Angle more clearly with Degree units.
I am curious of results if you experiment with that.
