Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
alien skies
#11
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
Reply
#12
Trees Reflection
Here is an example of water reflection and trees too for that matter. I hope it helps add to this wonderful project. I have to give it a thumbs up because you got me pulling out old old code and translating it to QB64!

Code: (Select All)
_Title "Trees Reflection" 'b+ trans from SB 2022-05-06
Rem trees reflection.bas 2016-02-22 SmallBASIC 0.12.2 [B+=MGA]
'lakeshore demo repurposed with new and improved trees reflected in lake

Const xmax = 1024, ymax = 600

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 80 ' clear sides
Dim Shared As _Unsigned Long qb(15)
qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

For i = 0 To ymax
    Line (0, i)-(xmax, i), _RGB32(70, 60, i / ymax * 160)
Next
stars = xmax * ymax * 10 ^ -4
horizon = .67 * ymax
For i = 1 To stars 'stars in sky
    PSet (Rnd * xmax, Rnd * horizon), qb(11)
Next
stars = stars / 2
For i = 1 To stars
    fcirc Rnd * xmax, Rnd * horizon, 1, qb(11)
Next
stars = stars / 2
For i = 1 To stars
    fcirc Rnd * xmax, Rnd * horizon, 2, qb(11)
Next
For i = .67 * ymax To .8 * ymax
    gc = max(0, 100 - (i - .67 * ymax) * .5)
    Line (0, i)-(xmax, i), _RGB32(gc, gc, gc)
Next
branch xmax * .6 + Rnd * .3 * xmax, ymax * .75 - .07 * ymax, 6, 90, xmax / 20, 0
branch Rnd * .3 * xmax, ymax * .75 - .05 * ymax, 7, 90, xmax / 18, 0
branch xmax / 2, ymax * .77, 8, 90, xmax / 16, 0
Line (0, .8 * ymax)-(xmax, .8 * ymax + 1), _RGB32(70, 70, 70), BF
For y = .8 * ymax To ymax
    For x = 0 To xmax
        yy = .8 * ymax - (y - .8 * ymax) * 4
        PSet (x, y), Point(x, yy)
    Next
Next
_Display

'code from lakeshore make waves in tree reflection??
' This image size: 1,1-400,270
' Water area: 1,190 - 400,270  that means wh=270-190=80 ww=400-1=399
'now water area is .8*ymax to ymax by 0 to xmax
wh = Int(.2 * ymax): ww = xmax
Dim t1(.25 * ymax + 3, xmax + 2) As _Unsigned Long ' store water area > t1(), make it slighly bigger
For ii = .8 * ymax To ymax
    For iii = 0 To xmax
        t1(ii - Int(.8 * ymax), iii) = Point(iii, ii)
    Next
Next

' *** Let's wave it ***
waveit:
mo = 3 '  height of strip, bigger > waves, smaller > flickering
If bb < mo Then bb = wh - 3
colp = (colp + 1) Mod 4 'need to random place for to create clickering
aa = 0
For aa1 = 1 To (mo - 1)
    aa = bb - aa1 + Int(.8 * ymax) - 1
    For aaa = 0 To xmax
        PSet (aaa, aa), t1(aa + colp - .8 * ymax, aaa)
        PSet (aaa, aa + 1), t1(aa + colp - Int(.8 * ymax), aaa)
        PSet (aaa, aa + 2), t1(aa + colp - Int(.8 * ymax), aaa)
    Next
Next
bb = bb - (mo + 1) ' next strip place
_Display
_Limit 5
If _KeyDown(27) Then End
GoTo waveit

Sub branch (x, y, startr, angD, lngth, lev)
    ' local x2,y2,dx,dy,bc,i
    Dim bc As _Unsigned Long
    x2 = x + Cos(_D2R(angD)) * lngth
    y2 = y - Sin(_D2R(angD)) * lngth
    dx = (x2 - x) / lngth
    dy = (y2 - y) / lngth
    bc = _RGB32(10 + lev, 15 + lev, 10)
    For i = 0 To lngth
        fcirc x + dx * i, y + dy * i, startr, bc
    Next
    If startr - 1 < 0 Or lev > 11 Or lngth < 5 Then Exit Sub
    lev2 = lev + 1
    branch x2, y2, startr - 1, angD + 10 + 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2
    branch x2, y2, startr - 1, angD - 10 - 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2
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

Function max (x, y)
    If x > y Then max = x Else max = y
End Function

For water reflection pick horizon line across screen, measure from it to top and from it to bottom and scale (fit) the sky into the bottom water section in height (width is 1 to 1). Map!( ) function might be useful. 
Oh heck might try a _PutImage of the sky flipped upside down and crammed into the water section, all I've done is a lakeside view across the whole width but puddles could be made by drawing ground to cover reflected points where you don't want to see them.

