Дан вектор P с координатами {x,y,z} и вектор G с координатами {x1,y1,z1} Их по очереди раскладывают по формуле P= a*x+ b*y + c*z и G= a*x1 + b*y1 + c*z1 соответственно, где P=G, необходимо найти коэффициенты a,b,c. При этом чтобы программа запрашивала условие и относительно этого условия выводила результат — Visual Basic(Бейсик)

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

Leave a Comment