Author Topic: Gears Afire!  (Read 1400 times)

B+

  • Guest
Gears Afire!
« on: May 25, 2018, 02:04:24 AM »
Code: [Select]
_TITLE "Gears afire!.bas for QB64 by B+ started  2018-05-24"
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)

CONST xmax = 800
CONST ymax = 600
DIM SHARED pi
pi = _PI
CONST bhr = 20
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60

DIM SHARED f(xmax, ymax) 'fire array tracks flames
DIM SHARED p&(300) 'pallette thanks harixxx
FOR i = 1 TO 100
    fr = 240 * i / 100 + 15
    p&(i) = _RGB(fr, 0, 0)
    p&(i + 100) = _RGB(255, fr, 0)
    p&(i + 200) = _RGB(255, 255, fr)
NEXT

'gear up
sq = 20
nt1 = 12
r1 = gearRadius(nt1, sq)
nt2 = nt1 * 2
r2 = gearRadius(nt2, sq)
iA2 = pi / nt2
acc = 300: d = -1
WHILE 1 'main show
    CLS
    rao = rao + pi / acc
    gear 600, 300, nt1, sq, rao
    gear 600 - r1 - r2 - sq - 6, 300, nt2, sq, -.5 * rao - iA2
    FOR y = 1 TO ymax - 2 'fire based literally on 4 pixels below it like cellular automata
        FOR x = 1 TO xmax - 1
            v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
            IF v > 0 AND RND < .96 THEN f(x, y) = v ELSE f(x, y) = 0
            IF v > 294 THEN f(x, y) = 300
            PSET (x, y), p&(f(x, y))
        NEXT
    NEXT
    acc = acc + d * 2
    IF acc < 6 THEN acc = 6: d = d * -1
    IF acc > 300 THEN acc = 300: d = d * -1
    _DISPLAY
WEND

FUNCTION gearRadius (nteeth, sqtooth)
    gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
END FUNCTION

SUB gear (x, y, nteeth, sqtooth, raOffset)
    radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
    FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
        x2 = x + (radius + sqtooth) * COS(ra + raOffset)
        y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
        thic x, y, x2, y2, sqtooth - 4
    NEXT
    FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
        x2 = x + radius * COS(ra + raOffset)
        y2 = y + radius * SIN(ra + raOffset)
        thic x, y, x2, y2, sqtooth + 4
    NEXT
END SUB

SUB thic (x1, y1, x2, y2, thick)
    t2 = thick / 2
    IF t2 < 1 THEN t2 = 1
    a = _ATAN2(y2 - y1, x2 - x1)
    FOR i = 0 TO t2 STEP .5
        x3 = x1 + i * COS(a + _PI(.5))
        y3 = y1 + i * SIN(a + _PI(.5))
        x4 = x1 + i * COS(a - _PI(.5))
        y4 = y1 + i * SIN(a - _PI(.5))
        x5 = x2 + i * COS(a + _PI(.5))
        y5 = y2 + i * SIN(a + _PI(.5))
        x6 = x2 + i * COS(a - _PI(.5))
        y6 = y2 + i * SIN(a - _PI(.5))
        'fireLine x3, y3, x4, y4
        fireLine x4, y4, x6, y6
        'fireLine x6, y6, x5, y5
        fireLine x5, y5, x3, y3
    NEXT
END SUB

SUB fireLine (x, y, x1, y1)
    d = ((x - x1) ^ 2 + (y - y1) ^ 2) ^ .5
    a = _ATAN2(y1 - y, x1 - x)
    FOR i = 0 TO d
        xx = INT(x + i * COS(a) + .5)
        yy = INT(y + i * SIN(a) + .5)
        f(xx, yy) = rand(200, 300)
    NEXT
END SUB

FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION

Edit: Removed unused parameter in fireLine.
« Last Edit: May 25, 2018, 02:33:44 AM by B+ »

B+

  • Guest
Re: Gears Afire!
« Reply #1 on: May 25, 2018, 02:27:24 PM »
To speed up, you can reduce screen size OR scale the pixel drawing up to boxes. Either way, there is less calculations.
Of course, you can also rotate the gears faster and slower as demo'd already. ;-))

Here is doing it with scaling, the smaller the scale the bigger the fire but the blurrier the picture. Try any scale >0 and <=1:

Code: [Select]
_TITLE "Gears Afire! SCALED.bas for QB64 by B+ started  2018-05-25"
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)