The trees have branch widths indirectly proportional to level from trunk. 
   

Oops having trouble with waves BRB
OK hacked a fix, it's been years since I looked at this code.
b = b + ...
Reply
#13
I tested the _Putimage idea for reflection here: https://qb64phoenix.com/forum/showthread.php?tid=369
b = b + ...
Reply
#14
Well, I definitely had fun with the trees.

[Image: image.png]
Reply
#15
LOL yeah that's starting to look alien!

Oh ha! another place to try plasma color sequencing! Oh boy!

Code: (Select All)
_Title "Alien Trees Reflection - Plasma Mod" 'b+ trans from SB 2022-05-06
Rem trees reflection.bas 2016-02-22 SmallBASIC 0.12.2 [B+=MGA]
'lakeshore demo repurposed with new and improved trees reflected in lake
Randomize Timer
Const xmax = 1024, ymax = 600

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 80 ' clear sides
Dim Shared As _Unsigned Long qb(15)
Dim Shared pR, pG, pB, cN, dcN

qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

restart:
For i = 0 To ymax
    Line (0, i)-(xmax, i), _RGB32(70, 60, i / ymax * 160)
Next
stars = xmax * ymax * 10 ^ -4
horizon = .67 * ymax
For i = 1 To stars 'stars in sky
    PSet (Rnd * xmax, Rnd * horizon), qb(11)
Next
stars = stars / 2
For i = 1 To stars
    fcirc Rnd * xmax, Rnd * horizon, 1, qb(11)
Next
stars = stars / 2
For i = 1 To stars
    fcirc Rnd * xmax, Rnd * horizon, 2, qb(11)
Next
For i = .67 * ymax To .8 * ymax
    gc = max(0, 100 - (i - .67 * ymax) * .5)
    Line (0, i)-(xmax, i), _RGB32(gc, gc, gc)
Next
resetPlasma
branch xmax * .6 + Rnd * .3 * xmax, ymax * .75 - .07 * ymax, 6, 90, xmax / 20, 0
resetPlasma
branch Rnd * .3 * xmax, ymax * .75 - .05 * ymax, 7, 90, xmax / 18, 0
resetPlasma
branch xmax / 2, ymax * .77, 8, 90, xmax / 16, 0

Line (0, .8 * ymax)-(xmax, .8 * ymax + 1), _RGB32(70, 70, 70), BF
For y = .8 * ymax To ymax
    For x = 0 To xmax
        yy = .8 * ymax - (y - .8 * ymax) * 4
        PSet (x, y), Point(x, yy)
    Next
Next
_Display

'code from lakeshore make waves in tree reflection??
' This image size: 1,1-400,270
' Water area: 1,190 - 400,270  that means wh=270-190=80 ww=400-1=399
'now water area is .8*ymax to ymax by 0 to xmax
wh = Int(.2 * ymax): ww = xmax
ReDim t1(.25 * ymax + 3, xmax + 2) As _Unsigned Long ' store water area > t1(), make it slighly bigger
For ii = .8 * ymax To ymax
    For iii = 0 To xmax
        t1(ii - Int(.8 * ymax), iii) = Point(iii, ii)
    Next
Next

' *** Let's wave it ***
waveit:
mo = 3 '  height of strip, bigger > waves, smaller > flickering
If bb < mo Then bb = wh - 3
colp = (colp + 1) Mod 4 'need to random place for to create clickering
aa = 0
For aa1 = 1 To (mo - 1)
    aa = bb - aa1 + Int(.8 * ymax) - 1
    For aaa = 0 To xmax
        PSet (aaa, aa), t1(aa + colp - .8 * ymax, aaa)
        PSet (aaa, aa + 1), t1(aa + colp - Int(.8 * ymax), aaa)
        PSet (aaa, aa + 2), t1(aa + colp - Int(.8 * ymax), aaa)
    Next
Next
bb = bb - (mo + 1) ' next strip place
_Display
_Limit 5
If _KeyDown(32) Then GoTo restart
If _KeyDown(27) Then End
GoTo waveit

