close

Вход

Забыли?

вход по аккаунту

?

Guro

код для вставкиСкачать
5.11.2
StepUg = 0.1
ngr = 0 'номер расчитываемой грани
For i = -0.5 To 2.5 Step StepUg
'1 точка основания
xb = 15 * Cos(i)
yb = 10 * Sin(i)
zb = 0
xc = 15 * Cos(i)
yc = 10 * Sin(i)
zc = -30
Call XYZ(xb, yb, zb, xxb, yyb)
Call XYZ(xc, yc, zc, xxc, yyc)
'2 точка основания
xb1 = 15 * Cos(i + StepUg)
yb1 = 10 * Sin(i + StepUg)
zb1 = 0
xc1 = 15 * Cos(i + StepUg)
yc1 = 10 * Sin(i + StepUg)
zc1 = -30
Call XYZ(xb1, yb1, zb1, xxb1, yyb1)
Call XYZ(xc1, yc1, zc1, xxc1, yyc1)
'вычисляем нормаль к грани
Call normal(xb, yb, zb, xb1, yb1, zb1, xc1, yc1, zc1, xn, yn, zn)
'вычисляем кос угла между источн. света и нормалью к поверх
cus = Abs(cosugolsun(xsun, ysun, zsun, xn, yn, zn))
'Заполнение массивов
koord(ngr, 1) = xxb
koord(ngr, 2) = yyb
koord(ngr, 3) = xxb1: dop(ngr, 1) = xxc1
Инв.№
подл.
Подпись и дата
Взамен инв.№
Dim RGBcolor As Integer ' цвет грани
Dim koord(32, 6) As Variant 'массив координат точек b и c
Dim dop(32, 2) As Variant
Dim Igr(32) As Variant 'массив освещенности граней
Dim Ngrmax As Integer ' число граней пир. <10
'координаты источника света
Dim xsun As Variant
Dim ysun As Variant
Dim zsun As Variant
'координаты вершина пирамиды
Dim xa As Variant
Dim ya As Variant
Dim za As Variant
Dim StepUg As Variant 'Шаг по граням пирамиды в радианах
Public Sub F3_Гуро()
xsun = 3
ysun = 3
zsun = 2
'вершина пирамиды
xa = 0
ya = 0
za = 0
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
'шаг по граням
StepUg = 0.3
ngr = 0 'номер расчитываемой грани
'Call Parametr
For i = 0 To 6.3 Step StepUg
Call XYZ(xa, ya, za, xxa, yya)
'1 точка основания
xb = 15 * Cos(i)
yb = 10 * Sin(i)
zb = 0
Call XYZ(xb, yb, zb, xxb, yyb)
'2 точка основания
xc = 15 * Cos(i + StepUg)
yc = 10 * Sin(i + StepUg)
zc = 0
Call XYZ(xc, yc, zc, xxc, yyc)
'вычисляем нормаль к грани
Call normal(xa, ya, za, xb, yb, zb, xc, yc, zc, xn, yn, zn)
'вычисляем кос угла между источн. света и нормалью к поверх
cus = Abs(cosugolsun(xsun, ysun, zsun, xn, yn, zn))
'Заполнение массивов
koord(ngr, 1) = xxa
koord(ngr, 2) = yya
koord(ngr, 3) = xxb
koord(ngr, 4) = yyb
koord(ngr, 5) = xxc
koord(ngr, 6) = yyc
'интенсивность света
Igr(ngr) = modsv(cus)
ngr = ngr + 1
If ngr = 22 Then Exit For
Next i
'Число граней
Инв.№
подл.
Подпись и дата
Взамен инв.№
koord(ngr, 4) = yyb1: dop(ngr, 2) = yyc1
koord(ngr, 5) = xxc
koord(ngr, 6) = yyc
'интенсивность света
Igr(ngr) = modsv(cus)
ngr = ngr + 1
If ngr = 31 Then Exit For
Next i
'Число граней
Ngrmax = ngr - 1
'Цикл рисования граней
For ngr = 0 To 30
'рисование грани
Call treug_Guro(ngr)
koord(ngr, 1) = dop(ngr, 1)
koord(ngr, 2) = dop(ngr, 2)
Call treug_Guro(ngr)
Next ngr
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
Взамен инв.№
Подпись и дата
Инв.№
подл.
Ngrmax = ngr - 1
'Цикл рисования граней
For ngr = 0 To 21
'рисование грани
Call treug_Guro(ngr)
Next ngr
'засечка конечного системного времени
End Sub
Sub normal(xxa, yya, zza, xxb, yyb, zzb, xxc, yyc, zzc, xxn, yyn, zzn)
'процедура вычисления нормали к поверхности
'входные величины координаты трех точек в мировых координатах
'xxn, yyn, zzn координаты радиус-вектора к нормале
xxn = (yyb - yya) * (zzc - zza) - (zzb - zza) * (yyc - yya)
yyn = (zzb - zza) * (xxc - xxa) - (xxb - xxa) * (zzc - zza)
zzn = (xxb - xxa) * (yyc - yya) - (yyb - yya) * (xxc - xxa)
End Sub
Function cosugolsun(xxsun, yysun, zzsun, xxn, yyn, zzn)
'xxsun, yysun, zzsun, - координаты источника света
'xxn, yyn, zzn - координаты нормали к поверхности
'вычислим длину радиус векторов
sun = (xxsun ^ 2 + yysun ^ 2 + zzsun ^ 2) ^ 0.5
n = (xxn ^ 2 + yyn ^ 2 + zzn ^ 2) ^ 0.5
'косинус угла между источником света и норалью к поверхности
cosugolsun = (xxsun * xxn + yysun * yyn + zzsun * zzn) / (sun * n)
End Function
Function modsv(cug)
'модель освещения матового тела
modsv = 255 * cug
End Function
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, 50 - uz, qX, qY, qX, qY)
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
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
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
Инв.№
подл.
Подпись и дата
Взамен инв.№
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)
a11 = 1: a12 = 0: a13 = x0
a21 = 0: a22 = 1: a23 = y0
a31 = 0: a32 = 0: a33 = 1
b11 = x
b21 = y
b31 = 1
xx = a11 * b11 + a12 * b21 + a13 * b31
yy = a21 * b11 + a22 * b21 + a23 * b31
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
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
Взамен инв.№
Подпись и дата
Инв.№
подл.
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 plott_color(xx, yy, intens)
'функция рисования путем создания прямоугольника
Worksheets("экран").Shapes.AddShape(msoShapeRectangle, 2 * xx, 2 * yy, 2, 2).Select
' закраска прямоугольника
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(intens, intens, intens)
'удаление границы
Selection.ShapeRange.Line.Visible = msoFalse
End Sub
Public Sub treug_Guro(ngr)
'алгоритм закраски методом списка активных ребер
xa = koord(ngr, 1)
ya = koord(ngr, 2)
xb = koord(ngr, 3)
yb = koord(ngr, 4)
xc = koord(ngr, 5) '
yc = koord(ngr, 6)
'определение ограничивающего прямоугольника
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 Step 1
'список активных ребер
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
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
dx = 1
If xac < xab Then dx = -1
For xcol = Int(xab) To Int(xac) Step dx
'Функция определения интенсивности освещения по модели Гуро
RGBcolor = modGuro(Int(xcol), Int(xab), Int(xac), ngr)
Call plott_color(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
'Функция определения интенсивности освещения по модели Гуро
RGBcolor = modGuro(Int(xcol), Int(xab), Int(xbc), ngr)
Call plott_color(xcol, istr, RGBcolor)
Next xcol
End If
If bc And ac = True Then
dx = 1
End If
Next istr
End Sub
Public Function modGuro(x, x1, x2, n)
'Вычисление освещенности граней методом Гуро
'освещенность на соседних ребрах
'Проверка краиних индексов массивов
If n = 31 Then
I1 = Igr(0)
Else
I1 = Igr(n + 1)
End If
'Левое ребро
Il = (I1 + Igr(n)) / 2
If n = 0 Then
I2 = Igr(Ngrmax)
Else
I2 = Igr(n - 1)
End If
'Правое ребро
Инв.№
подл.
Подпись и дата
Взамен инв.№
If xac > xbc Then dx = -1
For xcol = Int(xac) To Int(xbc) Step dx
'Функция определения интенсивности освещения по модели Гуро
RGBcolor = modGuro(Int(xcol), Int(xbc), Int(xac), ngr)
Call plott_color(xcol, istr, RGBcolor)
Next xcol
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
Инв.№
подл.
Подпись и дата
Взамен инв.№
Ir = (I2 + Igr(n)) / 2
'Освещенность в текущей точке x
If x2 = x1 Then
modGuro = (Ir + Il) / 2
Else
modGuro = Il - (Il - Ir) * (x - x2) / (x1 - x2)
'Stop
End If
End Function
Лист
Изм. Колич Лист №док.
.
Подп.
Дата
Формат А4
Документ
Категория
Математика
Просмотров
5
Размер файла
144 Кб
Теги
guro
1/--страниц
Пожаловаться на содержимое документа