These seem to work so far, they up for discussion and I,m sure they could be better
Function Transpose(Matrix As Variant) As Variant
Dim transMat(0 To 3, 0 To 3) As Double
Dim i As Integer, j As Integer
For i = 0 To 3
For j = 0 To 3
transMat(i, j) = Matrix(j, i)
Next j
Next i
Transpose = transMat
End Function
Function InverseMatrix(M As Variant) As Variant
Dim Matrix() As Double
Dim RowCt As Integer, ColCt As Integer
Dim NewColCt As Integer
Dim NoInverse As Boolean
Dim i As Integer, j As Integer
RowCt = UBound(M, 1)
ColCt = UBound(M, 2)
NewColCt = ColCt + RowCt + 1
ReDim Matrix(RowCt, NewColCt)
For i = 0 To RowCt
'add the given matrix
For j = 0 To ColCt
If Rd(M(i, j), 0) Then
Matrix(i, j) = 0
Else
Matrix(i, j) = M(i, j)
End If
Next j
'add an identity crisis
For j = ColCt + 1 To NewColCt
If j - (ColCt + 1) = i Then
Matrix(i, j) = 1
Else
Matrix(i, j) = 0
End If
Next
Next i
Matrix = MPivot(Matrix)
'now see if it worked
For i = 0 To RowCt
For j = 0 To ColCt
If j = i Then
If Not Rd(Matrix(i, j), 1) Then
NoInverse = True
Debug.Print Matrix(i, j)
'Exit Function
End If
Else
If Not Rd(Matrix(i, j), 0) Then
NoInverse = True
'Exit Function
End If
End If
Next
Next i
If NoInverse Then
'MsgBox "nope"
' Debug.Print
' For i = 0 To 3
' Debug.Print Matrix(i, 0), Matrix(i, 1), Matrix(i, 2), Matrix(i, 3), Matrix(i, 4), Matrix(i, 5), Matrix(i, 6), Matrix(i, 7)
' Next
Matrix = OrderMatrix(Matrix)
End If
'If Not NoInverse Then
ReDim InVMatrix(RowCt, ColCt)
For i = 0 To RowCt
For j = ColCt + 1 To NewColCt
InVMatrix(i, j - (ColCt + 1)) = Matrix(i, j)
Next j
Next i
'End If
InverseMatrix = InVMatrix
End Function
Function MPivot(Matrix) As Variant
Dim j As Integer, i As Integer, k As Integer
Dim iP As Integer
Dim Pivot As Double
Dim ColCt As Integer
Dim RowCt As Integer
Dim PC As Double
Dim Sign As Integer
Dim Den As Integer
Dim dTemp As Double
RowCt = UBound(Matrix, 1)
ColCt = UBound(Matrix, 2)
'ij is row,column
For i = 0 To RowCt
For j = 0 To ColCt
If Matrix(i, j) <> 0 Then
Pivot = Matrix(i, j)
iP = j
Exit For
End If
Next j
For k = 0 To RowCt
If Not k = i Then
PC = Matrix(k, iP)
If PC = 0 Then GoTo Skip
Sign = 1
If Pivot < 0 Then
If PC < 0 Then
Sign = -1
End If
Else
If PC > 0 Then
Sign = -1
End If
End If
Dim N1 As Double, N2 As Double
N1 = Abs(Pivot): N2 = Abs(PC)
Den = LCD(N1, N2)
For j = 0 To ColCt
dTemp = Matrix(k, j) * N1 / Den + (Matrix(i, j) * N2 / Den * Sign)
If Rd(dTemp, 0) Then
Matrix(k, j) = 0
Else
Matrix(k, j) = dTemp
End If
Next j
End If
Skip:
Next k
Next i
For i = 0 To RowCt
For j = 0 To ColCt
If Matrix(i, j) <> 0 Then
Pivot = 1 / Matrix(i, j)
Exit For
End If
Next j
For j = 0 To ColCt
Matrix(i, j) = Matrix(i, j) * Pivot
Next j
Next i
MPivot = Matrix
End Function
Function OrderMatrix(Matrix As Variant) As Variant
Dim i As Integer, j As Integer
Dim k As Integer, l As Integer
Dim RowCt As Integer, ColCt As Integer
RowCt = UBound(Matrix, 1)
ColCt = UBound(Matrix, 2)
ReDim tempRow(ColCt) As Double
'ij is row,column
For i = 0 To RowCt
For j = 0 To ColCt
If j = i Then
If Not Rd(Matrix(i, j), 1) Then
For k = 0 To RowCt
If Not k = i Then
If Rd(Matrix(k, j), 1) Then
For l = 0 To ColCt
tempRow(l) = Matrix(k, l)
Matrix(k, l) = Matrix(i, l)
Matrix(i, l) = tempRow(l)
Next l
End If
End If
Next k
End If
End If
Next j
Next i
OrderMatrix = Matrix
End Function
Function LCD(N1, N2) As Integer
'LowestCommonDenominator
Dim iCt As Integer, i As Integer
Dim Ans As Integer
Ans = 1
If N1 < N2 Then
iCt = N1
Else
iCt = N2
End If
If iCt > 1 Then
For i = 1 To iCt
If (N1 Mod i = 0 And N2 Mod i = 0) Then Ans = i
Next i
End If
LCD = Ans
End Function
Function TransformPt(M As Variant, P1 As Variant) As Variant
Dim i As Integer
Dim x As Double, y As Double, z As Double, D As Double
Dim P(3) As Double
For i = 0 To 2
P(i) = P1(i)
Next
P(3) = 1
For i = 0 To 3
x = x + P(i) * M(i, 0)
y = y + P(i) * M(i, 1)
z = z + P(i) * M(i, 2)
D = D + P(i) * M(i, 3)
Next
P1(0) = x: P1(1) = y: P1(2) = z
TransformPt = P1
End Function
And this is the reason I wanted to use a matrix
Sub TestMultiplyMatrix()
Dim P, Ent As AcadEntity
Dim i As Integer
Dim M, ContextData, TransMatrix
ThisDrawing.Utility.GetSubEntity Ent, P, TransMatrix, ContextData
ThisDrawing.ModelSpace.AddPoint P
If VarType(ContextData) = vbEmpty Then
MsgBox "This is not a block"
Exit Sub
End If
M = InverseMatrix(TransMatrix)
P = TransformPt(M, P)
P = NearestPtOnObject(Ent, P)
P = TransformPt(TransMatrix, P)
ThisDrawing.ModelSpace.AddPoint P
End Sub
The NearestPtOnObject(Ent, P) function is not included as I'm still working on it.
I thought getting this far was going to give me a little break from math but instead I just seemed to have opened Pandora's box.
The nearest point to an ellipse is insane. I dont even know if the article is offering a proof or a question. I'm inclined to go with the one that mentions "best guess",