Архив4 / Kursach_po_KG_pokhozhe_na_10_variant / 5.8 / 5.8prog
.docDim VE(1, 7) As Double
Dim v(4, 7) As Double
Dim E(1, 4) As Double
Dim RGBcolor As Integer ' цвет грани
Public Sub поворот_объекта_3()
'матрица тела
v(1, 1) = -2: v(1, 2) = 2: v(1, 3) = 0: v(1, 4) = 0: v(1, 5) = 0: v(1, 6) = 0: v(1, 7) = 0
v(2, 1) = 0: v(2, 2) = 0: v(2, 3) = -2: v(2, 4) = 2: v(2, 5) = 0: v(2, 6) = 0: v(2, 7) = -2
v(3, 1) = 0: v(3, 2) = 0: v(3, 3) = 0: v(3, 4) = 0: v(3, 5) = -2: v(3, 6) = 2: v(3, 7) = 1
v(4, 1) = 1: v(4, 2) = 1: v(4, 3) = 1: v(4, 4) = 1: v(4, 5) = 1: v(4, 6) = 1: v(4, 7) = -40
'Очистка листа от предыдущего рисунка
For gamma = 0 To 6.28 Step 1.256
Range("A1:iv200").Interior.ColorIndex = xlNone
'Координаты нижнего основания
xa = -20: ya = -20: za = -20
xb = 20: yb = -20: zb = -20
xc = 20: yc = 10: zc = -20
xd = -20: yd = 10: zd = -20
'Координаты верхнего основания
xa1 = -20: ya1 = -10: za1 = 20
xb1 = 20: yb1 = -10: zb1 = 20
xc1 = 20: yc1 = 10: zc1 = 20
xd1 = -20: yd1 = 10: zd1 = 20
'Координаты сечения
xe = -20: ye = -20: ze = 0
xf = 20: yf = -20: zf = 0
'угол наблюдения в радианах от иси х
gammaNabl = 0.985
'корректируем вектор Е
E(1, 1) = -Cos(gammaNabl - gamma): E(1, 2) = -1: E(1, 3) = -Sin(gammaNabl - gamma): E(1, 4) = 0
'поворот всех точек
Call поворотZ(gamma, xa, ya, za, xa, ya, za)
Call поворотZ(gamma, xb, yb, zb, xb, yb, zb)
Call поворотZ(gamma, xc, yc, zc, xc, yc, zc)
Call поворотZ(gamma, xd, yd, zd, xd, yd, zd)
Call поворотZ(gamma, xa1, ya1, za1, xa1, ya1, za1)
Call поворотZ(gamma, xb1, yb1, zb1, xb1, yb1, zb1)
Call поворотZ(gamma, xc1, yc1, zc1, xc1, yc1, zc1)
Call поворотZ(gamma, xd1, yd1, zd1, xd1, yd1, zd1)
Call поворотZ(gamma, xe, ye, ze, xe, ye, ze)
Call поворотZ(gamma, xf, yf, zf, xf, yf, zf)
Call mul(1, 4, 4, 7, E, v, VE)
'рисуем фигуру
Call Nгранник(xa, ya, za, xb, yb, zb, xc, yc, zc, xd, yd, zd, _
xa1, ya1, za1, xb1, yb1, zb1, xc1, yc1, zc1, xd1, yd1, zd1, _
xe, ye, ze, xf, yf, zf)
Next gamma
End Sub
Sub Nгранник(xa, ya, za, xb, yb, zb, xc, yc, zc, xd, yd, zd, _
xa1, ya1, za1, xb1, yb1, zb1, xc1, yc1, zc1, _
xd1, yd1, zd1, xe, ye, ze, xf, yf, zf)
'проверка на неотрицательность скалярного произведения
'матрицы тела V и вектора наблюдателя Е
If VE(1, 1) > 0 Then
RGBcolor = 3
Call пятиугольникXYZ(xb1, yb1, zb1, xf, yf, zf, xb, yb, zb, xc, yc, zc, xc1, yc1, zc1)
End If
If VE(1, 2) > 0 Then
RGBcolor = 4
Call пятиугольникXYZ(xa, ya, za, xe, ye, ze, xa1, ya1, za1, xd1, yd1, zd1, xd, yd, zd)
End If
If VE(1, 3) > 0 Then
RGBcolor = 5
Call четырехугольникXYZ(xa1, ya1, za1, xb1, yb1, zb1, xc1, yc1, zc1, xd1, yd1, zd1)
End If
If VE(1, 4) > 0 Then
RGBcolor = 6
Call четырехугольникXYZ(xa, ya, za, xb, yb, zb, xc, yc, zc, xd, yd, zd)
End If
If VE(1, 5) > 0 Then
RGBcolor = 8
Call четырехугольникXYZ(xc1, yc1, zc1, xc, yc, zc, xd, yd, zd, xd1, yd1, zd1)
End If
If VE(1, 6) > 0 Then
RGBcolor = 10
Call четырехугольникXYZ(xa, ya, za, xe, ye, ze, xf, yf, zf, xb, yb, zb)
End If
If VE(1, 6) > 0 Then
RGBcolor = 12
Call четырехугольникXYZ(xe, ye, ze, xa1, ya1, za1, xb1, yb1, zb1, xf, yf, zf)
End If
End Sub
Sub четырехугольникXYZ(xa, ya, za, xb, yb, zb, _
xc, yc, zc, xd, yd, zd)
'рисует четырехугольник в трехмерном изображении
Call XYZ(xa, ya, za, xxa, yya)
Call XYZ(xb, yb, zb, xxb, yyb)
Call XYZ(xc, yc, zc, xxc, yyc)
Call XYZ(xd, yd, zd, xxd, yyd)
'закраска
Call четырехугольникXY(xxa, yya, xxb, yyb, xxc, yyc, xxd, yyd)
'рисование отрезков
Call граница_четырехугольника(xxa, yya, xxb, yyb, xxc, yyc, xxd, yyd)
End Sub
Public Sub четырехугольникXY(x1, y1, x2, y2, x3, y3, x4, y4)
'закраска четырехугольника как двух треугольников
Call CAP(x1, y1, x2, y2, x3, y3)
Call CAP(x1, y1, x3, y3, x4, y4)
End Sub
Public Sub граница_четырехугольника(x1, y1, x2, y2, x3, y3, x4, y4)
'рисование границы
Call line(x1, y1, x2, y2, 1)
Call line(x2, y2, x3, y3, 1)
Call line(x3, y3, x4, y4, 1)
Call line(x1, y1, x4, y4, 1)
End Sub
Sub пятиугольникXYZ(xa, ya, za, xb, yb, zb, _
xc, yc, zc, xd, yd, zd, xe, ye, ze)
'рисует пятиугольник в трехмерном изображении
Call XYZ(xa, ya, za, xxa, yya)
Call XYZ(xb, yb, zb, xxb, yyb)
Call XYZ(xc, yc, zc, xxc, yyc)
Call XYZ(xd, yd, zd, xxd, yyd)
Call XYZ(xe, ye, ze, xxe, yye)
'закраска
Call пятиугольникXY(xxa, yya, xxb, yyb, xxc, yyc, xxd, yyd, _
xxe, yye)
'рисование отрезков
Call граница_пятиугольника(xxa, yya, xxb, yyb, xxc, yyc, xxd, _
yyd, xxe, yye)
End Sub
Public Sub пятиугольникXY(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5)
'закраска пятиугольника как трех треугольников
Call CAP(x1, y1, x2, y2, x3, y3)
Call CAP(x1, y1, x3, y3, x4, y4)
Call CAP(x1, y1, x4, y4, x5, y5)
End Sub
Public Sub граница_пятиугольника(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5)
'рисование границы
Call line(x1, y1, x2, y2, 1)
Call line(x2, y2, x3, y3, 1)
Call line(x3, y3, x4, y4, 1)
Call line(x4, y4, x5, y5, 1)
Call line(x5, y5, x1, y1, 1)
End Sub
Public Sub XYZ(wx, vy, uz, qX, qY)
'определение угла между осями
al = 3 * 3.14 / 4
Call поворот(al, 0, 0, vy, 0, qX, qY)
Call сдвиг(100 + wx, 0, qX, qY, qX, qY)
Call сдвиг(0, 100 - uz, qX, qY, qX, qY)
End Sub
Sub поворотZ(ugol, x1, y1, z1, x2, y2, z2)
alpha = ugol
'massiv A
a11 = x1: a21 = y1
a31 = z1: a41 = 1
'massiv B
b11 = Cos(alpha): b12 = -Sin(alpha): b13 = 0: b14 = 0
b21 = Sin(alpha): b22 = Cos(alpha): b23 = 0: b24 = 0
b31 = 0: b32 = 0: b33 = 1: b34 = 0
b41 = 0: b42 = 0: b43 = 0: b44 = 1
'massiv rezultat
x2 = a11 * b11 + a21 * b12 + a31 * b13 + a41 * b14
y2 = a11 * b21 + a21 * b22 + a31 * b23 + a41 * b24
z2 = a11 * b31 + a21 * b32 + a31 * b33 + a41 * b34
End Sub
Public Sub поворот(ugol, x0, y0, x, y, xx, yy)
alpha = ugol
'massiv 2
Dim a(3, 3) As Single
a(1, 1) = 1: a(1, 2) = 0: a(1, 3) = x0
a(2, 1) = 0: a(2, 2) = 1: a(2, 3) = y0
a(3, 1) = 0: a(3, 2) = 0: a(3, 3) = 1
Dim b(3, 3) As Single
b(1, 1) = Cos(alpha): b(1, 2) = -Sin(alpha): b(1, 3) = 0
b(2, 1) = Sin(alpha): b(2, 2) = Cos(alpha): b(2, 3) = 0
b(3, 1) = 0: b(3, 2) = 0: b(3, 3) = 1
'massiv 3
Dim c(3, 3) As Single
c(1, 1) = 1: c(1, 2) = 0: c(1, 3) = -x0
c(2, 1) = 0: c(2, 2) = 1: c(2, 3) = -y0
c(3, 1) = 0: c(3, 2) = 0: c(3, 3) = 1
'massiv 4
Dim E(3, 3) As Single
E(1, 1) = Cos(alpha)
E(1, 2) = -Sin(alpha)
E(1, 3) = (a(1, 1) * b(1, 1) + a(1, 2) * b(2, 1) + a(1, 3) * b(3, 1)) * c(1, 3) + (a(1, 1) * b(1, 2) + a(1, 2) * b(2, 2) + a(1, 3) * b(3, 2)) * c(2, 3) + (a(1, 1) * b(1, 3) + a(1, 2) * b(2, 3) + a(1, 3) * b(3, 3)) * c(3, 3)
E(2, 1) = Sin(alpha)
E(2, 2) = Cos(alpha)
E(2, 3) = (a(2, 1) * b(1, 1) + a(2, 2) * b(2, 1) + a(2, 3) * b(3, 1)) * c(1, 3) + (a(2, 1) * b(1, 2) + a(2, 2) * b(2, 2) + a(2, 3) * b(3, 2)) * c(2, 3) + (a(2, 1) * b(1, 3) + a(2, 2) * b(2, 3) + a(2, 3) * b(3, 3)) * c(3, 3)
E(3, 1) = 0
E(3, 2) = 0
E(3, 3) = 1
Dim D(3, 3) As Single
D(1, 1) = x
D(2, 1) = y
D(3, 1) = 1
xx = E(1, 1) * D(1, 1) + E(1, 2) * D(2, 1) + E(1, 3) * D(3, 1)
yy = E(2, 1) * D(1, 1) + E(2, 2) * D(2, 1) + E(2, 3) * D(3, 1)
End Sub
Sub сдвиг(x0, y0, x, y, xx, yy)
'massiv A
a11 = 1: a12 = 0: a13 = x0
a21 = 0: a22 = 1: a23 = y0
a31 = 0: a32 = 0: a33 = 1
'massiv B
b11 = x
b21 = y
b31 = 1
'massiv rezultat
xx = a11 * b11 + a12 * b21 + a13 * b31
yy = a21 * b11 + a22 * b21 + a23 * b31
End Sub
Sub line(x1, y1, x2, y2, color)
If Abs(x2 - x1) >= Abs(y2 - y1) Then
dlina = Abs(x2 - x1)
Else
dlina = Abs(y2 - y1)
End If
dx = (x2 - x1) / dlina
dy = (y2 - y1) / dlina
i = 0: xr = x1: yr = y1
Do While i <= dlina
Call plott(xr, yr, color)
xr = xr + dx
yr = yr + dy
i = i + 1
Loop
End Sub
Sub plott(xx, yy, color)
'процедура закраски ячейки
If xx >= 1 And yy >= 1 Then
Worksheets(1).Cells(Int(yy), Int(xx)).Interior.ColorIndex = color
End If
End Sub
Public Function X_Dif_anal(xx1, yy1, xx2, yy2, yanal)
'функция возвращает координату х пересесения отрезка с координатами
'xx1, yy1, xx2, yy2, и сканирующей строки с координатой yanal
k = (xx2 - xx1) / (yy2 - yy1)
X_Dif_anal = xx1 + (yanal - yy1) * k
End Function
Public Function min(w1, w2, w3)
'нахождение минимального значения
If w1 <= w2 And w1 <= w3 Then min = w1
If w2 < w1 And w2 <= w3 Then min = w2
If w3 < w1 And w3 < w2 Then min = w3
End Function
Public Function max(w1, w2, w3)
'нахождение минимального значения
If w1 >= w2 And w1 >= w3 Then max = w1
If w2 > w1 And w2 >= w3 Then max = w2
If w3 > w1 And w3 > w2 Then max = w3
End Function
Public Sub CAP(xa, ya, xb, yb, xc, yc)
'алгоритм закраски методом списка активных ребер
'определение ограничивающего прямоугольника
xmin = min(xa, xb, xc)
ymin = min(ya, yb, yc)
xmax = max(xa, xb, xc)
ymax = max(ya, yb, yc)
'цикл по оси y
For istr = ymin To ymax
'список активных ребер
ab = False
ac = False
bc = False
'сканирующая строка между точками a, b
If (ya - istr) * (yb - istr) <= 0 And ya <> yb Then
ab = True ' ребро активно
'точки пересечения отрезка со строкой istr
xab = X_Dif_anal(xa, ya, xb, yb, istr)
End If
'сканирующая строка между точками a, c
If (ya - istr) * (yc - istr) <= 0 And ya <> yc Then
ac = True
xac = X_Dif_anal(xa, ya, xc, yc, istr)
End If
'сканирующая строка между точками b, c
If (yb - istr) * (yc - istr) <= 0 And yc <> yb Then
bc = True
xbc = X_Dif_anal(xb, yb, xc, yc, istr)
End If
'цикл по оси x
'активные ребра ab , ac
If ab And ac = True Then
dx = 1
If xac < xab Then dx = -1
For xcol = Int(xab) To Int(xac) Step dx
Call plott(xcol, istr, RGBcolor)
Next xcol
End If
'активные ребра ab , ac
If ab And bc = True Then
dx = 1
If xab > xbc Then dx = -1
For xcol = Int(xab) To Int(xbc) Step dx
Call plott(xcol, istr, RGBcolor)
Next xcol
End If
If bc And ac = True Then
dx = 1
If xac > xbc Then dx = -1
For xcol = Int(xac) To Int(xbc) Step dx
Call plott(xcol, istr, RGBcolor)
Next xcol
End If
Next istr
End Sub
Sub mul(n1, m1, n2, m2, a, b, c)
'функция скалярного произведения двух матриц
For k = 1 To n1
For i = 1 To m2
tmp = 0
For j = 1 To m1
tmp = tmp + a(k, j) * b(j, i)
Next j
c(k, i) = tmp
Next i
Next k
End Sub