|
Post by bplus on Oct 16, 2022 13:08:29 GMT
From my Everything in Degrees utilities demo Option _Explicit _Title "Bounce Ball Inside Polygon" 'b+ 2022-10-16 Screen _NewImage(800, 600, 32) ' standard screen size 800 wide, 600 height for quick QB64 Demos with full color potential (the 32) _ScreenMove 250, 50 Randomize Timer _PrintMode _KeepBackground Type lineSegment As Single x1, y1, x2, y2, dN ' 2 end points End Type
' mod RegularPoly to save lines created by Dim cx, cy, polyRadius, Dstart, SecDegrees, x1, y1, x2, y2 ' building container Dim As _Unsigned Long PK Dim As Long NLines, L, Container cx = _Width / 2: cy = _Height / 2 + 40: polyRadius = 250: Dstart = 270 PK = _RGB32(0, 150, 85) ' minty green background out of bounds
startNewPoly: NLines = Int(Rnd * 10) + 3 SecDegrees = 360 / NLines
ReDim Boundaries(1 To NLines) As lineSegment Cls x1 = cx + polyRadius * CosD(Dstart) y1 = cy + polyRadius * SinD(Dstart) For L = 1 To NLines x2 = cx + polyRadius * CosD(Dstart + L * SecDegrees) y2 = cy + polyRadius * SinD(Dstart + L * SecDegrees) Line (x1, y1)-(x2, y2), PK ' back to first point Boundaries(L).x1 = x1 ' save these line segment end points for containing the ball Boundaries(L).y1 = y1 Boundaries(L).x2 = x2 Boundaries(L).y2 = y2 'if we take the midpoint of the two endpoints and draw a line to the center we have the normal angle of the line ' on the same side we want to keep the ball! ' midx = (x1+ x2)/2 ' midy = (y1 + y2)/2 ' the angle of the normal is! Aha! Boundaries(L).dN = DAtan2((x1 + x2) / 2, (y1 + y2) / 2, cx, cy) ' angle from midpoint to center ' check angles midpoint is 22.5 degress less (for 8 sides) and going in opp direction ' Print Dstart + L * SecDegrees - 22.5 - 180, Boundaries(L).dN x1 = x2: y1 = y2 Next Paint (1, 1), PK, PK Print " Yellow = the vector of ball heading towards line." Print " Blue = vector perpendicular (normal) to boundary line." Print " White = angle of refelection off line." Print " esc starts a different poly." Container = _NewImage(_Width, _Height, 32) _PutImage , 0, Container
Dim bx, by, ba, br, bspeed, hit, hitx1, hity1, hitx2, hity2, diff bx = cx: by = cy: bspeed = 5 br = 20 ' 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 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) For L = 1 To NLines ' did we hit any? hit = lineIntersectCircle%(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).y2, bx, by, br, hitx1, hity1, hitx2, hity2)
' probably should back it up before processing bounce If hit Then ' rebound ball Circle (bx, by), br _Display While hit ' back up circle bx = bx + CosD(ba - 180) by = by + SinD(ba - 180) hit = lineIntersectCircle%(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).y2, bx, by, br, hitx1, hity1, hitx2, hity2) 'Circle (bx, by), br '_Display Wend _PutImage , Container, 0 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(L).dN, 5 * br, &HFF0000FF
' Reflected ball off line diff = Boundaries(L).dN - ba + 180 ba = Boundaries(L).dN + diff ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> new direction ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
_Display _Delay 1 End If Next _Display _Limit 30 Loop Until _KeyDown(27) GoTo startNewPoly
' return 0 no Intersect, 1 = tangent 1 point touch, 2 = 2 point intersect ' if intersect returns point or points of intersect ix1, iy1, ix2, iy2 ' intersect points are -999 if non existent ie no intersect or 2nd point when circle is tangent Function lineIntersectCircle% (lx1, ly1, lx2, ly2, cx, cy, r, ix1, iy1, ix2, iy2) Dim m, y0, A, B, C, D, x1, y1, x2, y2, ydist 'needs SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept)
If lx1 <> lx2 Then slopeYintersect lx1, ly1, lx2, ly2, m, y0 ' Y0 otherwise know as y Intersect
' https://math.stackexchange.com/questions/228841/how-do-i-calculate-the-intersections-of-a-straight-line-and-a-circle A = m ^ 2 + 1 B = 2 * (m * y0 - m * cy - cx) C = cy ^ 2 - r ^ 2 + cx ^ 2 - 2 * y0 * cy + y0 ^ 2 D = B ^ 2 - 4 * A * C 'telling part of Quadratic formula = 0 then circle is tangent or > 0 then 2 intersect points If D < 0 Then ' no intersection ix1 = -999: iy1 = -999: ix2 = -999: iy2 = -999: lineIntersectCircle% = 0 ElseIf D = 0 Then ' one point tangent x1 = (-B + Sqr(D)) / (2 * A) y1 = m * x1 + y0 ix1 = x1: iy1 = y1: ix2 = -999: iy2 = -999: lineIntersectCircle% = 1 Else '2 points x1 = (-B + Sqr(D)) / (2 * A): y1 = m * x1 + y0 x2 = (-B - Sqr(D)) / (2 * A): y2 = m * x2 + y0 ix1 = x1: iy1 = y1: ix2 = x2: iy2 = y2: lineIntersectCircle% = 2 End If Else 'vertical line If r = Abs(lx1 - cx) Then ' tangent ix1 = lx1: iy1 = cy: ix2 = -999: iy2 = -999: lineIntersectCircle% = 1 ElseIf r < Abs(lx1 - cx) Then 'no intersect ix1 = -999: iy1 = -999: ix2 = -999: iy2 = -999: lineIntersectCircle% = 0 Else '2 point intersect ydist = Sqr(r ^ 2 - (lx1 - cx) ^ 2) ix1 = lx1: iy1 = cy + ydist: ix2 = lx1: iy2 = cy - ydist: lineIntersectCircle% = 2 End If End If End Function
Sub slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2 slope = (Y2 - Y1) / (X2 - X1) Yintercept = slope * (0 - X1) + Y1 End Sub
Sub RegularPolyFill (cx, cy, radius, nPoints, dStart, K As _Unsigned Long) Dim secDegrees, p, x, y, lastX, lastY, startX, startY secDegrees = 360 / nPoints For p = 1 To nPoints x = cx + radius * CosD(dStart + p * secDegrees) y = cy + radius * SinD(dStart + p * secDegrees) If p > 1 Then TriFill cx, cy, lastX, lastY, x, y, K Else startX = x: startY = y End If lastX = x: lastY = y Next TriFill cx, cy, lastX, lastY, startX, startY, K ' back to first point End Sub
Sub RegularPoly (cx, cy, radius, nPoints, dStart, K As _Unsigned Long) Dim secDegrees, p, x, y, saveX, saveY secDegrees = 360 / nPoints For p = 1 To nPoints x = cx + radius * CosD(dStart + p * secDegrees) y = cy + radius * SinD(dStart + p * secDegrees) If p = 1 Then PSet (x, y), K: saveX = x: saveY = y Else Line -(x, y), K Next Line -(saveX, saveY), K ' back to first point End Sub
' 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
' use angles in degrees units instead of radians (converted inside sub) Sub drawArc (xc, yc, radius, dStart, dMeasure, colr As _Unsigned Long) ' xc, yc Center for arc circle ' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians ' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians ' Arc will start at rStart and go clockwise around for rMeasure Radians
Dim rStart, rMeasure, rEnd, stepper, a, x, y rStart = _D2R(dStart) rMeasure = _D2R(dMeasure) rEnd = rStart + rMeasure stepper = 1 / radius ' the bigger the radius the smaller the steps For a = rStart To rEnd Step stepper x = xc + radius * Cos(a) y = yc + radius * Sin(a) If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr Next End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better '2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest Sub TriFill (x1, y1, x2, y2, x3, y3, K As _Unsigned Long) ' 2022-10-13 changed name 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
|
|
dbox
Junior Member
Posts: 82
|
Post by dbox on Oct 16, 2022 21:45:25 GMT
Very nice collision example bplus!
|
|
|
Post by bplus on Oct 17, 2022 11:01:30 GMT
The original goal was to bounce a circle inside a relatively random generated container, like a square frame but the sides full of weird angles. I have now finally (almost) succeeded in that with a new collision detection function for line segment points inside a circle: ' return 0 if no overlap 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 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 lineSegIntersectCircle% = -1: Exit Function Next End Function
It's allot less complex than what I was using before! So this may be great tool for collision detection. Here is test code with the randomly generated container, a guy named James offered up: Option _Explicit _Title "James Random Container 2" ' b+ 2022-10-16 Screen _NewImage(800, 680, 32) _ScreenMove 250, 50 Randomize Timer _PrintMode _KeepBackground Type lineSegment As Single x1, y1, x2, y2, dN ' 2 end points End Type
' mod RegularPoly to save lines created by Dim cx, cy, x1, y1, flag, x2, y2 ' building container Dim As _Unsigned Long c1 Dim As Long NLines, L, Container ReDim Boundaries(1 To 100) As lineSegment 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) + 80 + 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) + 80 + 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) + 80) 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) + 80) 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 " Yellow = the angle of ball heading towards line." Print " Blue = angle perpendicular (normal) to boundary line." Print " White = angle of refelection off line." Container = _NewImage(_Width, _Height, 32) _PutImage , 0, Container
Dim bx, by, ba, br, bspeed, diff bx = cx: by = cy: 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 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) For L = 1 To NLines ' did we hit any? ' probably should back it up before processing bounce If lineSegIntersectCircle%(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).y2, bx, by, br) Then ' rebound ball Sound 1000, .5 While lineSegIntersectCircle%(Boundaries(L).x1, Boundaries(L).y1, Boundaries(L).x2, Boundaries(L).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 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(L).dN, 5 * br, &HFF0000FF
' Reflected ball off line diff = Boundaries(L).dN - ba + 180 ba = Boundaries(L).dN + diff ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> new direction ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
_Display _Delay 2 End If Next _Display _Limit 120 Loop Until _KeyDown(27)
' return 0 if no overlap 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 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 lineSegIntersectCircle% = -1: Exit Function Next 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
There is still the occasional fly off. Usually when this happens, the circle does not follow the white arrow and jumps the boarder sometimes it jumps back but mostly it's off to other worlds. I thought problem might be bouncing circle off the wrong line segment as 2 segments could be intersecting circle at same time??? It does seem to happen more often around segment connections, 'corners'. Can anyone could figure this out before me? ;-))
|
|
|
Post by bplus on Oct 17, 2022 12:32:20 GMT
Improved again!
This function now counts just how many points of a line segment are contained in a circle:
' 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
Now I use those counts to see which line segment contains the deepest penetration of a circle and use that segment to bounce off of:
Option _Explicit _Title "James Random Container 3" ' b+ 2022-10-17 ' 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.
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
' mod RegularPoly to save lines created by Dim cx, cy, x1, y1, flag, x2, y2 ' building container Dim As _Unsigned Long c1 Dim As Long NLines, L, Container ReDim Boundaries(1 To 100) As lineSegment 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) + 80 + 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) + 80 + 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) + 80) 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) + 80) 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 " Yellow = the angle of ball heading towards line." Print " Blue = angle perpendicular (normal) to boundary line." Print " White = angle of refelection off line." Container = _NewImage(_Width, _Height, 32) _PutImage , 0, Container
Dim bx, by, ba, br, bspeed, diff, test, saveL, hits ' now for bouncing circles around bx = cx: by = cy: 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 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 Sound 1000, .5 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 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 diff = Boundaries(saveL).dN - ba + 180 ba = Boundaries(saveL).dN + diff ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> new direction ArrowTo bx, by, ba, 3 * br, &HFFFFFFFF
_Display _Delay .5 End If
_Display _Limit 300 Loop Until _KeyDown(27)
' 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
I haven't see the circle fly out yet but I have seen it get stuck in little indentation of walls. The circle doesn't move but the reflective arrows toggle back and forth.
Like a baseball stuck in a mitt.
|
|
|
Post by bplus on Oct 17, 2022 14:06:43 GMT
Oops, no it's not like a baseball in a mitt, 4 times I've been stuck on a slight penninsula (not a bay) angle in and angle out are nearly perpendicular to the normal angle like this
|
|
|
Post by sprezzo on Oct 19, 2022 1:08:42 GMT
Hey bplus long time no talk, nice program.
I only ran code from the top box so this may have been fixed - but I noticed the reflections are off sometimes. I see a lot of trig and hard-coded 180's in the code so I don't imagine your approach uses vectors. Is the code in the top post in this thread using the same reflection rules as the code in recent updates?
|
|
|
Post by bplus on Oct 19, 2022 2:36:17 GMT
Hey sprezzo, missed your interesting challenges ;-)) Yes you are seeing the evolution of a code solution that does not employ vectors. I really like the LineSegIntersectCircle solution I came up with for detecting which segment is intersected or rather judging which is being intersected the most! The guy that started this problem really prefers a vector solution, not my forte. So I am satisfied to leave it with the occasional hang-up on little peninsulas, until maybe I get a pinball app going. sprezzo so what have you been up to? People are wondering if you did a code translation Basic to JS or something similar? BTW my use of word "vector" is not technically correct I really just mean angles and directions, no magnitudes are being considered. I changed the wording as I evolved the last posted solution.
|
|
|
Post by bplus on Oct 20, 2022 3:21:20 GMT
Progress, less times stuck. I've added a delay mode to toggle between showing arrows at each hit with boundary with the color coded angles in (yellow), out (the reflection is white) and perpendicular to segment most contacted by circle (blue). The demo beeps everytime it's stuck = no change in x, y and I bounce in the blue perpendicular direction instead of the angle of reflection because that would just attempt to jam the lower body of the circle into the corner which causes the stuckness on a peninsula. Oddly this method of escape works inside "bay" even though the white reflective angle is clearly better and correct one. Maybe next time around I will ID corners as "innie" or "outie" ;-)) 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 Sub
Compare an outie that gets stuck to one that doesn't cause a problem Stuck! no problem outie.
|
|
|
Post by mikesharpe on Oct 21, 2022 0:06:19 GMT
that's a hell of an outie, bplus
|
|
|
Post by bplus on Oct 21, 2022 21:26:41 GMT
Hopefully a final reply, the first let's say ;-)) 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
This is stopped at a beep when an average of 2 perpendiculars was used for reflection angle because ball was intersected by 2 line segments. I'll show a screenshot with a mBox of a fix if I ever get one. OK finally here is one in the typical corner it occurs:
|
|