alien skies

[James D Jarvis]

Cooled off some of the stars (more variance to the color). Added in reflective water, not thrilled with it yet but it's on the path.

Code: (Select All)

' alienskies   0.3
' By James D. Jarvis
' also includes other folks fine code  found here https://qb64phoenix.com/forum/index.php
' fun little image genreating program
'now with bad reflective "water "
'
'press q to quit, any othjer key to generate a new image

Dim Shared imgmax_x, imgmax_y, MS&
imgmax_x = 800
imgmax_y = 600
Randomize Timer

MS& = _NewImage(imgmax_x, imgmax_y, 32)
Screen MS&
' "Some images can take a couple seconds to generate"
Do
    'Cls
    ectocheck = Rnd * 100
    If ectocheck < 30 Then ectosky
    starfield
    moons
    acheck = Rnd * 100
    If acheck < 60 Then atm& = atmos
    hrz = horizon
    flatland hrz
    gk& = Point(1, hrz)
    ocheck = Rnd * 100
    If ocheck < 50 Then ocean hrz, atm&, gk&
    mcheck = Rnd * 100
    If mcheck < 60 Then mountains gk&, hrz

    askagain:
    ask$ = LCase$(InKey$)
    If ask$ = "" Then GoTo askagain
    Cls
Loop Until ask$ = "q"

Sub moons
    mm = Int(Rnd * 6)
    If mm > 0 Then
        For m = 1 To mm
            mx = Int(Rnd * imgmax_x)
            my = Int(Rnd * imgmax_y * .75)
            mkr = Int(Rnd * 100) + 50: mkg = Int(Rnd * 100) + 50: mkb = Int(Rnd * 100) + 50
            mklr& = _RGB32(mkr, mkg, mkb)
            moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
            orb mx, my, moonsize, mklr&, 1.8
            kk = 1
            ccheck = Int(Rnd * 100)
            If ccheck < 90 Then
                kk = craters(mx, my, moonsize, mklr&)
            End If


            moonfuzz mx, my, moonsize, mklr&, 10 + (kk * 3)
        Next m
    End If
End Sub
Sub mountains (gk&, hrz)
    gc& = gk&
    mh = Int(Rnd * 10) + 2
    md = 1
    For by = hrz To imgmax_y Step 4

        x = 0
        Do
            If md = -1 Then mh = mh - Int(Rnd * 4)
            If mh > 0 Then
                Line (x, by - mh)-(x, by), gc&
                gc& = gk&
                For b = (by - mh + mh / 4) To mh + Int(Rnd * 6)
                    PSet (x, b), gc&
                    gc& = brighter(gc&, 13.5)
                Next b
            End If
            If md = 1 Then mh = mh + Int(Rnd * 4) - Int(Rnd * 4)
            If mh > 100 Then md = md - 1
            x = x + 1
        Loop Until x > imgmax_x
    Next by
End Sub
Sub ocean (hrz, sk&, gk&)
    Dim wx(imgmax_y, 2)
    wtr = Int((_Red32(sk&) + _Red32(gk&)) / 3)
    wtg = Int((_Green32(sk&) + _Green32(gk&)) / 3)
    wtb = Int((_Blue32(sk&) + _Blue32(gk&)) / 3)
    wk& = _RGB32(wtr, wtg, wtb)
    wk2& = _RGB32(wtr * 1.15, wtg * 1.15, wtb * 1.15)
    ' wk& = _RGB32(255, 255, 255)
    otop = hrz + Int(Rnd * 100)
    wrate = (1 + Rnd * 10 / 2)
    If otop > imgmax_x Then otop = imgmax_x
    wx1 = Int(Rnd * (imgmax_x / 2) * wrate): wx2 = wx1 + Int(((Rnd * (imgmax / 2 + 60)) + 1) * wrate)
    For w = otop To imgmax_y

        wx1 = wx1 - Int(Rnd * 8): wx2 = wx2 + Int(Rnd * 8)
        wx(w, 1) = wx1: wx(w, 2) = wx2
    Next w

    For w = otop To imgmax_y
        Line (wx(w, 1), w)-(wx(w, 2), w), wk&
        wx(w, 1) = wx(w, 1) + Int(Rnd * (w / 4)) 'changing these here for the reflection coming up
        wx(w, 2) = wx(w, 2) - Int(Rnd * (w / 4))
    Next w
    For w = otop To imgmax_y
        For xx = wx(w, 1) To wx(w, 2)
            tk& = Point(xx, (imgmax_y) - (w - horz))
            ttr = _Red32(tk&)
            ttg = _Green32(tk&)
            ttb = _Blue32(tk&)
            tta = Int(Rnd * 50) + 25
            tk& = _RGBA32(ttr, ttg, ttb, tta)
            If Rnd * 4 < 2 Then
                PSet (xx, w), tk&
            Else
                PSet (xx + Int(Rnd * 2) - Int(Rnd * 2), w), tk&
            End If
        Next xx
    Next w
    For w = otop To imgmax_y
        For xx = wx(w, 1) To wx(w, 2)
            wk2& = _RGBA32(wtr * 1.35, wtg * 1.35, wtb * 1.35, Int(Rnd * w / 4) + 50)
            PSet (xx, w), wk2&
        Next xx
        For xx = wx(w, 1) To wx(w, 2) Step 2
            tk& = Point(xx, (imgmax_y) - (w - horz))
            ttr = _Red32(tk&)
            ttg = _Green32(tk&)
            ttb = _Blue32(tk&)
            tta = Int(Rnd * 50) + 25

            tk2& = _RGBA32(ttr * 1.5, ttg * 1.5, ttb * 1.5, tta)
            PSet (xx, w), tk2&
        Next xx

    Next w

