Print Page - A mod of Archimedes Spiral

I just did this for another forum doing an Archimedes Spiral thread :D
Code: QB64: [Select]
OPTION _EXPLICIT
_TITLE "Draw Spinner and Web" 'B+ started 2019-06-15
' Draw Spinner and web mod 2019-09-17
RANDOMIZE TIMER
DIM sc&, sx, sy, sh 'spider stuff
DIM a, tn, ta, tcx, tcy, tr, tx, ty, tdx, tdy, oldx, oldy 'web stuff
sc& = _SCREENIMAGE
_DELAY .1
 
DIM SHARED xmax AS INTEGER, ymax AS INTEGER
xmax = _DESKTOPWIDTH
ymax = _DESKTOPHEIGHT
 
SCREEN _NEWIMAGE(xmax, ymax, 32)
'_SCREENMOVE 300, 20
_FULLSCREEN
 
_DEST sc&
tn = 13: ta = _PI(2 / 13): tcx = .75 * xmax: tcy = .33 * ymax
FOR a = 1 TO tn
    LINE (tcx + xmax * COS(a * ta), tcy + xmax * SIN(a * ta))-(tcx + xmax * COS(a * ta + _PI), tcy + xmax * SIN(a * ta + _PI)), &H88FFFFFF
NEXT
_DEST 0
 
tx = tcx: ty = tcy: tdx = 5: tdy = 0
sx = tcx: sy = tcy
a = a + ta: tr = tr + ta
tx = tcx + tr * COS(a): ty = tcy + tr * SIN(a)
sh = _ATAN2(ty - sy, tx - sx)
tdx = 1 * COS(sh): tdy = 1 * SIN(sh)
WHILE INKEY$ <> CHR$(27)
    'update web
    IF ((sx - tx) ^ 2 + (sy - ty) ^ 2) ^ .5 < 5 THEN 'setup next target x, y nad new spider heading
        oldx = sx: oldy = sy
        sx = tx: sy = ty
        _DEST sc&
        LINE (oldx, oldy)-(sx, sy), &H66FFFFFF
        _DEST 0
        a = a + ta: tr = tr + 3 * ta
        tx = tcx + tr * COS(a): ty = tcy + tr * SIN(a)
        sh = _ATAN2(ty - sy, tx - sx)
        tdx = 1 * COS(sh): tdy = 1 * SIN(sh)
    ELSE
        'save image wo spider
        oldx = sx: oldy = sy
        sx = sx + tdx: sy = sy + tdy
        _DEST sc&
        LINE (oldx, oldy)-(sx, sy), &H66FFFFFF
        _DEST 0
    END IF
    _PUTIMAGE , sc&
    '_PRINTSTRING (500, 200), STR$(tx) + STR$(ty) + STR$(tdx) + STR$(tdy) + STR$(sh)
    'place spider
    drawSpinner sx, sy, 1, sh, &H88221100
    _DISPLAY
    _LIMIT 30
