Hello everyone! I have always aroused the interest of four-dimensional figures, and generally multi-dimensional space. I decided to write a small program where you can twist in four-dimensional hypercube in 6 planes. In principle, many of these programs, but I decided to write it on your favorite VB6, moreover, with a little refinement can be done, and other shapes.
Cube has 6 faces, squares. Because drawing lines is quite possible to draw faces 4, and similarly hypercube, you can draw only 4-cube, rather than all eight, the rest will consist of adjacent faces of these figures.
For clarity, on the tops of the hypercube I made a circle, color and size which corresponds to the coordinate T (smaller and darker - more along the axis T).
Code:
Option Explicit
' Гиперкуб (тессеракт), просмотр проекции 4-хмерного гиперкуба на 2-х мерное пространство экрана.
' Автор: Кривоус Анатолий Анатольевич (The trick) 2013
' Возможность вращения по 6-ти осям (в 6-ти плоскостях), 3-х обычных трехмерных и 3-комбинированных (XT,YT,ZT) (T-ось четвертого измерения)
' Регулировка дистанции по оси Z (по оси T фиксированно 2), угла обзора для 3D
' Гиперкуб имеет размеры (0.5,0.5,0.5,0.5), центр в точке (0,0,0,2)
' Для проекции 4D->3D, имеется возможность переключать тип проекции с параллельной в перспективную
' Темные и малые вершины, находяться "глубже" по оси T, чем светлые
' Кнопками Z-зануляется скорость вращения по оси, кнопкам R сбрасывается поворот на 0 грудусов.
Private Type Vector4D ' Четырехмерный вектор
X As Single
Y As Single
Z As Single
t As Single
w As Single
End Type
Private Type Quad
P(3) As Vector4D ' Квадрат
End Type
Private Type Cube
P(3) As Quad ' Куб
End Type
Private Const PI2 = 6.28318530717959 ' 2 * PI
Dim XY As Single, ZX As Single, ZY As Single, _
ZT As Single, XT As Single, YT As Single ' Углы поворота
Dim Tesseract(3) As Cube ' 4 куба граней тессеракта
Private Function Vec4(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single) As Vector4D ' Создание вектора
Vec4.X = X: Vec4.Y = Y: Vec4.Z = Z: Vec4.t = t: Vec4.w = 1
End Function
Private Function Vec4Add(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D ' Сложение векторов
With Vec4Add
.X = Vec1.X + Vec2.X: .Y = Vec1.Y + Vec2.Y: .Z = Vec1.Z + Vec2.Z: .t = Vec1.t + Vec2.t: .w = 1
End With
End Function
Private Function Vec4Sub(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D ' Разность векторов
With Vec4Sub
.X = Vec1.X - Vec2.X: .Y = Vec1.Y - Vec2.Y: .Z = Vec1.Z - Vec2.Z: .t = Vec1.t - Vec2.t: .w = 1
End With
End Function
Private Sub Translation4D(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single, Out() As Single) ' Перенос
Identity4d Out(): Out(4, 0) = X: Out(4, 1) = Y: Out(4, 2) = Z: Out(4, 3) = t
End Sub
Private Sub Rotation4DXY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XY
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(1, 0) = S: Out(0, 1) = -S: Out(1, 1) = C
End Sub
Private Sub Rotation4DZY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZY
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(1, 1) = C: Out(2, 1) = S: Out(1, 2) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DZX(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZX
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(0, 2) = S: Out(2, 0) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DXT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(0, 3) = S: Out(3, 0) = -S: Out(3, 3) = C
End Sub
Private Sub Rotation4DYT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости YT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(1, 1) = C: Out(3, 1) = -S: Out(1, 3) = S: Out(3, 3) = C
End Sub
Private Sub Rotation4DZT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(2, 2) = C: Out(3, 2) = -S: Out(3, 3) = S: Out(3, 3) = C
End Sub
Private Sub Projection(FOV As Single, w As Single, h As Single, F As Single, N As Single, Out() As Single) ' Матрица проекции
Dim h_ As Single, w_ As Single, a_ As Single, b_ As Single
ReDim Out(4, 4)
h_ = 1 / Tan(FOV / 2): w_ = h_ / (w / h)
a_ = F / (F - N)
b_ = -N * F / (F - N)
Out(0, 0) = h_: Out(1, 1) = w_: Out(2, 2) = a_: Out(2, 3) = b_: Out(3, 2) = 1
End Sub
Private Sub Identity4d(Out() As Single) ' Единичная матрица 5х5
Dim i As Long
ReDim Out(4, 4): For i = 0 To 4: Out(i, i) = 1: Next
End Sub
Private Sub MultiplyTransform(Out() As Single, Op1() As Single, Op2() As Single) ' Умножение 2-х матриц
Dim Tmp() As Single, i As Long, j As Long, k As Long
If UBound(Op1, 1) <> UBound(Op2, 2) Then Exit Sub ' Умножение может быть только если число столбцов первого
ReDim Tmp(UBound(Op2, 1), UBound(Op1, 2)) ' равно числу строк второго
For j = 0 To UBound(Op1, 2): For i = 0 To UBound(Op2, 1)
For k = 0 To UBound(Op1, 1)
Tmp(i, j) = Tmp(i, j) + Op1(k, j) * Op2(i, k)
Next
Next: Next
Out = Tmp
End Sub
Private Function TransformVec4D(V As Vector4D, Transform() As Single) As Vector4D ' Трансформация вектора
With TransformVec4D
.X = V.X * Transform(0, 0) + V.Y * Transform(1, 0) + V.Z * Transform(2, 0) + V.t * Transform(3, 0) + V.w * Transform(4, 0)
.Y = V.X * Transform(0, 1) + V.Y * Transform(1, 1) + V.Z * Transform(2, 1) + V.t * Transform(3, 1) + V.w * Transform(4, 1)
.Z = V.X * Transform(0, 2) + V.Y * Transform(1, 2) + V.Z * Transform(2, 2) + V.t * Transform(3, 2) + V.w * Transform(4, 2)
.t = V.X * Transform(0, 3) + V.Y * Transform(1, 3) + V.Z * Transform(2, 3) + V.t * Transform(3, 3) + V.w * Transform(4, 3)
.w = V.X * Transform(0, 4) + V.Y * Transform(1, 4) + V.Z * Transform(2, 4) + V.t * Transform(3, 4) + V.w * Transform(4, 4)
End With
End Function
' Создание куба по 3-м граням верняя левая в глубину точка Pos, Dir - направления от этой точки
Private Function CreateCube(Pos As Vector4D, Dir1 As Vector4D, Dir2 As Vector4D, Dir3 As Vector4D) As Cube
With CreateCube
.P(0) = CreateQuad(Pos, Vec4Add(Pos, Dir1), Vec4Add(Pos, Dir2))
.P(1) = CreateQuad(.P(0).P(1), Vec4Add(.P(0).P(1), Dir3), .P(0).P(2))
.P(2) = CreateQuad(.P(1).P(1), Vec4Sub(.P(1).P(1), Dir1), .P(1).P(2))
.P(3) = CreateQuad(.P(2).P(1), Pos, Vec4Add(.P(2).P(1), Dir2))
End With
End Function
' Создание квадрата по трем точкам
Private Function CreateQuad(Pos1 As Vector4D, Pos2 As Vector4D, Pos3 As Vector4D) As Quad
CreateQuad.P(0) = Pos1
CreateQuad.P(1) = Pos2
CreateQuad.P(3) = Pos3
CreateQuad.P(2) = Vec4(Pos2.X + Pos3.X - Pos1.X, Pos2.Y + Pos3.Y - Pos1.Y, _
Pos2.Z + Pos3.Z - Pos1.Z, Pos2.t + Pos3.t - Pos1.t)
End Function
Private Sub cmdReset_Click(Index As Integer) ' Сброс трансформаций
Select Case Index
Case 0: XY = 0
Case 1: ZX = 0
Case 2: ZY = 0
Case 3: ZT = 0
Case 4: XT = 0
Case 5: YT = 0
End Select
End Sub
Private Sub cmdResetAll_Click() ' Сброс всех трансформаций
XY = 0: ZX = 0: ZY = 0: ZT = 0: XT = 0: YT = 0
End Sub
Private Sub cmdZero_Click(Index As Integer) ' Обнулить скорость
sldRotateSpd(Index).Value = 0
End Sub
Private Sub Form_Load()
' Создаем тессеракт
Tesseract(0) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
Tesseract(1) = CreateCube(Vec4(-0.5, 0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
Tesseract(2) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, 1))
Tesseract(3) = CreateCube(Vec4(-0.5, -0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, -1))
End Sub
Private Sub sldRotateSpd_Scroll(Index As Integer) ' Регулятор скорости
sldRotateSpd(Index).ToolTipText = sldRotateSpd(Index).Value
End Sub
Private Sub tmrRefresh_Timer()
Dim Wrld() As Single, Tmp() As Single ' Матрицы преобразований
Dim C As Long, Q As Long, V As Long ' Кубы, квадраты, векторы
Dim Out4D As Vector4D ' Результирующий вектор
Dim X As Single, Y As Single, _
Sx As Single, Sy As Single, t As Single
XY = XY + sldRotateSpd(0).Value / 1000 ' Прибавляем приращение к каждому углу
ZX = ZX + sldRotateSpd(1).Value / 1000 ' ///
ZY = ZY + sldRotateSpd(2).Value / 1000 ' ///
ZT = ZT + sldRotateSpd(3).Value / 1000 ' ///
XT = XT + sldRotateSpd(4).Value / 1000 ' ///
YT = YT + sldRotateSpd(5).Value / 1000 ' ///
Translation4D 0, 0, sldDist.Value / 100, 2, Wrld() ' Сдвигаем от камеры на величину Distance
Rotation4DXY XY, Tmp() ' Вычисляем матрицу поворота
MultiplyTransform Wrld, Wrld, Tmp ' Комбинируем трансформации
Rotation4DZX ZX, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DZY ZY, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DZT ZT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DXT XT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DYT YT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
If Abs(XY) > PI2 Then XY = XY - Sgn(XY) * PI2 ' Ограничиваем промежутком 0..2Pi
If Abs(ZX) > PI2 Then ZX = ZX - Sgn(ZX) * PI2
If Abs(ZY) > PI2 Then ZY = ZY - Sgn(ZY) * PI2
If Abs(ZT) > PI2 Then ZT = ZT - Sgn(ZT) * PI2
If Abs(XT) > PI2 Then XT = XT - Sgn(XT) * PI2
If Abs(YT) > PI2 Then YT = YT - Sgn(YT) * PI2
Projection sldFOV.Value / 100, 1, 1, 0.1, 3.5, Tmp() ' Вычисляем матрицу проекции 3D -> 2D
picDisp.Cls
For C = 0 To UBound(Tesseract): For Q = 0 To 3: For V = 0 To 3 ' Проход по всем вершинам
Out4D = TransformVec4D(Tesseract(C).P(Q).P(V), Wrld()) ' Трансформируем в мировые координаты
t = Out4D.t ' Для цвета сохраняем
If optProjection(0).Value Then ' Перспективная проекция 4D -> 3D
Out4D = Vec4(Out4D.X / (Out4D.t * 15), Out4D.Y / (Out4D.t * 15), Out4D.Z, 1)
Else ' Параллельная проекция 4D -> 3D
Out4D = Vec4(Out4D.X / 37.5, Out4D.Y / 37.5, Out4D.Z, 1)
End If
Out4D = TransformVec4D(Out4D, Tmp()) ' Проецируем на плоскость
If Out4D.Z > 0 And Out4D.Z < 1 Then ' Если глубина в пределах 0.1-3.5 то отрисовываем
X = picDisp.ScaleWidth * (1 + Out4D.X / Out4D.t) / 2 ' Перевод в координаты PictureBox'а
Y = picDisp.ScaleHeight * (1 - Out4D.Y / Out4D.t) / 2
If V Then ' Если не первая точка квадрата то рисуем линиию и круг
picDisp.Line -(X, Y)
picDisp.FillColor = RGB(64 + (3 - t) * 192, 0, 0) ' Цвет в зависимости от глубины по координате T
picDisp.Circle (X, Y), (4 - t) * 3
Else ' Иначе переносим текущие координаты, для начала отрисовки
picDisp.CurrentX = X: Sx = X
picDisp.CurrentY = Y: Sy = Y
End If
End If
Next
picDisp.Line -(Sx, Sy) ' Замыкаем квадрат
Next: Next
lblInfo.Caption = "XY: " & Format$(XY / PI2 * 360, "##0.0°") & vbNewLine & _
"ZX: " & Format$(ZX / PI2 * 360, "##0.0°") & vbNewLine & _
"ZY: " & Format$(ZY / PI2 * 360, "##0.0°") & vbNewLine & _
"ZT: " & Format$(ZT / PI2 * 360, "##0.0°") & vbNewLine & _
"XT: " & Format$(XT / PI2 * 360, "##0.0°") & vbNewLine & _
"YT: " & Format$(YT / PI2 * 360, "##0.0°")
End SubTesseract.zip