-Музыка

Этимологическая ошибка

Дневник

Среда, 29 Мая 2013 г. 02:33 + в цитатник
Как гласит педикия:
Hex (hexadeсimal) — обозначение шестнадцатеричной системы счисления.
В переводе с немецкого «Hexen» означает «ведьмы, колдуньи», а «to hex» — «колдовать».
То-то я не мог долгое время уловить связь меж фентезийной игрушкой, именованной превосходной степенью степени счисления. «Он куда более шестнадцатеричен, даже более, шестнадцатеричнейший...».
Теперь, обнаружив пропажу своего html-сборища полезных функций, я буду публиковать их прямо тут. Мне насрать на то, что это вовсе не дняфковый формат, просто сюда я имею быстрый доступ, а ещё больше мне насрать на мнение окружающих, что VB6 отнюдь не самая лучшая среда реализации всего-всего, я как Кен Сильверман, отрабатываю алгоритмы и принципы в самом что ни на есть допустимо-нестрогом и в то же время однозначно интерпретируемом языке BASIC. Зачастую пусть так и остаётся, ибо зачастую производительность «и так сойдёт». Затем весь этот индусский код можно запилить в ASM, однако VB хорош тем, что доступен даже из Excel.
Итак, не отвлекаемся.
Перевод кодовых страниц CP1251 и CP866 (VB, QB)
Function String1251To866$(strWin$)
   'Из кодовой страницы 1251 в 866
   TwinTodos$ = ""
   For i = 1 To Len(strWin$)
      k = Asc(Mid$(strWin$, i, 1))
      If k >= 192 And k <= 239 Then
        TwinTodos$ = TwinTodos$ + Chr$(k - 64)
      ElseIf k >= 240 And k <= 255 Then
        TwinTodos$ = TwinTodos$ + Chr$(k - 16)
      ElseIf k = 9 Then 'Конверсия табуляторов
        TwinTodos$ = TwinTodos$ + Space$(8)
      Else
        TwinTodos$ = TwinTodos$ + Chr$(k)
      End If
   Next i
   String1251To866$ = TwinTodos$
End Function

Function String866To1251$(strDos$)
   'Из кодовой страницы 866 в 1251
   TdosTowin$ = ""
   For i = 1 To Len(strDos$)
      k = Asc(Mid$(strDos$, i, 1))
      If k >= 128 And k <= 175 Then
        TdosTowin$ = TdosTowin$ + Chr$(k + 64)
      ElseIf k >= 224 And k <= 239 Then
        TdosTowin$ = TdosTowin$ + Chr$(k + 16)
      ElseIf k = 9 Then 'Конверсия табуляторов
        TdosTowin$ = TdosTowin$ + Space$(8)
      Else
        TdosTowin$ = TdosTowin$ + Chr$(k)
      End If
   Next i
   String866To1251$ = TdosTowin$
End Function

Нахождение точки пересечения двух отрезков (VB,QB)
Sub LineSegmentCross(x1, y1, x2, y2, x3, y3, x4, y4, xCross, yCross)
  ' Собственно сама выходная функция
  LineEquation x1, y1, x2, y2, AP1, BP1, CP1
  LineEquation x3, y3, x4, y4, AP2, BP2, CP2
  LineCrossing AP1, BP1, CP1, AP2, BP2, CP2, xCross, yCross
End Sub

Sub LineEquation(x1, y1, x2, y2, AP, BP, CP)
  ' Перевод координат линии по двум точкам X,Y в коэффициенты
  If x1 = x2 And y1 = y2 Then
    AP = 0
    BP = 0
    CP = 0
  Else
    AP = y2 - y1
    BP = x1 - x2
    CP = -AP * x1 - BP * y1
    coeff = Sqr(AP * AP + BP * BP)
    AP = AP / coeff
    BP = BP / coeff
    CP = CP / coeff
  End If
End Sub

Sub LineCrossing(AP1, BP1, CP1, AP2, BP2, CP2, xCross, yCross)
 'Нахождение пересечения линий
 Delta = AP1 * BP2 - BP1 * AP2
 If Delta <> 0 Then
   xCross = -(CP1 * BP2 - BP1 * CP2) / Delta
   yCross = -(AP1 * CP2 - CP1 * AP2) / Delta
 End If
End Sub

Алгоритм Сазерленда-Коэна, любезно транслированный одним добрым человеком из википедии на VB
Для «урезонивания» (обрезания) с сохранением углов и направлений координат отрезка (X0,Y0,X1,Y1), если оный выходит за рамки xMin,xMax,yMin,yMax. Возвращает False если он не пересекает ограниченную область.
Private Enum EdgeCode
 ecNone = &H0
 ecLeft = &H1
 ecRight = &H2
 ecBottom = &H4
 ecTop = &H8
End Enum

