Gears
#1
Code:
_TITLE "Gear 1.bas for QB64 by B+ started  2018-05-22"
'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
sq = 20
nt1 = 16
k1 = _RGB32(250, 150, 0)
r1 = gearRadius(nt1, sq)
nt2 = nt1 * 2
k2 = _RGB32(255, 255, 0)
r2 = gearRadius(nt2, sq)
iA2 = pi / nt2
FOR rao = 0 TO pi * 2 STEP pi / 180
   CLS
   gear 600, 300, nt1, sq, rao, k1
   gear 600 - r1 - r2 - sq, 300, nt2, sq, -.5 * rao - iA2, k2
   _DISPLAY
   _LIMIT 25
NEXT

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

SUB gear (x, y, nteeth, sqtooth, raOffset, K AS _UNSIGNED LONG)
   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, K
   NEXT
   'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
   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, K
   NEXT
   COLOR _RGB32(155, 70, 35)
   fcirc x, y, .9 * radius
   K1 = _RGB(0, 0, 0)
   COLOR K1
   fcirc x, y, bhr
   thic x, y, x + (bhr + sqtooth) * COS(raOffset), y + (bhr + sqtooth) * SIN(raOffset), sqtooth, K1
END SUB

SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
   t2 = thick / 2
   IF t2 < 1 THEN t2 = 1
   a = _ATAN2(y2 - y1, x2 - x1)
   x3 = x1 + t2 * COS(a + _PI(.5))
   y3 = y1 + t2 * SIN(a + _PI(.5))
   x4 = x1 + t2 * COS(a - _PI(.5))
   y4 = y1 + t2 * SIN(a - _PI(.5))
   x5 = x2 + t2 * COS(a + _PI(.5))
   y5 = y2 + t2 * SIN(a + _PI(.5))
   x6 = x2 + t2 * COS(a - _PI(.5))
   y6 = y2 + t2 * SIN(a - _PI(.5))
   filltri x6, y6, x4, y4, x3, y3, K
   filltri x3, y3, x5, y5, x6, y6, K
END SUB


'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
   DIM subRadius AS LONG, RadiusError AS LONG
   DIM X AS LONG, Y AS LONG

   subRadius = ABS(R)
   RadiusError = -subRadius
   X = subRadius
   Y = 0

   IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

   ' Draw the middle span here so we don't draw it twice in the main loop,
   ' which would be a problem with blending turned on.
   LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
               LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
           END IF
           X = X - 1
           RadiusError = RadiusError - X * 2
       END IF
       Y = Y + 1
       LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
       LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
   WEND
END SUB

' found at QB64.net:    http://www.qb64.net/forum/index.php?topic=14425.0
SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
   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

B += x
Reply
#2
Cool... Much smoother than the JB version... and yes, this also lends well to the need to have slightly rounded teeth... lol  Well done.

J
May your journey be free of incident.

Live long and prosper.
Reply
#3
Gears Afire!

Code:
_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 an unused parameter in fireLine.

B += x
Reply
#4
One way to get more speed (and more fire and blurrier gears) is to scale down the number of calculation (per pixel) so each pixel color becomes a small square of color.

So here is some code to try out some scales to see the trade-offs between speed, fire and blurriness:
Code:
_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

B += x
Reply
#5
Now you're just showing off... lol

Very nicely done...

J
May your journey be free of incident.

Live long and prosper.
Reply