| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
As technology rapidly evo...
Forum: Utilities
Last Post: Frankvab
06-15-2025, 06:09 AM
» Replies: 14
» Views: 165
|
Everybody's heard about t...
Forum: Utilities
Last Post: Frankvab
06-15-2025, 06:07 AM
» Replies: 22
» Views: 1,366
|
MBA Assignment Help in Du...
Forum: General Discussion
Last Post: hafsahomar
06-11-2025, 07:05 AM
» Replies: 0
» Views: 22
|
лучшие песни медляки слуш...
Forum: Petr
Last Post: WillieTop
06-08-2025, 02:21 AM
» Replies: 0
» Views: 30
|
пинк слушать онлайн беспл...
Forum: SMcNeill
Last Post: WillieTop
06-08-2025, 02:20 AM
» Replies: 0
» Views: 24
|
скачать музыку российскую...
Forum: madscijr
Last Post: WillieTop
06-08-2025, 02:18 AM
» Replies: 0
» Views: 25
|
нежная музыка mp3 скачать
Forum: Keybone
Last Post: WillieTop
06-08-2025, 02:17 AM
» Replies: 0
» Views: 26
|
лучшая песня слушать онла...
Forum: bplus
Last Post: WillieTop
06-08-2025, 02:16 AM
» Replies: 0
» Views: 30
|
пикник слушать онлайн луч...
Forum: Spriggsy
Last Post: WillieTop
06-08-2025, 02:15 AM
» Replies: 0
» Views: 25
|
какая сейчас популярная м...
Forum: RhoSigma
Last Post: WillieTop
06-08-2025, 02:14 AM
» Replies: 0
» Views: 20
|
|
|
| Long Date Function |
|
Posted by: AtomicSlaughter - 05-21-2022, 09:20 PM - Forum: Utilities
- Replies (2)
|
 |
Code: (Select All) Function lDate$
p$ = "th"
If Val(Mid$(Date$, 4, 2)) <= 9 Then
day$ = Right$(Mid$(Date$, 4, 2), 1)
Else
day$ = Mid$(Date$, 4, 2)
End If
If Val(Mid$(Date$, 4, 2)) = 1 Or Val(Mid$(Date$, 4, 2)) = 21 Or Val(Mid$(Date$, 4, 2)) = 31 Then p$ = "st"
If Val(Mid$(Date$, 4, 2)) = 2 Or Val(Mid$(Date$, 4, 2)) = 22 Then p$ = "nd"
If Val(Mid$(Date$, 4, 2)) = 3 Or Val(Mid$(Date$, 4, 2)) = 23 Then p$ = "rd"
Select Case Val(Mid$(Date$, 1, 2))
Case 1: Month$ = "January"
Case 2: Month$ = "February"
Case 3: Month$ = "March"
Case 4: Month$ = "April"
Case 5: Month$ = "May"
Case 6: Month$ = "June"
Case 7: Month$ = "July"
Case 8: Month$ = "August"
Case 9: Month$ = "September"
Case 10: Month$ = "October"
Case 11: Month$ = "November"
Case 12: Month$ = "December"
End Select
lDate = day$ + p$ + " " + Month$ + " " + Mid$(Date$, 7, 4)
End Function
|
|
|
| What do you like to use for adding commas to numerical output? |
|
Posted by: Pete - 05-21-2022, 08:55 PM - Forum: General Discussion
- Replies (1)
|
 |
