QB64 Phoenix Edition
Geometry Tools - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: Geometry Tools (/showthread.php?tid=2770)



Geometry Tools - bplus - 06-04-2024

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 Smile


RE: Geometry Tools - bplus - 06-04-2024

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