Pentagram of DOOM - Printable Version

Code: (Select All)
'Spooky pentagram of doom for Halloween

'juts a little halloween season fun

Screen _NewImage(800, 500, 32)

_Define K As _UNSIGNED LONG

_FullScreen

'good music here

Play "MB O0 L4  cdccdcecdccdccdccdcecdccababcddcddcdde O2 L2  e  e  e  e  e"

'well not really

For d = 0 To 360

    _Limit 20

    Cls

    circleBF 400, 250, (d * 1.1) / 2, _RGB32(250, 250, 0)

    circleBF 400, 250, ((d * 1) / 2) - 2, _RGB32(0, 0, 0)

    bumpypoly 400, 250, d / 2, 72, 180 + d, 1 + Int(d / 120), _RGB32(0, 250, 10)



    bumpypentagram 400, 250, d / 2, 72, 180 + d, 1 + Int(d / 90), _RGB32(250, 2, 5)

    _Display

Next d

_AutoDisplay

For n = 1 To 900

    _Limit 400

    sx = Int(Rnd * 800)

    sy = Int(Rnd * 500)

    klr = _RGB32(240 + Int(Rnd * 16), Int(Rnd * 10), Int(Rnd * 10))

    rd = Int(Rnd * 12)

    circleBF sx, sy, 8 + rd, klr

    circleBF sx + Int(Rnd * (rd / 2)), sy + Int(Rnd * (rd / 2)), 4 + rd, klr

    circleBF sx + Int(Rnd * (rd / 2)), sy + Int(Rnd * (rd / 2)), 2 + rd, klr

Next

Line (0, 0)-(800, 500), klr, BF

klr2 = _RGB32(250, 250, 0)

For t = 1 To 360

    _Limit 180

    pp = 1 + Int(Rnd * 3)

    For reps = 1 To pp

        sx = Int(Rnd * 800)

        sy = Int(Rnd * 500)

        rd = 3 + Int(Rnd * 24)



        pentagram sx, sy, rd, 72, Int(Rnd * 360), .5 + Rnd * 2.5, klr2

    Next reps

    bumpypentagram 400, 250, 180, 72, 360, 1 + Int(t / 90), _RGB32(75 + t / 2, 75 + t / 2, 5)

Next t

For n = 0 To 255

    _Limit 180

    Line (0, 0)-(800, 500), _RGB32(0, 0, 0, n), BF

    bumpypentagram 400, 250, 180, 72, 360, 5, _RGB32(255, 255, 5)

Next n

For n = 0 To 255

    _Limit 180

    bumpypentagram 400, 250, 180, 72, 360, 5, _RGB32(255, 255, 5)

    Line (0, 0)-(800, 500), _RGB32(0, 0, 0, n), BF



Next n

_Delay 3

Cls

System







Sub bumpypentagram (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)

    Dim p(6, 2)

    x = rr * Sin(0.01745329 * turn)

    y = rr * Cos(0.01745329 * turn)

    'Line (cx + x, cy + y)-(cx + x, cy + y), klr

    lx = cx + x: ly = cy + y

    n = 0

    For deg = turn To turn + 360 Step shapedeg

        x2 = rr * Sin(0.01745329 * deg)

        y2 = rr * Cos(0.01745329 * deg)

        ' tv = (Rnd * 6 + Rnd * 6 + 3) / 10

        ' bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr

        lx = cx + x2: ly = cy + y2

        n = n + 1

        p(n, 1) = cx + x2

        p(n, 2) = cy + y2

    Next

    tv = (Rnd * 6 + Rnd * 6 + 3) / 10

    bumpyline p(1, 1), p(1, 2), p(3, 1), p(3, 2), thk * tv, klr

    tv = (Rnd * 6 + Rnd * 6 + 3) / 10

    bumpyline p(3, 1), p(3, 2), p(5, 1), p(5, 2), thk * tv, klr

    tv = (Rnd * 6 + Rnd * 6 + 3) / 10

    bumpyline p(5, 1), p(5, 2), p(2, 1), p(2, 2), thk * tv, klr

    tv = (Rnd * 6 + Rnd * 6 + 3) / 10

    bumpyline p(2, 1), p(2, 2), p(4, 1), p(4, 2), thk * tv, klr

    tv = (Rnd * 6 + Rnd * 6 + 3) / 10

    bumpyline p(4, 1), p(4, 2), p(6, 1), p(6, 2), thk * tv, klr