End Sub
Function atmos&
    'add atmosphereic color
    ar = Int(Rnd * 255)
    ag = Int(Rnd * 255)
    ab = Int(Rnd * 255)
    aa = Int(Rnd * 85) + 10
    For y = imgmax_y To 0 Step -1
        a2 = Int(aa - y / 3)
        ak& = _RGBA32(ar, ag, ab, aa - a2)
        Line (0, y)-(imgmax_x, y), ak&
    Next y
    atmos& = _RGBA32(ar, ag, ab, aa)
End Function
Function horizon
    maxh = imgmax_y * .5
    hh = maxh + (Int(Rnd * 300) + 30)
    If hh > imgmax_y Then hh = maxh
    horizon = hh
End Function
Sub flatland (hr)
    'slap down the ground
    fr = Int(Rnd * 185)
    fg = Int(Rnd * 185)
    fb = Int(Rnd * 185)
    lk& = _RGB32(fr, fg, fb)
    kc = 0
    For y = hr To imgmax_y

        Line (0, y)-(imgmax_x, y), lk&
        If kc = 4 Then lk& = brighter&(lk&, 1.1)
        kc = kc + 1
        If kc > 4 Then kc = 0
    Next y
End Sub
Function craters (mx, my, mrd, mk&)
    ' put craters on those moons
    ' well mostly on the moons sometimes one walks off the edge, that'll get fixed eventually.
    crmax = mrd * .2
    numk = Int(Rnd * 24) + 12
    For k = 1 To numk
        crad = Int(Rnd * crmax) + 1
        cx = mx + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
        cy = my + Int(Rnd * crmax * 4) - Int(Rnd * crmax * 4)
        nk& = mk&
        orb cx, cy, crad, nk&, 1.9
    Next k
    craters = numk
End Function
Sub starfield
    ' generate goofy fuzzy stars
    maxstars = Int(Rnd * 6000) + 50
    starsize = Int(((Rnd * 3 + 1) + (Rnd * 3 + 1)) / 2)
    For s = 1 To maxstars
        bc = Int(Rnd * 100 + 155)
        sx = Int(Rnd * imgmax_x)
        sy = Int(Rnd * imgmax_y)
        bb = 0
        For sv = 1 To (starsize * starsize)
            PSet (sx + Int(Rnd * starsize) - (Rnd * starsize), sy - Int(Rnd * starsize) + Int(Rnd * starsize)), _RGB32(bc - Int(Rnd * 5), bc - Int(Rnd * 5), bc - Int(Rnd * 5))
        Next sv
    Next s
End Sub
Function brighter& (ch&&, p)
    'eventually going to replace this sub with a beter one
    r = _Red(ch&&)
    b = _Blue(ch&&)
    g = _Green(ch&&)
    If p < 0 Then p = 0
    If p > 100 Then p = 100
    p = p / 100
    rdif = 255 - r: rc = rdif * p: brr = Int(r + rc): If brr > 255 Then brr = 255
    gdif = 255 - g: gc = gdif * p: bgg = Int(g + gc): If bgg > 255 Then bgg = 255
    bdif = 255 - b: bc = bdif * p: bbb = Int(b + bc): If bbb > 255 Then bbb = 255
    brighter& = _RGB(brr, bgg, bbb)
