Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0784: Lineare Gleichungssysteme lösen

VB 5/6-Tipp 0784: Lineare Gleichungssysteme lösen

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: Sleep

Download: Download des Beispielprojektes [4,5 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--------------- Anfang Projektdatei LGS.vbp  ---------------
'--------- Anfang Klasse "clsLGS" alias clsLGS.cls  ---------
Option Explicit

' Der Code dieser Klasse enthält die Anweisungen 'Call Form1.ShowMatrix'
' Diese dienen nur der Animation und können sonst entfernt werden

' Variablen:

Private mMatrix()       As Double  ' Unsere Matrix
Private mNumVariables   As Integer ' Zahl der Variablen

' Mögliche Ergebnisse eines LGS
Public Enum LGSSolution
   NoSolution
   OneSolution
   MoreSolutions
End Enum

' Matrix initialisieren
Public Sub Initialize(ByVal NumVariables As Integer)
   
   If NumVariables <= 1 Then
      Call Err.Raise(vbObjectError, , "Mach' ein ordentliches LGS")
      Exit Sub
   End If
   
   mNumVariables = NumVariables
   ReDim mMatrix(1 To NumVariables + 1, 1 To NumVariables) As Double ' (Nur) das 2D-Matrixarray ist 1-basiert
End Sub

' "Gleichungsreihe" einfügen
Public Sub AddEquationByArray(ByRef Coefficients() As Double)
   Static Counter As Integer
   Dim i          As Integer
   
   Counter = Counter + 1 ' Nächste Zeile
  
   ' Auf falsche Eingabe prüfen *******************************************
   If Counter > mNumVariables Then
      Call Err.Raise(vbObjectError, , "Die Matrix ist schon gefüllt")
      Exit Sub
   End If
   
   If UBound(Coefficients) <> mNumVariables Then
      Call Err.Raise(vbObjectError, , "Falsche Koeffizientenzahl")
      Exit Sub
   End If
   ' **********************************************************************
   
   For i = 0 To UBound(Coefficients)
      mMatrix(i + 1, Counter) = CDbl(Coefficients(i))
   Next i
End Sub

' "Gleichungsreihe" einfügen [einfach]
Public Sub AddEquation(ParamArray Coefficients() As Variant)
   Dim tmp()   As Double
   Dim i       As Integer
   
   ReDim tmp(UBound(Coefficients)) As Double
   
   ' In ein temporäres Array laden
   For i = 0 To UBound(Coefficients)
      tmp(i) = CDbl(Coefficients(i))
   Next i
   Call Form1.ShowMatrix
   Call AddEquationByArray(tmp)
End Sub

' Eine Zeile kombinieren
Private Sub CombineLine(ByVal LineFrom As Integer, ByVal LineTo As Integer, ByVal Distance As Integer)
   Dim FactorA    As Double
   Dim FactorB    As Double
   Dim FactorggT  As Double
   Dim x          As Integer
   
   FactorA = mMatrix(Distance, LineFrom)
   FactorB = mMatrix(Distance, LineTo)
   
   FactorggT = ggT(FactorA, FactorB)
   
   If FactorggT <> 0 Then
      FactorA = FactorA / FactorggT
      FactorB = FactorB / FactorggT
   End If
  
   For x = Distance To mNumVariables + 1
      mMatrix(x, LineTo) = FactorA * mMatrix(x, LineTo) - FactorB * mMatrix(x, LineFrom)
      Call Form1.ShowMatrix
   Next
End Sub

' Eine Variable eleminieren
Private Sub CombineColumn(ByVal Line As Integer, ByVal Distance As Integer)
   Dim y As Integer
   
   For y = Line + 1 To mNumVariables
      Call CombineLine(Line, y, Distance)
   Next y
End Sub

' Komplette Matrix kombinieren
Private Sub CombineMatrix()
   Dim x As Integer
   
   For x = 1 To mNumVariables - 1
      Call CombineColumn(x, x)
   Next x
End Sub

' Eine Variable einsetzen
Private Function SolveNext(ByVal Line As Integer, ByVal Column As Integer) As LGSSolution
   Dim y             As Integer
      
   If mMatrix(Column, Line) = 0 Then
      SolveNext = IIf(mMatrix(mNumVariables + 1, Line) = 0, MoreSolutions, NoSolution)
      Exit Function ' Und tschüss
   End If
   
   mMatrix(mNumVariables + 1, Line) = mMatrix(mNumVariables + 1, Line) / mMatrix(Column, Line)
   mMatrix(Column, Line) = 1
   
   For y = Line - 1 To 1 Step -1
      mMatrix(mNumVariables + 1, y) = mMatrix(mNumVariables + 1, y) - mMatrix(Column, y) * mMatrix(mNumVariables + 1, Line)
      mMatrix(Column, y) = 0
      Call Form1.ShowMatrix
   Next y
   Call Form1.ShowMatrix
   SolveNext = OneSolution
End Function

' Einsetzen aller Variablen
Private Function SolveComplete() As LGSSolution
   Dim i    As Integer
   Dim ret  As LGSSolution
   
   For i = mNumVariables To 1 Step -1
      ret = SolveNext(i, i)
      If ret <> OneSolution Then
         SolveComplete = ret
         Exit Function
      End If
   Next i
   
   SolveComplete = OneSolution
End Function

' Die Variablen auslesen
Private Function ReadSolution() As Double()
   Dim y       As Integer
   Dim tmp()   As Double
   
   ReDim tmp(0 To mNumVariables - 1) As Double
   
   For y = 1 To mNumVariables
      tmp(y - 1) = mMatrix(mNumVariables + 1, y)
   Next y
   
   ReadSolution = tmp
End Function

' Alles zusammen berechnen
Public Function Solve(ByRef Solution() As Double) As LGSSolution

   ' Erstmal die ganzen Variablen eleminieren
   Call CombineMatrix
   
   ' Und sie dann ausrechnen ...
   Solve = SolveComplete
   If Solve = OneSolution Then Solution = ReadSolution
   
End Function

' Wenn jemand die Matrix sehen möchte
Public Function ToString() As String
   Dim tmp As String, x As Integer, y As Integer
   
   For y = 1 To mNumVariables
      For x = 1 To mNumVariables + 1
         tmp = tmp & CStr(mMatrix(x, y)) & IIf(x = mNumVariables, " |", "") & "  "
      Next x
      tmp = tmp & vbCrLf
   Next y
   
   ToString = tmp
End Function

' ggT rekursiv berechnen (Euklidischer Algorithmus)
Public Function ggT(ByVal a As Double, ByVal b As Double) As Double
   If b = 0 Then
      ggT = a
   Else
      ggT = ggT(b, a Mod b)
   End If
End Function


'---------- Ende Klasse "clsLGS" alias clsLGS.cls  ----------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) ' Für die Animation

Private DasLGS        As clsLGS
Private State         As Boolean ' Animationsstatus

Private Sub Calculate()
   Dim Ergebnis()    As Double
   Dim ErgebnisTyp   As LGSSolution
   
   Set DasLGS = New clsLGS
   
   With DasLGS
      ' LGS-Klasse für ein System mit 5 Variablen initialisieren
      Call .Initialize(5)
      
      ' Gleichungen hinzufügen
      Call .AddEquation(2, -3, 6, -1, 0, 5)
      Call .AddEquation(4, -1, 4, 5, 2, 29)
      Call .AddEquation(6, 2, -9, 1, 1, 58)
      Call .AddEquation(-1, -5, 2, -2, 4, -14)
      Call .AddEquation(7, 6, -5, 8, -1, 69)
      
      ' Lösung berechnen, es in einem Array speichern und das Ergebnis ausgeben
      ErgebnisTyp = .Solve(Ergebnis)
      
      If ErgebnisTyp = OneSolution Then
         Call ShowMatrix
         Call ShowSolution(Ergebnis)
      Else
         Call MsgBox("Das LGS hat " & IIf(ErgebnisTyp = NoSolution, "keine", "unendlich viele") & " Lösung(en)", 64)
      End If
      
   End With

   Set DasLGS = Nothing
End Sub

' Die Matrix anzeigen und ein bisschen schlafen
Sub ShowMatrix()
   Call Picture1.Cls
   Picture1.Print DasLGS.ToString
   If State Then Call Sleep(250)
   Call [DoEvents]
End Sub

' Ergebnis anzeigen
Private Sub ShowSolution(MyArray() As Double)
   Dim tmp  As String
   Dim i    As Long
      
   For i = 0 To UBound(MyArray)
      tmp = tmp & MyArray(i) & "; "
   Next i
   Picture1.Print "lL = { " & tmp & "}"
End Sub

' Berechnungen ausführen
Private Sub Command1_Click()
   State = False
   
   Command1.Enabled = False
   Command2.Enabled = False
   
   Call Calculate
   
   Command1.Enabled = True
   Command2.Enabled = True
End Sub

Private Sub Command2_Click()
   State = True
   
   Command1.Enabled = False
   Command2.Enabled = False
   
   Call Calculate
   
   Command1.Enabled = True
   Command2.Enabled = True
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---------------- Ende Projektdatei LGS.vbp  ----------------