'' bluatigro 10 sept 2017
'' all basic stuf you need for graphics3d :
'' 3dengine , math stuf , matrix , double3d and colors
Public Module basis3D
Public Class Dbl3D
Public x As Double
Public y As Double
Public z As Double
Public Sub New()
x = 0
y = 0
z = 0
End Sub
Public Sub New(a As Double, b As Double, c As Double)
x = a
y = b
z = c
End Sub
Public Sub fill(a As Double, b As Double, c As Double)
x = a
y = b
z = c
End Sub
Public Function toColor() As Color
Return Color.FromArgb(255 _
, CInt(x * 255), CInt(y * 255), CInt(z * 255))
End Function
Public Shared Operator +(a As Dbl3D, b As Dbl3D) As Dbl3D
Return New Dbl3D(a.x + b.x, a.y + b.y, a.z + b.z)
End Operator
Public Shared Operator -(a As Dbl3D, b As Dbl3D) As Dbl3D
Return New Dbl3D(a.x - b.x, a.y - b.y, a.z - b.z)
End Operator
Public Shared Operator /(a As Dbl3D, b As Double) As Dbl3D
Return New Dbl3D(a.x / b, a.y / b, a.z / b)
End Operator
Public Shared Operator *(a As Dbl3D, b As Double) As Dbl3D
Return New Dbl3D(a.x * b, a.y * b, a.z * b)
End Operator
End Class
Public Function normalize(a As Dbl3D) As Dbl3D
Return a / length(a)
End Function
Public Function dot(a As Dbl3D, b As Dbl3D) As Double
Return a.x * b.x + a.y * b.y + a.z * b.z
End Function
Public Function cross(a As Dbl3D, b As Dbl3D) As Dbl3D
Return New Dbl3D(a.y * b.z - a.z * b.y _
, a.z * b.x - a.x * b.z _
, a.x * b.y - a.y * b.x)
End Function
Public Function length(a As Dbl3D) As Double
Return Math.Sqrt(dot(a, a))
End Function
Public Function getAngle(a As Dbl3D, b As Dbl3D) As Double
Dim la As Double = length(a)
Dim lb As Double = length(b)
Dim d As Double = dot(a, b)
Return Math.Acos(d / (la * lb))
End Function
Public Class m4x4
Public m(3, 3) As Double
Public Sub identity()
Dim i As Integer
Dim j As Integer
For i = 0 To 3
For j = 0 To 3
m(i, j) = 0.0
Next j
m(i, i) = 1.0
Next i
End Sub
Public Shared Operator *(a As m4x4, b As m4x4) As m4x4
Dim uit As New m4x4()
Dim i As Int16
Dim j As Int16
Dim k As Int16
For i = 0 To 3
For j = 0 To 3
uit.m(i, j) = 0.0
For k = 0 To 3
uit.m(i, j) += a.m(i, k) * b.m(k, j)
Next k
Next j
Next i
Return uit
End Operator
Public Shared Operator *(m As m4x4, v As Dbl3D) As Dbl3D
Return New Dbl3D(v.x * m.m(0, 0) + v.y * m.m(1, 0) _
+ v.z * m.m(2, 0) + m.m(3, 0) _
, v.x * m.m(0, 1) + v.y * m.m(1, 1) _
+ v.z * m.m(2, 1) + m.m(3, 1) _
, v.x * m.m(0, 2) + v.y * m.m(1, 2) _
+ v.z * m.m(2, 2) + m.m(3, 2))
End Operator
Public Sub translate(x As Double _
, y As Double, z As Double)
m(3, 0) = x
m(3, 1) = y
m(3, 2) = z
End Sub
Public Sub rotate(deg As Double _
, ax As Int16)
Dim a As Int16 = 1
Dim b As Int16 = 2
If ax = 1 Then
a = 0
b = 2
End If
If ax = 2 Then
a = 0
b = 1
End If
m(a, a) = Math.Cos(rad(deg))
m(a, b) = -Math.Sin(rad(deg))
m(b, a) = Math.Sin(rad(deg))
m(b, b) = Math.Cos(rad(deg))
End Sub
Public Sub scale(x As Double _
, y As Double, z As Double)
m(0, 0) = x
m(1, 1) = y
m(2, 2) = z
End Sub
End Class
Public Function inverseMatrix(q As m4x4) As m4x4
'' for the inverse rotation matrix only
'' it wil NOT calculate inverse translation
Dim d As Double
Dim uit As New m4x4()
d = q.m(0, 0) * q.m(1, 1) * q.m(2, 2) _
- q.m(0, 0) * q.m(2, 1) * q.m(1, 2) _
+ q.m(1, 0) * q.m(2, 1) * q.m(0, 2) _
- q.m(1, 0) * q.m(0, 1) * q.m(2, 2) _
+ q.m(2, 0) * q.m(0, 1) * q.m(1, 2) _
- q.m(2, 0) * q.m(1, 1) * q.m(0, 2)
uit.m(0, 0) = (q.m(1, 1) * q.m(2, 2) - q.m(1, 2) * q.m(2, 1)) / d
uit.m(1, 0) = (q.m(0, 1) * q.m(2, 2) - q.m(0, 2) * q.m(2, 1)) / d
uit.m(2, 0) = (q.m(0, 1) * q.m(1, 2) - q.m(0, 2) * q.m(1, 1)) / d
uit.m(0, 1) = (q.m(1, 0) * q.m(2, 2) - q.m(1, 2) * q.m(2, 0)) / d
uit.m(1, 1) = (q.m(0, 0) * q.m(2, 2) - q.m(0, 2) * q.m(2, 0)) / d
uit.m(2, 1) = (q.m(0, 0) * q.m(1, 2) - q.m(0, 2) * q.m(1, 0)) / d
uit.m(0, 2) = (q.m(1, 0) * q.m(2, 1) - q.m(1, 1) * q.m(2, 0)) / d
uit.m(1, 2) = (q.m(0, 0) * q.m(2, 1) - q.m(0, 1) * q.m(2, 0)) / d
uit.m(2, 2) = (q.m(0, 0) * q.m(1, 1) - q.m(0, 1) * q.m(1, 2)) / d
uit.translate(0, 0, 0)
Return uit
End Function
Private sk(64) As Dbl3D
Private v(20) As m4x4
Private number As Int16
Public Const xyz As Int16 = 0
Public Const xzy As Int16 = 1
Public Const yxz As Int16 = 2
Public Const yzx As Int16 = 3
Public Const zxy As Int16 = 4
Public Const zyx As Int16 = 5
Public golden_ratio As Double = (Math.Sqrt(5) - 1) / 2
''primary colors
Public black As New Dbl3D(0, 0, 0)
Public red As New Dbl3D(1, 0, 0)
Public green As New Dbl3D(0, 1, 0)
Public yellow As New Dbl3D(1, 1, 0)
Public blue As New Dbl3D(0, 0, 1)
Public magenta As New Dbl3D(1, 0, 1)
Public cyan As New Dbl3D(0, 1, 1)
Public white As New Dbl3D(1, 1, 1)
''mixed colors
Public gray As Dbl3D = white / 2
Public orange As New Dbl3D(1, 0.5, 0)
Public pink As New Dbl3D(1, 0.5, 0.5)
Public purple As Dbl3D = magenta / 2
Public Function rainbow(deg As Double) As Dbl3D
Return New Dbl3D(Math.Sin(rad(deg)) / 2 + 0.5 _
, Math.Sin(rad(deg - 120)) / 2 + 0.5 _
, Math.Sin(rad(deg + 120)) / 2 + 0.5)
End Function
Public Function rad(deg As Double) As Double
Return deg * Math.PI / 180.0
End Function
Public Function degrees(r As Double) As Double
Return r * 180.0 / Math.PI
End Function
Public Sub rotate(ByRef k As Double _
, ByRef l As Double, deg As Double)
Dim s As Double = Math.Sin(rad(deg))
Dim c As Double = Math.Cos(rad(deg))
Dim hk As Double = k * c - l * s
Dim hl As Double = k * s + l * c
k = hk
l = hl
End Sub
Public Function nr(no As Int32, m As Int16) As String
Return Right("0000000000" & no, m)
End Function
Public Sub link(no As Int16 _
, x As Double, y As Double, z As Double _
, xz As Double, yz As Double, xy As Double _
, ax As Int16, p As Int16)
'' create new matrix
'' wil effect future drawings
If no < 1 Or no > 20 Then Exit Sub
If p < 0 Or p > 20 Then Exit Sub
If p = no Then Exit Sub
Dim trans As New m4x4
Dim rotx As New m4x4
Dim roty As New m4x4
Dim rotz As New m4x4
trans.identity()
trans.translate(x, y, z)
rotx.identity()
rotx.rotate(yz, 0)
roty.identity()
roty.rotate(xz, 1)
rotz.identity()
rotz.rotate(xy, 2)
Select Case ax
Case xyz
v(no) = rotx * roty * rotz * trans * v(p)
Case xzy
v(no) = rotx * rotz * roty * trans * v(p)
Case yxz
v(no) = roty * rotx * rotz * trans * v(p)
Case yzx
v(no) = roty * rotz * rotx * trans * v(p)
Case zxy
v(no) = rotz * rotx * roty * trans * v(p)
Case zyx
v(no) = rotz * roty * rotx * trans * v(p)
Case Else
v(no) = rotx * roty * rotz * trans * v(p)
End Select
number = no
End Sub
Public Sub child(no As Int16 _
, x As Double, y As Double, z As Double _
, lim As Int16, ax As Int16, p As Int16)
'' create a lim matrix of a avatar
'' wil effect furure drawings
link(no, x, y, z, sk(lim).y, sk(lim).x, sk(lim).z, ax, p)
End Sub
Public Sub skelet(lim As Int16 _
, x As Double, y As Double, z As Double)
'' set the skelet lim of a avatar
sk(lim) = New Dbl3D(x, y, z)
End Sub
Public Function pend(f As Double _
, amp As Double) As Double
'' for smoot animations of lims
Return Math.Sin(rad(f)) * amp
End Function
Public Sub spot(ByRef x As Double _
, ByRef y As Double, ByRef z As Double)
'' from local to world coordinates
Dim v3d As New Dbl3D(x, y, z)
v3d = v(number) * v3d
x = v3d.x
y = v3d.y
z = v3d.z
End Sub
Public Sub local(ByRef x As Double _
, ByRef y As Double, ByRef z As Double)
'' from world to local coordinates
'' only rotation matrix
Dim v3d As New Dbl3D(x, y, z)
Dim m44 As New m4x4
m44 = inverseMatrix(v(number))
v3d = m44 * v3d
x = v3d.x
y = v3d.y
z = v3d.z
End Sub
End Module