Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Рейтинг: 5.00. Голосов: 1.

4d гиперкуб (тессеракт)

Запись от The trick размещена 19.11.2013 в 02:44

У меня всегда вызывали интерес четырехмерные фигуры, и вообще многомерные пространства. Решил написать небольшую програмку где можно покрутить 4-хмерный гиперкуб в 4-хмерном простанстве в 6-ти плоскостях. В принципе, таких программ много, но я решил написать на любимом VB6, к тому же, с небольшой доработкой можно сделать и другие фигуры.
Куб состоит из 6-ти граней, квадратов. Т.к. отрисовка идет линиями, вполне можно рисовать 4 грани, аналогично и гипеперкуб, можно нарисовать всего 4-куба, а не все 8, остальные будут состоять из примыкающих граней этих фигур.
Для наглядности, на вершинах гиперкуба я сделал окружности, цвет и размер которых соостветствует Т координате (меньше и темнее - дальше по оси Т).
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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 Sub
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.png
Просмотров: 530
Размер:	19.0 Кб
ID:	1878  
Вложения
Тип файла: rar Tesseract.rar (15.8 Кб, 241 просмотров)
Размещено в Без категории
Показов 3813 Комментарии 0
Всего комментариев 0
Комментарии
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.