End Function
Sub orb (XX As Long, YY As Long, Rd As Long, KK As Long, brt As Integer)
    'false shaded 3d spheres
    Dim nk As Long
    nk = KK
    ps = _Pi
    p3 = _Pi / 3
    p4 = _Pi / 4
    If Rd < 10 Then ps = _Pi / 6 'so small radius orbs look cool too
    rdc = p4 / Rd
    For c = 0 To Int(Rd * .87) Step ps
        nk = brighter&(nk, brt)
        CircleFill XX, YY, Rd - (c), nk
        XX = XX + rdc * (c * p3) ' could be fiddled with to move the center of the gradient
        YY = YY - rdc * (c * 2 * p4) ' could be fiddled with to move the center of the gradient
    Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
    'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
    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 moonfuzz (CX As Long, CY As Long, R As Long, C As Long, CHNC As Integer)
    'CX and CY are to plot of the circle center R is the radius, c is the primary color, CHNC is the chance for noise to vary from from primary color
    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
    'checking to see if we should use the base color or slap down some random noise
    For tx = CX - X To CX + X
        chance = Rnd * 100
        If chance < CHNC Then
            dotc = Int(Rnd * 256)
            PSet (tx, CY), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84)) 'drawing each point in the line because color can change from pixel to pixel
        Else
            ' dotc = C        let the color stay as drawn by orb
        End If
    Next tx
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                For tx = CX - Y To CX + Y
                    chance = Rnd * 100
                    If chance < CHNC Then
                        dotc = Int(Rnd * 256)
                        PSet (tx, CY - X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
                    Else
                        ' dotc = C   let the color stay as drawn by orb
                    End If
                Next tx
                For tx = CX - Y To CX + Y
                    chance = Rnd * 100
                    If chance < CHNC Then
                        dotc = Int(Rnd * 256)
                        PSet (tx, CY + X), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
                    Else
                        ' dotc = C     let the color stay as drawn by orb
                    End If
                Next tx
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        For tx = CX - X To CX + X
            chance = Rnd * 100
            If chance < CHNC Then
                dotc = Int(Rnd * 256)
                PSet (tx, CY - Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
            Else
                ' dotc = C   let the color stay as drawn by orb
            End If
        Next tx
        For tx = CX - X To CX + X
            chance = Rnd * 100
            If chance < CHNC Then
                dotc = Int(Rnd * 256)
                PSet (tx, CY + Y), _RGBA32(dotc, dotc, dotc, Int(Rnd * 84))
            Else
                'dotc = C        let the color stay as drawn by orb
            End If
        Next tx
    Wend
End Sub
Sub ectosky
    Dim tim&
    tim& = _NewImage(400, 300, 32)
    _Dest tim&
    sh = _Height
    sw = _Width
    Dim d, dv, vv
    d = 1
    dv = 1
    vv = 1
    ' replim = Int(Rnd * 12) + 1
    replim = 1
    nr = 0
    Do
        tm = Rnd * Timer(.001)
        dr = Int(Rnd * 255) + 1: dg = Int(Rnd * 255) + 1: db = Int(Rnd * 255) + 1
        w = w + 5 / 83
        wave1 = Rnd * 100
        wave2 = Rnd * 100
        wave3 = Rnd * 100
        wave4 = Rnd * 100
        If wave1 + wave2 < 100 Then w = w + 2 / 83
        If wave3 + wav4 > 180 Then w = w - 3 / 75
        If wave1 + wav4 < 40 Then w = w * .35
        For y = 0 To sh
            '_limit 1000
            For x = 0 To sw
                vl = Sin(distance(x + tm * w, y, 128, 128) / 8 + w)
                If wave1 < 85 Then vl = vl + Sin(distance(x, y, 64, 64) / 8)
                If wave2 < 80 Then vl = vl + Sin(distance(x, y + tm / 7, 192, 64) / 7)
                If wave3 < 75 Then vl = vl + Sin(distance(x, y, 192, 100) / 8)
                If wave4 < 60 Then vl = vl + Sin(distance(x, y, 45 + tm * w, 100) / 8)
                If wave4 < 30 And wave1 < 50 Then vl = vl + Sin(distance(x, y, 45 + tm * w, (100 + tm) * w) / 8)
                clr = 255 / (1.00001 * Abs(vl))
                r = .9 * Abs(clr - dr): g = .4 * Abs(clr - dg): b = .5 * Abs(clr - db)
                PSet (x, y), _RGB32(r, g, b)
            Next
        Next
        If w > 1440 Or w < -1440 Then w = 0: d = d * -1
        _Limit 6000
        nr = nr + 1
    Loop Until nr = replim 'genrating a still so we move through a few iterations for the ecto plasma
    _PutImage , tim&, MS&
    _Dest MS&
    _FreeImage tim&
End Sub
Function distance (x1, y1, x2, y2) '//between two points x1,y1 and x2,y2
    distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ (.5)
End Function