+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Overlapping Circles (/showthread.php?tid=582)
Overlapping Circles - SierraKen - 07-04-2022
I've never made something like this before so I figured I would try it out using the fillcircle sub as pitch black and a colored circle around each of the 2 circles. It might be useful on something someday. I should point out that the 3D rotation orbit isn't a circle, it's more like a 3D square. I couldn't figure out the equation for a 3D orbit on the Z axis, so I just winged it.
Edit: There's a full-circle 3D one on a post below on this thread that I figured out. But I am keeping this one in case anyone wants to use this type.
Code: (Select All)
Screen _NewImage(800, 600, 32)
Dim c As Long, c2 As Long
cx = 600: cy = 300: r = 98: c = _RGB32(0, 0, 0)
dir = 1
cx2 = 200: cy2 = 300: r2 = 98: c2 = _RGB32(0, 0, 0)
dir2 = 2
r = 100
r2 = 100
firstoverlap:
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If dir = 1 And dir2 = 2 Then GoTo secondoverlap:
For t = 0 To 360
x = (Sin(t) * (r + 2)) + cx
y = (Cos(t) * (r + 2)) + cy
Circle (x, y), 2, _RGB32(0, 255, 0)
fillCircle cx, cy, r, c
Next t
If dir = 1 And cx < 400 Then r = r - 1
If dir = 1 And cx > 399 Then r = r + 1
If dir = 2 And cx < 400 Then r = r + 1
If dir = 2 And cx > 399 Then r = r - 1
If r < 50 Then r = 50
If r > 150 Then r = 150
If dir = 1 Then cx = cx + 10
If dir = 2 Then cx = cx - 10
If cx > 600 Then dir = 2
If cx < 200 Then dir = 1
For t = 0 To 360
x = (Sin(t) * (r2 + 2)) + cx2
y = (Cos(t) * (r2 + 2)) + cy2
Circle (x, y), 2, _RGB32(255, 0, 0)
fillCircle cx2, cy2, r2, c2
Next t
If dir2 = 1 And cx2 < 400 Then r2 = r2 + 1
If dir2 = 1 And cx2 > 399 Then r2 = r2 - 1
If dir2 = 2 And cx2 < 400 Then r2 = r2 - 1
If dir2 = 2 And cx2 > 399 Then r2 = r2 + 1
If r2 < 50 Then r2 = 50
If r2 > 150 Then r2 = 150
If dir2 = 1 Then cx2 = cx2 + 10
If dir2 = 2 Then cx2 = cx2 - 10
If cx2 > 600 Then dir2 = 2
If cx2 < 200 Then dir2 = 1
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 50), BF
_Display
Loop
secondoverlap:
Do
a$ = InKey$
If a$ = Chr$(27) Then End
If dir = 2 And dir2 = 1 Then GoTo firstoverlap:
For t = 0 To 360
x = (Sin(t) * (r2 + 2)) + cx2
y = (Cos(t) * (r2 + 2)) + cy2
Circle (x, y), 2, _RGB32(255, 0, 0)
fillCircle cx2, cy2, r2, c2
Next t
If dir2 = 1 And cx2 < 400 Then r2 = r2 - 1
If dir2 = 1 And cx2 > 399 Then r2 = r2 + 1
If dir2 = 2 And cx2 < 400 Then r2 = r2 + 1
If dir2 = 2 And cx2 > 399 Then r2 = r2 - 1
If r2 < 50 Then r2 = 50
If r2 > 150 Then r2 = 150
If dir2 = 1 Then cx2 = cx2 + 10
If dir2 = 2 Then cx2 = cx2 - 10
If cx2 > 600 Then dir2 = 2
If cx2 < 200 Then dir2 = 1
For t = 0 To 360
x = (Sin(t) * (r + 2)) + cx
y = (Cos(t) * (r + 2)) + cy
Circle (x, y), 2, _RGB32(0, 255, 0)
fillCircle cx, cy, r, c
Next t
If dir = 1 And cx < 400 Then r = r + 1
If dir = 1 And cx > 399 Then r = r - 1
If dir = 2 And cx < 400 Then r = r - 1
If dir = 2 And cx > 399 Then r = r + 1
If r < 50 Then r = 50
If r > 150 Then r = 150
If dir = 1 Then cx = cx + 10
If dir = 2 Then cx = cx - 10
If cx > 600 Then dir = 2
If cx < 200 Then dir = 1
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 50), BF
_Display
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
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 SubRE: Overlapping Circles - bplus - 07-04-2022
It does look like they are going in circles, pretty neat.
RE: Overlapping Circles - SierraKen - 07-04-2022
Thanks B+.
RE: Overlapping Circles - James D Jarvis - 07-04-2022
I fiddled with adding a modifier to CY and CY2 and that made the paths look a little more elliptical, but really it looks fine without it.
RE: Overlapping Circles - SierraKen - 07-05-2022
Thanks James! Yeah people can make different things with it I think.
RE: Overlapping Circles - SierraKen - 07-05-2022
Here is a much better version I just figured out today. It goes in a full 3D circle (front to back and back to front again, etc.) overlapping both circles as it was before. People can make 3D orbits with this, etc. I'll keep the older one up there in case people want to make it that way. The funny thing is, this one has much less code which I am proud of.
Code: (Select All)
Screen _NewImage(800, 600, 32)
r = 100
c = _RGB32(0, 0, 0)
t2 = 180
r2 = 100
Do
For t = 90 To 180 Step .25
_Limit 20
x = (Sin(t) * 180) + 400
y = (Cos(t) * 180) / _Pi + 300
r = (Cos(t) * 90) / _Pi / 2 + 50
fillCircle x, y, r, c
Circle (x, y), r + 2, _RGB32(0, 255, 0)
t2 = t2 - .25
If t2 < 90 Then t2 = 180
x2 = (Sin(t2) * 180) + 400
y2 = (Cos(t2) * 180) / _Pi + 300
r2 = (Cos(t2) * 90) / _Pi / 2 + 50
fillCircle x2, y2, r2, c
Circle (x2, y2), r2 + 2, _RGB32(255, 0, 0)
_Delay .01
_Display
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 30), BF
Next t
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
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 SubRE: Overlapping Circles - OldMoses - 07-06-2022
Thanks for doing these. They look pretty cool and inspired me to try my hand at something vaguely similar.
Code: (Select All)
SCREEN _NEWIMAGE(1024, 512, 32)
DIM orb(1) AS LONG
a% = 0
b% = -1
r% = 200 ' orbital radius
orb(0) = _NEWIMAGE(100, 100, 32) ' create the circles
orb(1) = _NEWIMAGE(100, 100, 32)
FOR x% = 0 TO 1
_DEST orb(x%)
CLS
_CLEARCOLOR &HF000000
IF x% MOD 2 = 0 THEN c& = &HFFFF0000 ELSE c& = &HFF0000FF
FCirc 49, 49, 49, c&
NEXT x%
_DEST 0
DO
CLS
ang% = ang% + 1
IF ang% > 359 THEN ang% = 0
IF ang% = 90 OR ang% = 270 THEN SWAP a%, b% ' flip display order when orthogonal to view
sw% = 10 * COS(_D2R(ang%)) ' swell factor
ps% = r% * SIN(_D2R(ang%)) ' orbital radius position
IF a% THEN ' set display order
_PUTIMAGE (281, 206), orb(0)
Image_Resize 285 + ps% + sw%, 206 + sw%, 385 + ps% - sw%, 306 - sw%, orb(1), 0, "c", "c"
ELSE
Image_Resize 285 + ps% + sw%, 206 + sw%, 385 + ps% - sw%, 306 - sw%, orb(1), 0, "c", "c"
_PUTIMAGE (281, 206), orb(0)
END IF
_LIMIT 100
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG)
DIM AS INTEGER R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
LINE (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw line above equator
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw line below equator
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw line north latitudes
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw line south latitudes
WEND
END SUB 'FCirc
SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl
xp = xpos: yp = ypos: xl = xlim: yl = ylim ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_ResizeRE: Overlapping Circles - SierraKen - 07-06-2022
That's pretty wild OldMoses!
Here is my orbital Earth:
Code: (Select All)
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
Do
_Limit 20
t = t - .25
If t < 90 Then t = 1800
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
If y2 < 300 Then
'Earth
For s = .25 To r2 Step .25
cc = cc + .25
Circle (x2, y2), s, _RGB32(cc, cc, 100 + cc)
Next s
cc = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(200 + cc2, 200 + cc2, 64 + cc2)
Next sun
cc2 = 0
If y2 > 300 Then
'Earth
For s = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), s, _RGB32(cc3, cc3, 100 + cc3)
Next s
cc3 = 0
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)RE: Overlapping Circles - SierraKen - 07-06-2022
Here is a much slower Earth:
Code: (Select All)
Screen _NewImage(800, 600, 32)
t = 1800
x = 400: y = 300: r = 50
Do
_Limit 20
If t < 90 Then t = 1800
x2 = (Sin(t) * 360) + 400
y2 = (Cos(t) * 180) / _Pi / 1.5 + 300
r2 = (Cos(t) * 180) / _Pi / 1.5 + 50
t = t - .025
If y2 < 300 Then
'Earth
For S = .25 To r2 Step .25
cc = cc + .25
Circle (x2, y2), S, _RGB32(cc, cc, 100 + cc)
Next S
cc = 0
End If
'Sun
For sun = .25 To 35 Step .25
cc2 = cc2 + 1
Circle (x, y), sun, _RGB32(200 + cc2, 200 + cc2, 64 + cc2)
Next sun
cc2 = 0
If y2 > 300 Then
'Earth
For S = .25 To r2 Step .25
cc3 = cc3 + .25
Circle (x2, y2), S, _RGB32(cc3, cc3, 100 + cc3)
Next S
cc3 = 0
End If
_Delay .05
_Display
Cls
Loop Until InKey$ = Chr$(27)RE: Overlapping Circles - SierraKen - 07-06-2022
Here is a funny one with the Moon orbiting the Earth and both of them orbiting the Sun. It's funny because it's not proportional, but I think it's neat.
Code deleted, try the next one on Page 2, it is much better thanks.