Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
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
Posts: 3,986
Threads: 178
Joined: Apr 2022
Reputation:
222
05-06-2022, 06:12 PM
(This post was last modified: 05-06-2022, 06:38 PM by bplus.)
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 + ...
Posts: 3,986
Threads: 178
Joined: Apr 2022
Reputation:
222
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Well, I definitely had fun with the trees.
![[Image: image.png]](https://i.ibb.co/LPVzkpX/image.png)
Posts: 3,986
Threads: 178
Joined: Apr 2022
Reputation:
222
05-07-2022, 05:09 PM
(This post was last modified: 05-07-2022, 06:33 PM by bplus.)
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 + ...
Posts: 3,986
Threads: 178
Joined: Apr 2022
Reputation:
222
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 + ...
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
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
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
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
|
