Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Crop Circles 3 mod 2 Blender
#1
Dedicated to all farmers who code with Basic ;-))

Code: (Select All)
_Title "Crop Circles #3 Mod 2 Blender" 'b+ trans and mod to QB64 2021-01-25
Randomize Timer

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

[Image: Crop-Circles-3-Mod-2-Blender.png]
Reply
#2
Crop circles! Watch the skies! Blender! Futurama!
May your journey be free of incident. Live long and prosper.
Reply
#3
LOL that's where I heard blender before!

I forgot to suggest flying the saucer/mouse to a corner of the screen so you can get maximum effect from the Laser Plasma Canon when you click the screen for new design and color set.
Reply
#4
Nice mod B+, is this a JB original?
Reply
#5
Ha! Most my original JB comes from tsh73 , John or Rod one of those JB experts, I have to simplify to port QB64 graphics to JB unless I make sprites.
Reply
#6
LOL awesome B+! I like how you combined so many different variations. And of course the saucer. Big Grin
Reply
#7
Yes Ken, thanks for returning my ship not dented and the plasma tank full. ;-))
Reply
#8
Glad I looked at that before I planted my crops.
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply




Users browsing this thread: 2 Guest(s)