Sub branch (x, y, startr, angD, lngth, lev)
    ' local x2,y2,dx,dy,bc,i
    Dim bc As _Unsigned Long
    x2 = x + Cos(_D2R(angD)) * lngth
    y2 = y - Sin(_D2R(angD)) * lngth
    dx = (x2 - x) / lngth
    dy = (y2 - y) / lngth
    'bc = _RGB32(10 + lev, 15 + lev, 10)
    For i = 0 To lngth
        fcirc x + dx * i, y + dy * i, startr, changePlasma~&
    Next
    If startr - 1 < 0 Or lev > 11 Or lngth < 5 Then Exit Sub
    lev2 = lev + 1
    branch x2, y2, startr - 1, angD + 10 + 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2
    branch x2, y2, startr - 1, angD - 10 - 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2
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

Function max (x, y)
    If x > y Then max = x Else max = y
End Function

Function changePlasma~& ()
    cN = cN + dcN 'dim shared cN as _Integer64, pR as long, pG as long, pB as long
    changePlasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function

Sub resetPlasma ()
    pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: dcN = Rnd
End Sub

   
b = b + ...
Reply
#16
I have animated the above still shot and used _PutImage for reflecting the animation every 1/30th of a sec. see bplus Proggies thread.
b = b + ...
Reply
#17
Fiddled with water more. Trying to get the fluid to look like it's not always water but still provide a reflection of the sky. Still far from perfect. I'm getting a true reflection now (positionally) but due to how the routines are setup I'm not getting mountains to work just yet.  ( have to move things about a tad probably pull the ocean code out of where it is in rendering order).

Code: (Select All)
' alienskies   0.3c
' By James D. Jarvis
' also includes other folks fine code  found here https://qb64phoenix.com/forum/index.php
' fun little image generating program
'
'press q to quit, any other 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 = 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)
    wk& = _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
    rcount = 0
    For w = otop To imgmax_y
        For xx = wx(w, 1) To wx(w, 2)
            tk& = Point(xx, otop - rcount)

            ttr = _Red32(tk&)
            ttg = _Green32(tk&)
            ttb = _Blue32(tk&)
            tta = Int(Rnd * 10) + 243
            tk& = _RGBA32(ttr, ttg, ttb, tta)
            '  If Rnd * 4 < 5 Then 'chnage to get noise
            PSet (xx, w), tk&
            ' Else
            '     PSet (xx + Int(Rnd * 2) - Int(Rnd * 2), w), tk&
            '  End If
        Next xx
        rcount = rcount + 1
    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
    rcount = 0
    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))
            tk& = Point(xx, otop - rcount)
            ttr = _Red32(tk&)
            ttg = _Green32(tk&)
            ttb = _Blue32(tk&)
            'tta = Int(Rnd * 50) + 25
            tta = Int(Rnd * 5) + 200
            tk2& = _RGBA32(ttr, ttg, ttb, tta)
            '  tk2& = _RGBA32(ttr * 1.5, ttg * 1.5, ttb * 1.5, tta)
            PSet (xx, w), tk2&
        Next xx
        rcount = rcount + 1
    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 * 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
Reply
#18
not a whole re-write yet but a change to the moon generating code that I haven't shoved into place yet.

Code: (Select All)
'a better moon 2
'going to be doing a rewrite of alienskies
'here's a slightly more interestign moon
'press Q to quit
' this is just a piece of  larger program so it's got a few biases that don't make sense in a solor demo
Dim Shared imgmax_x, imgmax_y, MS&, cp&
Dim Shared nopaint As _Unsigned Long
imgmax_x = 800
imgmax_y = 600
Randomize Timer
MS& = _NewImage(imgmax_x, imgmax_y, 32)
cp& = _NewImage(imgmax_x, imgmax_y, 32)
Screen MS&
nopaint = Point(1, 1)
Do
    Cls
    _Limit 1
    bettermoon
    _Display
    A$ = InKey$

Loop Until A$ = "q"
Sub bettermoon
    mx = 200 + Int(Rnd * 200)
    my = 150 + Int(Rnd * 150)
    ' mx = Int(Rnd * (imgmax_x / 2)) + (imgmax_x / 4)
    ' my = Int(Rnd * (imgmax_y / 2)) + (imgmax_x / 4)
    mc = Int(Rnd * 100) + 1: mm = Int(Rnd * 100) + 1: my = Int(Rnd * 100) + 1: mk = Int(Rnd * 100) + 1:
    mklr& = cmyk~&(mc, mm, my, mk)
    ' moonsize = Int(((Rnd * 200) + (Rnd * 200)) / 2)
    moonsize = Int(((Rnd * 200) + 50 + (Rnd * 200) + 50) / 2)
    orb mx, my, moonsize, mklr&, 1.8
    _Dest cp&
    orb mx, my, moonsize, mklr&, 1.8
    _Dest MS&
    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)
    moonshadow mx, my, moonsize, mklr&
