+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Utilities (https://staging.qb64phoenix.com/forumdisplay.php?fid=8)
+---- Thread: Everything in Degrees instead of Radians (/showthread.php?tid=967)
RE: Everything in Degrees instead of Radians - bplus - 10-20-2022
This problem was started by James in Help Me Board and is quite a challenge and has inspired previous 2 posts by me here and now a 3rd post.
Containing a bouncing circle inside a raggedy frame of random line segments, the problem arises, for me, of overcoming "stuck" points where the circle runs into a segment corner (called peninsulas by me) here the circle center may be clear of corner but it's lower body gets stuck pressing into corner.
First how to detect stick points in code?
2nd how to escape them?
To detect a stick, I just check the new coordinates of circle x, y if neither of them has changed, it's stuck.
If I find that condition then I change the ball angle to the perpendicular of the line segment (blue color code) it's mostly stuck at instead of using it's natural reflective angle (white color code). This seems to get the ball clear most every time.
There are times when ball gets wedged into a "bay" and this method of getting unstuck doesn't look like it would help much, the white arrow looks like the best way out but using the perpendicular doesn't seem to get it stuck worse...
See for yourself, let this demo run in delay mode (press d to toggle on/off) when you here a beep it will stop show arrows and attempt to use the blue direction angle (perpendicular to the line segment it's hitting) instead of the normal white reflective angle. (In delay mode, it will stop and show color coded arrows at every hit with boundary.)
When delay mode is not toggled, you will hear a BEEP and the beep will be counted but the circle just keeps moving the color coded arrows don't show up at that speed.
Code: (Select All)
Option _Explicit
_Title "James Random Container 4" ' b+ 2022-10-19
' Modify the lineSegIntersectCircle function to count number of points intersecting
' if more than one line segment do the one with the most points Yes! works better.
' Still can get a point stuck but it doesn't fly out of bounds.
' 2022-10-19 Aha! a simple solution to being stuck on peninsulas, just back out 1 more time
' nope, nor 2 more, nor until both x or y change more than a pixel
' Now we are getting stuck in bays as well as peninsulas! and it seems bad choice to use segment
' normal to get out of a bay, usually just follow white arrow for bays...
' Move Container making code into a sub and make doubly raggety changing min 80 to min 40
' Added delaid mode toggle with d keypresses listen for BEEP in this mode it goes into sleep mode.
' Have to press a key to continue...
Screen _NewImage(800, 680, 32)
_ScreenMove 250, 50
Randomize Timer
_PrintMode _KeepBackground
Type lineSegment
As Single x1, y1, x2, y2, dN ' 2 end points and an angle pointing towards center (I think)
End Type
Dim Shared As Long Container, Nlines, L
ReDim Shared Boundaries(1 To 100) As lineSegment
MakeContainer ' for background ball boundaries
Dim bx, by, ba, br, bspeed, diff, test, saveL, hits ' now for bouncing circles around
Dim saveBx, saveBy, Beeps, delaid ' more variables to handle getting stuck
bx = _Width / 2: by = _Height / 2: bspeed = 5
br = 15 ' make ball radius (br) at least 2* speed
ba = Rnd * 360 ' setup up ball in middle of screen/container random heading = ba (ball angle)
' ok just bounce ball around the polygon container
Do
_PutImage , Container, 0
Locate 1, 1: Print " Number of times line segment perpendicular used to prevent getting stuck"; Beeps
Circle (bx, by), br ' draw ball then calc next loaction
bx = bx + bspeed * CosD(ba) ' test x, y is new ball position if dont run into wall
by = by + bspeed * SinD(ba)
hits = 0: saveL = 0
For L = 1 To Nlines ' get line segment with highest hit count if any
test = lineSegIntersectCircle(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).y2, bx, by, br)
If test > hits Then saveL = L: hits = test
Next
' probably should back it up before processing bounce
If hits Then ' backup circle
While lineSegIntersectCircle(Boundaries(saveL).x1, Boundaries(saveL).y1, Boundaries(saveL).x2, Boundaries(saveL).y2, bx, by, br) ' back up circle
bx = bx + CosD(ba - 180)
by = by + SinD(ba - 180)
Wend
'' getting over the peninsula's mod 2022-10-19 one more backout? this did not help much
'For i = 1 To 2
'bx = bx + CosD(ba - 180)
'by = by + SinD(ba - 180)
'Next
' =========================== fix penisula stick problem ???????????????????????????????????????????
_PutImage , Container, 0 ' show circle hit on boundary
Locate 1, 1: Print " Number of times line segment perpendicular used to prevent getting stuck"; Beeps
Circle (bx, by), br
' Yellow arrow for incoming towards boundary (I reversed the head of arrow to compare to reflection angle)
ArrowTo bx + 3 * br * CosD(ba + 180), by + 3 * br * SinD(ba + 180), ba, 3 * br, &HFFFFFF00
' Blue Vector Perpendicular to plane
ArrowTo bx, by, Boundaries(saveL).dN, 5 * br, &HFF0000FF
' Reflected ball off line are we stuck???
If Abs(bx - saveBx) > 1 Or Abs(by - saveBy) > 1 Then ' NO ball is moving right along
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>> new direction
Else '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Quite likely stuck so use the normal angle for ba
If delaid Then
' show what I would normally do with ball
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> new direction
ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
_Display
End If
Beep ' indicate by sound that the alternate angle for ball was used
Beeps = Beeps + 1
If delaid Then Sleep
' now fix angle to normal instead of regular method
ba = Boundaries(saveL).dN ' >>>>>>>>>>>>>>>>>>>>>>> new direction from line segment perpendicular angle
End If
ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
saveBx = bx: saveBy = by
_Display
If delaid Then _Delay 1 'comment out to find stucks faster
End If
If InKey$ = "d" Then delaid = 1 - delaid ' toggle dlaid mode
_Display
_Limit 300
Loop Until _KeyDown(27)
Sub MakeContainer
Dim cx, cy, x1, y1, flag, x2, y2 ' building container
Dim As _Unsigned Long c1
cx = _Width / 2: cy = _Height / 2 + 40
c1 = _RGB32(0, 150, 85) ' minty green background out of bounds
Cls
x1 = 50
y1 = 50
flag = 0
While flag = 0
x2 = (Rnd * 80) + 40 + x1
If x2 > 750 Then
x2 = 750
flag = 1
End If
y2 = Rnd * 60 + 20
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
y2 = (Rnd * 80) + 40 + y1
If y2 > 550 Then
y2 = 550
flag = 1
End If
x2 = 750 - (Rnd * 60 + 20)
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
x2 = x1 - ((Rnd * 80) + 40)
If x2 < 50 Then
x2 = 50
flag = 1
End If
y2 = 550 - (Rnd * 60 + 20)
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
y2 = y1 - ((Rnd * 80) + 40)
If y2 < 50 Then
y2 = 50
flag = 1
End If
x2 = Rnd * 60 + 20
If flag = 1 Then x2 = 50
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
Paint (1, 1), c1, c1
Locate 37, 1
Print " Press d for delay mode, if you hear a beep then in sleep mode showing potential stuck point,"
Print " press any to continue... Yellow = the angle of ball heading towards line,"
Print " Blue = angle perpendicular (normal) to boundary line. White = angle of reflection off line."
Container = _NewImage(_Width, _Height, 32)
_PutImage , 0, Container
End Sub
' return count of how many points overlap segment
Function lineSegIntersectCircle (x1, y1, x2, y2, cx, cy, r)
' x1, y1 and x2, y2 are end points of line segment
' cx, cy are circle center with radius r
Dim rtn, d, dx, dy, i, x, y
d = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
dx = (x2 - x1) / d
dy = (y2 - y1) / d
For i = 0 To d
x = x1 + dx * i
y = y1 + dy * i
If Sqr((x - cx) ^ 2 + (y - cy) ^ 2) <= r Then rtn = rtn + 1
Next
lineSegIntersectCircle = rtn
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function CosD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
CosD = Cos(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function SinD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
SinD = Sin(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function DAtan2 (x1, y1, x2, y2) ' The angle in degrees a 2nd point (x2, y2) makes to a first point (x1, y1)
' Note this function uses whatever the default type is, better not be some Integer Type.
' Delta means change between 1 measure and another for example x2 - x1
Dim deltaX, deltaY, rtn
deltaX = x2 - x1
deltaY = y2 - y1
' To find the angle point(x2, y2) makes to (x1, y1) in Degrees
' Take DegreeAngle = DAtan2(y2 - y1, x2 - x1)
rtn = _R2D(_Atan2(deltaY, deltaX))
If rtn < 0 Then DAtan2 = rtn + 360 Else DAtan2 = rtn
End Function
' use angles in degrees units instead of radians (converted inside sub)
Sub ArrowTo (BaseX As Long, BaseY As Long, dAngle As Double, lngth As Long, colr As _Unsigned Long)
Dim As Long x1, y1, x2, y2, x3, y3
Dim As Double rAngle
rAngle = _D2R(dAngle)
x1 = BaseX + lngth * Cos(rAngle)
y1 = BaseY + lngth * Sin(rAngle)
x2 = BaseX + .8 * lngth * Cos(rAngle - _Pi(.05))
y2 = BaseY + .8 * lngth * Sin(rAngle - _Pi(.05))
x3 = BaseX + .8 * lngth * Cos(rAngle + _Pi(.05))
y3 = BaseY + .8 * lngth * Sin(rAngle + _Pi(.05))
Line (BaseX, BaseY)-(x1, y1), colr
Line (x1, y1)-(x2, y2), colr
Line (x1, y1)-(x3, y3), colr
End SubThe circle does not get stuck at this peninsula, you don't see the white arrow pushing into the corner.
Here is a common example of when a circle does get stuck because the white arrow is headed straight into the point of peninsula and the lower body is going to collide with it. Here you can see why the blue arrow direction is the way out of being stuck.
RE: Everything in Degrees instead of Radians - bplus - 11-01-2022
Oh I forgot to post my solution to James Container #5, where the ball no longer gets stuck on peninsulas. @TempodiBasic comment reminded me of it.
Here is solution, I added a message box to stop in the places I was getting hung at. Part of the solution was to use average of normal directions when ball is in 2 lines ie peninsula but also bays too if I recall. Sometimes on rare occasions the calculation is wrong usually in upper left corner, that's where message box shows the average angle that looks wrong and the corrected direction.
Code: (Select All)
Option _Explicit
_Title "James Random Container 5" ' b+ 2022-10-21
' Modify the lineSegIntersectCircle function to count number of points intersecting
' if more than one line segment do the one with the most points Yes! works better.
' Still can get a point stuck but it doesn't fly out of bounds.
' 2022-10-19 Aha! a simple solution to being stuck on peninsulas, just back out 1 more time
' nope, nor 2 more, nor until both x or y change more than a pixel
' Now we are getting stuck in bays as well as peninsulas! and it seems bad choice to use segment
' normal to get out of a bay, usually just follow white arrow for bays...
' Move Container making code into a sub and make doubly raggety changing min 80 to min 40
' Added delaid mode toggle with d keypresses listen for BEEP in this mode it goes into sleep mode.
' Have to press a key to continue...
' 2022-10-21 Container #5 OK this time around let's average the normals (hopefully only 2) I think
' for both innies and outies the aveage of 2 line segments will be ideal path out of either.
' Yes that works fine until the average is screwed up in top left corner mostly, very rare!
' I am tracking normal reflections, reflections by average of perpediculars when more than one segment
' and finally fixed average by simply using the angle to screen center!
' I've added my message box code for showing the wrongness of the avaerage and the fixed angle.
Screen _NewImage(800, 680, 32)
_ScreenMove 250, 10
Randomize Timer
Const x0 = 400, y0 = 300, bspeed = 5, br = 15 ' make ball radius (br) at least 2 * speed
_PrintMode _KeepBackground
Type lineSegment
As Single x1, y1, x2, y2, dN ' 2 end points and an Normal angle pointing towards center
End Type
Dim Shared As Long Container, Nlines, L ' building a Random Container with NLines random lines
Dim bx, by, ba ' changing ball location and angle
Dim test, saveL, totN, hits, totLinesHit ' now for bouncing circles around, finding the best reflection
Dim saveBx, saveBy, diff ' check for stuckness
Dim delaid, delayT, k$ ' delay mode and time, key check for reset, escape delay mode toggle
Dim As Long nr, anr, fixr ' track types of bounces
' nr = normal reflection, anr = average of 2 normals, fixr is fixed average
restart:
Nlines = 0: nr = 0: anr = 0: fixr = 0 'reset report data
ReDim Shared Boundaries(1 To 100) As lineSegment
MakeContainer ' for background ball boundaries
bx = x0: by = y0: ba = Rnd * 360 ' setup up ball in middle of screen/container random heading = ba (ball angle)
' ok just bounce ball around the polygon container
Do
_PutImage , Container, 0
Locate 1, 1: Print " Normal Reflection:"; nr; ", (beep) average normals:"; anr; ", (mbox) fixed average:"; fixr
Circle (bx, by), br ' draw ball then calc next loaction
bx = bx + bspeed * CosD(ba) ' test x, y is new ball position if dont run into wall
by = by + bspeed * SinD(ba)
hits = 0: saveL = 0: totN = 0: totLinesHit = 0
For L = 1 To Nlines ' get line segment with highest hit count if any
test = lineSegIntersectCircle(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).y2, bx, by, br)
If test Then
If test > hits Then saveL = L: hits = test ' save the line number with greatest anount of hits to backup from
totN = totN + Boundaries(L).dN: totLinesHit = totLinesHit + 1 ' save data to get an average N
End If
Next
delayT = 0
If hits Then ' back circle out of most hit line should show up right next to line
While lineSegIntersectCircle(Boundaries(saveL).x1, Boundaries(saveL).y1, Boundaries(saveL).x2, Boundaries(saveL).y2, bx, by, br) ' back up circle
bx = bx + CosD(ba - 180)
by = by + SinD(ba - 180)
Wend
_PutImage , Container, 0 ' show circle hit on boundary
Locate 1, 1: Print " Normal Reflection:"; nr; ", (beep) average normals:"; anr; ", (mbox) fixed average:"; fixr
Circle (bx, by), br
' Yellow arrow for incoming towards boundary (I reversed the head of arrow to compare to reflection angle)
ArrowTo bx + 3 * br * CosD(ba + 180), by + 3 * br * SinD(ba + 180), ba, 3 * br, &HFFFFFF00
' Blue Vector Perpendicular to plane
ArrowTo bx, by, Boundaries(saveL).dN, 5 * br, &HFF0000FF
If Abs(bx - saveBx) > 1 Or Abs(by - saveBy) > 1 Then ' Ball is moving right along
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>> new direction
delayT = 1: nr = nr + 1
Else ' could be stuck
If totLinesHit = 1 Then
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>> new direction
delayT = 1: nr = nr + 1
ElseIf totLinesHit > 1 Then
'If totLinesHit > 1 Then
' new 2022-10-21 fix angle to average of normals hit totN is total or all Normals / total lines hit
' new ball direction is average of normals
ba = totN / totLinesHit ' >>>>>>>>>>>>>>>>>>>>>>> new direction from line segment perpendicular angle
delayT = 3: Beep: anr = anr + 1
If Abs(ba - DAtan2(bx, by, x0, y0)) > 90 And Abs(ba - 360 - DAtan2(bx, by, x0, y0)) > 90 Then
Beep ' indicate by sound that the alternate angle for ball was used
mBox "Multiple Line hits", "Ave of norms looks wrong:" + Str$(totN / totLinesHit) + ", fixed using:" + Str$(DAtan2(bx, by, x0, y0))
ba = DAtan2(bx, by, x0, y0)
fixr = fixr + 1
End If
End If
End If
If delaid Then
ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
_Display
_Delay delayT
End If
End If
ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
saveBx = bx: saveBy = by
_Display
k$ = InKey$
If k$ = "d" Then
delaid = 1 - delaid ' toggle dlaid mode
ElseIf k$ = "r" Then
GoTo restart
End If
_Limit 300
Loop Until _KeyDown(27)
Sub MakeContainer
Dim cx, cy, x1, y1, flag, x2, y2 ' building container
Dim As _Unsigned Long c1
cx = _Width / 2: cy = _Height / 2 + 40
c1 = _RGB32(0, 150, 85) ' minty green background out of bounds
Cls
x1 = 50
y1 = 50
flag = 0
While flag = 0
x2 = (Rnd * 80) + 40 + x1
If x2 > 750 Then
x2 = 750
flag = 1
End If
y2 = Rnd * 60 + 20
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
If Boundaries(Nlines).dN > 359.99999 Then Boundaries(Nlines).dN = Boundaries(Nlines).dN - 360
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
y2 = (Rnd * 80) + 40 + y1
If y2 > 550 Then
y2 = 550
flag = 1
End If
x2 = 750 - (Rnd * 60 + 20)
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
x2 = x1 - ((Rnd * 80) + 40)
If x2 < 50 Then
x2 = 50
flag = 1
End If
y2 = 550 - (Rnd * 60 + 20)
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
flag = 0
While flag = 0
y2 = y1 - ((Rnd * 80) + 40)
If y2 < 50 Then
y2 = 50
flag = 1
End If
x2 = Rnd * 60 + 20
If flag = 1 Then x2 = 50
Line (x1, y1)-(x2, y2), c1
Nlines = Nlines + 1
Boundaries(Nlines).x1 = x1: Boundaries(Nlines).y1 = y1
Boundaries(Nlines).x2 = x2: Boundaries(Nlines).y2 = y2
Boundaries(Nlines).dN = DAtan2(x1, y1, x2, y2) + 90 ' the angle x2, y2 is to x1, y1 + 90 points inward
x1 = x2
y1 = y2
Wend
Paint (1, 1), c1, c1
Locate 37, 1
Print " Press d for delay mode, stop at every intersect. Yellow = the angle of ball heading towards line,"
Print " Blue = angle perpendicular (normal) to boundary line. White = angle of reflection off line."
Print " A longer pause and beep is an average of 2 normals."
Print " Press r to reset boundary lines, escape to quite."
Container = _NewImage(_Width, _Height, 32)
_PutImage , 0, Container
End Sub
' return count of how many points overlap segment
Function lineSegIntersectCircle (x1, y1, x2, y2, cx, cy, r)
' x1, y1 and x2, y2 are end points of line segment
' cx, cy are circle center with radius r
Dim rtn, d, dx, dy, i, x, y
d = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
dx = (x2 - x1) / d
dy = (y2 - y1) / d
For i = 0 To d
x = x1 + dx * i
y = y1 + dy * i
If Sqr((x - cx) ^ 2 + (y - cy) ^ 2) <= r Then rtn = rtn + 1
Next
lineSegIntersectCircle = rtn
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function CosD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
CosD = Cos(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function SinD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
SinD = Sin(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function DAtan2 (x1, y1, x2, y2) ' The angle in degrees a 2nd point (x2, y2) makes to a first point (x1, y1)
' Note this function uses whatever the default type is, better not be some Integer Type.
' Delta means change between 1 measure and another for example x2 - x1
Dim deltaX, deltaY, rtn
deltaX = x2 - x1
deltaY = y2 - y1
' To find the angle point(x2, y2) makes to (x1, y1) in Degrees
' Take DegreeAngle = DAtan2(y2 - y1, x2 - x1)
rtn = _R2D(_Atan2(deltaY, deltaX))
If rtn < 0 Then DAtan2 = rtn + 360 Else DAtan2 = rtn
End Function
' use angles in degrees units instead of radians (converted inside sub)
Sub ArrowTo (BaseX As Long, BaseY As Long, dAngle As Double, lngth As Long, colr As _Unsigned Long)
Dim As Long x1, y1, x2, y2, x3, y3
Dim As Double rAngle
rAngle = _D2R(dAngle)
x1 = BaseX + lngth * Cos(rAngle)
y1 = BaseY + lngth * Sin(rAngle)
x2 = BaseX + .8 * lngth * Cos(rAngle - _Pi(.05))
y2 = BaseY + .8 * lngth * Sin(rAngle - _Pi(.05))
x3 = BaseX + .8 * lngth * Cos(rAngle + _Pi(.05))
y3 = BaseY + .8 * lngth * Sin(rAngle + _Pi(.05))
Line (BaseX, BaseY)-(x1, y1), colr
Line (x1, y1)-(x2, y2), colr
Line (x1, y1)-(x3, y3), colr
End Sub
Sub mBox (title As String, m As String)
Dim bg As _Unsigned Long, fg As _Unsigned Long
bg = &H33404040
fg = &HFF33AAFF
'first screen dimensions and items to restore at exit
Dim sw As Long, sh As Long
Dim curScrn As Long, backScrn As Long, mbx As Long 'some handles
Dim ti As Long, limit As Long 'ti = text index for t$(), limit is number of chars per line
Dim i As Long, j As Long, ff As _Bit, addb As _Byte 'index, flag and
Dim bxH As Long, bxW As Long 'first as cells then as pixels
Dim mb As Long, mx As Long, my As Long, mi As Long, grabx As Long, graby As Long
Dim tlx As Long, tly As Long 'top left corner of message box
Dim lastx As Long, lasty As Long, t As String, b As String, c As String, tail As String
Dim d As String, r As Single, kh As Long
'screen and current settings to restore at end ofsub
ScnState 0
sw = _Width: sh = _Height
_KeyClear '<<<<<<<<<<<<<<<<<<<< do i still need this? YES! 2019-08-06 update!
'screen snapshot
curScrn = _Dest
backScrn = _NewImage(sw, sh, 32)
_PutImage , curScrn, backScrn
'setup t() to store strings with ti as index, linit 58 chars per line max, b is for build
ReDim t(0) As String: ti = 0: limit = 58: b = ""
For i = 1 To Len(m)
c = Mid$(m, i, 1)
'are there any new line signals, CR, LF or both? take CRLF or LFCR as one break but dbl LF or CR means blank line
Select Case c
Case Chr$(13) 'load line
If Mid$(m, i + 1, 1) = Chr$(10) Then i = i + 1
t(ti) = b: b = "": ti = ti + 1: ReDim _Preserve t(ti) As String
Case Chr$(10)
If Mid$(m, i + 1, 1) = Chr$(13) Then i = i + 1
t(ti) = b: b = "": ti = ti + 1: ReDim _Preserve t(ti)
Case Else
If c = Chr$(9) Then c = Space$(4): addb = 4 Else addb = 1
If Len(b) + addb > limit Then
tail = "": ff = 0
For j = Len(b) To 1 Step -1 'backup until find a space, save the tail end for next line
d = Mid$(b, j, 1)
If d = " " Then
t(ti) = Mid$(b, 1, j - 1): b = tail + c: ti = ti + 1: ReDim _Preserve t(ti)
ff = 1 'found space flag
Exit For
Else
tail = d + tail 'the tail grows!
End If
Next
If ff = 0 Then 'no break? OK
t(ti) = b: b = c: ti = ti + 1: ReDim _Preserve t(ti)
End If
Else
b = b + c 'just keep building the line
End If
End Select
Next
t(ti) = b
bxH = ti + 3: bxW = limit + 2
'draw message box
mbx = _NewImage(60 * 8, (bxH + 1) * 16, 32)
_Dest mbx
Color _RGB32(128, 0, 0), _RGB32(225, 225, 255)
Locate 1, 1: Print Left$(Space$((bxW - Len(title) - 3) / 2) + title + Space$(bxW), bxW)
Color _RGB32(225, 225, 255), _RGB32(200, 0, 0)
Locate 1, bxW - 2: Print " X "
Color fg, bg
Locate 2, 1: Print Space$(bxW);
For r = 0 To ti
Locate 1 + r + 2, 1: Print Left$(" " + t(r) + Space$(bxW), bxW);
Next
Locate 1 + bxH, 1: Print Space$(limit + 2);
'now for the action
_Dest curScrn
'convert to pixels the top left corner of box at moment
bxW = bxW * 8: bxH = bxH * 16
tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
lastx = tlx: lasty = tly
'now allow user to move it around or just read it
While 1
Cls
_PutImage , backScrn
_PutImage (tlx, tly), mbx, curScrn
_Display
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then 'mouse down on title bar
If mx >= tlx + bxW - 24 Then Exit While
grabx = mx - tlx: graby = my - tly
Do While mb 'wait for release
mi = _MouseInput: mb = _MouseButton(1)
mx = _MouseX: my = _MouseY
If mx - grabx >= 0 And mx - grabx <= sw - bxW And my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
If ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .5 > 10 Then
tlx = mx - grabx: tly = my - graby
Cls
_PutImage , backScrn
_PutImage (tlx, tly), mbx, curScrn
lastx = tlx: lasty = tly
_Display
End If
End If
_Limit 400
Loop
End If
End If
kh = _KeyHit
If kh = 27 Or kh = 13 Or kh = 32 Then Exit While
_Limit 400
Wend
'put things back
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0): Cls '
_PutImage , backScrn
_Display
_FreeImage backScrn
_FreeImage mbx
ScnState 1 'Thanks Steve McNeill
End Sub
' ======================= This is old version dev for mBox or InputBox and new version dev with new GetArrayItem$
' for saving and restoring screen settins
Sub ScnState (restoreTF As Long) 'Thanks Steve McNeill
Static defaultColor~&, backGroundColor~&
Static font&, dest&, source&, row&, col&, autodisplay&, mb&
If restoreTF Then
_Font font&
Color defaultColor~&, backGroundColor~&
_Dest dest&
_Source source&
Locate row&, col&
If autodisplay& Then _AutoDisplay Else _Display
_KeyClear
While _MouseInput: Wend 'clear mouse clicks
mb& = _MouseButton(1)
If mb& Then
Do
While _MouseInput: Wend
mb& = _MouseButton(1)
_Limit 100
Loop Until mb& = 0
End If
Else
font& = _Font: defaultColor~& = _DefaultColor: backGroundColor~& = _BackgroundColor
dest& = _Dest: source& = _Source
row& = CsrLin: col& = Pos(0): autodisplay& = _AutoDisplay
_KeyClear
End If
End SubRE: Everything in Degrees instead of Radians - Pete - 11-01-2022
That's a blast! +1
Pete
RE: Everything in Degrees instead of Radians - bplus - 11-01-2022
This is main difference in code between Container #4 and Container #5
Container #5 has these fixes:
Code: (Select All)
If Abs(bx - saveBx) > 1 Or Abs(by - saveBy) > 1 Then ' Ball is moving right along
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>> new direction
delayT = 1: nr = nr + 1
Else ' could be stuck
If totLinesHit = 1 Then
diff = Boundaries(saveL).dN - ba + 180
ba = Boundaries(saveL).dN + diff ' >>>> new direction
delayT = 1: nr = nr + 1
ElseIf totLinesHit > 1 Then
'If totLinesHit > 1 Then
' new 2022-10-21 fix angle to average of normals hit totN is total or all Normals / total lines hit
' new ball direction is average of normals
ba = totN / totLinesHit ' >>>>>>>>>>>>>>>>>>>>>>> new direction from line segment perpendicular angle
delayT = 3: Beep: anr = anr + 1
If Abs(ba - DAtan2(bx, by, x0, y0)) > 90 And Abs(ba - 360 - DAtan2(bx, by, x0, y0)) > 90 Then
Beep ' indicate by sound that the alternate angle for ball was used
mBox "Multiple Line hits", "Ave of norms looks wrong:" + Str$(totN / totLinesHit) + ", fixed using:" + Str$(DAtan2(bx, by, x0, y0))
ba = DAtan2(bx, by, x0, y0)
fixr = fixr + 1
End If
End If
End IfFirst IF detects if ball is stuck, same place it was in last loop.
Then it detects if ball is collided with 1 line or more than one.
If one line, stick with the plan it will work it's way out, notice same code is used as if it weren't stuck.
If more than one line we have the problem of hitting 2 lines simultaneously or nearly so, so I took the average of the normals of the 2 lines. This calc is not perfect so I compare it to the angle of the ball to the center of the container if the calc is off by more than 90 degrees I head the ball to the center of the container and issue a message to that effect with the message box.
With the message box, I could see that the calc ave normal is wrong and choosing to head ball to center is smart way out of getting stuck.
Looking at screen shot, I see I was counting normal reflections off wall, the times where I had to use an average of normal angles because more than one line was intersected and the number of times I had to fix the average because it was pointed out not in.