+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: bplus (https://staging.qb64phoenix.com/forumdisplay.php?fid=36)
+---- Thread: Proggies (/showthread.php?tid=162)
RE: Proggies - SierraKen - 07-23-2022
Amazing animation flow, good work!
RE: Proggies - bplus - 07-24-2022
Thanks guys here's s'more
Diamond Spaceship
Code: (Select All)
_Title "Diamond Spaceship" 'b+ 2022-07-23
' 2022-7-24 fixed panel problems and added PolyFill routine for rise and fall glowing
'spinning diamond mini-micro script in micro(A)
' from Aurel Micro A trans: http://basic4all.epizy.com/index.php?topic=199.new#new
Screen _NewImage(800, 600, 32)
_ScreenMove 200, 0
Dim pi, p6, t, m, dir, glow, i, x, a, y, b, lx, ly, la, lb
pi = _Pi
p6 = pi / 6
t = 0
m = 400
dir = 1
glow = 50
Color _RGB32(200, 200, 240), _RGB32(0, 0, 0)
Dim As _Unsigned Long colr, edge
Dim poly(25)
edge = &H99AAAAFF
Do Until _KeyDown(27)
Cls
t = (t + 0.01)
i = 0
While i <= 12
r = Cos(p6 * i + t + ao)
x = m - 300 * r
a = m - 250 * r
y = 400 - 40 * Cos(p6 * (i - 3) + t + ao) - 140 + glow ' y
b = y + 50
Color _RGB32(200, 200, 240)
Line (m, 100 - 140 + glow)-(x, y), edge
Line (x, y)-(a, b), edge
If i Mod 2 Then colr = &H220000FF Else colr = &H2200FFFF
If i > 0 Then
Line (a, b)-(la, lb), edge ' bottom disk
Line (x, y)-(lx, ly), edge ' top disk
ftri lx, ly, x, y, a, b, colr
ftri a, b, la, lb, lx, ly, colr
ftri m, 100 - 140 + glow, lx, ly, x, y, colr
End If
poly(2 * i) = a
poly(2 * i + 1) = b
lx = x: ly = y
la = a: lb = b
i = i + 1
Wend
glow = glow + dir
If glow >= 256 Then dir = -dir: glow = 255
If glow <= 49 Then dir = -dir: glow = 50
PolyFill m, 450 - 140 + glow, poly(), _RGB32(200, 200, 255, glow)
_Display
_Limit 30
Loop
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
Sub PolyFill (xc, yc, poly(), K As _Unsigned Long) ' closed poly the last point repeats the first to close loop
Dim i
For i = LBound(poly) + 2 To UBound(poly) Step 2
ftri xc, yc, poly(i - 2), poly(i - 1), poly(i), poly(i + 1), K
Next
End SubSorry, @dbox, QBJS would have nothing to do with fTri (fill triangle)
There is a handy PolyFill routine in there, tell it the center x, y and an array (x, y, x, y, x, y...) of points on the perimeter and a color, and it will fill the N-gon with filled triangles of color specified.
RE: Proggies - dbox - 07-24-2022
(07-24-2022, 04:16 PM)bplus Wrote: Sorry, @dbox, QBJS would have nothing to do with fTri (fill triangle)
Yep, we haven’t added _MapTriangle yet but it is on the TODO list.
RE: Proggies - SierraKen - 07-24-2022
That rocks! Thanks B+. I may never learn how to make something like this but maybe someday.
RE: Proggies - bplus - 09-19-2022
Orbit Patterns
Code: (Select All)
_Title "Orbit Patterns" 'b+ started 2020-02-25
'can we find speeds for disks going in orbits around center st they form patterns
Const xmax = 700, ymax = 700, center = 350, P1 = _Pi, P2 = P1 * 2, PD2 = P1 * .5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 20
Dim rate(1 To 20)
For i = 1 To 20
rate(i) = (21 - i) / 12
Next
While _KeyDown(27) = 0
Cls
For r = 10 To 200 Step 10
Circle (center, center), r
i = Int(r / 10)
x = center + r * Cos(rate(i) * a)
y = center + r * Sin(rate(i) * a)
Circle (x, y), 5
Next
a = a + _Pi(2 / 120)
_Display
_Limit 30
WendRE: Proggies - bplus - 09-20-2022
OK now that we practiced with that:
Polygon Orbits
Code: (Select All)
Option _Explicit
_Title "Polygon Orbits 2" 'b+ 2020-02-25
' Fellippe's post 2020-02-25 https://www.qb64.org/forum/index.php?topic=2234.msg114766#msg114766
' Inspired by this post: https://www.reddit.com/r/gifs/comments/f91c99/every_addtional_shape_adds_one_more_corner_and/
Const xmax = 550, ymax = 550, side = 100, center = 275, P1 = _Pi, P2 = P1 * 2, PD2 = P1 * .5
Dim Shared poly$(3 To 15) 'point strings we will turn into arrays as needed
Dim Shared c(3 To 15) As _Unsigned Long 'colors
c(3) = &HFF550000: c(4) = &HFFAA0000: c(5) = &HFFFF0000: c(6) = &HFFDD4400: c(7) = &HFF888800: c(8) = &HFFFF8800
c(9) = &HFF00FF00: c(10) = &HFF00FF88: c(11) = &HFF00FFFF: c(12) = &HFF0088FF: c(13) = &HFF0000FF: c(14) = &HF88F0088: c(15) = &HFF330033
Dim Shared rate(3 To 15), radii(3 To 15), a 'for dots
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 20
Dim i, n, isoA, isoA2, turn, r, x1, y1, currA, x2, y2
For i = 3 To 15
rate(i) = (16 - i) / 12 'rate as angle mult that disc will move in circle
Next
For n = 3 To 15
a = P2 / n ' central angle
isoA = (P1 - a) / 2 ' angle of one iso triangle at base
isoA2 = isoA * 2 ' 2 iso's is interior angle at each node
turn = P1 - isoA2 ' for turtle drawing, turn this much at each point
r = .5 * side / Sin(a / 2) ' << so << 1/2 * side = r * sin(1/2 * a)
radii(n) = r
x1 = center + r * Cos(a / 2 + PD2): y1 = center + r * Sin(a / 2 + PD2)
poly$(n) = Str$(x1) + "," + Str$(y1) 'our first point for polygon
currA = P1 'turtle draw the rest of the poly and save the points
For i = 2 To n + 1
currA = currA + turn
x2 = x1 + side * Cos(currA): y2 = y1 + side * Sin(currA)
Line (x1, y1)-(x2, y2)
x1 = x2: y1 = y2
poly$(n) = poly$(n) + "," + Str$(x1) + "," + Str$(y1)
Next
Next
While _KeyDown(27) = 0
Cls
drawPolys
a = a + _Pi(2 / 120)
_Display
_Limit 30
Wend
Sub drawPolys
Dim n, i, Px, Py, dist, Rx, Ry, r, g, b
For n = 15 To 3 Step -1
'here is where we want our dot but we have to place on a line segment between two closest points to Px, Py
Px = center + radii(n) * Cos(rate(n) * a + PD2)
Py = center + radii(n) * Sin(rate(n) * a + PD2)
ReDim pts(0)
Split poly$(n), ",", pts()
ReDim min(1), save(1)
min(0) = 1000: min(1) = 1100: save(0) = -1: save(1) = -2 'dummy
For i = 0 To UBound(pts) Step 2
If i < 2 * n - 1 Then
dist = Sqr((Px - pts(i)) ^ 2 + (Py - pts(i + 1)) ^ 2)
If dist <= min(0) Then
min(1) = min(0): min(0) = dist: save(1) = save(0): save(0) = i
ElseIf dist <= min(1) Then
min(1) = dist: save(1) = i
End If
End If
If i = 0 Then
PSet (pts(0), pts(1)), c(n)
Else
Line -(pts(i), pts(i + 1)), c(n)
End If
Next
'now we have the two closest points of poly to px, py find Rx, RY on that line closest to Px, Py
If Abs(pts(save(0)) - pts(save(1))) < .001 Then 'have perpendicular line get Rx, Ry directly
Rx = pts(save(0)): Ry = Py
Else
PointOnLinePerp2Point pts(save(0)), pts(save(0) + 1), pts(save(1)), pts(save(1) + 1), Px, Py, Rx, Ry
End If
r = _Red32(c(n)): g = _Green32(c(n)): b = _Blue32(c(n))
For i = 9 To 0 Step -1
fcirc Rx, Ry, i, midInk(r, g, b, 255, 255, 255, (9 - i) / 9)
Next
Next
End Sub
Sub slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
If X1 = X2 Then
slope = X1
Yintercept = Y2
Else
slope = (Y2 - Y1) / (X2 - X1)
Yintercept = slope * (0 - X1) + Y1
End If
End Sub
Sub PointOnLinePerp2Point (Lx1, Ly1, Lx2, Ly2, Px, Py, Rx, Ry)
'
'this sub needs SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
'
'Lx1, Ly1, Lx2, Ly2 the two points that make a line
'Px, Py is point off the line
'Rx, Ry Return Point is the Point on the line perpendicular to Px, Py
Dim m, Y0, AA, B
slopeYintersect Lx1, Ly1, Lx2, Ly2, m, Y0
AA = m ^ 2 + 1
B = 2 * (m * Y0 - m * Py - Px)
Rx = -B / (2 * AA)
Ry = m * Rx + Y0
End Sub
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
'this sub modified for splitting into an single array!!!
Sub Split (SplitMeString As String, delim As String, loadMeArray())
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Val(Mid$(SplitMeString, curpos, dpos - curpos))
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000)
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Val(Mid$(SplitMeString, curpos))
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) 'get the ubound correct
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 SubRE: Proggies - James D Jarvis - 09-21-2022
Neato.
RE: Proggies - bplus - 09-21-2022
Thanks to James D Jarvis, your poly solids gave me idea for improvement to "Even Better Stars"
Even More Better Stars
Code: (Select All)
_Title "Even More Better Stars" 'b+ 2022-09-21
' Even Better Stars 2 Arrow Steering" 'b+ 2021-11-23 try with arrow steering
' Better Stars.sdlbas (B+=MGA) 2016-05-16
' odd or even number of point, fat or skinny, better fills
Const Pi = _Acos(-1) 'cute way to get pi
'Print (Pi) 'check pi
'End
Const Radians = Pi / 180 'to convert an angle measured in degrees to and angle measure in radians, just mutiply by this
Const Xmax = 700
Const Ymax = 700
Const Cx = Xmax / 2
Const Cy = Ymax / 2
'setdisplay(xmax, ymax, 32, 1)
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 300, 40
'setcaption("Better Stars demo")
'autoback(-2)
'main
Const NS = 100
Dim Shared x(NS), y(NS), dx(NS), dy(NS), ri(NS), ro(NS), p(NS), a(NS), turn(NS), fill(NS), c(NS) As _Unsigned Long
loopcounter = 0
For i = 0 To NS
NewStar i
Next
While _KeyDown(27) = 0
If _KeyDown(19200) Then ' turn left
For i = 0 To NS
x(i) = x(i) + 2 * ri(i) ^ 2
dx(i) = dx(i) + 1
Next
End If
If _KeyDown(19712) Then ' turn right
For i = 0 To NS
x(i) = x(i) - 2 * ri(i) ^ 2
dx(i) = dx(i) - 1
Next
End If
If _KeyDown(18432) Then ' turn up
For i = 0 To NS
y(i) = y(i) + 2 * ri(i) ^ 2
dy(i) = dy(i) + 1
Next
End If
If _KeyDown(20480) Then ' turn down
For i = 0 To NS
y(i) = y(i) - 2 * ri(i) ^ 2
dy(i) = dy(i) - 1
Next
End If
Line (0, 0)-(Xmax, Ymax), _RGB32(0, 0, 0, 10), BF
For i = 0 To NS
If x(i) > 0 And x(i) < Xmax And y(i) > 0 And y(i) < Ymax Then
'ink(colr(c(i)))
Color c(i)
Star x(i), y(i), ri(i), ro(i), p(i), a(i), fill(i)
x(i) = x(i) + dx(i)
y(i) = y(i) + dy(i)
ri(i) = 1.015 * ri(i)
ro(i) = 1.015 * ro(i)
a(i) = a(i) + turn(i)
Else
NewStar i
End If
Next
'screenswap
_Display
_Limit 100
'wait(50)
loopcounter = loopcounter + 1
Wend
Sub NewStar (nxt)
angle = Rnd * 2 * Pi
r = Rnd * 6 + 1
dx(nxt) = r * Cos(angle)
dy(nxt) = r * Sin(angle)
r = Rnd * 300
x(nxt) = Cx + r * dx(nxt)
y(nxt) = Cy + r * dy(nxt)
ri(nxt) = Rnd
ro(nxt) = ri(nxt) + 1 + Rnd
p(nxt) = 3 + Int(Rnd * 9)
a(nxt) = Rnd * 2 * Pi
turn(nxt) = Rnd * 6 - 3
fill(nxt) = 0 'Int(Rnd * 2)
c(nxt) = rndColor~&
End Sub
Function rndColor~& ()
rndColor~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
End Function
Sub Star (x, y, rInner, rOuter, nPoints, angleOffset, TFfill)
' x, y are same as for circle,
' rInner is center circle radius
' rOuter is the outer most point of star
' nPoints is the number of points,
' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
' this is to allow us to spin the polygon of n sides
' TFfill filled True or False (1 or 0)
p_angle = Radians * (360 / nPoints): rad_angle_offset = Radians * angleOffset
x1 = x + rInner * Cos(rad_angle_offset)
y1 = y + rInner * Sin(rad_angle_offset)
For i = 0 To nPoints - 1
x2 = x + rOuter * Cos(i * p_angle + rad_angle_offset + .5 * p_angle)
y2 = y + rOuter * Sin(i * p_angle + rad_angle_offset + .5 * p_angle)
x3 = x + rInner * Cos((i + 1) * p_angle + rad_angle_offset)
y3 = y + rInner * Sin((i + 1) * p_angle + rad_angle_offset)
Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
x1 = x3: y1 = y3
Next
If TFfill Then
'Circle (x, y), 2, &HFFFFFFFF
Paint (x, y), _DefaultColor, _DefaultColor
End If
End SubRE: Proggies - James D Jarvis - 09-21-2022
Excellent. Drawing stars is how I ended up with my ROTPOLY sub.
RE: Proggies - bplus - 09-21-2022
Meandering Circuits Struck by Lightning
Code: (Select All)
_Title "Adding some lightning, press any on beep" ' b+ 2020-09-17 so much better in living color!!
' ah much better response on on escape or Q to quit! too.
Screen _NewImage(1024, 620, 32)
_Delay .25
_ScreenMove _Middle
'_FULLSCREEN
Randomize Timer
Const flashy = &HFFFFFF00
Type box
x As Single
y As Single
w As Single
h As Single
K As _Unsigned Long
hit As Integer
End Type
Type move
x As Single
y As Single
'd AS INTEGER
End Type
Dim Shared beeLineK As _Unsigned Long, gSize As Integer
ReDim Shared VS(_Width, _Height)
Dim backColor As _Unsigned Long, hc As Integer
Do
'whole new set
ReDim VS(_Width, _Height)
gSize = units(Int(20 * Rnd) + 6, 5)
nBoxes = Int(Sqr(_Width * _Height) / gSize * Rnd) + 1
If nBoxes < 40 Then nBoxes = 40
If nBoxes > 100 Then nBoxes = 100
Color &HFFFFFFFF, &HFF000000
Print gSize, nBoxes
'_DISPLAY
ReDim b(1 To nBoxes) As box 'new box set
For i = 1 To nBoxes
tryAgain:
b(i).x = units(Rnd * (_Width - 2 * (gSize + 1)) + gSize + 1, gSize) 'get x, y off the edges of screen!
b(i).y = units(Rnd * (_Height - 2 * (gSize + 1)) + gSize + 1, gSize)
If i > 1 Then
OK = -1
For j = 1 To i - 1
If _Hypot(b(j).x - b(i).x, b(j).y - b(i).y) < 3 * gSize Then OK = 0: Exit For
Next
If OK = 0 Then GoTo tryAgain
End If
b(i).w = gSize + Rnd * gSize * .5
b(i).h = gSize + Rnd * gSize * .5
b(i).K = _RGB32(Rnd * 85 + 170, Rnd * 85 + 170, Rnd * 85 + 170)
Next
backColor = _RGB32(Rnd * 65, Rnd * 65, Rnd * 65)
hc = maxC(backColor)
If hc = 1 Then beeLineK = _RGB32(0, Rnd * 85 + 85, Rnd * 85 + 85)
If hc = 2 Then beeLineK = _RGB32(Rnd * 85 + 85, 0, Rnd * 85 + 85)
If hc = 3 Then beeLineK = _RGB32(Rnd * 85 + 85, Rnd * 85 + 85, 0)
Color , backColor
Cls
drawGrid gSize, gSize, _Width - 1, _Height - 1, gSize, &HFF404040
'SLEEP
For i = 2 To nBoxes ' draw the meanderings
meander2 b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
Line (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-Step(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
Next
For i = 1 To nBoxes
Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
Next
' and now for some lightning!!!
grd& = _NewImage(_Width, _Height, 32)
_PutImage , 0, grd&
Dim i As Long
i = 0
ReDim flash As box, moves(0) As move, mItem As move
r = Int(Rnd * nBoxes) + 1 'pick a place to strike, light it up
moves(i).x = b(r).x: moves(i).y = b(r).y: flash.w = b(r).w: flash.h = b(r).h: flash.K = flashy
Line (moves(i).x - .5 * flash.w, moves(i).y - .5 * flash.h)-Step(flash.w, flash.h), flashy, BF
GoSub checkoutThePlace
oldUB = 0
circuit:
ub = UBound(moves)
If ub > oldUB Then
_PutImage , grd&, 0
For i = 1 To nBoxes
If b(i).hit Then Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), &HFF551100, BF
Next
For i = oldUB To ub
fcirc moves(i).x, moves(i).y, .33 * gSize, flashy - Rnd * 150
For j = 1 To nBoxes
If moves(i).x = b(j).x And moves(i).y = b(j).y Then b(j).hit = 1
Next
GoSub checkoutThePlace
Next
oldUB = ub
_Display
_Limit 10
GoTo circuit
End If
_PutImage , grd&, 0
For i = 1 To nBoxes
If b(i).hit Then Line (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-Step(b(i).w, b(i).h), &HFF551100, BF
Next
Beep
_FreeImage grd&
_AutoDisplay
Sleep
Loop Until _KeyDown(27) Or UCase$(InKey$) = "Q"
End
checkoutThePlace:
If moves(i).x + .5 * gSize >= 0 And moves(i).x + .5 * gSize < _Width Then
If VS(moves(i).x + .5 * gSize, moves(i).y) = 1 Then
mItem.x = moves(i).x + gSize: mItem.y = moves(i).y
sAppend moves(), mItem
VS(moves(i).x + .5 * gSize, moves(i).y) = 0
End If
End If
If moves(i).y + .5 * gSize >= 0 And moves(i).y + .5 * gSize < _Height Then
If VS(moves(i).x, moves(i).y + .5 * gSize) = 1 Then
mItem.x = moves(i).x: mItem.y = moves(i).y + gSize
sAppend moves(), mItem
VS(moves(i).x, moves(i).y + .5 * gSize) = 0
End If
End If
If moves(i).x - .5 * gSize >= 0 And moves(i).x - .5 * gSize < _Width Then
If VS(moves(i).x - .5 * gSize, moves(i).y) = 1 Then
mItem.x = moves(i).x - gSize: mItem.y = moves(i).y
sAppend moves(), mItem
VS(moves(i).x - .5 * gSize, moves(i).y) = 0
End If
End If
If moves(i).y - .5 * gSize >= 0 And moves(i).y - .5 * gSize < _Height Then
If VS(moves(i).x, moves(i).y - .5 * gSize) = 1 Then
mItem.x = moves(i).x: mItem.y = moves(i).y - gSize
sAppend moves(), mItem
VS(moves(i).x, moves(i).y - .5 * gSize) = 0
End If
End If
Return
Sub meander2 (x1, y1, x2, y2) ' snap to grid! gSize is shared
startx = x1: starty = y1: endx = x2: endy = y2
x = startx: y = starty
GoSub dist
If dist > 100 Then
time = Int(Rnd * 8 + 4) ' total amount allowed to move The More the time the more the meander!!!!
Else
time = 3
End If
startTime = time ' > 20 is too much!!
If Rnd < .5 Then lastmoveX = 0 Else lastmoveX = -1
lastx = startx: lasty = starty
Do
GoSub dist
If Rnd < .5 Then d = -1 Else d = 1
If lastmoveX = 0 Then
lastx = x
If time <= 2 Then
x = endx
Else
dx = units(d * (.4 * distx * Rnd + gSize), gSize)
If dx = 0 Then dx = gSize
If x + dx > 0 And x + dx < _Width Then
x = x + dx
Else
x = x + -dx
End If
End If
'LINE (lastx, y)-(x, y)
beeline lastx, y, x, y
lastmoveX = -1
Else
lasty = y
If time <= 2 Then
y = endy
Else
dy = units(d * (.3 * disty * Rnd + gSize), gSize)
If dy = 0 Then dy = gSize
If y + dy > 0 And y + dy < _Height Then
y = y + dy
Else
y = y + -dy
End If
End If
'LINE (x, lasty)-(x, y)
beeline x, lasty, x, y
lastmoveX = 0
End If
time = time - 1
'_LIMIT 10
Loop Until time <= 0
Exit Sub
dist:
distx = endx - x: disty = endy - y
Return
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
Sub beeline (x1, y1, x2, y2)
If x1 = x2 Then
If y1 <= y2 Then For y = y1 To y2: fcirc x1, y, 1, beeLineK: VS(Int(x1), Int(y)) = 1: Next
If y1 > y2 Then For y = y1 To y2 Step -1: fcirc x1, y, 1, beeLineK: VS(Int(x1), Int(y)) = 1: Next
Else
If x1 <= x2 Then For x = x1 To x2: fcirc x, y1, 1, beeLineK: VS(Int(x), Int(y1)) = 1: Next
If x1 > x2 Then For x = x1 To x2 Step -1: fcirc x, y1, 1, beeLineK: VS(Int(x), Int(y1)) = 1: Next
End If
End Sub
Function maxC (K As _Unsigned Long)
If _Red32(K) >= _Green32(K) And _Red32(K) >= _Blue32(K) Then maxC = 1: Exit Function
If _Green32(K) >= _Blue(K) Then maxC = 2 Else maxC = 3
End Function
' this sub needs FUNCTION units (x, unit)
Sub drawGrid (x1, y1, x2, y2, gsize, gridClr As _Unsigned Long) ' grid of square gsize X gsize
' fit a grid between x1, x2 and y1, y2
' x1, y1 top right corner and x2, y2 expected bottom right corner of boundary line
Dim x As Integer, y As Integer, gx1 As Integer, gy1 As Integer, gx2 As Integer, gy2 As Integer
gx1 = units(x1, gsize): gy1 = units(y1, gsize) 'convert to grid coordinates
gx2 = units(x2, gsize): gy2 = units(y2, gsize)
If gx1 < x1 Then gx1 = gx1 + gsize 'stay inside boundarys passed to sub
If gy1 < y1 Then gy1 = gy1 + gsize
If gx1 >= gx2 Or gy1 >= gy2 Then Exit Sub 'that's not even a single square!
For x = gx1 To gx2 Step gsize: Line (x, gy1)-(x, gy2), gridClr: Next
For y = gy1 To gy2 Step gsize: Line (gx1, y)-(gx2, y), gridClr: Next
End Sub
Function units (x, unit)
units = Int(x / unit) * unit
End Function
Sub sAppend (arr() As move, addItem As move)
ReDim _Preserve arr(LBound(arr) To UBound(arr) + 1) As move
arr(UBound(arr)) = addItem
End Sub