WEND
 
 
SUB drawSpinner (x AS INTEGER, y AS INTEGER, scale AS SINGLE, heading AS SINGLE, c AS _UNSIGNED LONG)
    DIM x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
    STATIC switch AS INTEGER
    switch = switch + 2
    switch = switch MOD 16 + 1
    red = _RED32(c): green = _GREEN32(c): blue = _BLUE32(c)
    r = 10 * scale
    x1 = x + r * COS(heading): y1 = y + r * SIN(heading)
    r = 2 * r 'lg lengths
    FOR lg = 1 TO 8
        IF lg < 5 THEN
            a = heading + .9 * lg * _PI(1 / 5) + (lg = switch) * _PI(1 / 10)
        ELSE
            a = heading - .9 * (lg - 4) * _PI(1 / 5) - (lg = switch) * _PI(1 / 10)
        END IF
        x2 = x1 + r * COS(a): y2 = y1 + r * SIN(a)
        drawLink x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
        IF lg = 1 OR lg = 2 OR lg = 7 OR lg = 8 THEN d = -1 ELSE d = 1
        a1 = a + d * _PI(1 / 12)
        x3 = x2 + r * 1.5 * COS(a1): y3 = y2 + r * 1.5 * SIN(a1)
        drawLink x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
        rd = INT(RND * 8) + 1
        a2 = a1 + d * _PI(1 / 8) * rd / 8
        x4 = x3 + r * 1.5 * COS(a2): y4 = y3 + r * 1.5 * SIN(a2)
        drawLink x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
    NEXT
    r = r * .5
    fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
    x2 = x1 + (r + 1) * COS(heading - _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading - _PI(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    x2 = x1 + (r + 1) * COS(heading + _PI(1 / 12)): y2 = y1 + (r + 1) * SIN(heading + _PI(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    r = r * 2
    x1 = x + r * .9 * COS(heading + _PI): y1 = y + r * .9 * SIN(heading + _PI)
    TiltedEllipseFill 0, x1, y1, r, .7 * r, heading + _PI, _RGB32(red, green, blue)
END SUB
 
SUB drawLink (x1, y1, r1, x2, y2, r2, c AS _UNSIGNED LONG)
    DIM a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
    a = _ATAN2(y2 - y1, x2 - x1)
    a1 = a + _PI(1 / 2)
    a2 = a - _PI(1 / 2)
    x3 = x1 + r1 * COS(a1): y3 = y1 + r1 * SIN(a1)
    x4 = x1 + r1 * COS(a2): y4 = y1 + r1 * SIN(a2)
    x5 = x2 + r2 * COS(a1): y5 = y2 + r2 * SIN(a1)
    x6 = x2 + r2 * COS(a2): y6 = y2 + r2 * SIN(a2)
    fquad x3, y3, x4, y4, x5, y5, x6, y6, c
    fcirc x1, y1, r1, c
    fcirc x2, y2, r2, c
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
 
SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
    DIM a&
    a& = _NEWIMAGE(1, 1, 32)
    _DEST a&
    PSET (0, 0), K
    _DEST 0
    _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
    _FREEIMAGE a& '<<< this is important!
END SUB
 
SUB fcirc (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 SUB
 
SUB TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c AS _UNSIGNED LONG)
    DIM max AS INTEGER, mx2 AS INTEGER, i AS INTEGER, j AS INTEGER, k AS SINGLE, lasti AS SINGLE, lastj AS SINGLE
    DIM prc AS _UNSIGNED LONG, tef AS LONG
    prc = _RGB32(255, 255, 255, 255)
    IF a > b THEN max = a + 1 ELSE max = b + 1
    mx2 = max + max
    tef = _NEWIMAGE(mx2, mx2)
    _DEST tef
    _SOURCE tef 'point wont read without this!
    FOR k = 0 TO 6.2832 + .05 STEP .1
        i = max + a * COS(k) * COS(ang) + b * SIN(k) * SIN(ang)
        j = max + a * COS(k) * SIN(ang) - b * SIN(k) * COS(ang)
        IF k <> 0 THEN
            LINE (lasti, lastj)-(i, j), prc
        ELSE
            PSET (i, j), prc
        END IF
        lasti = i: lastj = j
    NEXT
    DIM xleft(mx2) AS INTEGER, xright(mx2) AS INTEGER, x AS INTEGER, y AS INTEGER
    FOR y = 0 TO mx2
        x = 0
        WHILE POINT(x, y) <> prc AND x < mx2
            x = x + 1
        WEND
        xleft(y) = x
        WHILE POINT(x, y) = prc AND x < mx2
            x = x + 1
        WEND
        WHILE POINT(x, y) <> prc AND x < mx2
            x = x + 1
        WEND
        IF x = mx2 THEN xright(y) = xleft(y) ELSE xright(y) = x
    NEXT
    _DEST destHandle&
    FOR y = 0 TO mx2
        IF xleft(y) <> mx2 THEN LINE (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
    NEXT
    _FREEIMAGE tef
END SUB
 
 
Thanks B+Mark !
It is very good. A possible improvement would be to get the rear of the spider's abdomen (where the spinnerets are) to trace out the forming web, just to ultimately please the arachnologists.
Wow! Spider looks realistic.
Nice program, B+! Super!
Thanks guys,

You know spiders get into everything, my dreams, my peace of mind, my

Oh no!!!
QB64.org Forum

Active Forums => Programs => Topic started by: bplus on September 17, 2019, 01:01:16 pm
