Crop Circles 3 mod 2 Blender - Printable Version

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