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 17 656 fois - Téléchargée 24 fois

Commenter

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

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

Ajouter un commentaire

Commentaires

Signaler
us_30
Messages postés
2117
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
 7 -
Salut,

Les 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.
Signaler
arundel
Messages postés
8
Date d'inscription
dimanche 27 mars 2005
Statut
Membre
Dernière intervention
20 décembre 2009
 -
Bonjour,
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.
Signaler
pifou25
Messages postés
150
Date d'inscription
lundi 13 octobre 2003
Statut
Membre
Dernière intervention
21 décembre 2014
 -
ça!? J'en ai aucune idée, je me demande déjà si Excel vba est compatible VS.NET 2005 (pas évident, c'est pas la même version de vb à priori, c'est quelle version Excel au fait?)
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! :)
Signaler
arundel
Messages postés
8
Date d'inscription
dimanche 27 mars 2005
Statut
Membre
Dernière intervention
20 décembre 2009
 -
Bonjour Pifou,

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+
Signaler
fdiedler2000
Messages postés
383
Date d'inscription
samedi 29 janvier 2005
Statut
Membre
Dernière intervention
1 décembre 2008
 -
Pourrais tu mettre un zip ?
S'inscrire maintenant

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.

Du même auteur (pifou25)