QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Works in Progress v
alien skies

Threaded Mode
alien skies
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#1
05-05-2022, 01:11 PM (This post was last modified: 05-05-2022, 01:12 PM by James D Jarvis.)
Alien Skies is based off recollection of code from a book I read 25-30 years ago.  I've made use of some code from the fine contributors in this forum.
to add: rocks, sky beams, oceans, flora

Code: (Select All)
' alienskies
' By James D. Jarvis
' also includes other folks fine code  found here https://staging.qb64phoenix.com/index.php
' fun little image genreating program
'
'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&
Print "Some images can take a couple seconds to generate"
Do
    'Cls
    ectocheck = Int(Rnd * 100)
    If ectocheck < 30 Then ectosky
    starfield
    moons
    acheck = Int(Rnd * 100)
    If acheck < 60 Then atm& = atmos
    hrz = horizon
    flatland hrz
    gk& = Point(1, hrz)
    mcheck = Int(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&)
            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
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 * 10 + 244)
        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 * (1 - bb), bc * (1 - bb), bc * (1 - bb))
            bb = bb + .1
        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
    nr = 0
    Do
        tm = Timer(.001)
        dr = Int(Rnd * 255) + 1: dg = Int(Rnd * 255) + 1: db = Int(Rnd * 255) + 1
        w = w + 5 / 83
        For y = 0 To sh
            '_limit 1000
            For x = 0 To sw
                vl = Sin(distance(x + tm * w, y, 128, 128) / 8 + w)
                vl = vl + Sin(distance(x, y, 64, 64) / 8)
                vl = vl + Sin(distance(x, y + tm / 7, 192, 64) / 7)
                vl = vl + Sin(distance(x, y, 192, 100) / 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
Find
Reply
johnno56 Offline
Member
***
Posts: 144
Threads: 10
Joined: Apr 2022
Reputation: 5
#2
05-05-2022, 01:23 PM
Very cool... Ah yes. The 'plasma' skies took a little time but was worth the wait... Nicely done indeed!
May your journey be free of incident. Live long and prosper.
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#3
05-05-2022, 01:45 PM
(05-05-2022, 01:23 PM)johnno56 Wrote: Very cool... Ah yes. The 'plasma' skies took a little time but was worth the wait... Nicely done indeed!

I've been loving the plasma explorations thread, it couldn't have been posted at a better time. This ectoplasma sub bogs down because it has to run a few iterations to get different patterns as it is setup currently. Some of the other plasma may be quicker I just haven't had time to mess about with them yet.
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#4
05-05-2022, 02:20 PM
of course, just minutes after my last post i realized how I could speed up the ectoplasma sky generation and have it look different enough from image to image (for now).

Code: (Select All)
' alienskies   0.2
' By James D. Jarvis
' also includes other folks fine code  found here https://staging.qb64phoenix.com/index.php
' fun little image genreating program
'
'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&
Print "Some images can take a couple seconds to generate"
Do
    'Cls
    ectocheck = Int(Rnd * 100)
    If ectocheck < 30 Then ectosky
    starfield
    moons
    acheck = Int(Rnd * 100)
    If acheck < 60 Then atm& = atmos
    hrz = horizon
    flatland hrz
    gk& = Point(1, hrz)
    mcheck = Int(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&)
            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
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 * 10 + 244)
        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 * (1 - bb), bc * (1 - bb), bc * (1 - bb))
            bb = bb + .1
        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
Find
Reply
Dav Offline
Mini-Mod
***
Posts: 300
Threads: 57
Joined: Apr 2022
Reputation: 56
#5
05-05-2022, 03:12 PM (This post was last modified: 05-05-2022, 03:14 PM by Dav.)
That's pretty neat, @James D Jarvis.  Generates real fast for me on my slow laptop.  The moons look especially realistic.

- Dav
Find my programs here in Dav's QB64 Corner
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#6
05-05-2022, 03:52 PM
(05-05-2022, 03:12 PM)Dav Wrote: That's pretty neat, @James D Jarvis.  Generates real fast for me on my slow laptop.  The moons look especially realistic.

- Dav

Thank you. The craters jump off a moon every now and again, pretty sure I know what needs to be fixed there just haven't gotten back to it yet. The noise makes it. I have a few featureless moons getting generated as well because eventually I'll get cloud bands in some of them.
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation: 134
#7
05-05-2022, 04:00 PM
Oh this is really cool shot!
[Image: image-2022-05-05-120002840.png]
b = b + ...
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#8
05-05-2022, 04:59 PM
(05-05-2022, 04:00 PM)bplus Wrote: Oh this is really cool shot!
[Image: image-2022-05-05-120002840.png]

Glad you like it. I'm trying to do reflective bodies of liquid now.  Haven't gotten it good enough just yet.

[Image: image.png]
Find
Reply
johnno56 Offline
Member
***
Posts: 144
Threads: 10
Joined: Apr 2022
Reputation: 5
#9
05-05-2022, 07:54 PM
Really cool... Much quicker on the 'plasma' images... Suggestion: Perhaps fewer stars and maybe 3 or 4 levels of brightness.
May your journey be free of incident. Live long and prosper.
Find
Reply
James D Jarvis Offline
Senior Member
****
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation: 39
#10
05-05-2022, 09:31 PM
(05-05-2022, 07:54 PM)johnno56 Wrote: Really cool... Much quicker on the 'plasma' images... Suggestion: Perhaps fewer stars and maybe 3 or 4 levels of brightness.

There actually is a few levels of brightness but probably just for the blobby stars. Definitely a good idea for a fix, thanks.
Find
Reply




Users browsing this thread: 1 Guest(s)