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.
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 Sub
b = b + ...