'Matan Cohen
Option Explicit
Public Const MaxPoints = 800
Public Const Parallel = 0
Public Const Perspective = 1
'Distance center of projection
Private Dist As Single
'Current projection
Private Projec As Byte
'Center of view origin
Private Xorg As Single
Private Yorg As Single
'Point to be used in API functions
Private Type POINTAPI
X As Long
Y As Long
End Type
'View of polygon
Private Poly2D(1 To MaxPoints) As POINTAPI
Private ST(1 To MaxPoints) As m3Point
'Point to be used in API functions
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
'Set current projection to be Perspective
Public Sub DrSetPerspective()
Projec = Perspective
'Set default distance to be 600
If Dist = 0 Then Dist = 600
End Sub
'Set current projection to be Parallel
Public Sub DrSetParallel()
Projec = Parallel
End Sub
'Return True if current projection is Parallel
'Return False if current projection is Perspective
Public Function DrIsParallel() As Boolean
DrIsParallel = (Projec = Parallel)
End Function
'Return distance center of projection
Public Function DrGetDistance() As Single
DrGetDistance = Dist
End Function
'Set distance Center of projection
Public Sub DrSetDistance(ByVal New_Dist As Single)
Dist = New_Dist
End Sub
Public Sub DrLine3D(ByRef Obj As Object, ByRef p1 As m3Point, ByRef p2 As m3Point)
Dim x1 As Long, y1 As Long
Dim x2 As Long, y2 As Long
Dim pt As POINTAPI
Dim f As Single
Xorg = Abs(Obj.ScaleLeft)
Yorg = Abs(Obj.ScaleTop)
Select Case Projec
Case Parallel
x1 = Xorg + p1.X
y1 = Yorg - p1.Y
x2 = Xorg + p2.X
y2 = Yorg - p2.Y
Case Perspective
f = Dist / (Dist - p1.Z)
x1 = Xorg + f * p1.X
y1 = Yorg - f * p1.Y
f = Dist / (Dist - p2.Z)
x2 = Xorg + p2.X
y2 = Yorg - p2.Y
End Select
MoveToEx Obj.hdc, x1, y1, pt
LineTo Obj.hdc, x2, y2
SetPixel Obj.hdc, x2, y2, Obj.ForeColor
End Sub
Public Sub Poly3DDraw(ByRef Obj As Object, ByRef P As Poly3D, ByVal closed As Boolean)
Dim i As Integer
Dim nVerts As Integer
Dim f As Single
Xorg = Abs(Obj.ScaleLeft)
Yorg = Abs(Obj.ScaleTop)
nVerts = P.nVerts
Select Case Projec
Case Parallel
For i = 1 To nVerts
Poly2D(i).X = Xorg + P.Verts(i).X
Poly2D(i).Y = Yorg - P.Verts(i).Y
Next i
Case Perspective
For i = 1 To nVerts
f = Dist / (Dist - P.Verts(i).Z)
Poly2D(i).X = Xorg + f * P.Verts(i).X
Poly2D(i).Y = Yorg - f * P.Verts(i).Y
Next i
End Select
If closed Then
nVerts = nVerts + 1
Poly2D(nVerts) = Poly2D(1)
End If
Polyline Obj.hdc, Poly2D(1), nVerts
End Sub
Public Sub Poly3DFill(ByRef Obj As Object, ByRef P As Poly3D)
Dim i As Integer
Dim nVerts As Integer
Dim f As Single
Xorg = Abs(Obj.ScaleLeft)
Yorg = Abs(Obj.ScaleTop)
nVerts = P.nVerts
Select Case Projec
Case Parallel
For i = 1 To nVerts
Poly2D(i).X = Xorg + P.Verts(i).X
Poly2D(i).Y = Yorg - P.Verts(i).Y
Next i
Case Perspective
For i = 1 To nVerts
f = Dist / (Dist - P.Verts(i).Z)
Poly2D(i).X = Xorg + f * P.Verts(i).X
Poly2D(i).Y = Yorg - f * P.Verts(i).Y
Next i
End Select
Polygon Obj.hdc, Poly2D(1), P.nVerts
End Sub
Public Function PlaneIsVisible(ByRef p1 As m3Point, ByRef p2 As m3Point, ByRef P3 As m3Point) As Boolean
Dim f As Single
Dim v As m3Vector
Dim u As m3Vector
Dim W As m3Vector
Dim pp1 As m3Point
Dim pp2 As m3Point
Dim pp3 As m3Point
Select Case Projec
Case Parallel
pp1 = p1
pp2 = p2
pp3 = P3
Case Perspective
f = Dist / (Dist - p1.Z)
pp1.X = f * p1.X
pp1.Y = f * p1.Y
pp1.Z = p1.Z
f = Dist / (Dist - p2.Z)
pp2.X = f * p2.X
pp2.Y = f * p2.Y
pp2.Z = p2.Z
f = Dist / (Dist - P3.Z)
pp3.X = f * P3.X
pp3.Y = f * P3.Y
pp3.Z = P3.Z
End Select
v = m3VectorInit(pp1, pp2)
u = m3VectorInit(pp2, pp3)
W = m3VectorCross(v, u)
PlaneIsVisible = (W.Z > 0)
End Function
Public Sub Solid3DDraw(ByRef Obj As Object, ByRef S As Solid3D)
Dim i As Integer
Dim j As Integer
Dim nVerts As Integer
Dim f As Single
Dim p1 As m3Point
Dim p2 As m3Point
Dim P3 As m3Point
Xorg = -Obj.ScaleLeft
Yorg = Obj.ScaleTop
nVerts = S.nVerts
Select Case Projec
Case Parallel
For i = 1 To nVerts
ST(i) = S.Verts(i)
Next i
Case Perspective
For i = 1 To nVerts
f = Dist / (Dist - S.Verts(i).Z)
ST(i).X = f * S.Verts(i).X
ST(i).Y = f * S.Verts(i).Y
ST(i).Z = S.Verts(i).Z
Next i
End Select
For i = 1 To S.nFaces
p1 = S.Verts(S.Faces(i).Face(1))
p2 = S.Verts(S.Faces(i).Face(2))
P3 = S.Verts(S.Faces(i).Face(3))
If PlaneIsVisible(p1, p2, P3) Then
For j = 1 To S.Faces(i).nVerts
Poly2D(j).X = Xorg + ST(S.Faces(i).Face(j)).X
Poly2D(j).Y = Yorg - ST(S.Faces(i).Face(j)).Y
Next j
Polygon Obj.hdc, Poly2D(1), S.Faces(i).nVerts
End If
Next i
End Sub
Public Sub Solid3DDrawFromTo(ByRef Obj As Object, ByRef S As Solid3D, ByVal FromFace As Integer, ByVal ToFace As Integer)
Dim i As Integer
Dim j As Integer
Dim nVerts As Integer
Dim f As Single
Dim p1 As m3Point
Dim p2 As m3Point
Dim P3 As m3Point
Xorg = -Obj.ScaleLeft
Yorg = Obj.ScaleTop
nVerts = S.nVerts
Select Case Projec
Case Parallel
For i = 1 To nVerts
ST(i) = S.Verts(i)
Next i
Case Perspective
For i = 1 To nVerts
f = Dist / (Dist - S.Verts(i).Z)
ST(i).X = f * S.Verts(i).X
ST(i).Y = f * S.Verts(i).Y
ST(i).Z = S.Verts(i).Z
Next i
End Select
For i = FromFace To ToFace
p1 = S.Verts(S.Faces(i).Face(1))
p2 = S.Verts(S.Faces(i).Face(2))
P3 = S.Verts(S.Faces(i).Face(3))
If PlaneIsVisible(p1, p2, P3) Then
For j = 1 To S.Faces(i).nVerts
Poly2D(j).X = Xorg + ST(S.Faces(i).Face(j)).X
Poly2D(j).Y = Yorg - ST(S.Faces(i).Face(j)).Y
Next j
Polygon Obj.hdc, Poly2D(1), S.Faces(i).nVerts
End If
Next i
End Sub
'********* Light Direction ***************************
Private lightVector As m3Vector
'*********** Ambient Light is some non-directional light in the
'************environment (background light).
'Ambient Light Factor is 0.2
Private Const AmbFactor = 0.2
'//////////////////////////////////////////////////////////////
Public Sub DrSetLightVector(ByRef lVector As m3Vector)
Dim L As Single
L = m3VectorLen(lVector)
If L < 0.000001 Then
lightVector.X = 0
lightVector.Y = 0
lightVector.Z = 1
Else
lightVector.X = lVector.X / L
lightVector.Y = lVector.Y / L
lightVector.Z = lVector.Z / L
End If
End Sub
Public Function DrGetLightVector() As m3Vector
DrGetLightVector = lightVector
End Function
Public Sub DrApplyLightVector(ByRef M As m3Matrix)
m3VectorApply lightVector, M
End Sub
'Draw the solid object width Shading on the object
Public Sub Solid3DShadingDraw(ByRef Obj As Object, ByRef S As Solid3D, ByVal Border As Boolean)
Dim i As Integer
Dim j As Integer
Dim f As Single
Dim v As m3Vector
Dim u As m3Vector
Dim n As m3Vector
Dim nVerts As Integer
Dim p1 As Integer
Dim p2 As Integer
Dim P3 As Integer
'********** Shading Factors*******************************
Dim color As Long
Dim ColorTo As Long
Dim BorderColor As Long
Dim R As Byte
Dim G As Byte
Dim B As Byte
Dim maxRGB As Byte
Dim dot As Single
Dim dotMax As Single
'*************************************************************
'********** Shading Init Factors*******************************
color = Obj.FillColor
BorderColor = Obj.ForeColor
'Resolve Fill Color Into RGB Components
R = &HFF& And color
G = (&HFF00& And color) \ &H100&
B = (&HFF0000 And color) \ &H10000
'Compute Maximum Componen Of RGB Components
maxRGB = R
If G > maxRGB Then maxRGB = G
If B > maxRGB Then maxRGB = B
'Compute Maximum Factor Of RGB Components
dotMax = maxRGB / 255
'Ambient Light is some non-directional light in the environment
' (background light).
' Ambient Light Factor is 0.2
dotMax = dotMax + AmbFactor
If dotMax * maxRGB > 255 Then dotMax = 255 / maxRGB
Xorg = Abs(Obj.ScaleLeft)
Yorg = Abs(Obj.ScaleTop)
Select Case Projec
Case Parallel
For i = 1 To S.nVerts
ST(i) = S.Verts(i)
Next i
Case Perspective
For i = 1 To S.nVerts
f = Dist / (Dist - S.Verts(i).Z)
ST(i).X = S.Verts(i).X * f
ST(i).Y = S.Verts(i).Y * f
ST(i).Z = S.Verts(i).Z
Next i
End Select
For i = 1 To S.nFaces
p1 = S.Faces(i).Face(1)
p2 = S.Faces(i).Face(2)
P3 = S.Faces(i).Face(3)
v = m3VectorInit(ST(p1), ST(p2))
u = m3VectorInit(ST(p2), ST(P3))
n = m3VectorCross(v, u)
nVerts = S.Faces(i).nVerts
If n.Z > 0 Then
For j = 1 To nVerts
p1 = S.Faces(i).Face(j)
Poly2D(j).X = Xorg + ST(p1).X
Poly2D(j).Y = Yorg - ST(p1).Y
Next j
m3VectorSetLen 1, n
dot = lightVector.X * n.X + lightVector.Y * n.Y + lightVector.Z * n.Z
If dot > 0.0000001 Then
dot = dot + AmbFactor
Else
dot = AmbFactor
End If
If dot > dotMax Then dot = dotMax
ColorTo = RGB(dot * R, dot * G, dot * B)
Obj.FillColor = ColorTo
If Not Border Then
Obj.ForeColor = ColorTo
End If
Polygon Obj.hdc, Poly2D(1), nVerts
End If
Next i
' Restore Object's Colors
Obj.FillColor = color
Obj.ForeColor = BorderColor
End Sub
'Aplly view of Polygon 3D to 2D
Private Sub ProjectM3Points(ByVal nVerts As Integer, ByRef P() As m3Point)
Dim f As Single
Dim i As Integer
Select Case Projec
Case Parallel
For i = 1 To nVerts
Poly2D(i).X = Xorg + P(i).X
Poly2D(i).Y = Yorg - P(i).Y
Next i
Case Perspective
For i = 1 To nVerts
f = Dist / (Dist - P(i).Z)
Poly2D(i).X = Xorg + f * P(i).X
Poly2D(i).Y = Yorg - f * P(i).Y
Next i
End Select
End Sub
'Draw and fill the polygon width Shading on the object
Public Sub Poly3DShadingFill(ByRef Obj As Object, ByRef P As Poly3D, ByVal Border As Boolean)
Dim i As Integer
Dim p1 As m3Point
Dim p2 As m3Point
Dim P3 As m3Point
Dim n As m3Vector
Dim v As m3Vector
Dim u As m3Vector
Dim f As Single
'********** Shading Factors*******************************
Dim color As Long
Dim ColorTo As Long
Dim BorderColor As Long
Dim R As Byte
Dim G As Byte
Dim B As Byte
Dim maxRGB As Byte
Dim dot As Single
Dim dotMax As Single
'*************************************************************
'********** Shading Init Factors*******************************
color = Obj.FillColor
BorderColor = Obj.ForeColor
'Resolve Fill Color Into RGB Components
R = &HFF& And color
G = (&HFF00& And color) \ &H100&
B = (&HFF0000 And color) \ &H10000
'Compute Maximum Componen Of RGB Components
maxRGB = R
If G > maxRGB Then maxRGB = G
If B > maxRGB Then maxRGB = B
'Compute Maximum Factor Of RGB Components
dotMax = maxRGB / 255
'Ambient Light is some non-directional light in the environment
' (background light).
' Ambient Light Factor is 0.2
dotMax = dotMax + AmbFactor
If dotMax * maxRGB > 255 Then dotMax = 255 / maxRGB
Xorg = Abs(Obj.ScaleLeft)
Yorg = Abs(Obj.ScaleTop)
Select Case Projec
Case Parallel
p1 = P.Verts(1)
p2 = P.Verts(2)
P3 = P.Verts(3)
Case Perspective
f = Dist / (Dist - P.Verts(1).Z)
p1.X = P.Verts(1).X * f
p1.Y = P.Verts(1).Y * f
p1.Z = P.Verts(1).Z
f = Dist / (Dist - P.Verts(2).Z)
p2.X = P.Verts(2).X * f
p2.Y = P.Verts(2).Y * f
p2.Z = P.Verts(2).Z
f = Dist / (Dist - P.Verts(3).Z)
P3.X = P.Verts(3).X * f
P3.Y = P.Verts(3).Y * f
P3.Z = P.Verts(3).Z
End Select
v = m3VectorInit(p1, p2)
u = m3VectorInit(p2, P3)
n = m3VectorCross(v, u)
If n.Z < 0 Then
n.Y = -n.Y
n.X = -n.X
n.Z = -n.Z
End If
m3VectorSetLen 1, n
dot = lightVector.X * n.X + lightVector.Y * n.Y + lightVector.Z * n.Z
dot = dot + AmbFactor
If dot > dotMax Then dot = dotMax
ColorTo = RGB(dot * R, dot * G, dot * B)
Obj.FillColor = ColorTo
If Not Border Then
Obj.ForeColor = ColorTo
End If
ProjectM3Points P.nVerts, P.Verts
Polygon Obj.hdc, Poly2D(1), P.nVerts
' Restore Object's Colors
Obj.FillColor = color
Obj.ForeColor = BorderColor
End Sub