Pentagram of DOOM

[James D Jarvis]

A brief Halloween themed demo.   

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