Posts: 3,800
Threads: 172
Joined: Apr 2022
Reputation:
196
06-04-2024, 01:33 AM
(This post was last modified: 06-04-2024, 01:38 AM by bplus.)
Needs lots of clean up eg 2 slope routines but things appear to be working correctly:
circumscribe any triangle
Code: (Select All) _Title "Circumscribe Triangle" ' b+ 2024-06-03 trans to qb64pe from
'circumscribe Triangle.bas in SmallBASIC 2015-09-12 MGA/B+
'Thanks to ScriptBasic for posting 1968 Dartmouth Code
'OK now try to find point where I can circumscribe a circle about triangle
Screen _NewImage(800, 600, 32)
_ScreenMove 200, 60
Dim Shared A, B, C, D, E, F, U, V, W ' standard eq coefficients
Dim Shared SolvedX, SolvedY
Dim px(0 To 2), py(0 To 2), mpx(0 To 2), mpy(0 To 2)
Do
Color &HFFFFFFFF
Cls
Print "To find origin to circumscribe triangle, click 3 points to draw Triangle."
For i = 0 To 2
getClick px(i), py(i), kh&
If kh& = 0 Then
Circle (px(i), py(i)), 2
Print "point"; Str$(i); " = ("; ts$(px(i)); ","; ts$(py(i)); ")"
_Delay .2
Else
End
End If
Next
drawTri px(), py() ' draw triangle
'line p1x,p1y,p2x,p2y
' calc midpoints
For i = 0 To 2
mpx(i) = (px(i) + px((i + 1) Mod 3)) / 2
mpy(i) = (py(i) + py((i + 1) Mod 3)) / 2
Circle (mpx(i), mpy(i)), 2
Next
'? "and...Center!"
ABCs4StdFrm px(1), py(1), mpx(0), mpy(0) ' sets U, V, W
A = U: B = V: C = W ' Save as A, B, C
ABCs4StdFrm px(2), py(2), mpx(1), mpy(1) ' sets U, V, W
D = U: E = V: F = W 'Save as D, E, F
Solve4XY
Circle (SolvedX, SolvedY), 2, &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(0), mpy(0)), &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(1), mpy(1)), &HFFFFFF00
Line (SolvedX, SolvedY)-(mpx(2), mpy(2)), &HFFFFFF00
radius = ((px(0) - SolvedX) ^ 2 + (py(0) - SolvedY) ^ 2) ^ .5
Circle (SolvedX, SolvedY), radius, &HFFFFFF00
_PrintString (50, _Height - 20), "zzz... press any for another run"
Sleep
Loop
Function slope (q1x, q1y, q2x, q2y)
slope = (q2y - q1y) / (q2x - q1x)
End Function
Sub ABCs4StdFrm (r1x, r1y, r2x, r2y)
'takes two points that define line and gets A,B,C's for Standard Form of line
m = slope(r1x, r1y, r2x, r2y)
'Ax + By = C find equation of line perpendicular through point r2x,r2y
U = 1 / m: V = 1: W = r2x / m + r2y 'U,V,W are global these are perpendicular line calcs
End Sub
Sub Solve4XY ()
'globals A,B,C of eq1 Ax+By=C D,E,F of eq2 Dx+Ey=F
G = A * E - B * D
If G = 0 Then Print "NO UNIQUE SOLUTION": Exit Sub
SolvedX = (C * E - B * F) / G
SolvedY = (A * F - C * D) / G
End Sub
Sub getClick (mx, my, q) ' from 000 test\getClick test
'getClick returns the mouse x, y position WHEN THE MOUSE WAS RELEASED! or keypress ASC 27 or 32 to 125
'2019-08-06 Test now with new mBox and inputBox procedures
'found mBox needed a _KEYCLEAR, how about inputBox? OK had _KEYCLEAR already
mb = _MouseButton(1)
While mb
While _MouseInput: Wend '<<<<<<<<<<<<<<<<<<<< clear previous mb
mb = _MouseButton(1)
Wend
_KeyClear 'clear previous key presses
mx = -1: my = -1: q = 0
Do While mx = -1 And my = -1
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then _KeyClear: Exit Sub
i = _MouseInput: mb = _MouseButton(1)
'IF mb THEN
Do While mb 'wait for release
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then Exit Sub
i = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
_Limit 1000
Loop
_Limit 1000
Loop
End Sub
Function ts$ (N)
ts$ = _Trim$(Str$(Int(N)))
End Function
Sub drawTri (px(), py())
' px(), py() arrays 1 to 3 of points
Line (px(0), py(0))-(px(1), py(1))
Line (px(1), py(1))-(px(2), py(2))
Line (px(2), py(2))-(px(0), py(0))
End Sub
that was the easy one 
b = b + ...
Posts: 3,800
Threads: 172
Joined: Apr 2022
Reputation:
196
inscribe any triangle
Code: (Select All) _Title "Inscribe Triangle from LineBisectAngle Test" ' b+ 2024-06-03
Screen _NewImage(800, 600, 32)
_ScreenMove 200, 60
Dim px(0 To 2), py(0 To 2)
Do
Color &HFFFFFFFF
Cls
Print "To find origin to Inscribe a triangle with Circle, click 3 points to draw Triangle."
For i = 0 To 2
getClick px(i), py(i), kh&
If kh& = 0 Then
Circle (px(i), py(i)), 2
Print "point"; Str$(i); " = ("; ts$(px(i)); ","; ts$(py(i)); ")"
_Delay .2
Else
End
End If
Next
drawTri px(), py() ' draw triangle
Dim ix1(0 To 2), iy1(0 To 2), ix2(0 To 2), iy2(0 To 2)
For i = 0 To 2
LineBisectAngle px(), py(), i, ix1(i), iy1(i), ix2(i), iy2(i)
Line (ix1(i), iy1(i))-(ix2(i), iy2(i))
Next
test = lineIntersectLine%(ix1(0), iy1(0), ix2(0), iy2(0), ix1(1), iy1(1), ix2(1), iy2(1), ix, iy)
Circle (ix, iy), 3, &HFFFFFF00
PointOnLinePerp2Point px(0), py(0), px(1), py(1), ix, iy, perpX, perpY
Circle (perpX, perpY), 3, &HFFFFFF00
radius = _Hypot(perpX - ix, perpY - iy)
Circle (ix, iy), radius, &HFFFFFF00
_PrintString (50, _Height - 20), "zzz... press any for another run"
Sleep
Loop
Sub LineBisectAngle (px(), py(), angleI, ix1, iy1, ix2, iy2)
' 2 points equal distance from angleI use orbit
a = _Atan2(py((angleI + 1) Mod 3) - py(angleI), px((angleI + 1) Mod 3) - px(angleI))
orbit px(angleI), py(angleI), _R2D(a), 10, x, y
a = _Atan2(py((angleI + 2) Mod 3) - py(angleI), px((angleI + 2) Mod 3) - px(angleI))
orbit px(angleI), py(angleI), _R2D(a), 10, x1, y1
' now have two circle origins, give them same radius and get 2 points of line
intersect2Circles x, y, 500, x1, y1, 500, ix1, iy1, ix2, iy2
End Sub
Sub getClick (mx, my, q) ' from 000 test\getClick test
'getClick returns the mouse x, y position WHEN THE MOUSE WAS RELEASED! or keypress ASC 27 or 32 to 125
'2019-08-06 Test now with new mBox and inputBox procedures
'found mBox needed a _KEYCLEAR, how about inputBox? OK had _KEYCLEAR already
mb = _MouseButton(1)
While mb
While _MouseInput: Wend '<<<<<<<<<<<<<<<<<<<< clear previous mb
mb = _MouseButton(1)
Wend
_KeyClear 'clear previous key presses
mx = -1: my = -1: q = 0
Do While mx = -1 And my = -1
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then _KeyClear: Exit Sub
i = _MouseInput: mb = _MouseButton(1)
'IF mb THEN
Do While mb 'wait for release
q = _KeyHit
If q = 27 Or (q > 31 And q < 126) Then Exit Sub
i = _MouseInput: mb = _MouseButton(1): mx = _MouseX: my = _MouseY
_Limit 1000
Loop
_Limit 1000
Loop
End Sub
Function ts$ (N)
ts$ = _Trim$(Str$(Int(N)))
End Function
Sub drawTri (px(), py())
' px(), py() arrays 1 to 3 of points
Line (px(0), py(0))-(px(1), py(1))
Line (px(1), py(1))-(px(2), py(2))
Line (px(2), py(2))-(px(0), py(0))
End Sub
Sub label (xc, yc, text$)
Dim th2, pw2
th2 = _FontHeight / 2
pw2 = _PrintWidth(text$) / 2
_PrintString (xc - pw2 + 1.25, yc - th2 + .5), text$
End Sub
Sub orbit (X_Origin, Y_Origin, Degrees, Radius, xOut, yOut) ' all default single should be ok
xOut = X_Origin + Radius * Cos(_D2R(Degrees))
yOut = Y_Origin + Radius * Sin(_D2R(Degrees))
End Sub
Sub intersect2Circles (x1, y1, r1, x2, y2, r2, ix1, iy1, ix2, iy2)
'x1, y1 origin of circle 1 with radius r1
'x2, y2 origin of circle 2 with radius r2
'ix1, iy1 is the first point of intersect
'ix2, iy2 is the 2nd point of intersect
'if ix1 = ix2 = iy1 = iy2 = 0 then no points returned
Dim d, a, h, Px, pY
d = _Hypot(x1 - x2, y1 - y2) 'distance between two origins
If r1 + r2 < d Then
'PRINT "The circles are too far apart to intersect.": END
'some signal ??? if ix1 = ix2 = iy1 = iy2 = 0 then no points returned
ix1 = 0: ix2 = 0: iy1 = 0: iy2 = 0
Exit Sub
End If
If (d < r1 And r2 + d < r1) Or (d < r2 And r1 + d < r2) Then 'one circle is inside the other = no intersect
ix1 = 0: ix2 = 0: iy1 = 0: iy2 = 0
Exit Sub
'IF ABS(r1 - r2) > 3 THEN
' PRINT "No intersect, same center (or nearly so) and different radii (or seemingly so).": END
'ELSE
' PRINT "Infinite intersect, the circles are the same (or nearly so).": END
'END IF
End If
'results
a = (r1 ^ 2 - r2 ^ 2 + d ^ 2) / (2 * d)
Px = x1 + a * (x2 - x1) / d
pY = y1 + a * (y2 - y1) / d
h = (r1 ^ 2 - a ^ 2) ^ .5
ix1 = Int(Px - h * (y2 - y1) / d)
iy1 = Int(pY + h * (x2 - x1) / d)
'circle x1,y1,2,1 filled
'PRINT: PRINT "Intersect pt1: "; x1; ", "; y1
ix2 = Int(Px + h * (y2 - y1) / d)
iy2 = Int(pY - h * (x2 - x1) / d)
'circle x2,y2,2,1 filled
'PRINT: PRINT "Intersect pt2: "; x2; ", "; y2
'line x1,y1,x2,y2
End Sub
Function slopeY0% (X, Y, X2, Y2, M, Y0)
If X = X2 Then Exit Function Else slopeY0% = -1: M = (Y2 - Y) / (X2 - X): Y0 = -X * M + Y
End Function
Function lineIntersectLine% (ax1, ay1, ax2, ay2, bx1, by1, bx2, by2, ix, iy)
' Return 1, ix, iy if lines intersect, Return -1 if they overlap, return 0 if neither.
' This function needs:
' Return 0 if x = x2 and line is perpendicular otherwise return -1, slope = M and yIntersect = Y0
' needs FUNCTION slopeY0% (X, Y, X2, Y2, M, Y0)
Dim ai, bi, aM, bM, aY0, bY0, d
ai = slopeY0%(ax1, ay1, ax2, ay2, aM, aY0) ' here's the scoop on line a
bi = slopeY0%(bx1, by1, bx2, by2, bM, bY0) ' here's the dope on line b
If ai = 0 And bi = 0 Then ' both are perpendicular how bout that!
If ax1 = bx1 Then lineIntersectLine% = -1 ' whole line overlaps more amazing!!
ElseIf ai = 0 And bi Then ' a is perpendicular and b is not so ix = ax
ix = ax1: iy = bM * ix + bY0: lineIntersectLine% = 1 ' signal a point was found
ElseIf ai And bi = 0 Then ' b is perpendicular and a is not so ix = bx
ix = bx1: iy = aM * ix + aY0: lineIntersectLine% = 1 ' signal a point was found
Else
d = -aM + bM ' if = 0 then parallel or equal because slopes are same
If d = 0 Then ' lines a and b are parallel
If aY0 = bY0 Then lineIntersectLine% = -1 ' the same Y0 means signal overlapping lines
Else ' get values of ix, iy intersect point and signal intersect
ix = (aY0 - bY0) / d: iy = (-aM * bY0 + bM * aY0) / d: lineIntersectLine% = 1
End If
End If
End Function
Sub slopeYintersect (X1, Y1, X2, Y2, slopeY, Yintercept) ' fix for when x1 = x2
If X1 = X2 Then
slopeY = X1
Yintercept = Y2
Else
slopeY = (Y2 - Y1) / (X2 - X1)
Yintercept = slopeY * (0 - X1) + Y1
End If
End Sub
Sub PointOnLinePerp2Point (Lx1, Ly1, Lx2, Ly2, Px, Py, Rx, Ry)
'
'this sub needs SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
'
'Lx1, Ly1, Lx2, Ly2 the two points that make a line
'Px, Py is point off the line
'Rx, Ry Return Point is the Point on the line perpendicular to Px, Py
slopeYintersect Lx1, Ly1, Lx2, Ly2, m, Y0
A = m ^ 2 + 1
B = 2 * (m * Y0 - m * Py - Px)
Rx = -B / (2 * A)
Ry = m * Rx + Y0
End Sub
b = b + ...
|
