If it helps / easier to follow/debug, you can also take a look at my code based on that example 2:
If you remark the 3 'test' lines in mouseRotate that are setting fixed values to newP, newY and newR, you can run and drag mouse down from plane0 to plane4. If you then drag left/right you see it 'yaws' instead of 'rolls' from plane0 perspective
Code: (Select All)
Type XYZtype
x As Single
y As Single
z As Single
End Type
Type XYtype
x As Single
y As Single
End Type
_Define A-Z As SINGLE
Const FALSE = 0, TRUE = Not FALSE
PLANESIZE% = 1000
' CREATE PLANES
Dim P(5) As Long
createPlanes P(), PLANESIZE%
' BUILD CUBE IN OBJECT ARRAY
Dim As XYZtype O(5, 3) 'Object (PLANE,POINT)
createObject O(), PLANESIZE%
' CREATE SCREEN
fullScreen 0
'autoRotate O(), P()
mouseRotate O(), P()
End
Sub mouseRotate (O() As XYZtype, P() As Long)
mScale = _Height(0) / 4
rotate3D O(), P(), 100, PITCH, YAW, ROLL
Do
Do While _MouseInput
If _MouseButton(1) Then
If Not moving% Then
x0 = _MouseX
y0 = _MouseY
moving% = TRUE
End If
Else
moving% = FALSE
End If
Loop
If moving% Then
mdx = (x0 - _MouseX) / mScale
mdy = (y0 - _MouseY) / mScale
newP = PITCH + mdx * Sin(ROLL) + mdy * Cos(ROLL) * Cos(YAW)
newY = YAW + mdx * Cos(ROLL) * Cos(PITCH) + mdy * Sin(ROLL) * Sin(PITCH)
newR = ROLL + mdx * Sin(PITCH) * Cos(YAW) + mdy * -Sin(YAW) * Cos(PITCH)
'@TEMP: DEBUG FIXED VALUES ROLL With PITCH=-.5
newP = _Pi(-.5)
newY = 0
newR = _Pi(.1)
rotate3D O(), P(), 100, newP, newY, newR
Locate 1, 1, 0
Print Using "Pitch=####.#"; 360 * newP / _Pi(2)
Print Using " Yaw=####.#"; 360 * newY / _Pi(2)
Print Using " Roll=####.#"; 360 * newR / _Pi(2)
_Display
Else
YAW = newY
ROLL = newR
PITCH = newP
End If
Loop Until InKey$ <> ""
End Sub
Sub autoRotate (O() As XYZtype, P() As Long)
Scale = 1: dScale = 1.01
Do
_Limit 600
PITCH = PITCH + .01: If PITCH > _Pi(2) Then PITCH = PITCH - _Pi(2)
YAW = YAW + .02: If YAW > _Pi(2) Then YAW = YAW - _Pi(2)
ROLL = ROLL + .03: If ROLL > _Pi(2) Then ROLL = ROLL - _Pi(2)
Scale = Scale * dScale: If Scale < 1 Or Scale >= 500 Then dScale = 1 / dScale
rotate3D O(), P(), Scale, PITCH, YAW, ROLL
If Abs(Timer - t!) >= 1 Then t! = Timer: fps% = fp%: fp% = 0 Else fp% = fp% + 1
Locate 1, 1, 0: Print " FPS="; fps%
Print Using "Pitch=###.#"; 360 * PITCH / _Pi(2)
Print Using " Yaw=###.#"; 360 * YAW / _Pi(2)
Print Using " Roll=###.#"; 360 * ROLL / _Pi(2)
_Display
Loop Until InKey$ <> ""
End Sub
Sub rotate3D (O() As XYZtype, P() As Long, SCALE, PITCH, YAW, ROLL)
Static As XYtype P2D(4) ' SCREEN PLANE COORDINATES (#POINTS PER PLANE)
Static As XYZtype P3D(4) ' 3D PLANE COORDINATES (#POINTS PER PLANE)
Static MidX%, MidY%, MidZ%, PlaneSize%
If PlaneSize% = 0 Then
PlaneSize% = _Width(P(0)) - 1
MidX% = 0: MidY% = 0: MidZ% = -18 * PlaneSize%
End If
Scaler = SCALE * _Height(0) / 10
PitchSin = Sin(PITCH): PitchCos = Cos(PITCH)
YawSin = Sin(YAW): YawCos = Cos(YAW)
RollSin = Sin(ROLL): RollCos = Cos(ROLL)
Cls
For plane% = 0 To 5
For pnt% = 0 To 3
' TRANSLATE, THEN ROTATE
TX = O(plane%, pnt%).x: TY = O(plane%, pnt%).y: TZ = O(plane%, pnt%).z
RX = (TZ * PitchCos - TY * PitchSin) * YawSin - ((TZ * PitchSin + TY * PitchCos) * RollSin + TX * RollCos) * YawCos
RY = (TZ * PitchSin + TY * PitchCos) * RollCos - TX * RollSin
RZ = (TZ * PitchCos - TY * PitchSin) * YawCos + ((TZ * PitchSin + TY * PitchCos) * RollSin + TX * RollCos) * YawSin
' ROTATE, THEN TRANSLATE
RX = RX + MidX%: RY = RY + MidY%: RZ = RZ + MidZ%
P3D(pnt%).x = RX: P3D(pnt%).y = RY: P3D(pnt%).z = RZ
P2D(pnt%).x = _Width(0) / 2 + (Scaler * RX / RZ)
P2D(pnt%).y = _Height(0) / 2 + (Scaler * RY / RZ)
Next pnt%
' CHECK TO SEE IF PLANE IS VISIBLE
x1 = P3D(0).x: y1 = P3D(0).y: z1 = P3D(0).z
x2 = P3D(1).x: y2 = P3D(1).y: z2 = P3D(1).z
x3 = P3D(2).x: y3 = P3D(2).y: z3 = P3D(2).z
t1 = -x1 * (y2 * z3 - y3 * z2)
t2 = x2 * (y3 * z1 - y1 * z3)
t3 = x3 * (y1 * z2 - y2 * z1)
VISIBLE = t1 - t2 - t3
If VISIBLE > 0 Then
' DRAW PLANE
xx1 = P2D(0).x: yy1 = P2D(0).y
xx2 = P2D(1).x: yy2 = P2D(1).y
xx3 = P2D(2).x: yy3 = P2D(2).y
xx4 = P2D(3).x: yy4 = P2D(3).y
_MapTriangle (0, 0)-(0, PlaneSize%)-(PlaneSize%, PlaneSize%), P(plane%) To(xx3, yy3)-(xx2, yy2)-(xx1, yy1), , _Smooth
_MapTriangle (0, 0)-(PlaneSize%, PlaneSize%)-(PlaneSize%, 0), P(plane%) To(xx3, yy3)-(xx1, yy1)-(xx4, yy4), , _Smooth
End If
Next plane%
End Sub
Sub createPlanes (P() As Long, PLANESIZE%)
font& = _LoadFont(Environ$("SYSTEMROOT") + "\fonts\lucon.ttf", PLANESIZE%, "MONOSPACE, BOLD")
For PLANE% = 0 To 5
P(PLANE%) = _NewImage(PLANESIZE%, PLANESIZE%, 32)
_Dest P(PLANE%): _Font font&
Color QBcolor(8 + 6 - PLANE%), QBcolor(1 + PLANE%)
Cls
_PrintString (-PLANESIZE% * .4, PLANESIZE% * .09), Str$(PLANE%)
Next PLANE%
End Sub
Sub createObject (O() As XYZtype, PLANESIZE%)
Restore ObjectData
For plane% = 0 To 5
For pnt% = 0 To 3
Read x, y, z
O(plane%, pnt%).x = x * PLANESIZE% / 2: O(plane%, pnt%).y = y * PLANESIZE% / 2: O(plane%, pnt%).z = z * PLANESIZE% / 2
Next pnt%
Next plane%
ObjectData:
' PLANE 0
Data 1,-1,1
Data -1,-1,1
Data -1,1,1
Data 1,1,1
' PLANE 1
Data 1,-1,-1
Data 1,-1,1
Data 1,1,1
Data 1,1,-1
' PLANE 2
Data -1,-1,-1
Data 1,-1,-1
Data 1,1,-1
Data -1,1,-1
' PLANE 3
Data -1,-1,1
Data -1,-1,-1
Data -1,1,-1
Data -1,1,1
' PLANE 4
Data 1,1,1
Data -1,1,1
Data -1,1,-1
Data 1,1,-1
' PLANE 5
Data 1,-1,-1
Data -1,-1,-1
Data -1,-1,1
Data 1,-1,1
End Sub
Function QBcolor& (qc%)
Static q%, qbc&(256)
If qc% >= q% Then
tt& = _NewImage(1, 1, 0)
For q% = 0 To 255
qbc&(q%) = _PaletteColor(q%, tt&)
Next q%
_FreeImage tt&
End If
QBcolor& = qbc&(qc% Mod q%)
End Function
Sub fullScreen (size%)
$If WIN Then
Declare Library
Function getMetrics& Alias GetSystemMetrics (ByVal n As Long)
End Declare
xwin% = getMetrics(16): ywin% = getMetrics(17): xborder% = getMetrics(5): yborder% = getMetrics(6): caption% = getMetrics(4)
$Else
xwin% = _DesktopWidth: ywin% = _DesktopHeight
$End If
Select Case size%
Case 1 ' taskbar visible
w% = xwin%: h% = ywin% + caption%: x% = xborder% + 2: y% = yborder% + caption% + 2
Case 2 'taskbar and titlebar visible
w% = xwin%: h% = ywin%: x% = xborder% + 2: y% = yborder% + 2
Case Else 'default full screen
w% = _DesktopWidth: h% = _DesktopHeight: x% = xborder% + 2: y% = yborder% + caption% + 2
End Select
Screen _NewImage(w%, h%, 32): Do: Loop Until _ScreenExists: _ScreenMove -x%, -y%
_Source 0: _Dest 0
End Sub
45y and 2M lines of MBASIC>BASICA>QBASIC>QBX>QB64 experience