Attribute VB_Name = "Module1"
Global VvodIchX%, VvodIchY%, Vvod_1%, Vvod_2%
Global TimVal1!, TimVal2!
Global En As String * 2
' Всё связанное с методом Гаусса
Global MatrPoX%, MatrPoY%, DelitelStroki#, DelitelNull%
Global NowElmnt%, Matrix#(1 To 51, 1 To 50)
' Метод симплекса
Global Bazisniye%, Svobodniye%, MassivKombinacij%(1 To 50)
' Отправить текст в консоль на комментарий
'
Public Sub OutConsole(Text_To_Pute$)
Form1.Text2.Text = Form1.Text2.Text + Text_To_Pute$ + En
End Sub
' Очистить консоль
'
Private Sub ClearConsole()
Form1.Text2.Text = ""
End Sub
' Отправить текущую матрицу в консоль
'
Private Sub Matrix_To_Console()
Dim mxx%, myy%, Matrica_Stroka$
For myy% = 1 To MatrPoY%: Matrica_Stroka$ = "| "
For mxx% = 1 To MatrPoX%
Matrica_Stroka$ = Matrica_Stroka$ + LTrim$(Str$(TblXY#(mxx%, myy%))) + " "
Next: Matrica_Stroka$ = Matrica_Stroka$ + "|"
Call OutConsole(Matrica_Stroka$): Next
End Sub
' Взять значение с FlexGrid1
Private Function TblXY#(x_T%, y_T%)
Dim GettingZn$
GettingZn$ = Form1.MSFlexGrid1.TextMatrix(y_T%, x_T% - 1)
If GettingZn$ <> "" Then TblXY# = Val(GettingZn$)
End Function
' Запись значения в FlexGrid1
Public Sub SetTblXY(x_T%, y_T%, Znachenie#)
Form1.MSFlexGrid1.TextMatrix(y_T%, x_T% - 1) = Znachenie#
End Sub
' Очистка значения в FlexGrid1
Private Sub ClrTblXY(x_T%, y_T%)
Form1.MSFlexGrid1.TextMatrix(y_T%, x_T% - 1) = ""
End Sub
' <<< [ Метод Гаусса ] >>>
' Очень полезная процедура т.к. легко
' переводится с языка на язык
Public Sub Gauss_Math()
Dim xx%, yy%, Minimal_Razmer%, Try_Find_Stroka%
Dim Resheno_OK%
' Атрибуты введённой матрыцы
Call GetMatrixAttr
' Цикл копирования в память матрицы
' Сохраним первоначальную матрицу
For yy% = 1 To MatrPoY%: For xx% = 1 To MatrPoX%
Matrix#(xx%, yy%) = TblXY#(xx%, yy%): Next: Next
' Проверка размера матрицы и введённых переменных
Minimal_Razmer% = MatrPoX% - 1
If MatrPoY% > Minimal_Razmer% Then Minimal_Razmer% = MatrPoY%
If Minimal_Razmer% > 2 Then Form1.HScroll2.Value = Minimal_Razmer%
If MatrPoX% < MatrPoY% Then
Call ClearConsole
Call OutConsole("Матрица задана неправильно !!!")
Call OutConsole("Введите недостающие столбцы...")
Exit Sub
End If
'Call Stroka_Del(1, 1) 'Вызов процедуры деления на строку
'Form1.Print Stolbec_Bazis%(1, 1) 'Процедура проверки базиса
'Call Zamena_Strok(1, 2) ' Перестановка строк
'Form1.Print Detect_Best_Stroka%(3, 3)
'Call Stroka_Del(1, 1)
' Exit Sub
Call OutConsole(" _-^-^-^- Р Е Ш Е Н И Е -^-^-^-_")
For i% = 1 To MatrPoX% - 1
If TblXY#(i%, i%) <> 0 Then
Call Stroka_Del(i%, i%) 'Делим строку и вычитаем её из др.
Call OutConsole(" Приводим переменную X" + LTrim$(Str$(i%)) + " к базисной переменной")
Call Matrix_To_Console
Else
Try_Find_Stroka% = Detect_Best_Stroka%(i%, i%)
If Try_Find_Stroka% = -1 Then
Call OutConsole("Дальше решать нельзя !!!")
Exit For
Else
Call Zamena_Strok(i%, Try_Find_Stroka%)
Call OutConsole("Переставляем строки с номерами " + Str$(i%) + "и" + Str$(Try_Find_Stroka%))
Call Stroka_Del(i%, i%) 'Делим строку и вычитаем её из др.
Call OutConsole(" Приводим переменную X" + LTrim$(Str$(i%)) + " к базисной переменной")
End If
End If
Next
' Проверка: Решена ли система...
Resheno_OK% = 1
For u% = 1 To MatrPoX% - 1
If Stolbec_Bazis%(u%, u%) <> 3 Then
Resheno_OK% = 0: Exit For
End If
Next u%
If Resheno_OK% = 1 Then
Call OutConsole("Система успешно решена методом Жордана Гаусса !!!")
Else
Call OutConsole("Система не решена полностью, найдено частное решение !!!")
End If
End Sub
' Деление строки y% на x% элемент и
' вычитание из др строк строки y%
Private Sub Stroka_Del(x%, y%)
Dim xx%, yy%, Minus_Stroka#, Umnojenie#
DelitelStroki# = TblXY#(x%, y%)
If DelitelStroki# = 0 Then DelitelNull% = 1: Exit Sub
DelitelNull% = 0
For xx% = 1 To MatrPoX%
Call SetTblXY(xx%, y%, TblXY#(xx%, y%) / DelitelStroki#): Next
For yy% = 1 To MatrPoY%
If yy% <> y% Then
Umnojenie# = -TblXY#(x%, yy%)
For xx% = 1 To MatrPoX%
Minus_Stroka# = TblXY#(xx%, yy%) + TblXY#(xx%, y%) * Umnojenie#
Call SetTblXY(xx%, yy%, Minus_Stroka#)
Next xx%
End If
Next yy%
'Form1.Print MatrPoX%, MatrPoY%
End Sub
' Определить является ли столбец базисом в данный момент
' частичным или полным
Private Function Stolbec_Bazis%(x%, y%)
Dim xxx%, yyy%, SummaX%, SummaY%, BAZIS%
If x% > 0 And x% < MatrPoX% And y% > 0 And y% < MatrPoY% + 1 Then
SummaX% = 0: SummaY% = 0: BAZIS% = 0
' Сканируем сумму по X
For xxx% = 1 To MatrPoX% - 1
SummaX% = SummaX% + TblXY#(xxx%, y%): Next
' Сканируем сумму по Y
For yyy% = 1 To MatrPoY%
SummaY% = SummaY% + TblXY#(x%, yyy%): Next
Form1.Print SummaY%
If TblXY#(x%, y%) = 1 And SummaX% = 1 Then BAZIS% = 1
If TblXY#(x%, y%) = 1 And SummaY% = 1 Then BAZIS% = BAZIS% + 2
' 1 - базис по X , 2 - базис по Y, 3 - Базис по обеим(полный)
Stolbec_Bazis% = BAZIS%
End If
End Function
' Определение параметров матрицы
'
Private Sub GetMatrixAttr()
Dim xx%, yy%
MatrPoX% = 0: MatrPoY% = 0
For xx% = 1 To Form1.MSFlexGrid1.Cols
For yy% = 1 To Form1.MSFlexGrid1.Rows - 1
If TblXY#(xx%, yy%) <> 0 Then
If xx% > MatrPoX% Then MatrPoX% = xx%
If yy% > MatrPoY% Then MatrPoY% = yy%
End If
Next: Next
' Доработка матрицы
For yy% = 1 To Form1.MSFlexGrid1.Rows - 1
For xx% = 1 To Form1.MSFlexGrid1.Cols
If xx% <= MatrPoX% And yy% <= MatrPoY% Then
Call SetTblXY(xx%, yy%, TblXY#(xx%, yy%))
Else: Call ClrTblXY(xx%, yy%)
End If
Next: Next
End Sub
' Перестановка двух строк
'
Private Sub Zamena_Strok(StrokaY1%, StrokaY2%)
Dim SwpPRM#, xx%
For xx% = 1 To MatrPoX%
SwpPRM# = TblXY#(xx%, StrokaY1%)
Call SetTblXY(xx%, StrokaY1%, TblXY#(xx%, StrokaY2%))
Call SetTblXY(xx%, StrokaY2%, SwpPRM#)
Next xx%
End Sub
' Нахождение ненулевого элемента столбца
' сканируя вниз
Private Function Detect_Best_Stroka%(StolbecN%, BeginY%)
Dim yy%, Nashel%
Nashel% = 0
For yy% = BeginY% To MatrPoY%
If TblXY#(StolbecN%, yy%) <> 0 Then
Nashel% = 1: Detect_Best_Stroka% = yy%: Exit Function
End If
Next
If Nashel% = 0 Then Detect_Best_Stroka% = -1
End Function