Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Endless ants running about inside a window.
Code: (Select All) 'ants!!!
' a program by James D. Jarvis
'just some ants made with the draw command running about
'press any key to quit
_Title "ANTS!!!"
Screen _NewImage(800, 500, 256)
'_FullScreen
Dim Shared ant$, ax(100), ay(100), am(100), aa(100), ascl(100), aklr(100)
loadCMYK
Color 20, 145
Cls
ant$ = "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2bm-3,+0e5g5f5h5u5d10u6dg5e5h5"
For a = 1 To 100
ax(a) = 100 - Int(Rnd * 100)
ay(a) = Int(Rnd * 300) + 100
am(a) = Int(Rnd * 3) + 2
aa(a) = Int(Rnd * 10) - Int(Rnd * 10)
ascl(a) = Int(Rnd * 6) + 3
aklr(a) = 20 - Int(Rnd * 4)
Next a
ro = _Pi / 180
Do
_Limit 30
Cls
For a = 1 To 100
If Rnd * 6 > 4 Then
ax(a) = ax(a) + ascl(a) * Sin((aa(a) + 90) * ro)
ay(a) = ay(a) + ascl(a) * Cos((aa(a) + 90) * ro)
If ax(a) < -20 Or ax(a) > 850 Then
ax(a) = 0 - (Int(Rnd * 10) + 5)
ay(a) = Int(Rnd * 300) + 100
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If ay(a) < -10 Or ay(a) > 650 Then
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
End If
dant aa(a), aklr(a), ascl(a), ax(a), ay(a)
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
aa(a) = aa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
aa(a) = aa(a) + (Int(Rnd * 6) + 2)
End Select
Next a
aa$ = InKey$
_Display
Loop Until aa$ <> ""
System
Sub dant (ang, klr, scl, x, y)
Draw "s" + Str$(scl)
PSet (x, y)
Draw "c" + Str$(klr) + "ta" + Str$(ang) + ant$
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' 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)
_PaletteColor pk, _RGB32(r, g, b)
End Sub
Sub loadCMYK
'builing a cmyk pallete
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255
k = 10 + (klr - 240) * 4
c = 0
m = 100
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Color 0, klr
Next klr
End Sub
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(07-15-2022, 07:40 PM)Anthony.R.Brown Wrote: I love this sort of stuff...
C++ Ants Simulation 6, Editor
I have a soft-spot for little simulated critters as well.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Added puddles of repellant that will make the ants avoid them and go crazy until they stumble out .
There's some other curious behavior I have not figured out just yet.
Code: (Select All) 'ants2!!!
' a program by Jmes D. Jarvis
'just some ants made with the draw command running about the screen avoiding toxic puddles
'press any key to quit
_Title "ANTS 2!!!"
Screen _NewImage(800, 500, 256)
'_FullScreen
Dim Shared ant$, ax(100), ay(100), am(100), aa(100), ascl(100), aklr(100)
Dim Shared b&
Randomize Timer
loadCMYK
Color 20, 145
Cls
b& = _NewImage(800, 500, 256)
_Dest b&
Color 20, 145
Cls
For p = 1 To 4
CircleFill Int(Rnd * 500) + 200, Int(Rnd * 300) + 100, Int(Rnd * 60) + 12, Int(Rnd * 5) + 55
Next p
_Dest 0
ant$ = "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2bm-3,+0e5g5f5h5u5d10u6dg5e5h5"
For a = 1 To 100
ax(a) = 100 - Int(Rnd * 100)
ay(a) = Int(Rnd * 300) + 100
am(a) = Int(Rnd * 3) + 2
aa(a) = Int(Rnd * 10) - Int(Rnd * 10)
ascl(a) = Int(Rnd * 6) + 3
aklr(a) = 20 - Int(Rnd * 4)
Next a
ro = _Pi / 180
Do
_Limit 30
'Cls
_PutImage (0, 0), b&, 0
For a = 1 To 100
If Rnd * 6 > 4 Then
ax(a) = ax(a) + ascl(a) * Sin((aa(a) + 90) * ro)
ay(a) = ay(a) + ascl(a) * Cos((aa(a) + 90) * ro)
If ax(a) < -20 Or ax(a) > 850 Then
ax(a) = 0 - (Int(Rnd * 10) + 5)
ay(a) = Int(Rnd * 300) + 100
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If ay(a) < -10 Or ay(a) > 650 Then
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
End If
dant aa(a), aklr(a), ascl(a), ax(a), ay(a)
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
aa(a) = aa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
aa(a) = aa(a) + (Int(Rnd * 6) + 2)
End Select
_Source b&
If Point(ax(a) + ascl(a) * 4, ay(a)) <> 145 And Point(ax(a) + ascl(a) * 4, ay(a)) <> 20 Then
aa(a) = Int(aa(a) + 30)
End If
Next a
aa$ = InKey$
_Display
Loop Until aa$ <> ""
System
Sub dant (ang, klr, scl, x, y)
Draw "s" + Str$(scl)
PSet (x, y)
Draw "c" + Str$(klr) + "ta" + Str$(ang) + ant$
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' 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)
_PaletteColor pk, _RGB32(r, g, b)
End Sub
Sub loadCMYK
'builing a cmyk pallete
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255
k = 10 + (klr - 240) * 4
c = 0
m = 100
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Color 0, klr
Next klr
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
Posts: 3,986
Threads: 178
Joined: Apr 2022
Reputation:
222
Definitely cool stuff! Thumbs up!
b = b + ...
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(07-16-2022, 04:18 AM)bplus Wrote: Definitely cool stuff! Thumbs up!
Thank you.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Now there's red and black ants, the poison does them ill and they leave remains and tracks.
Code: (Select All) 'ants!!!
' a program by James D. Jarvis
'just some ants made with the draw command running about the screen
'there are black and and red ants and they fall victim to the insecticide
'press any key to quit
_Title "ANTS 3!!!"
Screen _NewImage(800, 500, 256)
'_FullScreen
Dim Shared ant$, ax(100), ay(100), am(100), aa(100), ascl(100), aklr(100), ah(100)
Dim Shared rax(100), ray(100), ram(100), raa(100), rascl(100), raklr(100), rah(100)
Dim Shared b&
Randomize Timer
loadCMYK
Color 20, 145
Cls
b& = _NewImage(800, 500, 256)
_Dest b&
Color 20, 145
For y = 0 To 499
For x = 0 To 798 Step Int(3 + Rnd * 3)
Draw "c" + Str$(Int(Rnd * 6) + 63) + "bm" + Str$(x) + "," + Str$(y) + "r" + Str$(1 + Int(Rnd * 5))
Next
Next
For p = 1 To 4
CircleFill Int(Rnd * 500) + 200, Int(Rnd * 300) + 100, Int(Rnd * 60) + 12, Int(Rnd * 5) + 55
Next p
_Dest 0
ant$ = "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2bm-3,+0e5g5f5h5u5d10u6dg5e5h5"
For a = 1 To 100
ax(a) = 0 - Int(Rnd * 20)
ay(a) = Int(Rnd * 300) + 100
am(a) = Int(Rnd * 3) + 2
aa(a) = Int(Rnd * 10) - Int(Rnd * 10)
ascl(a) = Int(Rnd * 6) + 3
aklr(a) = 20 - Int(Rnd * 4)
ah(a) = Int(Rnd * 10) + ascl(a) * 2
rax(a) = 800 + Int(Rnd * 20)
ray(a) = Int(Rnd * 300) + 100
ram(a) = Int(Rnd * 3) + 2
raa(a) = 180 + Int(Rnd * 10) - Int(Rnd * 10)
rascl(a) = Int(Rnd * 6) + 3
raklr(a) = 178 - Int(Rnd * 4)
rah(a) = Int(Rnd * 10) + rascl(a) * 2
Next a
ro = _Pi / 180
Do
_Limit 30
'Cls
_PutImage (0, 0), b&, 0
For a = 1 To 100
If Rnd * 6 > 4 Then
ax(a) = ax(a) + ascl(a) * Sin((aa(a) + 90) * ro)
ay(a) = ay(a) + ascl(a) * Cos((aa(a) + 90) * ro)
rax(a) = rax(a) + rascl(a) * Sin((raa(a) + 90) * ro)
ray(a) = ray(a) + rascl(a) * Cos((raa(a) + 90) * ro)
If ax(a) < -20 Or ax(a) > 850 Then
ax(a) = 0 - (Int(Rnd * 10) + 5)
ay(a) = Int(Rnd * 300) + 100
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If ay(a) < -10 Or ay(a) > 650 Then
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If rax(a) < -20 Or rax(a) > 850 Then
rax(a) = 810 - (Int(Rnd * 10) + 5)
ray(a) = Int(Rnd * 300) + 100
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
End If
If ray(a) < -10 Or ray(a) > 650 Then
ray(a) = Int(Rnd * 300) + 100
rax(a) = 810 - (Int(Rnd * 10) + 5)
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
End If
End If
dant aa(a), aklr(a), ascl(a), ax(a), ay(a)
dant raa(a), raklr(a), rascl(a), rax(a), ray(a)
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
aa(a) = aa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
aa(a) = aa(a) + (Int(Rnd * 6) + 2)
End Select
_Source b&
If Point(ax(a) + ascl(a) * 4, ay(a)) > 54 And Point(ax(a) + ascl(a) * 4, ay(a)) < 61 Then
aa(a) = Int(aa(a) + 30)
ah(a) = ah(a) - 1
Else
If Rnd * 20 > 18.5 Then
_Dest b&
PSet (ax(a), ay(a)), 4
_Dest 0
End If
End If
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
raa(a) = raa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
raa(a) = raa(a) + (Int(Rnd * 6) + 2)
End Select
_Source b&
If Point(rax(a) + rascl(a) * 4, ray(a)) > 54 And Point(rax(a) + rascl(a) * 4, ray(a)) < 61 Then
raa(a) = Int(raa(a) + 30)
rah(a) = rah(a) - 1
Else
If Rnd * 20 > 18.5 Then
_Dest b&
PSet (rax(a), ray(a)), 4
_Dest 0
End If
End If
If ah(a) < 1 Then
_Dest b&
PSet (ax(a), ay(a))
Draw "s" + Str$(ascl(a) - 1)
Draw "ta" + Str$(aa(a)) + "c" + Str$(Int(4 + Rnd * 4)) + "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2"
_Dest 0
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
ah(a) = Int(Rnd * 10) + ascl(a) * 2
End If
If rah(a) < 1 Then
_Dest b&
PSet (rax(a), ray(a))
Draw "s" + Str$(rascl(a) - 1)
Draw "ta" + Str$(raa(a)) + "c" + Str$(Int(4 + Rnd * 4)) + "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2"
_Dest 0
ray(a) = Int(Rnd * 300) + 100
rax(a) = 810 - (Int(Rnd * 10) + 5)
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
rah(a) = Int(Rnd * 10) + rascl(a) * 2
End If
Next a
aa$ = InKey$
_Display
Loop Until aa$ <> ""
System
Sub dant (ang, klr, scl, x, y)
Draw "s" + Str$(scl)
PSet (x, y)
Draw "c" + Str$(klr) + "ta" + Str$(ang) + ant$
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' 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)
_PaletteColor pk, _RGB32(r, g, b)
End Sub
Sub loadCMYK
'builing a cmyk pallete
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255
k = 10 + (klr - 240) * 4
c = 0
m = 100
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Color 0, klr
Next klr
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
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Posts: 418
Threads: 75
Joined: Apr 2022
Reputation:
22
LOL James, I was hesitant to trying this out because I've had a real ant problem for around a month now in my kitchen. The trap seems to be working sometimes. You did a good job though! I will have to look at your code and see how you did the A.I. for each ant.  . Another idea is to make an Ant Farm and have them dig tunnels like the one I had as a kid.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
(07-16-2022, 09:30 PM)SierraKen Wrote: LOL James, I was hesitant to trying this out because I've had a real ant problem for around a month now in my kitchen. The trap seems to be working sometimes. You did a good job though! I will have to look at your code and see how you did the A.I. for each ant. . Another idea is to make an Ant Farm and have them dig tunnels like the one I had as a kid.
"AI" is a bit generous of a term. The poison traps aren't instant kills, they degrade health and have the ant spin about.
Tunnels might be fun.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
07-16-2022, 10:01 PM
(This post was last modified: 07-17-2022, 01:01 PM by James D Jarvis.)
Now they fight. The Collison detection isn't great but with the commotion of maybe 100 ants per side on the screen at a time it's not too much of problem. Little bits of ant get strewn about and they change their heading when they fight.
a poison pool can fill up with so many dead ants they can just walk over it and be unharmed as well.
Code: (Select All) 'ants!!!
' a program by Jmes D. Jarvis
'just some ants made with the draw command running about the screen
'there are black and and red ants and they fall victim to the insecticide
' now they fight too
'press any key to quit
_Title "ANTS 4!!!"
Screen _NewImage(800, 500, 256)
'_FullScreen
Dim Shared ant$, ax(100), ay(100), am(100), aa(100), ascl(100), aklr(100), ah(100), asp(100), af(100)
Dim Shared rax(100), ray(100), ram(100), raa(100), rascl(100), raklr(100), rah(100), rasp(100), raf(100)
Dim Shared b&
Randomize Timer
loadCMYK
Color 20, 145
Cls
b& = _NewImage(800, 500, 256)
_Dest b&
Color 20, 145
For y = 0 To 499
For x = 0 To 798 Step Int(3 + Rnd * 3)
Draw "c" + Str$(Int(Rnd * 6) + 63) + "bm" + Str$(x) + "," + Str$(y) + "r" + Str$(1 + Int(Rnd * 5))
Next
Next
For p = 1 To 4
CircleFill Int(Rnd * 500) + 200, Int(Rnd * 300) + 100, Int(Rnd * 60) + 12, Int(Rnd * 5) + 55
Next p
_Dest 0
ant$ = "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2bm-3,+0e5g5f5h5u5d10u6dg5e5h5"
For a = 1 To 100
ax(a) = 0 - Int(Rnd * 20)
ay(a) = Int(Rnd * 300) + 100
am(a) = Int(Rnd * 3) + 2
aa(a) = Int(Rnd * 10) - Int(Rnd * 10)
ascl(a) = Int(Rnd * 6) + 3
aklr(a) = 20 - Int(Rnd * 4)
ah(a) = Int(Rnd * 10) + ascl(a) * 2
asp(a) = ascl(a) - 2
af(a) = 0
rax(a) = 800 + Int(Rnd * 20)
ray(a) = Int(Rnd * 300) + 100
ram(a) = Int(Rnd * 3) + 2
raa(a) = 180 + Int(Rnd * 10) - Int(Rnd * 10)
rascl(a) = Int(Rnd * 6) + 3
raklr(a) = 178 - Int(Rnd * 4)
rah(a) = Int(Rnd * 10) + rascl(a) * 2
rasp(a) = rascl(a) - 2
raf(a) = 0
Next a
ro = _Pi / 180
Do
_Limit 30
'Cls
_PutImage (0, 0), b&, 0
For a = 1 To 100
If Rnd * 6 > 4 Then
If af(a) < 1 Then
ax(a) = ax(a) + asp(a) * Sin((aa(a) + 90) * ro)
ay(a) = ay(a) + asp(a) * Cos((aa(a) + 90) * ro)
End If
If raf(a) < 1 Then
rax(a) = rax(a) + rasp(a) * Sin((raa(a) + 90) * ro)
ray(a) = ray(a) + rasp(a) * Cos((raa(a) + 90) * ro)
End If
af(a) = af(a) - 1
raf(a) = raf(a) - 1
If ax(a) < -20 Or ax(a) > 850 Then
ax(a) = 0 - (Int(Rnd * 10) + 5)
ay(a) = Int(Rnd * 300) + 100
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If ay(a) < -10 Or ay(a) > 650 Then
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
End If
If rax(a) < -20 Or rax(a) > 850 Then
rax(a) = 810 - (Int(Rnd * 10) + 5)
ray(a) = Int(Rnd * 300) + 100
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
End If
If ray(a) < -10 Or ray(a) > 650 Then
ray(a) = Int(Rnd * 300) + 100
rax(a) = 810 - (Int(Rnd * 10) + 5)
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
End If
End If
dant aa(a), aklr(a), ascl(a), ax(a), ay(a)
dant raa(a), raklr(a), rascl(a), rax(a), ray(a)
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
aa(a) = aa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
aa(a) = aa(a) + (Int(Rnd * 6) + 2)
End Select
_Source b&
If Point(ax(a) + ascl(a) * 4, ay(a)) > 54 And Point(ax(a) + ascl(a) * 4, ay(a)) < 61 Then
aa(a) = Int(aa(a) + 30)
ah(a) = ah(a) - 1
Else
If Rnd * 20 > 18.5 Then
_Dest b&
PSet (ax(a), ay(a)), 4
_Dest 0
End If
End If
dc = Int(Rnd * 20) + 1
Select Case dc
Case 1 TO 3
raa(a) = raa(a) - (Int(Rnd * 6) + 2)
Case 4 TO 17
Case 18 TO 20
raa(a) = raa(a) + (Int(Rnd * 6) + 2)
End Select
_Source b&
If Point(rax(a) + rascl(a) * 4, ray(a)) > 54 And Point(rax(a) + rascl(a) * 4, ray(a)) < 61 Then
raa(a) = Int(raa(a) + 30)
rah(a) = rah(a) - 1
Else
If Rnd * 20 > 18.5 Then
_Dest b&
PSet (rax(a), ray(a)), 4
_Dest 0
End If
End If
For n = 1 To 100
bxx = ax(n) + ascl(n) * 2 * Sin((aa(n) + 90) * ro)
byy = ay(n) + ascl(n) * 2 * Cos((aa(n) + 90) * ro)
If Int(bxx / 4) = Int((rax(a) + 3) / 4) And Int(byy / 4) = Int((ray(a) + 3) / 4) Then
ah(n) = ah(n) - Int(1 + Rnd * rascl(a))
rah(a) = rah(a) - Int(1 + Rnd * ascl(n))
aa(n) = aa(n) + Int(30 + Rnd * 20)
raa(a) = raa(a) - Int(30 + Rnd * 20)
rasp(a) = 0
asp(n) = 0
Circle ((ax(n) + rax(a)) / 2, (ay(n) + ray(a) / 2)), ascl(n) + rascl(a), 115
_Dest b&
PSet (rax(a), ray(a))
Draw "ta" + Str$(Int(Rnd * 360)) + "c" + Str$(Int(4 + Rnd * 4)) + "r4"
_Dest 0
If raf(a) < 1 Then raf(a) = 12
If af(n) < 1 Then af(n) = 12
End If
Next n
For n = 1 To 100
bxx = rax(n) + rascl(n) * 2 * Sin((raa(n) + 90) * ro)
byy = ray(n) + rascl(n) * 2 * Cos((raa(n) + 90) * ro)
If Int((ax(a) + 3) / 4) = Int(bxx / 4) And Int((ay(a) + 3) / 4) = Int(byy / 4) Then
ah(a) = ah(a) - Int(1 + Rnd * rascl(n))
rah(n) = rah(n) - Int(1 + Rnd * ascl(a))
aa(a) = aa(a) + Int(30 + Rnd * 20)
raa(n) = raa(n) - Int(30 + Rnd * 20)
asp(a) = 0
rasp(n) = 0
Circle ((ax(a) + rax(n)) / 2, (ay(a) + ray(n) / 2)), ascl(a) + rascl(n), 115
_Dest b&
PSet (ax(a), ay(a))
Draw "ta" + Str$(Int(Rnd * 360)) + "c" + Str$(Int(4 + Rnd * 4)) + "r4"
_Dest 0
If raf(a) < 1 Then raf(n) = 12
If af(a) < 1 Then af(a) = 12
End If
Next n
asp(a) = asp(a) + Int(Rnd * 2)
If asp(a) > ascl(a) * 1.5 Then asp(a) = ascl(a)
rasp(a) = rasp(a) + Int(Rnd * 2)
If rasp(a) > rascl(a) * 1.5 Then rasp(a) = rascl(a)
If ah(a) < 1 Then
_Dest b&
PSet (ax(a), ay(a))
Draw "s" + Str$(ascl(a) - 1)
Draw "ta" + Str$(aa(a)) + "c" + Str$(Int(4 + Rnd * 4)) + "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2"
_Dest 0
ay(a) = Int(Rnd * 300) + 100
ax(a) = 0 - (Int(Rnd * 10) + 5)
aa(a) = 0
ascl(a) = Int(Rnd * 6) + 3
ah(a) = Int(Rnd * 10) + ascl(a) * 2
End If
If rah(a) < 1 Then
_Dest b&
PSet (rax(a), ray(a))
Draw "s" + Str$(rascl(a) - 1)
Draw "ta" + Str$(raa(a)) + "c" + Str$(Int(4 + Rnd * 4)) + "m+4,-2m+4,+2m-4,+2m-4,-2br8r5m+2,-2m+1,+2m-1,+2m-2,-2"
_Dest 0
ray(a) = Int(Rnd * 300) + 100
rax(a) = 810 - (Int(Rnd * 10) + 5)
raa(a) = 180
rascl(a) = Int(Rnd * 6) + 3
rah(a) = Int(Rnd * 10) + rascl(a) * 2
End If
Next a
aa$ = InKey$
_Display
Loop Until aa$ <> ""
System
Sub dant (ang, klr, scl, x, y)
Draw "s" + Str$(scl)
PSet (x, y)
Draw "c" + Str$(klr) + "ta" + Str$(ang) + ant$
End Sub
Sub pal_cmyk (pk, c, m, y, k)
' create a 256 color palette entry using CMYK
' 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)
_PaletteColor pk, _RGB32(r, g, b)
End Sub
Sub loadCMYK
'builing a cmyk pallete
klr = 0
c = 0
m = 0
y = 0
k = 0
For klr = 0 To 255
Select Case klr
Case 1 TO 20
k = k + 5
c = 0
m = 0
y = 0
Case 21 TO 40
k = 0
c = c + 5
m = 0
y = 0
Case 41 TO 60
k = 0
c = 0
m = m + 5
y = 0
Case 61 TO 80
k = 0
c = 0
m = 0
y = y + 5
Case 81 TO 100
k = 0
c = c + 5
m = m + 5
y = 0
Case 101 TO 120
k = 0
c = c + 5
m = 0
y = y + 5
Case 121 TO 140
k = 0
c = 0
m = m + 5
y = y + 5
Case 121 TO 140
k = 20
c = c + 5
m = m + 5
y = 0
Case 141 TO 160
k = 20
c = c + 5
m = 0
y = y + 5
Case 161 TO 180
k = 20
c = 0
m = m + 5
y = y + 5
Case 181 TO 200
k = 40
c = c + 5
m = m + 5
y = 0
Case 201 TO 220
k = 40
c = c + 5
m = 0
y = y + 5
Case 221 TO 240
k = 40
c = 0
m = m + 5
y = y + 5
Case 241 TO 255
k = 10 + (klr - 240) * 4
c = 0
m = 100
y = y + 5
End Select
pal_cmyk klr, c, m, y, k
Color 0, klr
Next klr
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
|
