Overlapping Circles

[OldMoses]

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_Resize