|
Post by william33 on Oct 20, 2022 17:52:09 GMT
Ported from a YaBASIC sample:
'based on a YaBASIC example, ported by William33 'the FillTriangle code is based on a Turbo Pascal example
_TITLE "Tetraeder"
SCREEN _NEWIMAGE(1280, 720, 32)
DIM opoints(4, 3) RESTORE points FOR n = 1 TO 4: FOR p = 1 TO 3: READ opoints(n, p): NEXT p: NEXT n
DIM triangles(4, 3) RESTORE triangles FOR n = 1 TO 4: FOR p = 1 TO 3: READ triangles(n, p): NEXT p: NEXT n
phi = 0: dphi = 0.1: psi = 0: dpsi = 0.05 DIM points(4, 3)
r = 60: g = 20 dr = 0.5: dg = 1.2: db = 3 DO _LIMIT 60 CLS phi = phi + dphi psi = psi + dpsi FOR n = 1 TO 4 points(n, 1) = opoints(n, 1) * COS(phi) - opoints(n, 2) * SIN(phi) points(n, 2) = opoints(n, 2) * COS(phi) + opoints(n, 1) * SIN(phi) p2 = points(n, 2) * COS(psi) - opoints(n, 3) * SIN(psi) points(n, 3) = opoints(n, 3) * COS(psi) + points(n, 2) * SIN(psi) points(n, 2) = p2 NEXT n
r = r + dr: IF (r < 0 OR r > 60) THEN dr = -dr g = g + dg: IF (g < 0 OR g > 60) THEN dg = -dg b = b + db: IF (b < 0 OR b > 60) THEN db = -db dm = dm + 0.01 m = 120 - 80 * SIN(dm) FOR n = 1 TO 4 p1 = triangles(n, 1) p2 = triangles(n, 2) p3 = triangles(n, 3) n1 = points(p1, 1) + points(p2, 1) + points(p3, 1) n2 = points(p1, 2) + points(p2, 2) + points(p3, 2) n3 = points(p1, 3) + points(p2, 3) + points(p3, 3) IF (n3 > 0) THEN sp = n1 * 0.5 - n2 * 0.7 - n3 * 0.6 COLOR _RGB32(INT(60 + r + 30 * sp) MOD 256, INT(60 + g + 30 * sp) MOD 256, INT(60 + b + 30 * sp) MOD 256) FillTriangle INT(_WIDTH / 2) + m * points(p1, 1), INT(_HEIGHT / 2) + m * points(p1, 2), INT(_WIDTH / 2) + m * points(p2, 1), INT(_HEIGHT / 2) + m * points(p2, 2), INT(_WIDTH / 2) + m * points(p3, 1), INT(_HEIGHT / 2) + m * points(p3, 2) END IF NEXT n _DISPLAY
LOOP UNTIL INKEY$ = CHR$(27)
SYSTEM
points: DATA -1,-1,+1,+1,-1,-1,+1,+1,+1,-1,+1,-1 triangles: DATA 1,2,4,2,3,4,1,3,4,1,2,3
SUB FillTriangle (xa AS INTEGER, ya AS INTEGER, xb AS INTEGER, yb AS INTEGER, xc AS INTEGER, yc AS INTEGER) DIM y1 AS LONG, y2 AS LONG, y3 AS LONG, x1 AS LONG, x2 AS LONG, x3 AS LONG DIM dx12 AS LONG, dx13 AS LONG, dx23 AS LONG DIM dy12 AS LONG, dy13 AS LONG, dy23 AS LONG, dy AS LONG DIM a AS LONG, b AS LONG IF ya = yb THEN yb = yb + 1 END IF IF ya = yc THEN yc = yc + 1 END IF IF yc = yb THEN yb = yb + 1 END IF IF (ya <> yb) AND (ya <> yc) AND (yc <> yb) THEN IF (ya > yb) AND (ya > yc) THEN y1 = ya: x1 = xa IF yb > yc THEN y2 = yb: x2 = xb y3 = yc: x3 = xc ELSE y2 = yc: x2 = xc y3 = yb: x3 = xb END IF ELSE IF (yb > ya) AND (yb > yc) THEN y1 = yb: x1 = xb IF ya > yc THEN y2 = ya: x2 = xa y3 = yc: x3 = xc ELSE y2 = yc: x2 = xc y3 = ya: x3 = xa END IF ELSE IF (yc > yb) AND (yc > ya) THEN y1 = yc: x1 = xc IF yb >= ya THEN y2 = yb: x2 = xb y3 = ya: x3 = xa ELSE y2 = ya: x2 = xa y3 = yb: x3 = xb END IF END IF END IF End if dx12 = x2 - x1: dy12 = y2 - y1 dx23 = x3 - x2: dy23 = y3 - y2 dx13 = x3 - x1: dy13 = y3 - y1 a = x2 - ((y2 - y3 + dy23) * dx23) / dy23 b = x3 + (-dy23 * dx13) / (dy13) IF (a < b) THEN LINE (a, y2)-(b, y2) FOR dy = 0 TO -dy23 - 1 a = x2 + ((dy23 + dy) * dx23) / dy23 b = x3 + (dy * dx13) / (dy13) LINE (a, dy + y3)-(b, dy + y3) NEXT FOR dy = -dy23 + 1 TO -dy13 a = x2 + ((dy23 + dy) * dx12) / dy12 b = x3 + (dy * dx13) / (dy13) LINE (a, dy + y3)-(b, dy + y3)
NEXT ELSE LINE (b, y2)-(a, y2) FOR dy = 0 TO -dy23 - 1 a = x2 + ((dy23 + dy) * dx23) / dy23 b = x3 + (dy * dx13) / (dy13) LINE (a, dy + y3)-(b, dy + y3) NEXT FOR dy = -dy23 + 1 TO -dy13 a = x2 + ((dy23 + dy) * dx12) / dy12 b = x3 + (dy * dx13) / (dy13) LINE (a, dy + y3)-(b, dy + y3) NEXT END IF END IF
END SUB
|
|
dbox
Junior Member
Posts: 82
|
Post by dbox on Oct 20, 2022 22:38:30 GMT
Cool sample. Works in QBJS with only minor changes: 'based on a YaBASIC example, ported by William33 'the FillTriangle code is based on a Turbo Pascal example 'Option _Explicit
Dim n, p, phi, dphi, psi, dpsi, r, g, dr, dg, db, p2, b, dm, m, p1, p3, n1, n2, n3, sp
_Title "Tetraeder"
Screen _NewImage(1280, 720, 32)
Dim opoints(4, 3) Restore points For n = 1 To 4: For p = 1 To 3: Read opoints(n, p): Next p: Next n
Dim triangles(4, 3) Restore triangles For n = 1 To 4: For p = 1 To 3: Read triangles(n, p): Next p: Next n
phi = 0: dphi = 0.1: psi = 0: dpsi = 0.05 Dim points(4, 3)
r = 60: g = 20 dr = 0.5: dg = 1.2: db = 3 Do _Limit 60 Cls phi = phi + dphi psi = psi + dpsi For n = 1 To 4 points(n, 1) = opoints(n, 1) * Cos(phi) - opoints(n, 2) * Sin(phi) points(n, 2) = opoints(n, 2) * Cos(phi) + opoints(n, 1) * Sin(phi) p2 = points(n, 2) * Cos(psi) - opoints(n, 3) * Sin(psi) points(n, 3) = opoints(n, 3) * Cos(psi) + points(n, 2) * Sin(psi) points(n, 2) = p2 Next n
r = r + dr If (r < 0 Or r > 60) Then dr = -dr g = g + dg If (g < 0 Or g > 60) Then dg = -dg b = b + db If (b < 0 Or b > 60) Then db = -db dm = dm + 0.01 m = 120 - 80 * Sin(dm) For n = 1 To 4 p1 = triangles(n, 1) p2 = triangles(n, 2) p3 = triangles(n, 3) n1 = points(p1, 1) + points(p2, 1) + points(p3, 1) n2 = points(p1, 2) + points(p2, 2) + points(p3, 2) n3 = points(p1, 3) + points(p2, 3) + points(p3, 3) If (n3 > 0) Then sp = n1 * 0.5 - n2 * 0.7 - n3 * 0.6 Color _RGB32(Int(60 + r + 30 * sp) Mod 256, Int(60 + g + 30 * sp) Mod 256, Int(60 + b + 30 * sp) Mod 256) FillTriangle Int(_Width / 2) + m * points(p1, 1), Int(_Height / 2) + m * points(p1, 2), Int(_Width / 2) + m * points(p2, 1), Int(_Height / 2) + m * points(p2, 2), Int(_Width / 2) + m * points(p3, 1), Int(_Height / 2) + m * points(p3, 2) End If Next n _Display
Loop Until InKey$ = Chr$(27)
System
points: Data -1,-1,+1,+1,-1,-1,+1,+1,+1,-1,+1,-1 triangles: Data 1,2,4,2,3,4,1,3,4,1,2,3
Sub FillTriangle (xa As Integer, ya As Integer, xb As Integer, yb As Integer, xc As Integer, yc As Integer) Dim y1 As Long, y2 As Long, y3 As Long, x1 As Long, x2 As Long, x3 As Long Dim dx12 As Long, dx13 As Long, dx23 As Long Dim dy12 As Long, dy13 As Long, dy23 As Long, dy As Long Dim a As Long, b As Long If ya = yb Then yb = yb + 1 End If If ya = yc Then yc = yc + 1 End If If yc = yb Then yb = yb + 1 End If If (ya <> yb) And (ya <> yc) And (yc <> yb) Then If (ya > yb) And (ya > yc) Then y1 = ya: x1 = xa If yb > yc Then y2 = yb: x2 = xb y3 = yc: x3 = xc Else y2 = yc: x2 = xc y3 = yb: x3 = xb End If Else If (yb > ya) And (yb > yc) Then y1 = yb: x1 = xb If ya > yc Then y2 = ya: x2 = xa y3 = yc: x3 = xc Else y2 = yc: x2 = xc y3 = ya: x3 = xa End If Else If (yc > yb) And (yc > ya) Then y1 = yc: x1 = xc If yb >= ya Then y2 = yb: x2 = xb y3 = ya: x3 = xa Else y2 = ya: x2 = xa y3 = yb: x3 = xb End If End If End If End If dx12 = x2 - x1: dy12 = y2 - y1 dx23 = x3 - x2: dy23 = y3 - y2 dx13 = x3 - x1: dy13 = y3 - y1 a = x2 - ((y2 - y3 + dy23) * dx23) / dy23 b = x3 + (-dy23 * dx13) / (dy13) If (a < b) Then Line (a, y2)-(b, y2) For dy = 0 To -dy23 - 1 a = x2 + ((dy23 + dy) * dx23) / dy23 b = x3 + (dy * dx13) / (dy13) Line (a, dy + y3)-(b, dy + y3) Next For dy = -dy23 + 1 To -dy13 a = x2 + ((dy23 + dy) * dx12) / dy12 b = x3 + (dy * dx13) / (dy13) Line (a, dy + y3)-(b, dy + y3)
Next Else Line (b, y2)-(a, y2) For dy = 0 To -dy23 - 1 a = x2 + ((dy23 + dy) * dx23) / dy23 b = x3 + (dy * dx13) / (dy13) Line (a, dy + y3)-(b, dy + y3) Next For dy = -dy23 + 1 To -dy13 a = x2 + ((dy23 + dy) * dx12) / dy12 b = x3 + (dy * dx13) / (dy13) Line (a, dy + y3)-(b, dy + y3) Next End If End If
End Sub
View in QBJS
|
|
|
Post by mikesharpe on Oct 20, 2022 23:46:17 GMT
Pretty impressive mod, I do wonder what those DATA statements do, it's like they are concealing vector operations somehow
maybe someone can help me fix this program:
'pyramid mod inspired by a B+ original defdbl a-z const d = 300 const z0 = 550 const oy = 00 dim shared pi pi = 4*atn(1) dim x(5), y(5), z(5) x( 0) = 0: y( 0) = 70: z( 0) = 0 x( 1) = 70: y( 1) =-70: z( 1) = 70 x( 2) =-70: y( 2) =-70: z( 2) = 70 x( 3) =-70: y( 3) =-70: z( 3) =-70 x( 4) = 70: y( 4) =-70: z( 4) =-70 x( 5) = 70: y( 5) =-70: z( 5) = 70 zoom = 4 sw = 640 sh = 480 screen _newimage(sw,sh,32) a = 0 do cls
a = a + 0.01
xx = x(0) yy = y(0) zz = z(0)
rot yy, zz, a rot xx, zz, a
proj p0, q0, xx, yy, zz
'draw all triangles for i=1 to 4 x1 = x(i) y1 = y(i) z1 = z(i)
rot y1, z1, a rot x1, z1, a
x2 = x(i + 1) y2 = y(i + 1) z2 = z(i + 1)
rot y2, z2, a rot x2, z2, a
c = _rgb(35,35,35)
proj p, q, x1, y1, z1 pset (sw/2 + zoom*p0, sh/2 - zoom*q0 + oy), c line -(sw/2 + zoom*p, sh/2 - zoom*q + oy), c
proj p, q, x2, y2, z2 line -(sw/2 + zoom*p, sh/2 - zoom*q + oy), c line -(sw/2 + zoom*p0, sh/2 - zoom*q0 + oy), c next
'draw the visible triangles for i=1 to 4 x1 = x(i) y1 = y(i) z1 = z(i)
rot y1, z1, a rot x1, z1, a
x2 = x(i + 1) y2 = y(i + 1) z2 = z(i + 1)
rot y2, z2, a rot x2, z2, a
'vector cross product cz = (x1 - xx)*(y2 - yy) - (y1 - yy)*(x2 - xx)
if cz > 0 then c = _rgb(255,255,255)
proj p, q, x1, y1, z1 pset (sw/2 + zoom*p0, sh/2 - zoom*q0 + oy), c line -(sw/2 + zoom*p, sh/2 - zoom*q + oy), c
proj p, q, x2, y2, z2 line -(sw/2 + zoom*p, sh/2 - zoom*q + oy), c line -(sw/2 + zoom*p0, sh/2 - zoom*q0 + oy), c end if next
'draw the base xx = x(1) yy = y(1) zz = z(1) rot yy, zz, a rot xx, zz, a
x1 = x(2) y1 = y(2) z1 = z(2) rot y1, z1, a rot x1, z1, a
x2 = x(3) y2 = y(3) z2 = z(3) rot y2, z2, a rot x2, z2, a
cz = (x1 - xx)*(y2 - yy) - (y1 - yy)*(x2 - xx)
if cz < 0 then c = _rgb(255,255,255) proj p0, q0, xx, yy, zz pset (sw/2 + zoom*p0, sh/2 - zoom*q0 + oy), c for i=2 to 5 xx = x(i) yy = y(i) zz = z(i)
rot yy, zz, a rot xx, zz, a
proj p, q, xx, yy, zz line -(sw/2 + zoom*p, sh/2 - zoom*q + oy), c next end if
_display _limit 30 loop until _keyhit = 27 sleep system 'rotate sub rot(x, y, a) xx = x*cos(a) - y*sin(a) yy = x*sin(a) + y*cos(a) x = xx y = yy end sub 'perspective projection sub proj(p, q, x, y, z) dz = z0 + z p = x*d/dz q = y*d/dz end sub
|
|
|
Post by dcromley on Feb 18, 2023 18:45:11 GMT
_@william33 , I saw you on, looked at your "Rotating Tetra.." and liked it, thanks. I haven't done much with QB64, but I did something related (QB64 Phoenix). Drag your mouse over this (I don't use "Defxxx" any more):
EDIT: Oh, Tetraeder is German for Tetrahedron!
_Title "Quaternion Rotation" ' dcromley Option _Explicit DefSng A-Z: DefLng I-N: DefStr S Const TRUE = -1, FALSE = 0 Dim Shared mx, my, m1Clk, m1Rpt, m1Dn, m1End, m2Clk, m2Dn ' for MouseCk Dim Shared Img1, Img2 Img1 = _NewImage(1024, 768, 256) Img2 = _NewImage(1024, 768, 256) _Dest Img2: Color 0, 15: Cls _Dest Img1: Color 0, 15: Cls
' == MAIN start ==
Type type4f ' 4 floats for quaternions, points, triangles w As Single ' 0 for points; color for triangles x As Single ' pt1 for triangles y As Single ' pt2 for triangles z As Single ' pt3 for triangles End Type
Const x0 = 384, y0 = 384, kxy = 200, z0 = 200 ' center, scale Dim Shared As type4f T, aPts(5), aPts0(5), aTris(4), QMain, QSlew, va, vb Dim Shared nPts, nTris ' # of Points, Triangles Dim Shared aMatrix(2, 2) Dim As type4f Qxp, Qxm, Qyp, Qym, Qzp, Qzm ' +- 1 deg Q's Dim i, x, y, z, s, p1, p2, p3, icolor, nloop Dim EuAngX, EuAngY, EuAngZ, fcos, fsin ' Euler angles Dim az(4), ndx(4), time0, iSlew, xa, ya
' -- Points - x,y,z,/ (# ends) Data 0,1,0,/,-1,-1,-1,/,-1,-1,1,/,1,-1,1,/,1,-1,-1,# ' -- Triangles - p1,p2,p3,color,/ (# ends) Data 1,2,3,9,/,1,3,4,10,/,1,4,5,12,/,1,5,2,14,#
Do ' -- load aPoints nPts = nPts + 1 ' read point x,y,z Read aPts0(nPts).x, aPts0(nPts).y, aPts0(nPts).z, s ' s is / or # to end Loop Until s = "#" Do ' -- load aTriangles nTris = nTris + 1 ' read triangle p1,p2,p3,color Read aTris(nTris).x, aTris(nTris).y, aTris(nTris).z, aTris(nTris).w, s Loop Until s = "#" ' -- load 1 deg quaternions fcos = Cos(1 * _Pi / 360): fsin = Sin(1 * _Pi / 360) ' half angle Qxp.w = fcos: Qxp.x = fsin: Qxm.w = fcos: Qxm.x = -fsin Qyp.w = fcos: Qyp.y = fsin: Qym.w = fcos: Qym.y = -fsin Qzp.w = fcos: Qzp.z = fsin: Qzm.w = fcos: Qzm.z = -fsin QMain.w = 1 ' start with null rotation QSlew = QMain
time0 = Timer - 1 ' prevent div by 0 Do ' ======== MAIN LOOP ======== nloop = nloop + 1 ' nloop + 1 and print If nloop Mod 2 = 1 Then _Dest Img1: screen img1 _ Else _Dest Img2: Screen Img2 ' swap screens Cls ' simplicity, not performance Line (768, 0)-(768, 752), _RGB(192, 192, 192) ' vertical MouseCk ' get mouse data ' -- check controls If iBox(110, 12, " Up") Then Qmult Qxm, QMain, QMain ' nudge orientation If iBox(106, 13, "Lft") Then Qmult Qym, QMain, QMain If iBox(114, 13, "Rht") Then Qmult Qyp, QMain, QMain If iBox(110, 14, " Dn") Then Qmult Qxp, QMain, QMain If iBox(106, 15, "CCW") Then Qmult Qzp, QMain, QMain If iBox(114, 15, " CW") Then Qmult Qzm, QMain, QMain ' -- check for random quaternion If iBox(110, 16, "Random") Then QRandom ' -- check for mouse dragging (slewing) vb.x = mx - x0: vb.y = y0 - my: vb.z = z0 ' new mouse data If m1Dn And isIn(mx, 0, 767) And isIn(my, 0, 767) Then ' yes QVtoV va, vb, T ' need to smooth out the mouse data QSlew.x = QSlew.x * .9 + T.x * .1: QSlew.y = QSlew.y * .9 + T.y * .1: QSlew.z = QSlew.z * .9 + T.z * .1 Qnorm QSlew ' this is what slews Else Const k = .99 ' make the slewing decay QSlew.x = QSlew.x * k: QSlew.y = QSlew.y * k: QSlew.z = QSlew.z * k QSlew.w = Sqr(1 - QSlew.x * QSlew.x - QSlew.y * QSlew.y - QSlew.z * QSlew.z) End If Qmult QSlew, QMain, QMain ' add slew to QMain va = vb ' new becomes old mouse data ' -- quaternion to Matrix QtoMatrix ' -- quaternion to Euler EuAngX = _Atan2(2 * QMain.x * QMain.w - 2 * QMain.y * QMain.z, 1 - 2 * QMain.x * QMain.x - 2 * QMain.z * QMain.z) EuAngY = _Atan2(2 * QMain.y * QMain.w - 2 * QMain.x * QMain.z, 1 - 2 * QMain.y * QMain.y - 2 * QMain.z * QMain.z) EuAngZ = _Asin(2 * QMain.x * QMain.y + 2 * QMain.z * QMain.w) ' -- rotate points For i = 1 To nPts aPts(i) = aPts0(i) ' reset to original T = QMain T.x = -T.x: T.y = -T.y: T.z = -T.z: ' << Q' >> conjugate Qmult aPts(i), T, T ' << PQ' >> Qmult QMain, T, aPts(i) ' << QPQ' >> Next i For i = 1 To 4 ' get center Z's into a(4) T = aTris(i) az(i) = aPts(T.x).z + aPts(T.y).z + aPts(T.z).z ' p1.z+p2.z+p3.z Next i zSortIndexF az(), ndx() ' getting z-order For i = 1 To nTris ' this draws the triangles drawTri (ndx(i)) ' in z-order Next i ' -- print stuff Locate 2, 101: Print Using "nloops:#,###,###,###"; nloop Locate , 101: Print Using "fps: ####.#"; nloop / (Timer - time0) Locate , 104: Print Locate , 104: Print "-- To rotate --" Locate , 104: Print "1) Click boxes" Locate , 104: Print "2) Press boxes" Locate , 104: Print "3) Drag mouse" Locate , 104: Print "ESC to end" Locate 19, 102: Print " -- Quaternion --" Locate , 99: Print Using " ##.#####"; QMain.w Locate , 99: Print Using " ##.#####"; QMain.x; QMain.y; QMain.z ' Locate , 99: Print Using " ##.#####"; QSlew.w ' Locate , 99: Print Using " ##.#####"; QSlew.x; QSlew.y; QSlew.z Locate , 100: Print "" Locate , 102: Print " -- Matrix --" Locate , 99: Print Using " ##.#####"; aMatrix(0, 0); aMatrix(0, 1); aMatrix(0, 2) Locate , 99: Print Using " ##.#####"; aMatrix(1, 0); aMatrix(1, 1); aMatrix(1, 2) Locate , 99: Print Using " ##.#####"; aMatrix(2, 0); aMatrix(2, 1); aMatrix(2, 2) Locate , 99: Print Using " k(w)= ##.#####"; 1.0 + aMatrix(0, 0) + aMatrix(1, 1) + aMatrix(2, 2) Locate , 100: Print ""
Locate , 102: Print " -- Points --" For i = 1 To nPts Locate , 99: Print Using " ##.#####"; aPts(i).x; aPts(i).y; aPts(i).z Next i Locate , 100: Print "" Locate , 102: Print " -- Euler Angles --" Locate , 100: Print Using "EuAngX: ###"; (EuAngX * 180 / _Pi + 360) Mod 360 Locate , 100: Print Using "EuAngY: ###"; (EuAngY * 180 / _Pi + 360) Mod 360 Locate , 100: Print Using "EuAngZ: ###"; (EuAngZ * 180 / _Pi + 360) Mod 360 _Display Loop Until InKey$ = Chr$(27) System
' == ROUTINES start ==
Function iBox (iCol, iRow, s3) ' simple control Dim ix, iy Locate iRow, iCol: Color 0, 14: Print s3;: Color 0, 15 ix = iCol * 8 - 11 iy = iRow * 16 - 1 Line (ix, iy)-(ix + 3 * 8 + 4, iy - 16), , B ' rectangle If m1Rpt And isIn(mx, ix, ix + 28) And isIn(my, iy - 16, iy) Then iBox = TRUE End Function
Sub Qmult (qa As type4f, qb As type4f, qab As type4f) ' Q multiplication Dim w, x, y, z w = qa.w * qb.w - qa.x * qb.x - qa.y * qb.y - qa.z * qb.z x = qa.w * qb.x + qa.x * qb.w + qa.y * qb.z - qa.z * qb.y y = qa.w * qb.y - qa.x * qb.z + qa.y * qb.w + qa.z * qb.x z = qa.w * qb.z + qa.x * qb.y - qa.y * qb.x + qa.z * qb.w qab.w = w: qab.x = x: qab.y = y: qab.z = z End Sub
Sub QVtoV (v1 As type4f, v2 As type4f, Q As type4f) ' get Q from v1 to v2 Dim v1dv2, v1xv2 As type4f ' dot, cross v1dv2 = VdotV(v1, v2) ' dot VcrossV v1, v2, Q ' cross Q.w = v1dv2 + Sqr(v1dv2 * v1dv2 + VdotV(Q, Q)) ' from the book Qnorm Q End Sub
Function VdotV (v1 As type4f, v2 As type4f) ' dot product VdotV = v1.x * v2.x + v1.y * v2.y + v1.z * v2.z End Function
Sub VcrossV (v1 As type4f, v2 As type4f, v As type4f) ' cross product v.x = v1.y * v2.z - v1.z * v2.y v.y = v1.z * v2.x - v1.x * v2.z v.z = v1.x * v2.y - v1.y * v2.x End Sub
Sub Qnorm (q As type4f) ' normalize Dim d d = Sqr(q.w * q.w + q.x * q.x + q.y * q.y + q.z * q.z) q.w = q.w / d: q.x = q.x / d: q.y = q.y / d: q.z = q.z / d End Sub
Sub drawTri (iTri) ' draw Triangle Dim ip1, ip2, ip3, icolor Dim ixc, iyc, x1, y1, x2, y2, x3, y3 T = aTris(iTri) ' the triangle ip1 = T.x: ip2 = T.y: ip3 = T.z: icolor = T.w ' the points, color x1 = 386 + kxy * aPts(ip1).x: y1 = 386 - kxy * aPts(ip1).y x2 = 386 + kxy * aPts(ip2).x: y2 = 386 - kxy * aPts(ip2).y x3 = 386 + kxy * aPts(ip3).x: y3 = 386 - kxy * aPts(ip3).y Line (x1, y1)-(x2, y2), icolor Line (x2, y2)-(x3, y3), icolor Line (x3, y3)-(x1, y1), icolor ' don't paint if points are colinear If Abs(x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2)) < 1000 Then Exit Sub ixc = (x1 + x2 + x3) / 3: iyc = (y1 + y2 + y3) / 3 ' center Paint (ixc, iyc), icolor ' paint End Sub
' -- LIBRARY ROUTINES --
' -- need Dim Shared mx,my,m1Clk,m1Rpt,m1Dn,m1End,m2Clk,m2Dn Sub MouseCk () ' get mouse info Static m1Prev, m2Prev, m1Time ' for getting edges (Clk,End) and Repeating m1Clk = 0: m1Rpt = 0: m1End = 0: m2Clk = 0 While _MouseInput: Wend ' bplus mx = _MouseX: my = _MouseY: m1Dn = _MouseButton(1): m2Dn = _MouseButton(2) If m1Dn Then ' Btn 1 down If Not m1Prev Then ' got a Clk (& Rpt), now look for repeats m1Clk = TRUE: m1Rpt = TRUE: m1Time = iMsecs + 250 ' delay 1/4 sec for repeats Else ' has been down, ck for repeat If iMsecs > m1Time Then m1Rpt = TRUE: m1Time = iMsecs + 50 ' repeat 20/sec End If m1Prev = TRUE Else ' Btn 1 up If m1Prev Then m1End = TRUE ' end of downtime (upedge) m1Prev = FALSE ' for next time End If If m2Dn Then ' Btn 2 down If Not m2Prev Then m2Clk = TRUE ' click (downedge) m2Prev = TRUE Else m2Prev = FALSE End If End Sub
Function isIn (x, a, b) ' ck between If x >= a And x <= b Then isIn = TRUE End Function
Sub zSortIndexF (a(), ndx()) ' make index to a() Dim i, j, t For i = 1 To UBound(a) ' add one at a time t = a(i) ' to be added For j = i To 2 Step -1 ' merge in If a(ndx(j - 1)) <= t Then Exit For ndx(j) = ndx(j - 1) Next j ndx(j) = i Next i End Sub
Function iMsecs () ' milliseconds since midnight UTC iMsecs = Int(Timer(.001) * 1000 + .5) End Function
Function zRandAB (a, b) zRandAB = a + Rnd * (b - a) End Function
Sub QtoMatrix () ' quaternion to matrix ' https://www.euclideanspace.com/maths/geometry/rotations/conversions/ Dim w, x, y, z, wx, wy, wz, xx, xy, xz, yy, yz, zz w = QMain.w: x = QMain.x: y = QMain.y: z = QMain.z wx = w * x wy = w * y wz = w * z xx = x * x xy = x * y xz = x * z yy = y * y yz = y * z zz = z * z aMatrix(0, 0) = 1 - 2 * (yy + zz) aMatrix(1, 1) = 1 - 2 * (xx + zz) aMatrix(2, 2) = 1 - 2 * (xx + yy) aMatrix(0, 1) = 2 * (xy - wz) aMatrix(1, 0) = 2 * (xy + wz) aMatrix(0, 2) = 2 * (xz + wy) aMatrix(2, 0) = 2 * (xz - wy) aMatrix(1, 2) = 2 * (yz - wx) aMatrix(2, 1) = 2 * (yz + wx) End Sub
Sub QRandom () ' random (unit) quaternion Dim w, x, y, z, d w = zRandAB(-1, 1): x = zRandAB(-1, 1): y = zRandAB(-1, 1): z = zRandAB(-1, 1) d = Sqr(w * w + x * x + y * y + z * z) QMain.w = w / d: QMain.x = x / d: QMain.y = y / d: QMain.z = z / d End Sub
|
|