End Sub
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
        lighten_cmyk 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 ACircleFill (CX As Long, CY As Long, R As Long, C As _Unsigned 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
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
Function craters (mx, my, mrd, mk&)
    ' put craters on those moons
    crmax = mrd * .24
    numk = Int(Rnd * 24) + 12
    _Dest cp&
    'Line (0, 0)-(img_maxx - 1, img_maxy - 1), _RGB32(0, 0, 0) ' <---- why isn't this overwritng the old image on cp&
    For k = 1 To numk
        crad = Int(Rnd * crmax) + 1
        cgominx = mx - mrd + crad: cgomax = mx + mrd - crad
        cgominy = my - mrd + crad: cgomay = my + mrd - crad
        cx = Int(Rnd * (cgomax - cgominx)) + cgominx + 1
        cy = Int(Rnd * (cgomay - cgominy)) + cgominy + 1
        nk& = mk&
        orb cx, cy, crad, nk&, 1.9

    Next k
    _Dest MS&
    cratercopy mx, my, mrd
    _Dest cp&
    Cls
    _Source MS&
    _Dest MS&

    craters = numk
End Function


Sub cratercopy (CX As Long, CY As Long, R As Long)
    '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
    _Source cp&
    _Dest MS&
    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
        dotc& = Point(tx, CY)
        If dotc& <> nopaint Then PSet (tx, CY), dotc& 'drawing each point in the line because color can change from pixel to pixel
    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
                    dotc& = Point(tx, CY - X)
                    If dotc& <> nopaint Then PSet (tx, CY - X), dotc&
                Next tx
                For tx = CX - Y To CX + Y
                    dotc& = Point(tx, CY + X)
                    If dotc& <> nopaint Then PSet (tx, CY + X), dotc&
                Next tx
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        For tx = CX - X To CX + X
            dotc& = Point(tx, CY - Y)
            If dotc& <> nopaint Then PSet (tx, CY - Y), dotc&
        Next tx
        For tx = CX - X To CX + X
            dotc& = Point(tx, CY + Y)
            If dotc& <> nopaint Then PSet (tx, CY + Y), dotc&
        Next tx
    Wend
    _Dest cp&
    _Dest MS&
End Sub




Sub moonshadow (mx, my, moonsize, mklr&)
    nm = moonsize + Int(Rnd * 30) - (Rnd * 30)
    moffx = mx + Int(Rnd * nm) - Int(Rnd * nm)
    moffy = my + Int(Rnd * nm) - Int(Rnd * nm)
    ACircleFill moffx, moffy, nm, _RGB32(0, 0, 0, 100)
    ACircleFill moffx, moffy, (nm * .98), _RGB32(0, 0, 0, 150)
    CircleFill moffx, moffy, (nm * .95), _RGB32(0, 0, 0, 254)
End Sub
Function cmyk~& (c As Long, m As Long, y As Long, k As Long)
    ' CMYK process color Cyan, Magenta, Yellow, Black  each  expressed as a percent from 0 to 100
    r = 255 * (100 - c)
    r = (r / 100) * ((100 - k) / 100)
    g = 255 * (100 - m)
    g = (g / 100) * ((100 - k) / 100)
    b = 255 * (100 - y)
    b = (b / 100) * ((100 - k) / 100)
    cmyk~& = _RGB32(r, g, b)
End Function

Function get_c (klr As _Unsigned Long)
    r = _Red32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    get_c = c
End Function
Function get_m (klr As _Unsigned Long)
    g = _Green32(klr)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    get_m = m
End Function
Function get_y (klr As _Unsigned Long)
    b = _Blue32(klr)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    get_y = y
End Function
Function get_k (klr As _Unsigned Long)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
    Else
        k = 0
    End If
    get_k = k
End Function

Sub get_cmyk (klr As _Unsigned Long, c, m, y, k)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
End Sub
Sub lighten_cmyk (klr As _Unsigned Long, pp)
    'lightens all four CMYK color channels by the same relative %
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
    c = c * ((100 - pp) / 100)
    m = m * ((100 - pp) / 100)
    y = y * ((100 - pp) / 100)
    k = k * ((100 - pp) / 100)
    klr = cmyk~&(c, m, y, k)
End Sub
Sub darken_cmyk (klr As _Unsigned Long, pp)
    'lightens all four CMYK color channels by the same relative %
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
    c = c * ((100 + pp) / 100): If c > 100 Then c = 100
    m = m * ((100 + pp) / 100): If m > 100 Then m = 100
    y = y * ((100 + pp) / 100): If y > 100 Then y = 100
    k = k * ((100 + pp) / 100): If k > 100 Then k = 100
    klr = cmyk~&(c, m, y, k)
End Sub
Sub add_cyan (klr As _Unsigned Long, cc)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100) + cc
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
    If c > 100 Then c = 100
    If c < 0 Then c = 0
    klr = cmyk~&(c, m, y, k)
