Geometry Tools

[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