I've never used PRINT USING in my programs, so I usually code something like this demo...
Code: (Select All) DIM a AS _INTEGER64
DO
INPUT a
a$ = LTRIM$(STR$(ABS(a)))
j = LEN(a$) MOD 3: IF j = 0 THEN j = 3
DO UNTIL j >= LEN(a$)
a$ = MID$(a$, 1, j) + "," + MID$(a$, j + 1)
j = j + 4
LOOP
IF a < 0 THEN a$ = "-" + a$
PRINT a$ ' Output with commas.
LOOP
Pete
|
|
|
|
| INIEditor |
|
Posted by: AtomicSlaughter - 05-21-2022, 08:40 PM - Forum: Utilities
- No Replies
|
|
Code: (Select All) Type Sections
lineNum As Integer
section As String
End Type
Sub LoadINIFile (FileName As String, iniData() As String, iniSections() As Sections)
ReDim As String iniData(0)
ReDim As Sections iniSections(0)
If _FileExists(FileName) Then
file = FreeFile
Open FileName For Binary As #file
If LOF(file) = 0 Then Exit Sub
Do
Line Input #file, iniData(UBound(iniData))
If InStr(iniData(UBound(iniData)), "[") > 0 Then
iniSections(UBound(iniSections)).section = iniData(UBound(iniData))
iniSections(UBound(iniSections)).lineNum = x
ReDim _Preserve As Sections iniSections(UBound(iniSections) + 1)
End If
ReDim _Preserve iniData(UBound(iniData) + 1)
x = x + 1
Loop Until EOF(file)
Close
End If
iniSections(UBound(iniSections)).section = "End of File"
iniSections(UBound(iniSections)).lineNum = x
End Sub
Sub CheckSection (sec() As Sections, check As String, out1 As Single, out2 As Single, Ret As String)
For i = 0 To UBound(sec)
If LCase$(sec(i).section) = "[" + LCase$(check) + "]" Then
out1 = sec(i).lineNum + 1
out2 = sec(i + 1).lineNum - 1
Print out1, out2
Exit Sub
End If
Next
Ret = "New Section"
End Sub
Function ReadINI$ (FileName As String, Section As String, INIKey As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
If Section <> "" Then
CheckSection sec(), Section, start, finish, ret$
For i = start To finish
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReadINI = Right$(ini(i), (Len(ini(i)) - InStr(ini(i), "=")))
End If
Next
Else
Do
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReadINI = Right$(ini(i), (Len(ini(i)) - InStr(ini(i), "=")))
End If
i = i + 1
Loop Until ini(i) = ""
End If
End Function
Sub DelINI (FileName As String, Section As String, INIKey As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
If Section <> "" Then
CheckSection sec(), Section, start, finish, ret$
For i = start To finish
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReDim temp(UBound(ini) - 1) As String
For a = 0 To (i - 1)
temp(a) = ini(a)
Next
For a = i To UBound(temp)
temp(a) = ini(a + 1)
Next
End If
Next
Else
Do
If Left$(LCase$(ini(i)), InStr(ini(i), "=") - 1) = LCase$(INIKey) Then
ReDim temp(UBound(ini) - 1) As String
For a = 0 To i - 1
temp(a) = ini(a)
Next
For a = x To UBound(ini)
temp(x) = ini(x + 1)
Next
End If
i = i + 1
Loop Until ini(i) = ""
End If
Do
If temp(UBound(temp)) = "" Then ReDim _Preserve temp(UBound(temp) - 1)
Loop Until temp(UBound(temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(temp)
Print #f, temp(i)
Next
Close
End Sub
Sub DelSec (FileName As String, Section As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
CheckSection sec(), Section, start, finish, ret$
Print start, finish
ReDim Temp(UBound(ini)) As String
For i = 0 To start
Temp(i) = ini(i)
Next
For i = finish To UBound(ini)
Temp(i - finish) = ini(i)
Next
Do
If Temp(UBound(Temp)) = "" Then ReDim _Preserve Temp(UBound(Temp) - 1)
Loop Until Temp(UBound(Temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(Temp)
Print #f, Temp(i)
Next
Close
End Sub
Sub AddINI (FileName As String, Section As String, INIKey As String, INIData As String)
Dim sec(0) As Sections: Dim ini(0) As String
Dim As Single start, finish
LoadINIFile "Config.ini", ini(), sec()
CheckSection sec(), Section, start, finish, ret$
ReDim temp(UBound(ini) + 1) As String
If ret$ = "New Section" Then
ReDim temp(UBound(ini) + 3)
temp(0) = "[" + Section + "]"
temp(1) = INIKey + "=" + INIData
temp(2) = ""
For i = 3 To UBound(ini)
temp(i) = ini(i - 3)
Next
Else
If Section <> "" Then
For i = 0 To start
'Print ini(start): Sleep
temp(i) = ini(i)
Next
temp(start) = INIKey + "=" + INIData
For i = start + 1 To UBound(ini)
temp(i) = ini(i - 1)
Next
Else
temp(0) = INIKey + "=" + INIData
For i = 1 To UBound(ini)
temp(i) = ini(i - 1)
Next
End If
End If
Do
If temp(UBound(temp)) = "" Then ReDim _Preserve temp(UBound(temp) - 1)
Loop Until temp(UBound(temp)) <> ""
f = FreeFile
Open FileName For Output As #f
For i = 0 To UBound(temp)
Print #f, temp(i)
'Print temp(i): _Delay 1
Next
Close
End Sub
|
|
|
|
| Adding more Logical Operators |
|
Posted by: Dimster - 05-21-2022, 08:05 PM - Forum: General Discussion
- Replies (15)
|
 |
Would it be difficult to add more logical operators to the QB64 language?
I often come across math formulas which use some hieroglyics that I'm constantly looking us to decipher. When it comes to logical operators I see them so often I sometimes wonder if they may be useful in QB64. For example, a couple of them are:
V means the logical OR, so it would be "A V B" v's "A OR B". The inverted V means AND
A pyramid of dots . means "THEREFORE", so "HM = M and S = M . S = HM"
. . . .
(sorry, my depiction of a pyramid of dots leaves a lot to be desired)
And the inverse of the pyramid of dots means "Because" or "Since"
There are more, like << which means "much less than" and >> meaning "much more than" but I find personally I don't need those very much. The V and inverted V (or rotated 180 degree V) are just a short form of OR and AND so perhaps not as revolutionary for QB64, but the pyramid of dots may help with using the logical operator of IMP. (IMP being my pet peeve)
Is it too difficult to add more Logical Operators to QB64 math arsenal?
|
|
|
|
| A quick lesson on _DEFLATE and _INFLATE |
|
Posted by: SMcNeill - 05-20-2022, 01:05 AM - Forum: Learning Resources and Archives
- No Replies
|
 |
Code: (Select All) _CONTROLCHR OFF
_TITLE "Quick _DEFLATE Demo"
PRINT "First, let me give you a little story:"
PRINT
story$ = "The Boy Who Cried Wolf"
story$ = story$ + CHR$(13)
story$ = story$ + "A shepherd boy, who tended his flock not far from a village, used to amuse himself at times in crying out 'Wolf! Wolf!' Twice or thrice his trick succeeded; the whole village came running out to his assistance, when all the return they got was to be laughed at for their pains."
story$ = story$ + CHR$(13)
story$ = story$ + "At last one day the wolf came indeed. The boy cried out in earnest. His neighbors, supposing him to be at his old sport, paid no heed to his cries, and the wolf devoured the sheep. So the boy learned, when it was too late, that liars are not believed even when they tell the truth."
PRINT story$
PRINT
PRINT "Now, our story above is"; LEN(story$); "bytes long."
PRINT
COLOR 15
PRINT "But let's _DEFLATE it!"
deflated_story$ = _DEFLATE$(story$)
PRINT
PRINT deflated_story$
PRINT
PRINT "Doesn't look like much, now does it? The only thing is, the deflated story is now only"; LEN(deflated_story$); "bytes long!"
SLEEP
CLS
PRINT "Now, in this case, the original was"; LEN(story$); "bytes"
PRINT "And the compressed version was"; LEN(deflated_story$); "bytes"
PRINT
PRINT "So there's not a ton of compression in this limited example, as our original data set was rather small to begin with. But let's see what happens when we have a larger dataset to work with."
PRINT
FOR i = 1 TO 10
story$ = story$ + CHR$(13) + story$
NEXT
PRINT "If you check the source code, you'll see that I've basically doubled the size of our story 10 times."
PRINT "It's now:"; LEN(story$); "bytes in size."
PRINT
COLOR 7
deflated_story$ = _DEFLATE$(story$)
PRINT "And now when I deflate this massive file, it reduces down to"; LEN(deflated_story$); "bytes in size!"
PRINT
PRINT
PRINT "From about 600,000 bytes being used in memory to about 4,000 bytes to store the same data. That's less than 1/100th of the original size here!!"
PRINT
PRINT "So, if you wanted to send those 600,000 bytes across the internet, how would you rather send them? 600,00 bytes uncompressed, or 4,000 bytes compressed, and then let the end user uncompress them?? ;)"
SLEEP
CLS
COLOR 15
PRINT "Images take up a ton of space in memory. A 1000x1000, 32-bit screen, uses 4,000,000 bytes of memory/storage."
PRINT "Yet, how many times have you ever downloaded a picture that's that large?"
PRINT
PRINT "Most images use _DEFLATE style compression on that image data, to store and transfer that image information."
PRINT "And then when you load it into memory, it uses _INFLATE to restore the image back to its original size and structure."
PRINT
PRINT "_DEFLATE compresses a string of data. _INFLATE decompresses it."
PRINT "And that's about all there is to it. ;)"
Note that I didn't try to wordwrap any of these lines or such, as this is a truly quick little demo, but I think it highlights and explains fairly well what _DEFLATE and _INFLATE do for us. If anyone has any questions, feel free to ask them and I'll do my best to expand as wanted. 
|
|
|
|
| Smile - RotoZoom Example |
|
Posted by: SierraKen - 05-19-2022, 08:59 PM - Forum: Programs
- Replies (5)
|
 |
![[Image: Smile-Roto-Zoom-Example-by-Sierra-Ken.jpg]](https://i.ibb.co/6Y0LGnL/Smile-Roto-Zoom-Example-by-Sierra-Ken.jpg)
I think B+ or someone else made this once before, but I thought I would give it a try. It's a smiley face that turns around and around while bouncing off the sides. He also zooms larger and smaller. It's a really good example for the RotoZoom sub, the Fillcircle sub, and for anyone that wants to learn how to make animation with Copyimage using RotoZoom.
Code: (Select All) 'Smile - RotoZoom Example by SierraKen
'May 19, 2022
Dim image As Long
Screen _NewImage(200, 200, 32)
'Head
cx = 100: cy = 100: r = 95
c = _RGB32(255, 255, 0)
fillCircle cx, cy, r, c
'Right Eye
cx = 50: cy = 75: r = 15
c = _RGB32(0, 0, 0)
fillCircle cx, cy, r, c
'Left Eye
cx = 150: cy = 75: r = 15
c = _RGB32(0, 0, 0)
fillCircle cx, cy, r, c
'Mouth
Circle (100, 125), 70, _RGB32(0, 0, 0), _Pi, 2 * _Pi, .5
Line (30, 125)-(170, 125), _RGB32(0, 0, 0)
Paint (100, 140), _RGB32(0, 0, 0)
dirx = 1
diry = 1
x = 400
y = 400
scale = 1
_Title "Smile - RotoZoom Example by SierraKen"
image& = _CopyImage(0)
Cls
Screen _NewImage(800, 800, 32)
Do
_Limit 30
rotation = rotation + 1
If rotation > 359 Then rotation = 0
x = x + dirx
y = y + diry
If x > 700 Then dirx = -1 * Rnd * 3
If x < 100 Then dirx = 1 * Rnd * 3
If y > 700 Then diry = -1 * Rnd * 3
If y < 100 Then diry = 1 * Rnd * 3
If shrink = 0 Then scale = scale + .01
If scale > 5 Then shrink = 1
If shrink = 1 Then scale = scale - .01
If scale < .5 Then shrink = 0
RotoZoom x, y, image&, scale, rotation
_Display
Line (0, 0)-(800, 800), _RGB32(0, 0, 0, 10), BF
Loop Until InKey$ = Chr$(27)
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
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 RotoZoom (X As Long, Y As Long, image&, Scale As Single, Rotation As Single)
Dim px(3) As Single: Dim py(3) As Single
W& = _Width(image&): H& = _Height(image&)
px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
sinr! = Sin(-Rotation / 57.2957795131): cosr! = Cos(-Rotation / 57.2957795131)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
|
|
|
|
| Fractals |
|
Posted by: bplus - 05-19-2022, 07:34 PM - Forum: bplus
- Replies (14)
|
 |
Here is my favorite of all time! I imagined it in college 1976 let's say, way before I've heard term fractals and it took 40 years to get around to drawing it as imagined thanks to Alpha coloring in QB64, sort of had it with SmallBASIC but needed alpha to get the full spectrum of shading of overlapping squares.
Code: (Select All) _Title "recurring squares 2017-10-26 by bplus"
' Now with Alpha coloring!
'reoccuring squares SmallBASIC translation from
Rem reoccuring squares NaaLaa started 2015-05-14 MGA/B+
Const xmax = 700
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 30 'adjust as needed _MIDDLE needs a delay .5 or more for me
Common Shared dimmer
sq = 700: dir = 1
While 1
Cls
white& = _RGB(255, 255, 255)
fRecStep 0, 0, sq, sq, white&
sqPlus sq / 2, sq / 2, sq / 2
_Display
_Limit 20
dimmer = dimmer + dir
If dimmer > 255 Then dimmer = 255: dir = dir * -1: _Delay .5
If dimmer < 0 Then dimmer = 0: dir = dir * -1: _Delay .5
Wend
Sub fRecStep (x1, y1, x2, y2, c&)
Line (x1, y1)-Step(x2, y2), c&, BF
End Sub
Sub sqPlus (x, y, side)
cx = x - side / 2: cy = y - side / 2
fRecStep cx, cy, side, side, _RGBA(0, 0, 0, dimmer)
If side < 10 Then Exit Sub
ns = side / 2: nc = colorNumber - 35
sqPlus cx, cy, ns
sqPlus cx + side, cy, ns
sqPlus cx, cy + side, ns
sqPlus cx + side, cy + side, ns
End Sub
I have an 40 year old Ink Wash Drawing that looks very close to this snapshot.
|
|
|
|
| trying to draw a better moon |
|
Posted by: James D Jarvis - 05-19-2022, 02:10 PM - Forum: Help Me!
- Replies (8)
|
|
working on my alienskies program posted elsewhere and I'm trying to develop a better method of rendering the moons so the craters don't jump off the moon. I'm trying a rendering methods where I draw the craters in a separate image and then I scan that image layer only copying the pixels on that image layer that are inside the space of the moon. That's working but when I attempt to clear the image holding the craters to draw fresh craters it just isn't clearing out the old craters. I suspect it's in the order of my _dest and _source calls but I'm lost and can't see where the error is. Anyone want to take a look and offer advice I'd really appreciate it?
Code: (Select All) 'not better mooon
'arrggghhhh ..... why isn't this working????
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) <- the crater paint image
Screen MS&
nopaint = Point(1, 1)
Do
Cls
_Limit 1
bettermoon
_Display
A$ = InKey$
Loop Until A$ = "q"
Sub bettermoon
mx = 400
my = 300
' mx = Int(Rnd * (imgmax_x / 2)) + (imgmax_x / 4)
' my = Int(Rnd * (imgmax_y / 2)) + (imgmax_x / 4)
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)
moonsize = Int(((Rnd * 200) + 50 + (Rnd * 200) + 50) / 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)
' moonshadow mx, my, moonsize, mklr& turned off because I'm focusing on the problem for now
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
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
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
_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&)
'this isn't perfect but it works. It's currentyl commented in the main routine
moffx = mx + Int(Rnd * moonsize) - Int(Rnd * moonsize)
moffy = my + Int(Rnd * moonsize) - Int(Rnd * moonsize)
CircleFill moffx, moffy, moonsize, _RGB32(0, 0, 0)
End Sub
|
|
|
|
|