End Sub
Sub add_magenta (klr As _Unsigned Long, mm)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100) + mm
    y = Int((1 + 1 / 255 - (b / 255)) * 100)
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
    If m > 100 Then m = 100
    If m < 0 Then m = 0
    klr = cmyk~&(c, m, y, k)
End Sub
Sub add_yellow (klr As _Unsigned Long, yy)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100) + yy
    If c = m And m = y Then
        k = m
        m = 0
        y = 0
        c = 0
    Else
        k = 0
    End If
    If y > 100 Then y = 100
    If y < 0 Then y = 0
    klr = cmyk~&(c, m, y, k)
End Sub

Sub add_black (klr As _Unsigned Long, kk)
    r = _Red32(klr)
    g = _Green32(klr)
    b = _Blue32(klr)
    c = Int((1 + 1 / 255 - (r / 255)) * 100)
    m = Int((1 + 1 / 255 - (g / 255)) * 100)
    y = Int((1 + 1 / 255 - (b / 255)) * 100) + yy
    If c = m And m = y Then
        k = m + kk
        m = 0
        y = 0
        c = 0
    Else
        k = 0 + kk
    End If
    If k > 100 Then k = 100
    If k < 0 Then k = 0
    klr = cmyk~&(c, m, y, k)
End Sub
Function mix_cmyk~& (klr1 As _Unsigned Long, klr2 As _Unsigned Long)
    'evenly mix two colors
    r1 = _Red32(klr1)
    g1 = _Green32(klr1)
    b1 = _Blue32(klr1)
    c1 = Int((1 + 1 / 255 - (r1 / 255)) * 100)
    m1 = Int((1 + 1 / 255 - (g1 / 255)) * 100)
    y1 = Int((1 + 1 / 255 - (b1 / 255)) * 100)
    If c1 = m1 And m1 = y1 Then
        k1 = m1
        m1 = 0
        y1 = 0
        c1 = 0
    Else
        k1 = 0
    End If
    r2 = _Red32(klr2)
    g2 = _Green32(klr2)
    b2 = _Blue32(klr2)
    c2 = Int((1 + 1 / 255 - (r2 / 255)) * 100)
    m2 = Int((1 + 1 / 255 - (g2 / 255)) * 100)
    y2 = Int((1 + 1 / 255 - (b2 / 255)) * 100)
    If c2 = m2 And m2 = y2 Then
        k2 = m2
        m2 = 0
        y2 = 0
        c2 = 0
    Else
        k2 = 0
    End If
    c = Int((c1 + c2) / 2)
    m = Int((m1 + m2) / 2)
    y = Int((y1 + y2) / 2)
    k = Int((k1 + k2) / 2)
    mix_cmyk~& = cmyk~&(c, m, y, k)
End Function
Function add_cmyk~& (klr1 As _Unsigned Long, klr2 As _Unsigned Long)
    'add channels in each color   max vlaue wil be 100 per channel
    r1 = _Red32(klr1)
    g1 = _Green32(klr1)
    b1 = _Blue32(klr1)
    c1 = Int((1 + 1 / 255 - (r1 / 255)) * 100)
    m1 = Int((1 + 1 / 255 - (g1 / 255)) * 100)
    y1 = Int((1 + 1 / 255 - (b1 / 255)) * 100)
    If c1 = m1 And m1 = y1 Then
        k1 = m1
        m1 = 0
        y1 = 0
        c1 = 0
    Else
        k1 = 0
    End If
    r2 = _Red32(klr2)
    g2 = _Green32(klr2)
    b2 = _Blue32(klr2)
    c2 = Int((1 + 1 / 255 - (r2 / 255)) * 100)
    m2 = Int((1 + 1 / 255 - (g2 / 255)) * 100)
    y2 = Int((1 + 1 / 255 - (b2 / 255)) * 100)
    If c2 = m2 And m2 = y2 Then
        k2 = m2
        m2 = 0
        y2 = 0
        c2 = 0
    Else
        k2 = 0
    End If
    c = c1 + c2: If c > 100 Then c = 100
    m = m1 + m2: If m > 100 Then m = 100
    y = y1 + y2: If y > 100 Then y = 100
    k = k1 + k2: If k > 100 Then k = 100
    add_cmyk~& = cmyk~&(c, m, y, k)
End Function
Reply




Users browsing this thread: 1 Guest(s)