End Sub



Sub pentagram (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)

    Dim p(6, 2)

    x = rr * Sin(0.01745329 * turn)

    y = rr * Cos(0.01745329 * turn)

    'Line (cx + x, cy + y)-(cx + x, cy + y), klr

    lx = cx + x: ly = cy + y

    n = 0

    For deg = turn To turn + 360 Step shapedeg

        x2 = rr * Sin(0.01745329 * deg)

        y2 = rr * Cos(0.01745329 * deg)

        ' tv = (Rnd * 6 + Rnd * 6 + 3) / 10

        ' bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr

        lx = cx + x2: ly = cy + y2

        n = n + 1

        p(n, 1) = cx + x2

        p(n, 2) = cy + y2

    Next

    Line (p(1, 1), p(1, 2))-(p(3, 1), p(3, 2)), klr

    Line (p(3, 1), p(3, 2))-(p(5, 1), p(5, 2)), klr

    Line (p(5, 1), p(5, 2))-(p(2, 1), p(2, 2)), klr

    Line (p(2, 1), p(2, 2))-(p(4, 1), p(4, 2)), klr

    Line (p(4, 1), p(4, 2))-(p(6, 1), p(6, 2)), klr

End Sub





Sub bumpypoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)

    x = rr * Sin(0.01745329 * turn)

    y = rr * Cos(0.01745329 * turn)

    'Line (cx + x, cy + y)-(cx + x, cy + y), klr

    lx = cx + x: ly = cy + y

    For deg = turn To turn + 360 Step shapedeg

        x2 = rr * Sin(0.01745329 * deg)

        y2 = rr * Cos(0.01745329 * deg)

        tv = (Rnd * 6 + Rnd * 6 + 3) / 10

        bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr

        lx = cx + x2: ly = cy + y2

    Next

End Sub

Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    yi = 1

    If dy < 0 Then

        yi = -1

        dy = -dy

    End If

    'D = (2 * dy) - dx

    d = (dy + dy) - dx

    y = y0

    For x = x0 To x1

        tv = (Rnd * 12 + Rnd * 6 + 3) / 10

        circleBF x, y, r * tv, klr



        If d > 0 Then

            y = y + yi

            ' D = D + (2 * (dy - dx))

            d = d + ((dy - dx) + (dy - dx))

        Else

            ' D = D + 2 * dy

            d = d + dy + dy

        End If

    Next x

End Sub



Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    xi = 1

    If dx < 0 Then

        xi = -1

        dx = -dx

    End If

    ' D = (2 * dx) - dy

    D = (dx + dx) - dy

    x = x0

    For y = y0 To y1

        tv = (Rnd * 12 + Rnd * 6 + 3) / 10

        circleBF x, y, r * tv, klr



        If D > 0 Then

            x = x + xi

            ' D = D + (2 * (dx - dy))

            D = D + ((dx - dy) + (dx - dy))

        Else

            ' D = D + 2 * dx

            D = D + dx + dx

        End If

    Next y

End Sub

Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)

    If Abs(y1 - y0) < Abs(x1 - x0) Then

        If x0 > x1 Then

            bumpylineLow x1, y1, x0, y0, r, klr



        Else

            bumpylineLow x0, y0, x1, y1, r, klr

        End If

    Else

        If y0 > y1 Then

            bumpylineHigh x1, y1, x0, y0, r, klr

        Else

            bumpylineHigh x0, y0, x1, y1, r, klr

        End If

    End If

End Sub



Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)

    rsqrd = r * r

    y = -r

    While y <= r

        x = Sqr(rsqrd - y * y)

        Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF

        y = y + 1

    Wend

End Sub