Print Page - Crop Circles

Title: Crop Circles
Post by: bplus on January 25, 2021, 04:12:42 pm

Crop circles: 2 color geometric design with shades of fractal or whatever looks intelligently designed or fun!

Crop Circles #3 mod

Code: QB64: [Select]

_TITLE "Crop Circles #3" 'b+ trans and mod to QB64 2021-01-25
 
CONST Xmax = 730, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2
REDIM SHARED Hc AS _UNSIGNED LONG, Lc AS _UNSIGNED LONG
SCREEN _NEWIMAGE(Xmax, Ymax, 32)
_DELAY .25
_SCREENMOVE _MIDDLE
 
Hc = _RGB32(240, 220, 80): Lc = _RGB32(100, 50, 10): n = 12: stp = -40
COLOR , Hc
CLS
FOR br = 360 TO 0 STEP stp
    shft = shft + 720 / (n * n)
    FOR i = 1 TO n
        x = Cx + br * COS(_D2R(i * 360 / n + shft))
        y = Cy + br * SIN(_D2R(i * 360 / n + shft))
        drawc x, y
        _LIMIT 10
    NEXT
NEXT
SLEEP
 
SUB drawc (mx, my)
    'local m,cr,dx,dy,dr,i,cc
    REDIM cc AS _UNSIGNED LONG
    cr = .5 * SQR((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
    dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
    FOR i = m TO 0 STEP -1
        IF i MOD 2 = 0 THEN cc = Hc ELSE cc = Lc
        x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
        fcirc x, y, r, cc
    NEXT
END SUB
 
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM Radius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
    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
 
 
 

Title: Re: Crop Circles
Post by: johnno56 on January 25, 2021, 05:32:28 pm

You obviously have non-traditional aliens where you live...

Nicely done... Does it come in blue... lol Kidding....

Title: Re: Crop Circles
Post by: Pete on January 25, 2021, 05:35:58 pm

I want a slower frames version, with a zoom feature... so I can see Steve on his tractor, making those crop circles. We all know it's him!!!

Pete

Title: Re: Crop Circles
Post by: SierraKen on January 25, 2021, 05:52:45 pm

Awesome B+! I decided to change one line to make the colors red and green to make it a flower.

Code: QB64: [Select]

_TITLE "Crop Circles #3" 'b+ trans and mod to QB64 2021-01-25
 
CONST Xmax = 730, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2
REDIM SHARED Hc AS _UNSIGNED LONG, Lc AS _UNSIGNED LONG
SCREEN _NEWIMAGE(Xmax, Ymax, 32)
_DELAY .25
_SCREENMOVE _MIDDLE
 
'Color mod by SierraKen to look like a flower.
'Hc = _RGB32(240, 220, 80): Lc = _RGB32(100, 50, 10): n = 12: stp = -40
Hc = _RGB32(0, 255, 0): Lc = _RGB32(255, 0, 0): n = 12: stp = -40
COLOR , Hc
CLS
FOR br = 360 TO 0 STEP stp
    shft = shft + 720 / (n * n)
    FOR i = 1 TO n
        x = Cx + br * COS(_D2R(i * 360 / n + shft))
        y = Cy + br * SIN(_D2R(i * 360 / n + shft))
        drawc x, y
        _LIMIT 10
    NEXT
NEXT
SLEEP
 
SUB drawc (mx, my)
    'local m,cr,dx,dy,dr,i,cc
    REDIM cc AS _UNSIGNED LONG
    cr = .5 * SQR((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
    dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
    FOR i = m TO 0 STEP -1
        IF i MOD 2 = 0 THEN cc = Hc ELSE cc = Lc
        x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
        fcirc x, y, r, cc
    NEXT
END SUB
 
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM Radius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
    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
 

Title: Re: Crop Circles
Post by: bplus on January 25, 2021, 06:58:22 pm

Quote from: Pete on January 25, 2021, 05:35:58 pm

I want a slower frames version, with a zoom feature... so I can see Steve on his tractor, making those crop circles. We all know it's him!!!

Pete

Sure, sure but not a tractor, QB64! ;-))

Title: Re: Crop Circles
Post by: Pete on January 25, 2021, 07:11:38 pm

I lost a good first officer, adrift in space that way. I yelled to Ensign Steve, "Engage the tractor beam! To which he immediately went to the shuttle bay, and engaged the headlight on the John Deere. Oh well.

- Pete out.

Title: Re: Crop Circles
Post by: bplus on January 25, 2021, 07:26:41 pm

@johnno56 and @SierraKen different colors huh?

OK let's take a look into my little bag of tricks...

Title: Re: Crop Circles
Post by: bplus on January 25, 2021, 09:21:15 pm

OK here is what my tractor beam from my ship can do:

Code: QB64: [Select]

_TITLE "Crop Circles #3 Mod 1 Zap Color Changes" 'b+ trans and mod to QB64 2021-01-25
 
CONST Xmax = 1024, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2
REDIM SHARED CCircle AS LONG
SCREEN _NEWIMAGE(Xmax, Ymax, 32)
_DELAY .25
_SCREENMOVE _MIDDLE
REDIM SHARED LowColr AS _UNSIGNED LONG, HighColr AS _UNSIGNED LONG
HighColr = _RGB32(240, 220, 80): LowColr = _RGB32(100, 50, 10)
makeCCircle
DO
    _PUTIMAGE , CCircle, 0
    WHILE _MOUSEINPUT: WEND 'aim with mouse
    mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
    drawShip mx, my, LowColr
    IF mb THEN
        PLC mx, my, Cx, Cy, 360
        _DISPLAY
        FlagChange = -1
    END IF
    IF FlagChange THEN
        makeCCircle
        FlagChange = 0
    END IF
    _DISPLAY
LOOP UNTIL _KEYDOWN(27)
 
SUB makeCCircle
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    n = 12: stp = -40
    COLOR , HighColr
    CLS
    FOR br = 360 TO 0 STEP stp
        shft = shft + 720 / (n * n)
        FOR i = 1 TO n
            x = Cx + br * COS(_D2R(i * 360 / n + shft))
            y = Cy + br * SIN(_D2R(i * 360 / n + shft))
            drawc x, y
        NEXT
    NEXT
    _DEST 0
END SUB
 
SUB drawc (mx, my)
    REDIM cc AS _UNSIGNED LONG
    cr = .5 * SQR((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
    dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
    FOR i = m TO 0 STEP -1
        IF i MOD 2 = 0 THEN cc = HighColr ELSE cc = LowColr
        x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
        fcirc x, y, r, cc
    NEXT
END SUB
 
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM Radius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
    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 PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
    r = RND ^ 2 * RND: g = RND ^ 2 * RND: b = RND ^ 2 * RND: hp = _PI(.5) ' red, green, blue, half pi
    ta = _ATAN2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
    dist = _HYPOT(targetY - baseY, targetX - baseX) ' distance cannon to target
    dr = targetR / dist
    FOR r = 0 TO dist STEP .25
        x = baseX + r * COS(ta)
        y = baseY + r * SIN(ta)
        C = C + .3
        fcirc x, y, dr * r, _RGB32(128 + 127 * SIN(r * C), 128 + 127 * SIN(g * C), 128 + 127 * SIN(b * C))
    NEXT
    FOR rr = dr * r TO 0 STEP -.5
        C = C + 1
        LowColr = _RGB32(128 + 127 * SIN(r * C), 128 + 127 * SIN(g * C), 128 + 127 * SIN(b * C))
        fcirc x, y, rr, LowColr
    NEXT
    cAnalysis LowColr, rr, gg, bb, aa
    HighColr = _RGB32(255 - rr, 255 - gg, 255 - bb)
END SUB
 
SUB cAnalysis (c AS _UNSIGNED LONG, outRed, outGrn, outBlu, outAlp)
    outRed = _RED32(c): outGrn = _GREEN32(c): outBlu = _BLUE32(c): outAlp = _ALPHA32(c)
END SUB
 
SUB drawShip (x, y, colr AS _UNSIGNED LONG) 'shipType     collisions same as circle x, y radius = 30
    STATIC ls
    DIM light AS LONG, r AS LONG, g AS LONG, b AS LONG
    r = _RED32(colr): g = _GREEN32(colr): b = _BLUE32(colr)
    fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    fellipse x, y, 30, 7, _RGB32(r, g, b)
    FOR light = 0 TO 5
        fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    NEXT
    ls = ls + 1
    IF ls > 5 THEN ls = 0
END SUB
 
SUB fellipse (CX AS LONG, CY AS LONG, xr AS LONG, yr AS LONG, C AS _UNSIGNED LONG)
    IF xr = 0 OR yr = 0 THEN EXIT SUB
    DIM h2 AS _INTEGER64, w2 AS _INTEGER64, h2w2 AS _INTEGER64
    DIM x AS LONG, y AS LONG
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    LINE (CX - xr, CY)-(CX + xr, CY), C, BF
    DO WHILE y < yr
        y = y + 1
        x = SQR((h2w2 - y * y * w2) \ h2)
        LINE (CX - x, CY + y)-(CX + x, CY + y), C, BF
        LINE (CX - x, CY - y)-(CX + x, CY - y), C, BF
    LOOP
END SUB
 
 

Oh yeah! wear your laser safety glasses unless you have a welders helmet ;-))

Title: Re: Crop Circles
Post by: Pete on January 25, 2021, 10:03:56 pm

Okay, that was very amusing, to say the least. Ensign Steve, eat your heart out!

Pete

Title: Re: Crop Circles
Post by: SierraKen on January 25, 2021, 10:45:36 pm

The UFO is back!!! Run for your lives!!!!!!!! :D

Title: Re: Crop Circles
Post by: johnno56 on January 26, 2021, 07:16:52 am

You have excelled yourself yet again!!

Title: Re: Crop Circles
Post by: Dav on January 26, 2021, 08:11:47 am

Cool effect. Nice coding!.

Edit: I had to play around with it...

Code: QB64: [Select]

_TITLE "Crop Circles #3 Mod 1 Zap Color Changes" 'b+ trans and mod to QB64 2021-01-25
 
CONST Xmax = 1024, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2
REDIM SHARED CCircle AS LONG
SCREEN _NEWIMAGE(Xmax, Ymax, 32)
_DELAY .25
_SCREENMOVE _MIDDLE
REDIM SHARED LowColr AS _UNSIGNED LONG, HighColr AS _UNSIGNED LONG
HighColr = _RGB32(240, 220, 80): LowColr = _RGB32(100, 50, 10)
makeCCircle
DO
    _PUTIMAGE , CCircle, 0
    WHILE _MOUSEINPUT: WEND 'aim with mouse
    mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
    drawShip mx, my, LowColr
    IF mb THEN
        PLC mx, my, Cx, Cy, 360
        _DISPLAY
        FlagChange = -1
    END IF
    IF FlagChange THEN
        makeCCircle
        FlagChange = 0
    END IF
 
 
    temp& = _COPYIMAGE(_DISPLAY)
    RotoZoom _WIDTH / 2, _HEIGHT / 2, temp&, 1, angle
    angle = angle + 3: IF angle >= 360 THEN angle = angle - 360
    _FREEIMAGE temp&
    _DISPLAY
    _DELAY .01
 
 
LOOP UNTIL _KEYDOWN(27)
 
SUB makeCCircle
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    n = 12: stp = -40
    COLOR , HighColr
    CLS
    FOR br = 360 TO 0 STEP stp
        shft = shft + 720 / (n * n)
        FOR i = 1 TO n
            x = Cx + br * COS(_D2R(i * 360 / n + shft))
            y = Cy + br * SIN(_D2R(i * 360 / n + shft))
            drawc x, y
        NEXT
    NEXT
    _DEST 0
END SUB
 
SUB drawc (mx, my)
    REDIM cc AS _UNSIGNED LONG
    cr = .5 * SQR((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
    dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
    FOR i = m TO 0 STEP -1
        IF i MOD 2 = 0 THEN cc = HighColr ELSE cc = LowColr
        x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
        fcirc x, y, r, cc
    NEXT
END SUB
 
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM Radius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
    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 PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
    r = RND ^ 2 * RND: g = RND ^ 2 * RND: b = RND ^ 2 * RND: hp = _PI(.5) ' red, green, blue, half pi
    ta = _ATAN2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
    dist = _HYPOT(targetY - baseY, targetX - baseX) ' distance cannon to target
    dr = targetR / dist
    FOR r = 0 TO dist STEP .25
        x = baseX + r * COS(ta)
        y = baseY + r * SIN(ta)
        C = C + .3
        fcirc x, y, dr * r, _RGB32(128 + 127 * SIN(r * C), 128 + 127 * SIN(g * C), 128 + 127 * SIN(b * C))
    NEXT
    FOR rr = dr * r TO 0 STEP -.5
        C = C + 1
        LowColr = _RGB32(128 + 127 * SIN(r * C), 128 + 127 * SIN(g * C), 128 + 127 * SIN(b * C))
        fcirc x, y, rr, LowColr
    NEXT
    cAnalysis LowColr, rr, gg, bb, aa
    HighColr = _RGB32(255 - rr, 255 - gg, 255 - bb)
END SUB
 
SUB cAnalysis (c AS _UNSIGNED LONG, outRed, outGrn, outBlu, outAlp)
    outRed = _RED32(c): outGrn = _GREEN32(c): outBlu = _BLUE32(c): outAlp = _ALPHA32(c)
END SUB
 
SUB drawShip (x, y, colr AS _UNSIGNED LONG) 'shipType     collisions same as circle x, y radius = 30
    STATIC ls
    DIM light AS LONG, r AS LONG, g AS LONG, b AS LONG
    r = _RED32(colr): g = _GREEN32(colr): b = _BLUE32(colr)
    fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    fellipse x, y, 30, 7, _RGB32(r, g, b)
    FOR light = 0 TO 5
        fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    NEXT
    ls = ls + 1
    IF ls > 5 THEN ls = 0
END SUB
 
SUB fellipse (CX AS LONG, CY AS LONG, xr AS LONG, yr AS LONG, C AS _UNSIGNED LONG)
    IF xr = 0 OR yr = 0 THEN EXIT SUB
    DIM h2 AS _INTEGER64, w2 AS _INTEGER64, h2w2 AS _INTEGER64
    DIM x AS LONG, y AS LONG
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    LINE (CX - xr, CY)-(CX + xr, CY), C, BF
    DO WHILE y < yr
        y = y + 1
        x = SQR((h2w2 - y * y * w2) \ h2)
        LINE (CX - x, CY + y)-(CX + x, CY + y), C, BF
        LINE (CX - x, CY - y)-(CX + x, CY - y), C, BF
    LOOP
END SUB
 
SUB RotoZoom (X AS LONG, Y AS LONG, Image AS LONG, Scale AS SINGLE, Rotation AS SINGLE)
    DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
    W& = _WIDTH(Image&): H& = _HEIGHT(Image&)
    px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
    px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
    sinr! = SIN(-Rotation / 57.2957795131): cosr! = COS(-Rotation / 57.2957795131)
    FOR i& = 0 TO 3
        x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
        px(i&) = x2&: py(i&) = y2&
    NEXT
    _MAPTRIANGLE _SEAMLESS(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MAPTRIANGLE _SEAMLESS(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
END SUB
 
 

- Dav

Title: Re: Crop Circles
Post by: Pete on January 26, 2021, 11:37:25 am

As Steve's attorney, I have to warn you against stealing his intellectual property. You know, ROTATING CROPS.

Help! I'm in a flat spin.......

Pete :D

Title: Re: Crop Circles
Post by: bplus on January 26, 2021, 12:16:08 pm

Ha! Dav now I know what the aliens saw just before they crashed in Roswell ;-))

Well I think the current crop circle design is getting old and we need to zap some new ones.

Some ideas:
https://www.google.com/search?q=crop+circles&client=opera&hs=Vr&sxsrf=ALeKk03o1a04wOu4VzeNoGFGFOaq87A6Xw:1611681406788&source=lnms&tbm=isch&sa=X&ved=2ahUKEwiIhPiNjbruAhUTBs0KHVIzBKAQ_AUoAXoECAgQAw&biw=1179&bih=606

Title: Re: Crop Circles
Post by: Pete on January 26, 2021, 01:30:13 pm

I have a comic I photoshopped to a site once regarding the Roswell incident.

It was a saucer, half embedded in the ground at a 45-degree angle, and around the hull of the saucer, I printed "Student Flyer"

Pete

Title: Re: Crop Circles
Post by: johnno56 on January 26, 2021, 01:59:01 pm

Dav,

Mr. Warhol would be jealous...

J

Title: Re: Crop Circles
Post by: _vince on January 26, 2021, 03:19:01 pm

Nice, bplus, it looks very much like Romanesco broccoli

Title: Re: Crop Circles
Post by: Pete on January 26, 2021, 03:57:05 pm

Quote from: _vince on January 26, 2021, 03:19:01 pm

Nice, bplus, it looks very much like Romanesco broccoli

Stop encouraging him, Vince.Now he'll code it with cheese saucers.

Pete

Title: Re: Crop Circles
Post by: bplus on January 26, 2021, 05:13:49 pm

Thanks @vince, I had to remind myself that fractal veggie.

@Pete well cheese doesn't fly but flying cups, bowls, pans, egg timers or blenders, hmm... ;-)

Title: Re: Crop Circles
Post by: Pete on January 26, 2021, 05:18:02 pm

Flying blenders? Well, like the priest said, who visited Steve's farm... Holy Crop!

Pete

Title: Re: Crop Circles
Post by: bplus on January 26, 2021, 06:37:50 pm

Oh look what the blender dragged in:

Code: QB64: [Select]

_TITLE "Crop Circles #3 Mod 2 Blender" 'b+ trans and mod to QB64 2021-01-25
 
CONST Xmax = 1024, Ymax = 730, Cx = Xmax / 2, Cy = Ymax / 2, nCrops = 4
REDIM SHARED CCircle AS LONG
SCREEN _NEWIMAGE(Xmax, Ymax, 32)
_DELAY .25
_SCREENMOVE _MIDDLE
REDIM SHARED LowColr AS _UNSIGNED LONG, HighColr AS _UNSIGNED LONG, cNum AS LONG
HighColr = _RGB32(240, 220, 80): LowColr = _RGB32(100, 50, 10)
crop0
DO
    _PUTIMAGE , CCircle, 0
    WHILE _MOUSEINPUT: WEND 'aim with mouse
    mx = _MOUSEX: my = _MOUSEY: mb = _MOUSEBUTTON(1)
    drawShip mx, my, LowColr
    IF mb THEN
        PLC mx, my, Cx, Cy, 360
        _DISPLAY
        _DELAY .2
        FlagChange = -1
    END IF
    IF FlagChange THEN
        IF RND < .5 THEN
            crop3
        ELSE
            cNum = (cNum + 1) MOD nCrops
            SELECT CASE cNum
                CASE 0: crop0
                CASE 1: crop1
                CASE 2: crop2
                CASE 3: crop3
            END SELECT
        END IF
        FlagChange = 0
    END IF
    _DISPLAY
LOOP UNTIL _KEYDOWN(27)
 
'crop0 uses this
SUB drawc (mx, my)
    REDIM cc AS _UNSIGNED LONG
    cr = .5 * SQR((Cx - mx) ^ 2 + (Cy - my) ^ 2): m = .5 * cr
    dx = (mx - Cx) / m: dy = (my - Cy) / m: dr = cr / m
    FOR i = m TO 0 STEP -1
        IF i MOD 2 = 0 THEN cc = HighColr ELSE cc = LowColr
        x = Cx + dx * (m - i): y = Cy + dy * (m - i): r = dr * i
        fcirc x, y, r, cc
    NEXT
END SUB
 
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM Radius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
    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 PLC (baseX, baseY, targetX, targetY, targetR) ' PLC for PlasmaLaserCannon
    r = RND ^ 2 * RND: g = RND ^ 2 * RND: b = RND ^ 2 * RND: hp = _PI(.5) ' red, green, blue, half pi
    ta = _ATAN2(targetY - baseY, targetX - baseX) ' angle of target to cannon base
    dist = _HYPOT(targetY - baseY, targetX - baseX) ' distance cannon to target
    dr = targetR / dist
    FOR r = 0 TO dist STEP .25
        x = baseX + r * COS(ta)
        y = baseY + r * SIN(ta)
        c = c + .3
        fcirc x, y, dr * r, _RGB32(128 + 127 * SIN(r * c), 128 + 127 * SIN(g * c), 128 + 127 * SIN(b * c))
    NEXT
    FOR rr = dr * r TO 0 STEP -.5
        c = c + 1
        LowColr = _RGB32(128 + 127 * SIN(r * c), 128 + 127 * SIN(g * c), 128 + 127 * SIN(b * c))
        fcirc x, y, rr, LowColr
    NEXT
    cAnalysis LowColr, rr, gg, bb, aa
    HighColr = _RGB32(255 - rr, 255 - gg, 255 - bb)
END SUB
 
' PLC uses this
SUB cAnalysis (c AS _UNSIGNED LONG, outRed, outGrn, outBlu, outAlp)
    outRed = _RED32(c): outGrn = _GREEN32(c): outBlu = _BLUE32(c): outAlp = _ALPHA32(c)
END SUB
 
SUB drawShip (x, y, colr AS _UNSIGNED LONG) 'shipType     collisions same as circle x, y radius = 30
    STATIC ls
    DIM light AS LONG, r AS LONG, g AS LONG, b AS LONG
    r = _RED32(colr): g = _GREEN32(colr): b = _BLUE32(colr)
    fellipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    fellipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    fellipse x, y, 30, 7, _RGB32(r, g, b)
    FOR light = 0 TO 5
        fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    NEXT
    ls = ls + 1
    IF ls > 5 THEN ls = 0
END SUB
 
' drawShip needs
SUB fellipse (CX AS LONG, CY AS LONG, xr AS LONG, yr AS LONG, C AS _UNSIGNED LONG)
    IF xr = 0 OR yr = 0 THEN EXIT SUB
    DIM h2 AS _INTEGER64, w2 AS _INTEGER64, h2w2 AS _INTEGER64
    DIM x AS LONG, y AS LONG
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    LINE (CX - xr, CY)-(CX + xr, CY), C, BF
    DO WHILE y < yr
        y = y + 1
        x = SQR((h2w2 - y * y * w2) \ h2)
        LINE (CX - x, CY + y)-(CX + x, CY + y), C, BF
        LINE (CX - x, CY - y)-(CX + x, CY - y), C, BF
    LOOP
END SUB
 
FUNCTION rand (low, high)
    rand = RND * (high - low) + low
END FUNCTION
 
 
SUB crop0
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    COLOR , HighColr
    CLS
    n = 12: stp = -40
    FOR br = 360 TO 0 STEP stp
        shft = shft + 720 / (n * n)
        FOR i = 1 TO n
            x = Cx + br * COS(_D2R(i * 360 / n + shft))
            y = Cy + br * SIN(_D2R(i * 360 / n + shft))
            drawc x, y
        NEXT
    NEXT
    _DEST 0
END SUB
 
SUB crop1
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    COLOR , HighColr
    CLS
    ga = 137.5: bn = 800
    br = 9.5: lr = .5: r = br: dr = (br - lr) / bn
    hc = 180: lc = 120: cr = (hc - lc) / bn
    FOR n = 1 TO bn
        x = Cx + 10 * SQR(n) * COS(_D2R(n * ga))
        y = Cy + 10 * SQR(n) * SIN(_D2R(n * ga))
        r = r - dr
        fcirc x, y, r, LowColr
    NEXT
    _DEST 0
END SUB
 
SUB crop2
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    'this needs big constrast of color
    HighColr = _RGB32(RND * 80, RND * 80, RND * 80) ' field
    LowColr = _RGB32(175 + RND * 80, 175 + RND * 80, 175 + RND * 80)
    COLOR , HighColr
    CLS
    FOR i = 45 TO Xmax STEP 50
        LINE (i, 0)-(i + 10, Ymax), LowColr, BF
        LINE (0, i)-(Xmax, i + 10), LowColr, BF
    NEXT
    FOR y = 50 TO 650 STEP 50
        FOR x = 50 TO Xmax STEP 50
            fcirc x, y, 10, LowColr
        NEXT
    NEXT
    _DEST 0
END SUB
 
SUB crop3
    IF CCircle THEN _FREEIMAGE CCircle
    CCircle = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST CCircle
    COLOR , HighColr
    CLS
 
    r0 = rand(1, 5) / 5: r1 = rand(1, 5) / 10: r2 = rand(1, 5) / 10
    fc = rand(1, 200) / 10: st = rand(10, 500) / 1000
    xol = 0
    yol = 0
    mol = 0
    FOR i = 0 TO 120 STEP st
        a0 = (i / r0) * (2 * _PI)
        a1 = ((i / r1) * (2 * _PI)) * -1
        x1 = Cx + (SIN(a0) * ((r0 - r1) * fc)) * 30
        y1 = Cy + (COS(a0) * ((r0 - r1) * fc)) * 30
        x2 = x1 + (SIN(a1) * ((r2) * fc)) * 30
        y2 = y1 + (COS(a1) * ((r2) * fc)) * 30
        IF mol = 0 THEN
            mol = 1
            xol = x2
            yol = y2
        ELSE
            LINE (xol, yol)-(x2, y2), LowColr
            xol = x2
            yol = y2
        END IF
    NEXT
 
 
    _DEST 0
END SUB
 
 

Title: Re: Crop Circles
Post by: _vince on January 26, 2021, 07:28:18 pm

I remember seeing one of these fresh at a local farmer's market and I had to buy it. It was the most beautiful thing ever. Screw gifting flowers, imagine receiving one of these for a change.

I ate it raw like broccoli and it tasted like crap, compared to broccoli it's very hard and is relatively tasteless but whatever taste there is it's not very good, I ate the entire thing anyway (not at once). Maybe it's better cooked?

Title: Re: Crop Circles
Post by: bplus on January 26, 2021, 08:15:24 pm

Quote

Screw gifting flowers, imagine receiving one of these for a change.

Sure and Valentine's Day is coming soon!

Title: Re: Crop Circles
Post by: Pete on January 26, 2021, 08:19:53 pm

It was all fun and games, until I had to stop to count Steve's damn dots!

Pete

Title: Re: Crop Circles
Post by: bplus on January 26, 2021, 08:54:30 pm

Quote from: Pete on January 26, 2021, 08:19:53 pm

It was all fun and games, until I had to stop to count Steve's damn dots!

Pete

I know just what you mean!

Code: QB64: [Select]

DIM SHARED xmax AS INTEGER, ymax AS INTEGER
xmax = _DESKTOPWIDTH
ymax = _DESKTOPHEIGHT
sc& = _SCREENIMAGE
SCREEN _NEWIMAGE(xmax, ymax, 32)
_DELAY .25
_FULLSCREEN
WHILE LEN(INKEY$) = 0
    _PUTIMAGE , sc&, 0
    FOR y = 50 TO ymax - 50 STEP 50
        FOR x = 50 TO xmax - 50 STEP 50
            fcirc x, y, 10, _RGB32(RND * 40, RND * 40, RND * 40, RND * 40)
        NEXT
    NEXT
    _DISPLAY
    _LIMIT 10
WEND
CLS
SYSTEM
 
 
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
 

Edit: new and maybe improved

Title: Re: Crop Circles
Post by: SierraKen on January 26, 2021, 11:14:54 pm

Soon someone is going to write a book about this thread.... and it will be in the paranormal section. o_o

Title: Re: Crop Circles
Post by: STxAxTIC on January 26, 2021, 11:17:16 pm

It'll be the Librarian who writes about this. Are crop circles pure art? ... or are they ... simulation of a real thing?! OOooOOOOo

I don't buy what the BBC documentary says, there's something real about crop circles.

Title: Re: Crop Circles
Post by: bplus on January 27, 2021, 01:52:36 am

Yeah I only know some of those designs have captured my imagination.

Title: Re: Crop Circles
Post by: Pete on January 27, 2021, 11:27:44 am

I had something that captured my imagination once, but my wife refused to pay the ransom to get it back. Hey, two dollars is two dollars.

Pete

Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: bplus on January 25, 2021, 04:12:42 pm