Structure matrice : surcharge des opérateurs pour le calcul matriciel, inversion trace déterminant et autres opérations
Soyez le premier à donner votre avis sur cette source.
Snippet vu 18 330 fois - Téléchargée 25 fois
Contenu du snippet
Ce code est très largement inspiré de celui de US_30 posté il y a quelques jours ( http://www.vbfrance.com/codes/CALCUL-MATRICIEL_42018.aspx ) mais je l'ai transposé du vb6 vers vb .NET en utilisant l'avantage de cette nouvelle version, qui est la surcharge des opérateurs.
LISTE DES OPERATIONS DISPONIBLES :
Tranposée : B = A.Transpose
Produit : C = A *B
Produit scalaire : C = A * x ( ici x est un long )
Addition ou soustraction : D = A + B - C
Trace : x = A.Trace
Inversion par Gauss Jordan : B = A.Inverse
"Division de matrices" : C = A / B ( en fait = A * B.Inverse )
Déterminant par diagonalisation : x = A.Determinant
Puissance : B = A ^ n (n long)
les fonctions suivantes modifient la matrice A sur laquelle elles s'appliquent :
Permute deux lignes : A.PermuteLignes( L1, L2 )
Permute deux colonnes : A.PermuteColonnes( C1, C2 )
PIVOT d'un système Ax=r : A.Pivot ( Matrice R) => renvoi une matrice R
Résolution d'un système AX=R par ELIMINATION DE GAUSS : A.Gauss (Matrice R) => renvoi matrice X
Résolution d'un système AX=R par Gauss-Seidel : A.Gauss_seidel ( R, [Lambda], [Maxit], [Eps]) => renvoi matrice X
J'ai tenté de faire une matrice générique mais ça n'est pas possible car il eu fallu que vb .NET implémente l'interface IArithmetic ce qui n'existe pas et n'est pas codable actuellement (non plus que les complexes). C'est donc forcément une matrice de Double().
Merci à US_30 et je lui fais confiance pour la validité mathématique des algorithmes de résolution ;)
LISTE DES OPERATIONS DISPONIBLES :
Tranposée : B = A.Transpose
Produit : C = A *B
Produit scalaire : C = A * x ( ici x est un long )
Addition ou soustraction : D = A + B - C
Trace : x = A.Trace
Inversion par Gauss Jordan : B = A.Inverse
"Division de matrices" : C = A / B ( en fait = A * B.Inverse )
Déterminant par diagonalisation : x = A.Determinant
Puissance : B = A ^ n (n long)
les fonctions suivantes modifient la matrice A sur laquelle elles s'appliquent :
Permute deux lignes : A.PermuteLignes( L1, L2 )
Permute deux colonnes : A.PermuteColonnes( C1, C2 )
PIVOT d'un système Ax=r : A.Pivot ( Matrice R) => renvoi une matrice R
Résolution d'un système AX=R par ELIMINATION DE GAUSS : A.Gauss (Matrice R) => renvoi matrice X
Résolution d'un système AX=R par Gauss-Seidel : A.Gauss_seidel ( R, [Lambda], [Maxit], [Eps]) => renvoi matrice X
Source / Exemple :
Public Structure Matrice
' structure pour les matrices à 2 dimensions
Private A(,) As Long ' on peut changer de TYPE mais il faut alors le changer (partout)(ou presque)
Private mDim1 As Long, mDim2 As Long
#Region "Constructeurs et propriétés"
Public Sub New(ByVal dim1 As Long, ByVal dim2 As Long)
Dim longA(dim1, dim2) As Long
A = longA
mDim1 = dim1
mDim2 = dim2
End Sub
' ceci est la propriété par défaut pour une matrice
Default Public Property Item(ByVal dim1 As Long, ByVal dim2 As Long) As Long ' TYPE
Get
If dim1 <= mDim1 And dim2 <= mDim2 And dim1 >= 0 And dim2 >= 0 Then
Return A(dim1, dim2)
End If
End Get
Set(ByVal value As Long)
If dim1 <= mDim1 And dim2 <= mDim2 And dim1 >= 0 And dim2 >= 0 Then
A(dim1, dim2) = value
End If
End Set
End Property
Public ReadOnly Property Dim1() As Long
Get
Return mDim1
End Get
End Property
Public ReadOnly Property Dim2() As Long
Get
Return mDim2
End Get
End Property
Function Transpose() As Matrice
'TRANSPOSE MATRICIELLE
Dim result As New Matrice(mDim2, mDim1)
'Transpose
For i As Long = 1 To mDim1
For j As Long = 1 To mDim2
result(i, j) = A(j, i)
Next j, i
Return result
End Function
Public ReadOnly Property Trace() As Long ' TYPE
Get
'TRACE DE LA MATRICE
'Paramètres
Dim tmp As Long
'Vérifications
If mDim1 <> mDim2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Else
'Addition ou soustraction
For i As Long = 1 To mDim1
tmp += Me(i, i)
Next i
End If
End Get
End Property
Public ReadOnly Property Inverse() As Matrice
Get
'INVERSION MATRICE METHODE DE GAUSS JORDAN
'Paramètres
Dim i As Long, j As Long, k As Double
Dim Dummy As Double
Dim B As New Matrice(mDim1, mDim1)
'Vérifications
If mDim1 <> mDim2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return B
Else
'Algo
For k = 1 To mDim1
B(k, k) = 1
Next k
For k = 1 To mDim1
Dummy = A(k, k)
For j = 1 To mDim1
A(k, j) = A(k, j) / Dummy
B(k, j) = B(k, j) / Dummy
Next j
For i = 1 To mDim1
If i <> k Then
Dummy = A(i, k)
For j = 1 To mDim1
A(i, j) = A(i, j) - Dummy * A(k, j)
B(i, j) = B(i, j) - Dummy * B(k, j)
Next j
End If
Next i
Next k
'renvoi
Return B
End If
End Get
End Property
Public ReadOnly Property Determinant() As Long
Get
'DETERMINANT D'UNE MATRICE PAR TRIANGULATION DE GAUSS
'Paramètres
Dim i As Long, j As Long, k As Double
Dim Factor As Double, Sum As Double = 1
'Vérifications
If mDim1 <> mDim2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return 0
Else
'Algo élimination
For k = 1 To mDim1 - 1
For i = k + 1 To mDim1
Factor = A(i, k) / A(k, k)
For j = k + 1 To mDim1
A(i, j) = A(i, j) - Factor * A(k, j)
Next j
Next i
Next k
'Produit diagonale
For k = 1 To mDim1
Sum = Sum * A(k, k)
Next k
End If
End Get
End Property
#End Region
#Region "Opérateurs surchargés"
Public Shared Operator *(ByVal A As Matrice, ByVal B As Matrice) As Matrice
'PRODUIT MATRICE : R=A*B
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim B1 As Long = B.Dim1, B2 As Long = B.Dim2
Dim result As New Matrice(A1, B2)
Dim s As Long
'Vérification
If A2 <> B1 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return result
Else
'Produit
For i As Long = 1 To A1
For j As Long = 1 To B2
s = 0
For k As Long = 1 To B1
s = s + A(i, k) * B(k, j)
Next k
result(i, j) = s
Next j, i
'renvoi
Return result
End If
End Operator
Public Shared Operator *(ByVal A As Matrice, ByVal B As Long) As Matrice
'PRODUIT MATRICE PAR UN SCALAIRE : A=cR
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim result As New Matrice(A1, A2)
'Vérification
If A1 <> A2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return result
Else
'Produit scalaire
For i As Long = 1 To A1
For j As Long = 1 To A2
result(i, j) = B * A(i, j)
Next j, i
'renvoi
Return result
End If
End Operator
Public Shared Operator /(ByVal A As Matrice, ByVal B As Matrice) As Matrice
Return A * B.Inverse
End Operator
Public Shared Operator ^(ByVal A As Matrice, ByVal Expo As Long) As Matrice
'PUISSANCE ENTIERE D'UNE MATRICE
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim B As New Matrice(A1, A2)
'Vérification
If A1 <> A2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return B
Else
'Matrice unité
Dim i As Long
For i = 1 To A1 : B(i, i) = 1 : Next i
'Cas Triviaux
If Expo = 0 Then Return B
'Si puissance négative
If Expo < 0 Then
A = A.Inverse
Expo = Math.Abs(Expo)
End If
If Expo = 1 Then Return A
'Algo exponentiation rapide
Do
If Expo And 1 Then B = A * B
Expo = Expo \ 2
A = A * A
Loop While Expo > 1
Return B * A
End If
End Operator
Public Shared Operator +(ByVal A As Matrice, ByVal B As Matrice) As Matrice
'ADDITION MATRICE : R=A+B
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim B1 As Long = B.Dim1, B2 As Long = B.Dim2
Dim result As New Matrice(A1, B2)
'Vérifications
If A1 <> B1 Or A2 <> B2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return result
Else
'Addition
For i As Long = 1 To A1
For j As Long = 1 To B2
result(i, j) = A(i, j) + B(i, j)
Next j, i
'renvoi
Return result
End If
End Operator
Public Shared Operator -(ByVal A As Matrice, ByVal B As Matrice) As Matrice
'SOUSTRACTION MATRICE : R=A-B
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim B1 As Long = B.Dim1, B2 As Long = B.Dim2
Dim result As New Matrice(A1, B2)
'Vérifications
If A1 <> B1 Or A2 <> B2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Return result
Else
'soustraction
For i As Long = 1 To A1
For j As Long = 1 To B2
result(i, j) = A(i, j) - B(i, j)
Next j, i
'renvoi
Return result
End If
End Operator
Public Shared Operator -(ByVal A As Matrice) As Matrice
'NEGATION MATRICE : R=-B
'Paramètres
Dim A1 As Long = A.Dim1, A2 As Long = A.Dim2
Dim result As New Matrice(A1, A2)
'Négation
For i As Long = 1 To A1
For j As Long = 1 To A2
result(i, j) = -A(i, j)
Next j, i
'renvoi
Return result
End Operator
#End Region
#Region "Autres méthodes"
Public Sub PermuteLignes(ByVal L1 As Long, ByVal L2 As Long)
'PERMUTE LES LIGNES L1 ET L2
'Paramètres
Dim v As Double
'Vérifications
If mDim1 < L1 Or mDim1 < L2 Then
Err.Raise(Number:=514, Source:="MATRICE", Description:="MANIPULATION LIGNE : MATRICE PAS ASSEZ GRANDE")
Else
'Permutation
For j As Long = 1 To mDim2
v = A(L1, j) : A(L1, j) = A(L2, j) : A(L2, j) = v
Next j
End If
End Sub
Public Sub PermuteColonnes(ByVal C1 As Long, ByVal C2 As Long)
'PERMUTE LES COLONNES C1 ET C2
'Paramètres
Dim v As Double
'Vérifications
If mDim2 < C1 Or mDim2 < C2 Then
Err.Raise(Number:=514, Source:="MATRICE", Description:="MANIPULATION COLONNE : MATRICE PAS ASSEZ GRANDE")
Else
'Permutation
For j As Long = 1 To mDim1
v = A(j, C1) : A(j, C1) = A(j, C2) : A(j, C2) = v
Next j
End If
End Sub
Public Function Pivot(ByVal R As Matrice) As Matrice
'PIVOTage DE MATRICES d'un système Ax=r
'Paramètres
Dim R1 As Long = R.Dim1
Dim lDummy As Double, lMaxa As Double, lPivot As Double
'Vérifications
If mDim1 <> mDim2 Or mDim1 <> R1 Or R.Dim2 <> 1 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Else
'Recherche pivot
For k As Long = 1 To mDim1
lPivot = k
lMaxa = Math.Abs(A(k, k))
For i As Long = k + 1 To mDim1
lDummy = Math.Abs(A(i, k))
If lDummy > lMaxa Then
lMaxa = lDummy
lPivot = i
End If
Next i
If lPivot <> k Then
For j As Long = k To mDim1
lDummy = A(lPivot, j)
A(lPivot, j) = A(k, j)
A(k, j) = lDummy
Next j
lDummy = R(lPivot, 1)
R(lPivot, 1) = R(k, 1)
R(k, 1) = lDummy
End If
Next k
End If
Return R
End Function
Function GAUSS_SEIDEL(ByVal R As Matrice, Optional ByVal Lambda As Long = 1, _
Optional ByVal Maxit As Long = 150, Optional ByVal eps As Double = 0.0000000000001) As Matrice
'RESOLUTION DE GAUSS-SEIDEL
'Paramètres
Dim R1 As Long = R.Dim1
Dim i As Long, j As Long
Dim Dummy As Double, Sum As Double
Dim epsa As Double, iter As Long, Old As Double
Dim x As New Matrice(mDim1, 1)
'Vérifications
If mDim1 <> mDim2 Or mDim1 <> R1 Or R.Dim2 <> 1 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
ElseIf Lambda < 0 Or Lambda > 2 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="RELAXATION ERONNEE")
Else
'Algo
epsa = 1.1 * eps
For i = 1 To mDim1
Dummy = A(i, i)
For j = 1 To mDim1
A(i, j) = A(i, j) / Dummy
Next j
R(i, 1) = R(i, 1) / Dummy
Next i
iter = 0
Do While (iter < Maxit And epsa > eps)
iter = iter + 1
For i = 1 To mDim1
Old = x(i, 1)
Sum = R(i, 1)
For j = 1 To mDim1
If i <> j Then Sum = Sum - A(i, j) * x(j, 1)
Next j
x(i, 1) = Lambda * Sum + (1 - Lambda) * Old
If x(i, 1) <> 0 Then epsa = Math.Abs((x(i, 1) - Old) / x(i, 1)) * 100
Next i
Loop
End If
'renvoi
Return x
End Function
Function Gauss(ByVal R As Matrice) As Matrice
'ELIMINATION DE GAUSS
'Paramètres
Dim R1 As Long = R.Dim1
Dim i As Long, j As Long, k As Double
Dim lFactor As Double, lSum As Double
Dim x As New Matrice(mDim1, 1)
'Vérifications
If mDim1 <> mDim2 Or mDim1 <> R1 Or R.Dim2 <> 1 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON CARRE")
Else
'Algo élimination
For k = 1 To mDim1 - 1
For i = k + 1 To mDim1
R = Me.Pivot(R) ' modifie la matrice ME (A) et renvoie R(?)
If A(k, k) = 0 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE NON INVERSIBLE")
End If
lFactor = A(i, k) / A(k, k)
For j = k + 1 To mDim1
A(i, j) = A(i, j) - lFactor * A(k, j)
Next j
R(i, 1) = R(i, 1) - lFactor * R(k, 1)
Next i
Next k
'Algo remontée
If A(mDim1, mDim1) = 0 Then
Err.Raise(Number:=513, Source:="MATRICE", Description:="MATRICE SANS BASE PRINCIPALE / SOLUTIONS MULTIPLES")
Else
x(mDim1, 1) = R(mDim1, 1) / A(mDim1, mDim1)
For i = mDim1 - 1 To 1 Step -1
lSum = 0
For j = i + 1 To mDim1
lSum = lSum + A(i, j) * x(j, 1)
Next j
x(i, 1) = (R(i, 1) - lSum) / A(i, i)
Next i
End If
End If
'renvoi
Gauss = x
End Function
#End Region
End Structure
'############# test, dans un MODULE SEPARE #############
'taille
Public Const t As Long = 3
Public Sub DebugPrintMatrice(ByVal A As Matrice, Optional ByVal label As String = "")
Dim str As String
For i As Long = 1 To A.Dim1
str = ""
For j As Long = 1 To A.Dim2
str &= "," & A.Item(i, j)
Next j
Debug.Print(label & i & "(" & Mid(str, 2) & ")")
Next i
End Sub
Public Function InitMatrice() As Matrice
Dim A As New Matrice(t, t)
'remplis deux matrices
A.Item(1, 1) = 1 : A.Item(1, 2) = 1 : A.Item(1, 3) = -1
A.Item(2, 1) = 2 : A.Item(2, 2) = 1 : A.Item(2, 3) = 1
A.Item(3, 1) = 4 : A.Item(3, 2) = -4 : A.Item(3, 3) = 2
Return A
End Function
Public Sub Main()
'définitions des MATRICES
Dim A As New Matrice(t, t), B As New Matrice(t, t), R As New Matrice(t, 1)
A = InitMatrice()
Debug.Print("MATRICE A")
DebugPrintMatrice(A, "A")
B = A * 1
Debug.Print("MATRICE B = MATRICE A")
DebugPrintMatrice(B, "B")
'Calculs
Debug.Print("DETERMINANT A=" & A.Determinant)
Debug.Print("DETERMINANT B=" & B.Determinant)
Debug.Print("TRACE A=" & A.Trace)
Debug.Print("TRACE B=" & B.Trace)
A = A ^ 2
Debug.Print("MATRICE A^(-2)")
DebugPrintMatrice(A, "A")
'résolution SYSTEME EQUATION AX=C
Dim x As Matrice, c As New Matrice(t, 1)
A = InitMatrice()
c.Item(1, 1) = 3 : c.Item(2, 1) = 5 : c.Item(3, 1) = 1
x = A.Gauss(c)
Debug.Print("RESOLUTION EQUATION PAR GAUSS")
DebugPrintMatrice(x, "X")
A = InitMatrice()
c.Item(1, 1) = 3 : c.Item(2, 1) = 5 : c.Item(3, 1) = 1
Debug.Print("RESOLUTION EQUATION PAR GAUSS-SEIDEL")
x = A.GAUSS_SEIDEL(c, 0.5)
DebugPrintMatrice(x, "X")
End Sub
Conclusion :
J'ai tenté de faire une matrice générique mais ça n'est pas possible car il eu fallu que vb .NET implémente l'interface IArithmetic ce qui n'existe pas et n'est pas codable actuellement (non plus que les complexes). C'est donc forcément une matrice de Double().
Merci à US_30 et je lui fais confiance pour la validité mathématique des algorithmes de résolution ;)
A voir également
- Opérateur matriciel
- Trace matrice - Meilleures réponses
- Trace produit matrice - Meilleures réponses
- Python : Opération matricielle - CodeS SourceS - Guide
- Opération matricielle ✓ - Forum - Visual Basic 6
- Access l'opération doit utiliser une requête qui peut être mise à jour - Forum - VB.NET
- Produit matriciel en c - Guide
- Produit matriciel java - Guide
Ma version Excel est 2003.
Excel voit DLL_Matrix via l'explorateur d'objets qui affiche les 4 membres suivants : Equals, GetHashCode, GetType, ToString (je ne retrouve pas mes billes la dedans).
Le préfixage par le nom de projet ou de region ne change rien.
Je me demande si le pb n'est pas spécifique à l'utilisation d'une Structure car dans un autre contexte où j'avais une classe VB 2005 avec seulement des Sub et des Function, l'appel via VBA fonctionnait.
Je continue à chercher et te tiens au courant.
A+
Ensuite si ça c'est bon, Excel voit-il les objets ajoutés en référence? ça doit être visible dans l'explorateur d'objet Excel (F2 dans l'éditeur VBA). Il faut peut être préfixer avec le nom du projet ou région... en tout cas ça m'intéresserait de savoir si ça marche! :)
Ce code vb.net issu de l'adaptation du source VBA d'US_30 est très riche et très utile.
Je me permets une petite question car je suis débutant en VB 2005 : après avoir compilé ce code dans une classe et avoir généré l'ActiveX DLL correspondante, j'essaie d'utiliser ces fonctions et opérateurs depuis un module VBA dans Excel. J'ai une erreur de compile "type utilisateur non déini" pour le type Matrice.
J'ai pourtant généré le .tlb et inscrit ma dll dans les références VBA, et enregistré la dll dans le GAC.
Question : que faut-il mettre dans le code VBA Excel pour que le type Matrice soit reconnu et que les objets manipulés dans le code vb.net soient correctement utilisables ?
Merci d'avance pour votre aide.
- Messages postés
-
2065
- Date d'inscription
- lundi 11 avril 2005
- Statut
- Membre
- Dernière intervention
- 14 mars 2016
10Les calculs matriciels que je propose est actuellement un ébauche et comporte ici ou là, quelques bugs que je corrige progressivement. IL faudrait donc en tenir compte... A+
Amicalement,
Us.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.