_Title "Hexagonal Star Tiling 3" 'B+ 2019-04-19
' Trying to duplicate results shown here by Daniel Shiffman
' https://www.youtube.com/watch?v=sJ6pMLp_IaI&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH&index=70
' but using a completely different method for drawing the tile
' 2019-04-17 Yes! the star tile can be generalized to any N sided regular polygon!
' 2019-04-17 This version try Hexagonal Tiling.
' 2019-04-17 Hexagonal Star Tiling 2, prep one tile and rubber stamp the grid with image.
' 2019-04-18 Go for a dynamic tile, image constantly changing
Const xmax = 1380 'bigger than your screen can hold
Const ymax = 800
Screen _NewImage(xmax, ymax, 32)
'_SCREENMOVE _MIDDLE
_FullScreen
Randomize Timer
Dim Shared tile&, polyRadius, triColor As _Unsigned Long
If Rnd > .8 Then
polyRadius = rand(20, 200)
triColor = _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
rDir = -1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
Color , _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
Else
rDir = -1
End If
End If
End If
If rDir = -1 Then
If rd - 1 >= 0 Then
rd = rd - 1: prepTile polyRadius, rd, dm
Else
If Rnd > .8 Then
triColor = _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
polyRadius = rand(20, 200)
rDir = 1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
Color , _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
Else
rDir = 1
End If
End If
End If
Cls
gridheight = polyRadius * Sqr(3) / 2
xoff = 0
For y = -polyRadius To ymax + gridheight Step gridheight
xoff = (xoff + 1) Mod 2
For x = -polyRadius To xmax Step 3 * polyRadius
_PutImage (x + xoff * 1.5 * polyRadius, y), tile&, 0
Next
Next
_Display
_Limit .1 * polyRadius
Wend
End
Sub prepTile (pRadius, innerStarRadius, midPtDist)
If tile& Then _FreeImage tile&
tile& = _NewImage(2 * pRadius, 2 * pRadius, 32)
_Dest tile&
drawRegPolyStar pRadius, pRadius, pRadius, 6, innerStarRadius, midPtDist, triColor
_Dest 0
End Sub
Sub drawRegPolyStar (cx, cy, pRadius, nSides, innerStarRadius, midPtDist, c1 As _Unsigned Long)
Dim tilePtsX(1 To nSides), tilePtsY(1 To nSides)
Dim innerStarX(1 To nSides), innerStarY(1 To nSides)
pA = _Pi(2 / nSides)
For i = 1 To nSides
tilePtsX(i) = cx + pRadius * Cos(pA * i)
tilePtsY(i) = cy + pRadius * Sin(pA * i)
'on the same line the innerStar pts
innerStarX(i) = cx + innerStarRadius * Cos(pA * i)
innerStarY(i) = cy + innerStarRadius * Sin(pA * i)
'CIRCLE (innerStarX(i), innerStarY(i)), 3, _RGB32(255, 255, 0)
'draw tile
If i > 1 Then
Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(i - 1), tilePtsY(i - 1)), _RGB32(255, 0, 0, 200)
If i = nSides Then
Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(1), tilePtsY(1)), _RGB32(255, 0, 0, 200)
End If
End If
'_DELAY .5
Next
'from each innerStarPt 2 lines connect to side midpoints
'lets calc all the midpoints +/- midPtDist
Dim mpdX(1 To 2 * nSides), mpdY(1 To 2 * nSides)
For i = 1 To nSides
If i - 1 = 0 Then ei = nSides Else ei = i - 1
mx = (tilePtsX(ei) + tilePtsX(i)) / 2
my = (tilePtsY(ei) + tilePtsY(i)) / 2
'check
'CIRCLE (mx, my), 2, _RGB32(0, 0, 255)
'_DELAY .5
'from each mx, my we need a point midPtDist along the angle from mx, my to the ei index point
a = _Atan2(tilePtsY(ei) - my, tilePtsX(ei) - mx)
mdx = mx + midPtDist * Cos(a)
mdy = my + midPtDist * Sin(a)
'the other point is 180 degrees in opposite direction
mdx2 = mx + midPtDist * Cos(a - _Pi)
mdy2 = my + midPtDist * Sin(a - _Pi)
'check
'CIRCLE (mdx, mdy), 2, _RGB32(255, 255, 0)
'CIRCLE (mdx2, mdy2), 2, _RGB32(255, 0, 255)
'OK store all these points for drawing lines later
mpdX(2 * i - 1) = mdx: mpdY(2 * i - 1) = mdy
mpdX(2 * i) = mdx2: mpdY(2 * i) = mdy2
Next
Color c1
'from each point in inner star Radius draw 2 lines to the poly edges
For i = 1 To nSides
'now figure the pattern: sequence maps are to 2*i +2 and to 2*i - 1
If 2 * i + 2 > 2 * nSides Then map = 2 * i + 2 - 2 * nSides Else map = 2 * i + 2
Line (innerStarX(i), innerStarY(i))-(mpdX(map), mpdY(map))
If 2 * i - 1 < 1 Then map2 = 2 * i - 1 + 2 * nSides Else map2 = 2 * i - 1
Line (innerStarX(i), innerStarY(i))-(mpdX(map2), mpdY(map2))
Function rand% (lo%, hi%)
rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function
' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest tile&
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Const xmax = 1200, ymax = 700, pi = _Pi, nb = 100, no = 7, np = 3
Const green = _RGB32(0, 160, 0), blue = _RGB32(0, 0, 160), black = _RGB32(0, 0, 0), brown = _RGB32(100, 80, 40)
Dim As Long done, headmode, centermode, i, j, testx, testy, iter
Dim As Single hf, cf, t1, s, ao, dist
Dim As Single px(np), py(np), pa(np) ' Predator radius is const 10 or so, twice a bird at least
Dim As Single ox(no), oy(no), ord(no) ' obstacle x, y, radius
Dim As Single bx(nb), by(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As Long pw(np), bw(nb)
headmode = 1 ' on / off
hf = .3 ' % of 100 pixels distance .1 = 10
centermode = 0 ' on / off
cf = .2 'centering factor how strong a pull from 0 to 1 .01 is week .1 pretty strong!
For i = 1 To no ' in array for redraw
ox(i) = rand(90, xmax - 90): oy(i) = rand(90, ymax - 90): ord(i) = rand(25, 90)
Next
For i = 1 To nb
testAgain: ' don't start a bird inside an obstacle
testx = rand(20, xmax - 20) ' start random screen x, y away from borders
testy = rand(20, ymax - 20)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain
Wend
j = 0
While j < i - 1 'no bird crowds please note get strange results with For loop
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 15 Then GoTo testAgain
Wend
bx(i) = testx: by(i) = testy: ba(i) = 2 * pi * Rnd: bw(i) = Int(3 * Rnd) ' random headings
Next
For i = 1 To np ' might be smarter to pack the smaller after the larger, ie do predators before birds
testAgain2: ' don't start a predator inside an obstacle
testx = rand(40, xmax - 40) ' start random screen x, y away from borders
testy = rand(40, ymax - 40)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain2
Wend
j = 0
While j < nb ' give birds some space from predators too
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 30 Then GoTo testAgain2
Wend
px(i) = testx: py(i) = testy: pa(i) = 2 * pi * Rnd: pw(i) = Int(5 * Rnd)
Next
t1 = Timer(.001)
While _KeyDown(27) = 0
Color , green
Cls
For i = 1 To no
fcirc ox(i), oy(i), ord(i), brown
Next
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To np ' Predators are just like a birds
pw(i) = (1 + pw(i)) Mod 5 ' flapper wings or not
DrawBird px(i), py(i), 15, pa(i), pw(i), blue
s = Rnd * 4 + 3 ' get some bird separation here?
px(i) = px(i) + s * Cos(pa(i)): py(i) = py(i) + s * Sin(pa(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(px(i), py(i), ox(j), oy(j)) < ord(j) + 23 Then
ao = _Atan2(oy(j) - py(i), ox(j) - px(i))
pa(i) = AngleAve(pa(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
px(i) = Mod2(px(i) + xmax, xmax)
py(i) = Mod2(py(i) + ymax, ymax)
' except predators don't flock
Next
For i = 1 To nb 'draw then update positions of birds
' draw current
bw(i) = (bw(i) + 1) Mod 4 ' flapper wings or not
DrawBird bx(i), by(i), 8, ba(i), bw(i), black
s = rand(3, 7) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i)): by(i) = by(i) + s * Sin(ba(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(bx(i), by(i), ox(j), oy(j)) < ord(j) + 13 Then
ao = _Atan2(oy(j) - by(i), ox(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
j = 0
While j < np
j = j + 1
If distance(bx(i), by(i), px(j), py(j)) < 65 Then
ao = _Atan2(py(j) - by(i), px(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 50 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
If headmode And Rnd < hf Then
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
End If
If dist > 30 And dist < 100 Then
'stickiness stay close to neighbors, close distance between
If centermode And Rnd < cf Then
bx(i) = bx(i) - cf / 10 * (bx(i) - bx(j))
bx(j) = bx(j) + cf / 10 * (bx(i) - bx(j))
by(i) = by(i) - cf / 10 * (by(i) - by(j))
by(j) = by(j) + cf / 10 * (by(i) - by(j))
End If
End If
If dist < 20 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
_Display
_Limit 10
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
' this allows us to do floats including negative floats
Function Mod2# (n As Double, modulus As Double)
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
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
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
Const xmax = 1200, ymax = 700, pi = _Pi, nb = 100, no = 7, np = 3
Const green = _RGB32(0, 160, 0), blue = _RGB32(0, 0, 160), black = _RGB32(0, 0, 0), brown = _RGB32(100, 80, 40)
Dim As Long done, headmode, centermode, i, j, testx, testy, iter
Dim As Single hf, cf, t1, s, ao, dist
Dim As Single px(np), py(np), pa(np) ' Predator radius is const 10 or so, twice a bird at least
Dim As Single ox(no), oy(no), ord(no) ' obstacle x, y, radius
Dim As Single bx(nb), by(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As Long pw(np), bw(nb)
headmode = 1 ' on / off
hf = .3 ' % of 100 pixels distance .1 = 10
centermode = 0 ' on / off
cf = .2 'centering factor how strong a pull from 0 to 1 .01 is week .1 pretty strong!
For i = 1 To no ' in array for redraw
ox(i) = rand(90, xmax - 90): oy(i) = rand(90, ymax - 90): ord(i) = rand(25, 90)
Next
For i = 1 To nb
testAgain: ' don't start a bird inside an obstacle
testx = rand(20, xmax - 20) ' start random screen x, y away from borders
testy = rand(20, ymax - 20)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain
Wend
j = 0
While j < i - 1 'no bird crowds please note get strange results with For loop
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 15 Then GoTo testAgain
Wend
bx(i) = testx: by(i) = testy: ba(i) = 2 * pi * Rnd: bw(i) = Int(3 * Rnd) ' random headings
Next
For i = 1 To np ' might be smarter to pack the smaller after the larger, ie do predators before birds
testAgain2: ' don't start a predator inside an obstacle
testx = rand(40, xmax - 40) ' start random screen x, y away from borders
testy = rand(40, ymax - 40)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain2
Wend
j = 0
While j < nb ' give birds some space from predators too
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 30 Then GoTo testAgain2
Wend
px(i) = testx: py(i) = testy: pa(i) = 2 * pi * Rnd: pw(i) = Int(5 * Rnd)
Next
t1 = Timer(.001)
While _KeyDown(27) = 0
Color , green
Cls
For i = 1 To no
fcirc ox(i), oy(i), ord(i), brown
Next
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To np ' Predators are just like a birds
pw(i) = (1 + pw(i)) Mod 5 ' flapper wings or not
DrawBird px(i), py(i), 15, pa(i), pw(i), blue
s = Rnd * 4 + 3 ' get some bird separation here?
px(i) = px(i) + s * Cos(pa(i)): py(i) = py(i) + s * Sin(pa(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(px(i), py(i), ox(j), oy(j)) < ord(j) + 23 Then
ao = _Atan2(oy(j) - py(i), ox(j) - px(i))
pa(i) = AngleAve(pa(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
px(i) = Mod2(px(i) + xmax, xmax)
py(i) = Mod2(py(i) + ymax, ymax)
' except predators don't flock
Next
For i = 1 To nb 'draw then update positions of birds
' draw current
bw(i) = (bw(i) + 1) Mod 4 ' flapper wings or not
DrawBird bx(i), by(i), 8, ba(i), bw(i), black
s = rand(3, 7) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i)): by(i) = by(i) + s * Sin(ba(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(bx(i), by(i), ox(j), oy(j)) < ord(j) + 13 Then
ao = _Atan2(oy(j) - by(i), ox(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
j = 0
While j < np
j = j + 1
If distance(bx(i), by(i), px(j), py(j)) < 65 Then
ao = _Atan2(py(j) - by(i), px(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 50 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
If headmode And Rnd < hf Then
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
End If
If dist > 30 And dist < 100 Then
'stickiness stay close to neighbors, close distance between
If centermode And Rnd < cf Then
bx(i) = bx(i) - cf / 10 * (bx(i) - bx(j))
bx(j) = bx(j) + cf / 10 * (bx(i) - bx(j))
by(i) = by(i) - cf / 10 * (by(i) - by(j))
by(j) = by(j) + cf / 10 * (by(i) - by(j))
End If
End If
If dist < 20 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
_Display
_Limit 10
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
' this allows us to do floats including negative floats
Function Mod2# (n As Double, modulus As Double)
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
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
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
Love the way those little swallows (?) avoid the blue hawk (?)
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
_Title "Splats" 'b+ 2020-01-12
' from eRATication/cheese wedge tests/ multiple explosions.bas 2018-07-28 translated from
'bomb.bas for SmallBASIC 0.12.2 [B+=MGA] 2016-05-09 from explosion study
Const xmax = 1300, ymax = 760, pi2 = 6.283185
Type particle
x As Single
y As Single
dx As Single
dy As Single
size As Single
spread As Single
'tf AS INTEGER
End Type
ReDim Shared dots(1) As particle
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Randomize Timer
Dim kolor As _Unsigned Long
While Not _KeyDown(27)
Color , _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Cls
stopit = (Rnd * 100) \ 1 + 15
For i = 1 To stopit
dx = Rnd * 60 - 30: dy = Rnd * 60 - 30: a = 7 * (Rnd * 10 - 5): b = 7 * (Rnd * 10 - 5)
x = xmax * Rnd: y = ymax * Rnd
r = Rnd * 255
If InKey$ = " " Then toggle = 1 - toggle
If toggle Then
kolor = _RGB32(r, r, r)
Else
kolor = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
End If
While x > -100 And x < xmax + 100 And y > -100 And y < ymax + 100
splat x, y, kolor
x = x + dx: y = y + dy
dx = dx + a: dy = dy + b
_Display
Wend
Next
_Delay 5
Wend
System
Sub splat (x, y, kolor As _Unsigned Long)
round = 5
nRounds = (Rnd * 10) \ 1 + 1
nDots = nRounds * round
ReDim dots(1 To nDots) As particle
For i = 1 To round
NewDot i, x, y
Next
rounds = round
For loopCount = 0 To 20
If _KeyDown(27) Then End
For i = 1 To rounds
dots(i).x = dots(i).x + dots(i).dx
dots(i).y = dots(i).y + dots(i).dy
dots(i).dx = dots(i).dx * dots(i).spread
dots(i).dy = dots(i).dy * dots(i).spread
fcirc dots(i).x, dots(i).y, dots(i).size / 2, kolor
dots(i).size = dots(i).size * dots(i).spread
Next
If rounds < nDots Then
For i = 1 To round
NewDot i, x, y
Next
rounds = rounds + round
End If
_Display
Next
End Sub
Sub NewDot (i, x, y)
angle = Rnd * pi2
r = Rnd * 5
dots(i).x = x + r * Cos(angle)
dots(i).y = y + r * Sin(angle)
dots(i).size = Rnd * 15 + 5
r = Rnd * 3
dots(i).dx = r * (15 - dots(i).size) * Cos(angle)
dots(i).dy = r * (15 - dots(i).size) * Sin(angle)
dots(i).spread = Rnd * .3 + .2
End Sub
Sub fcirc (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