Public Function CohenSutherlandLineClip(x0, y0, x1, y1, xMin, xMax, yMin, yMax) As Boolean
 'Сама процедура алгоритма
 Dim accept As Boolean, done As Boolean
 Dim outcode0 As EdgeCode, outcode1 As EdgeCode, outcodeOut As EdgeCode
 Dim X As Double, Y As Double
 accept = False
 done = False
 Call CompOutCode(x0, y0, xmin, xmax, ymin, ymax, outcode0)
 Call CompOutCode(x1, y1, xmin, xmax, ymin, ymax, outcode1)
 Do
  If (outcode0 = ecNone) And (outcode1 = ecNone) Then
   accept = True
   done = True
  ElseIf ((outcode0 And outcode1) <> ecNone) Then
   done = True
  Else
   If (outcode0 <> ecNone) Then outcodeOut = outcode0 Else outcodeOut = outcode1
   If (outcodeOut And ecTop) Then
     X = x0 + (x1 - x0) * (ymax - y0) / (y1 - y0)
     Y = ymax
   End If
   If (outcodeOut And ecBottom) Then
     X = x0 + (x1 - x0) * (ymin - y0) / (y1 - y0)
     Y = ymin
   ElseIf (outcodeOut And ecRight) Then
     Y = y0 + (y1 - y0) * (xmax - x0) / (x1 - x0)
     X = xmax
   ElseIf (outcodeOut And ecLeft) Then
     Y = y0 + (y1 - y0) * (xmin - x0) / (x1 - x0)
     X = xmin
   End If
   If (outcodeOut = outcode0) Then
     x0 = X
     y0 = Y
     Call CompOutCode(x0, y0, xmin, xmax, ymin, ymax, outcode0)
   Else
     x1 = X
     y1 = Y
     Call CompOutCode(x1, y1, xmin, xmax, ymin, ymax, outcode1)
   End If
  End If
 Loop Until done
 CohenSutherlandLineClip = accept
 End Function

 Private Sub CompOutCode(X, Y, xMin, xMax, yMin, yMax, code As EdgeCode)
   'Вычисление бинарного кода состояния прямой (отрезка)
   code = 0
   If (Y > yMax) Then code = ecTop _
   Else If (Y < yMin) Then code = ecBottom
   If (X > xMax) Then code = code Or ecRight 
   Else If (X < xMin) Then code = code Or ecLeft
 End Sub

Алгоритмы сортировки массивов
    For i = 0 To UBound(MyArray) 'Сортировка пузырьком
        For j = i + 1 To UBound(MyArray)
            If MyArray(i) > MyArray(j) Then
                temp = MyArray(i)
                MyArray(i) = MyArray(j)
                MyArray(j) = temp
             End If
       Next j
    Next i
'---------------------------------------------
' Сортировка выбором (в принципе, N = UBound(MyArray)
         For q = 1 To N - 1
            Min = MyArray(q)
            k_min = q
            For j = q + 1 To N
               If MyArray(j) < Min Then
                 MinY = MyArray(j)
                 k_min = j
               End If
             Next j
             MyArray(k_min) = MyArray(q)
             MyArray(q) = MinY
         Next q

Преобразование координат 3D в 2D-проекцию на экране (догадываетесь, к чему я веду всем этим кодом;)?)
Dim camX, camY, camZ    'Абсолютные координаты камеры
Dim aX, aY 'Углы наклона камеры по осям X и Y
Dim xSize As Integer, ySize As Integer 'Размеры экрана (видимой области)

Function Calculate(X, Y, Z, xscr, yscr) As Boolean
  'Собственно, функция проекции из координат точки в экранные
  'Говорит True если надо рисовать
  CalculateTemporaryAxis X, Y, Z, tmpX, tmpY, tmpZ
  If tmpZ > 0 Then Calculate = False: Exit Function

  tempZ = ySize / tmpz
  xScr = Int(tmpX * tempZ + (xSize / 2))  'xSize
  yScr = Int(tmpY * tempZ + (ySize / 2))
  Calculate = True
  'В формулах проекции заключен FOV
End Function

Sub CalculateTemporaryAxis(X, Y, Z, tmpX, tmpY, tmpZ)
 'Приведение координат из абсолютных к оси Z, направленной из камеры
 tmpX = (X - camX) * Cos(aY) - (Z - camZ) * Sin(aY)
 tmpZ = ((X - camX) * Sin(aY) + (Z - camZ) * Cos(aY)) * (Cos(aX) - (Y - camY) * Sin(aX))
 tmpY = tmpZ * Sin(aX) + (Y - camY) * Cos(aX)
End Sub
soxie_pure_visual_basic_3d (700x406, 55Kb) soxie_pure_visual_basic_3d_1 (700x406, 153Kb)
Рубрики:  этот удивительный мир вокруг нас

Метки:  

 Страницы: [1]