+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Triangle Dissection (/showthread.php?tid=339)
Triangle Dissection - bplus - 05-05-2022
Can't think of a category for this one.
Code: (Select All)
Option _Explicit
_Define A-Z As _FLOAT
_Title "Triangle Dissection 2 user click" 'B+ 2020-01-29
' Turn a triangle into a square (and back)
' 2020-01-30 now for any triangle, oh and swap points around until back to original dissection! nice :)
' 2020-01-30 Oh now let user click his own triangle for dissection
Const xmax = 800, ymax = 740, blu = &H880000FF, red = &H88FF0000
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 0
Dim Ax, Ay, Fx, Fy, Jx, Jy '3 corners A is apex, F and J form iso triangle
Dim Bx, By, Cx, Cy 'midpoint AF and AJ
Dim Gx, Gy, Hx, Hy '1/4 lengths of base
Dim distFJ, aJ ' to calc points G and H
Dim Dx, Dy, Ex, Ey 'two crital points for forming 90 degree angles
Dim D2x, D2y, E2x, E2y, G2x, G2y 'copy points to move as independent blocks
Dim a, cnt, cc 'a = angle in degrees loop counter, cycle counter
Dim tx, ty ' for temp holders to swap points 3 way swap not 2 way
Dim mx(3), my(3), pi, oldMouse 'for mouse user input
getUserTri:
cc = 0
Cls: Circle (400, 370), 200
While pi < 3 'get 3 mouse clicks
_PrintString (5, 5), Space$(20)
_PrintString (5, 5), "Need 3 clicks inside circle, have" + Str$(pi)
While _MouseInput: Wend
mx(0) = _MouseX: my(0) = _MouseY
If _MouseButton(1) And oldMouse = 0 Then 'new mouse down
If Sqr((mx(0) - 400) ^ 2 + (my(0) - 370) ^ 2) < 200 Then
pi = pi + 1
mx(pi) = mx(0): my(pi) = my(0)
Circle (mx(pi), my(pi)), 2
End If
End If
oldMouse = _MouseButton(1)
_Display
_Limit 60
Wend
Ax = mx(1): Ay = my(1)
Jx = mx(2): Jy = my(2)
Fx = mx(3): Fy = my(3)
'initial triangle
'Ax = 400: Ay = 200: Fx = 200: Fy = 500: Jx = 600: Jy = 500 'jx = 600, jy = 500
restart:
cc = cc + 1
If cc = 4 Then pi = 0: GoTo getUserTri
Bx = (Ax + Fx) / 2: By = (Ay + Fy) / 2: Cx = (Ax + Jx) / 2: Cy = (Ay + Jy) / 2
distFJ = _Hypot(Fx - Jx, Fy - Jy)
aJ = _Atan2(Jy - Fy, Jx - Fx)
Gx = Fx + .25 * distFJ * Cos(aJ)
Gy = Fy + .25 * distFJ * Sin(aJ)
Hx = Fx + .75 * distFJ * Cos(aJ)
Hy = Fy + .75 * distFJ * Sin(aJ)
circleTangentXY Gx, Gy, Cx, Cy, Bx, By, Dx, Dy
circleTangentXY Gx, Gy, Cx, Cy, Hx, Hy, Ex, Ey
D2x = Dx: D2y = Dy
E2x = Ex: E2y = Ey
G2x = Gx: G2y = Gy
'draw traingle for check
'ln Ax, Ay, Fx, Fy
'ln Ax, Ay, Jx, Jy
'ln Fx, Fy, Jx, Jy
'ln Gx, Gy, Cx, Cy
'ln Dx, Dy, Bx, By
'ln Ex, Ey, Hx, Hy
'_DISPLAY
'_DELAY 1
'draw our starter triangle
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
_Display
_Delay 1
'start dissection with all points needed
a = 1: cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
rotate D2x, D2y, Bx, By, a
rotate Gx, Gy, Bx, By, a
rotate Fx, Fy, Bx, By, a
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
rotate Jx, Jy, Cx, Cy, -a
rotate Hx, Hy, Cx, Cy, -a
rotate Ex, Ey, Cx, Cy, -a
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Cx, Cy, -a
rotate E2x, E2y, Cx, Cy, -a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
_Display
_Limit 60
cnt = cnt + 1
Wend
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Hx, Hy, -a
rotate E2x, E2y, Hx, Hy, -a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
_Delay 1
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Hx, Hy, a
rotate E2x, E2y, Hx, Hy, a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
cnt = 0
While cnt < 180
Cls
fquad Ax, Ay, Cx, Cy, Dx, Dy, Bx, By, blu
rotate D2x, D2y, Bx, By, -a
rotate Gx, Gy, Bx, By, -a
rotate Fx, Fy, Bx, By, -a
fquad Bx, By, D2x, D2y, Gx, Gy, Fx, Fy, blu
rotate Jx, Jy, Cx, Cy, a
rotate Hx, Hy, Cx, Cy, a
rotate Ex, Ey, Cx, Cy, a
fquad Cx, Cy, Jx, Jy, Hx, Hy, Ex, Ey, blu
rotate G2x, G2y, Cx, Cy, a
rotate E2x, E2y, Cx, Cy, a
ftri Hx, Hy, G2x, G2y, E2x, E2y, blu
cnt = cnt + 1
_Display
_Limit 60
Wend
_Delay 1
'swap points for different dissection
tx = Ax: ty = Ay
Ax = Jx: Ay = Jy
Jx = Fx: Jy = Fy
Fx = tx: Fy = ty
GoTo restart
Sub rotate (x, y, cx, cy, rAngle) 'replace x, y with new position
Dim angle, distance
angle = _Atan2(y - cy, x - cx)
distance = ((x - cx) ^ 2 + (y - cy) ^ 2) ^ .5
x = cx + distance * Cos(angle + _D2R(rAngle))
y = cy + distance * Sin(angle + _D2R(rAngle))
End Sub
Sub circleTangentXY (X1, Y1, X2, Y2, xC, yC, findXperp, findYperp)
'p1 and p2 form a line, with slop and y intersect y0
'xC, yC is a circle origin
'we find X, Y such that line x, y to xC, yC is perpendicular to p1, p2 line that is radius of tangent circle
Dim slope, y0, A, B
If X2 <> X1 Then
slope = (Y2 - Y1) / (X2 - X1)
y0 = slope * (0 - X1) + Y1
A = slope ^ 2 + 1
B = 2 * (slope * y0 - slope * yC - xC)
findXperp = -B / (2 * A)
findYperp = slope * findXperp + y0
Else
findXperp = X1
findYperp = yC
End If
End Sub
'SUB drawLine (x1, y1, x2, y2, K AS _UNSIGNED LONG)
' slope = (y2 - y1) / (x2 - x1)
' y0 = slope * (0 - x1) + y1
' LINE (0, y0)-(_WIDTH, slope * _WIDTH + y0), &HFF0000FF
'END SUB
Sub ln (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2)
End Sub
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
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
'update 2019-12-16 needs updated fTri 2019-12-16
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
ftri x1, y1, x2, y2, x3, y3, K
ftri x3, y3, x4, y4, x1, y1, K
End SubFunny things might happen with narrow slivers of a triangle but any acute triangle should be fine.
RE: Triangle Dissection - Pete - 05-05-2022
If I ever need to fold up my pyramid and move, you're my GOTO guy!
Pete