CONST xmax = 800
CONST ymax = 600
DIM SHARED pi
pi = _PI

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60
DIM SHARED p&(300) 'pallette thanks harixxx
FOR i = 1 TO 100
    fr = 240 * i / 100 + 15
    p&(i) = _RGB(fr, 0, 0)
    p&(i + 100) = _RGB(255, fr, 0)
    p&(i + 200) = _RGB(255, 255, fr)
NEXT

WHILE 1
    CLS
    LOCATE 5, 23: PRINT "***  GEARS AFIRE! NOW SCALED TO YOUR SPECIFICATIONS ***"
    LOCATE 10, 35: PRINT "Please enter a scale from 0 to 1,"
    LOCATE 11, 10: PRINT "the lower the scale the less pixels used the bigger the fire and blurrier it gets. "
    LOCATE 13, 20: INPUT "(0 or any number > 1 quits) Enter your scale choice now > "; scale
    _DISPLAY
    IF NOT (scale > 0 AND scale <= 1) THEN END
    CLS

    LOCATE 10, 18: PRINT "Please wait 30 seconds to watch the _LIMIT changes for graphics speed."
    LOCATE 15, 41: PRINT "press any for show..."
    _DISPLAY
    'SLEEP      'WTF???
    k$ = ""
    WHILE LEN(k$) = 0: k$ = INKEY$: _LIMIT 500: WEND


    rscale = 1 / scale
    xxmax = scale * xmax
    yymax = scale * ymax

    REDIM SHARED f(xxmax, yymax) 'fire array tracks flames

    'gear up
    sq = 20
    nt1 = 12
    r1 = gearRadius(nt1, sq)
    nt2 = nt1 * 2
    r2 = gearRadius(nt2, sq)
    iA2 = pi / nt2
    acc = 1: d = 1

    start = TIMER
    WHILE TIMER - start < 30 'main show
        CLS
        PRINT "Scale, _LIMIT:"; scale; ","; acc
        rao = rao + pi / 180
        gear 600 * scale + 1, 300 * scale + 1, nt1, sq * scale, rao
        gear (600 - r1 - r2 - sq - 6) * scale + 1, 300 * scale + 1, nt2, sq * scale, -.5 * rao - iA2
        FOR y = 1 TO yymax - 2 'fire based literally on 4 pixels below it like cellular automata
            FOR x = 1 TO xxmax - 1
                v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
                IF v > 0 AND RND < .96 THEN f(x, y) = v ELSE f(x, y) = 0
                IF v > 294 THEN f(x, y) = 300
                LINE (x * rscale, y * rscale)-STEP(rscale, rscale), p&(f(x, y)), BF
            NEXT
        NEXT
        acc = acc + d
        IF acc < 1 THEN acc = 1: d = d * -1
        IF acc > 100 THEN acc = 100: d = d * -1
        _DISPLAY
        _LIMIT acc
    WEND
WEND


FUNCTION gearRadius (nteeth, sqtooth)
    gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
END FUNCTION

SUB gear (x, y, nteeth, sqtooth, raOffset)
    radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
    FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
        x2 = x + (radius + sqtooth) * COS(ra + raOffset)
        y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
        thic x, y, x2, y2, sqtooth - 4
    NEXT
    FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
        x2 = x + radius * COS(ra + raOffset)
        y2 = y + radius * SIN(ra + raOffset)
        thic x, y, x2, y2, sqtooth + 4
    NEXT
END SUB

SUB thic (x1, y1, x2, y2, thick)
    t2 = thick / 2
    IF t2 < 1 THEN t2 = 1
    a = _ATAN2(y2 - y1, x2 - x1)
    FOR i = 0 TO t2 STEP .5
        x3 = x1 + i * COS(a + _PI(.5))
        y3 = y1 + i * SIN(a + _PI(.5))
        x4 = x1 + i * COS(a - _PI(.5))
        y4 = y1 + i * SIN(a - _PI(.5))
        x5 = x2 + i * COS(a + _PI(.5))
        y5 = y2 + i * SIN(a + _PI(.5))
        x6 = x2 + i * COS(a - _PI(.5))
        y6 = y2 + i * SIN(a - _PI(.5))
        'fireLine x3, y3, x4, y4
        fireLine x4, y4, x6, y6
        'fireLine x6, y6, x5, y5
        fireLine x5, y5, x3, y3
    NEXT
END SUB

SUB fireLine (x, y, x1, y1)
    d = ((x - x1) ^ 2 + (y - y1) ^ 2) ^ .5
    a = _ATAN2(y1 - y, x1 - x)
    FOR i = 0 TO d
        xx = INT(x + i * COS(a) + .5)
        yy = INT(y + i * SIN(a) + .5)
        f(xx, yy) = rand(200, 300)
    NEXT
END SUB

FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION