Найти в матрице седловую точку

@enrieta · Регистрация: 13.05.2009

Студворк — интернет-сервис помощи студентам

Помогите решить задачу:
Седловой точкой в матрице называется элемент, являющийся одновременно наибольшим в столбце и наименьшим в строке. Седловых точек может быть и несколько (в этом случае они имеют равные значения). В матрице A найти седловую точку и ее координаты p, q либо установить, что такой точки нет.

Добавлено через 6 минут 35 секунд
есть вариант решения Макрасом, но как его переделать, чтобы выводилось сообщение седловой точки с координатами или об отсутствии точки

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
Option Base 1
 
Sub mtrx()
Dim R As Long, C As Long
Dim R1 As Long
Dim m As Long, n As Long
Dim i As Long
Dim k As Long
Dim Max As Long, Min As Long
 
Dim MyRange As Range
Dim MyArray() As Long
Dim MaxArray() As Long
 
Set MyRange = Selection
R = MyRange.Rows.Count
C = MyRange.Columns.Count
 
ReDim MyArray(1 To R, 1 To C)
ReDim MaxArray(1 To R, 1 To R)
 
For n = 1 To C
    R1 = R1 + 1
    i = 0
        For m = 1 To R
            MyArray(m, n) = MyRange.Cells(m, n)
                 
            If m = 1 Then
                Max = MyArray(m, n)
                i = i + 1
                MaxArray(R1, i) = m
            Else
                If MyArray(m, n) = Max Then
                    Max = MyArray(m, n)
                    i = i + 1
                    MaxArray(R1, i) = m
                ElseIf MyArray(m, n) > Max Then
                    Max = MyArray(m, n)
                    i = 1
                    MaxArray(R1, i) = m
                    For i = 2 To UBound(MaxArray)
                        MaxArray(R1, i) = 0
                    Next i
                    i = 1
                End If
            End If
        Next m
Next n
 
i = 1
R1 = 0
 
 
For m = 1 To R + 1
    If m > R Then GoTo EndOfRow
    If MaxArray(i, m) = 0 Then
EndOfRow:
        i = i + 1
            If i > MyRange.Columns.Count Then Exit For
        m = 1
    End If
     
    Min = MyArray(MaxArray(i, m), i)
 
    For n = 1 To C
        If Min > MyArray(MaxArray(i, m), n) Then k = k + 1
    Next n
 
    If k = 0 Then MyRange.Cells(MaxArray(i, m),i).Interior.ColorIndex = 3
    k = 0
Next m

@Sasha_Smirnov · 14.05.2009, 04:08

Здравствуйте, ваш "МАКРАС" — для Эксселя, что ли? (Целый час отлаживал в Ворде.)
Ну, судя по тому, что в конце цвет = 3, программа ещё прошлого века. Неважно.

Там, где я прокомментировал, — мои поправки. Ну и End Sub в конце, само собой.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Option Explicit
Option Base 1
 
Sub mtrx()
Dim R As Long, C As Long
Dim R1 As Long
Dim m As Long, n As Long
Dim i As Long
Dim k As Long
Dim Max As Long, Min As Long
 
Dim MyRange As Object 'Range ТУТ не работает
Dim MyArray() As Long
Dim MaxArray() As Long
 
If ActiveDocument.Tables.Count = 0 Then Exit Sub 'если таблиц нет - вышли из программы
ActiveDocument.Tables(1).Select 'в активном док. выделили 1-ю таблицу
 
Set MyRange = Selection.Tables(1) 'т. е.: "Мой диапазон = выделенной таблице"
R = MyRange.Rows.Count
C = MyRange.Columns.Count
 
ReDim MyArray(1 To R, 1 To C)
ReDim MaxArray(1 To R, 1 To R)
 
For n = 1 To C
    R1 = R1 + 1
    i = 0
        For m = 1 To R
            MyArray(m, n) = Val(MyRange.Cell(m, n)) ' Val берёт число из ячейки (первое)
                 
            If m = 1 Then
                Max = MyArray(m, n)
                i = i + 1
                MaxArray(R1, i) = m
            Else
                If MyArray(m, n) = Max Then
                    Max = MyArray(m, n)
                    i = i + 1
                    MaxArray(R1, i) = m
                ElseIf MyArray(m, n) > Max Then
                    Max = MyArray(m, n)
                    i = 1
                    MaxArray(R1, i) = m
                    For i = 2 To UBound(MaxArray)
                        MaxArray(R1, i) = 0
                    Next i
                    i = 1
                End If
            End If
        Next m
Next n
 
i = 1
R1 = 0
 
 
For m = 1 To R + 1
    If m > R Then GoTo EndOfRow
    If MaxArray(i, m) = 0 Then
EndOfRow:
        i = i + 1
            If i > MyRange.Columns.Count Then Exit For
        m = 1
    End If
     
    Min = MyArray(MaxArray(i, m), i)
 
    For n = 1 To C
        If Min > MyArray(MaxArray(i, m), n) Then k = k + 1
    Next n
 
    If k = 0 Then MyRange.Cell(MaxArray(i, m), i).Select 'найденное сначала выделяем
    Selection.Font.ColorIndex = 3               'а затем - окрашиваем (голубым)
    k = 0
Next m
 
End Sub

В приложенном файлике, по альт-F11, можете сами открыть код — и поотлаживать. Запуск по F5 (а F8 — пошагово). Ничего не поняли? Откроете — поймёте. Знаете, программа-то логична (внешне), и работает (!), но я не уверен, что она ищет всё то, что надо.

В моём примере (кстати, запуск там сделал, по альт-S), она 8 «сёдел» нашла, а самое очевидное, ячейку в центре! и не отметила. Её логику сейчас не осилю, а писать новую — это часа 2—3 надо.

Извините, приложил уже окрашенную матрицу. Но «обесцвечивать» просто: выделить и нажать контрол-пробел.

@Toxa33rus · 14.05.2009, 10:02

enrieta, Вам нужен код для экселя? Sasha_Smirnov зачем-то переделал его в ворд, и пока он 2 часа отлаживал код, то забыл что вообще требуется (если точек нет то мы об этом не узнаем).
А еще мне кажется что код с ошибкой. Не стал искать где она, но если в таблице во 2 столце первой строки ввести отрицательное число, то вся таблица становится из седловых точек (вся окрашивается голубым).
enrieta, почти то что Вам нужно уже было недавно на форуме, правда на QBasic:
https://www.cyberforum.ru/basic/thread32257.html
Если нужно, могу переделать под эксель с выводом сообщений. Только уточните в каком виде должно быть сообщение (отельное окно со списком седловых точек с координатами или отдельными окнами - "найдена точка с такими-то координатами", нажали ОК, "найдена еще одна точка с другими координатами" и т.д. по кадой точке).

Добавлено через 2 минуты 53 секунды
З.Ы.

Сообщение от Sasha_Smirnov

судя по тому, что в конце цвет = 3, программа ещё прошлого века.

Почему прошлого? Очень удобно указывать цифры вместо констант - места много не занимают. Сам так часто делаю не только с цветами но и с API константами.

Сообщение от Sasha_Smirnov

'а затем - окрашиваем (голубым)

В экселе это красный

@enrieta · 14.05.2009, 20:04 **[ТС]**

Toxa33rus да, мне нужно в экселе. Буду очень признательно,если поможите).
Если есть седловая точка, то нужно, чтобы выводилось сообщение "седловая точка A(p,q)".Лучше конечно, чтобы в одном окне. Но если что можно и 2 вариант.
если нет седловой точки "Седловой точки нет"

@Toxa33rus · 14.05.2009, 23:08

Вот что-то получилось:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Option Base 1
 
Sub mtrx()
Dim R As Long, C As Long
Dim MyRange As Range
Set MyRange = Selection
R = MyRange.Rows.Count
C = MyRange.Columns.Count
 
Dim isFind 'нашли точку
isFind = False 'пока нет
 
' Находим седловые точки
For i = 1 To R ' цикл по строкам
  ' найдем максимум в строке
  maxstr = MyRange.Cells(i, 1)
  For counter = 2 To R
    If MyRange.Cells(i, counter) > maxstr Then
      maxstr = MyRange.Cells(i, counter)
    End If
  Next counter
  ' теперь проверим для всех значений =maxstr, являются ли они
  ' минимумом в своем столбце
  For j = 1 To C
    If MyRange.Cells(i, j) = maxstr Then
      imin = 1
      For counter = 1 To R
        If MyRange.Cells(counter, j) < MyRange.Cells(i, j) Then ' Есть меньший элемент
          imin = 0
        End If
      Next counter
      ' Если элемент минимален в столбце - то это седловая точка
      If imin = 1 Then
        MsgBox "Седловая точка (" & i & "," & j & ")=" & MyRange.Cells(i, j)
        isFind = True
      End If
    End If
  Next j
Next i
 
If Not isFind Then MsgBox "Седловой точки нет."
End Sub

Option Explicit убрал т.к. лень было объявлять все переменные.
Работает по тому же принципу как было у Вас: заполняете таблицу, выделяете ее и запускаете макрос.

@Sasha_Smirnov · 15.05.2009, 02:53

Сообщение от enrieta

Помогите решить задачу:
Седловой точкой в матрице называется элемент, являющийся одновременно наибольшим в столбце и наименьшим в строке.

Code
1
2
3
4
5
0   0   33  0   0
0   0   8   0   0
-5  -6  [COLOR="Red"]0[/COLOR]  -99 -4
0   0   2   0   0
0   0   4   5   6

Вот теперь находит элемент (3, 3)!

Но надо повнимательней прочесть определение. Исходный код работал верно (хоть и не всегда).

Вот тут и начинается «мясо» программирования — логика.

Visual Basic
1
Option Explicit

для отладки незаменим! А переменные можно все скопом объявить через запятую.

@Toxa33rus · 15.05.2009, 09:54

Sasha_Smirnov, есть правило равнозначности строк и столбцов матрицы. Вот тут (http://tashgu.3dn.ru/load/5-1-0-15) например "...максимальный в строке...". А вообще смотрю я на исходную таблицу и там явно напрашивается очевидный 1 ответ, а не 8. Скорее всего именно так и надо.
Но если нужно, то переделать код просто: надо во всех циклах R поменять на C, а C на R.

Сообщение от Sasha_Smirnov

Option Explicit
для отладки незаменим!

То-то я и смотрю что на отладку ушел целый час

@enrieta · 15.05.2009, 14:55 **[ТС]**

Toxa33rus, Спасибо большое!!!!!Очень помогли)
в программе был небольшой недочет, в столбце находится максимум, а в строке минимум. Ну уж буковки я поменять смогла

@Sasha_Smirnov · 18.05.2009, 03:33

Всё же мне понравилась задача!

Новые блоги и статьи Все статьи Все блоги /
Жизнь в неопределённости kumehtar 23.03.2026 Жизнь — это постоянное существование в неопределённости. Например, даже если у тебя есть список дел, невозможно дойти до точки, где всё окончательно завершено и больше ничего не осталось. В принципе,. . .	Модель здравоСохранения: работники работают быстрее после её введения. anaschu 23.03.2026 geJalZw1fLo Корпорация до введения программа здравоохранения имела много невыполненных работниками заданий, после введения программы количество заданий выросло. Но на выплатах по больничным это. . .	1С: Контроль уникальности заводского номера Maks 23.03.2026 Алгоритм контроля уникальности заводского (или серийного) номера на примере документа выдачи шин для спецтехники с табличной частью. Данные берутся из регистра сведений, по которому настроено. . .	Хочу заставить корпорации вкладываться в здоровье сотрудников: делаю мат модель здравосохранения anaschu 22.03.2026 e7EYtONaj8Y Z4Tv2zpXVVo https:/ / github. com/ shumilovas/ med2. git
1С: Программный отбор элементов справочника по группе Maks 22.03.2026 Установка программного отбора элементов справочника "Номенклатура" из модуля формы документа. В качестве фильтра для отбора справочника служит группа номенклатуры. Отбор по наименованию группы. . .	Как я обхитрил таблицу Word Alexander-7 21.03.2026 Когда мигает курсор у внешнего края таблицы, и нам надо перейти на новую строку, а при нажатии Enter создается новый ряд таблицы с ячейками, то мы вместо нервных нажатий Энтеров мы пишем любые буквы. . .	Krabik - рыболовный бот для WoW 3.3.5a AmbA 21.03.2026 без регистрации и смс. Это не торговля, приложение не содержит рекламы. Выполняет свою непосредственную задачу - автоматизацию рыбалки в WoW - и ничего более. Однако если админы будут против -. . .	1С: Программный отбор элементов справочника по значению перечисления Maks 21.03.2026 Установка программного отбора элементов справочника "Сотрудники" из модуля формы документа. В качестве фильтра для отбора служит значение перечислений. / / Событие "НачалоВыбора" реквизита на форме. . .

@enrieta 1 / 1 / 0 Регистрация: 13.05.2009 Сообщений: 3
	14.05.2009, 20:04 [ТС]
	Toxa33rus да, мне нужно в экселе. Буду очень признательно,если поможите). Если есть седловая точка, то нужно, чтобы выводилось сообщение "седловая точка A(p,q)".Лучше конечно, чтобы в одном окне. Но если что можно и 2 вариант. если нет седловой точки "Седловой точки нет" 0

@enrieta 1 / 1 / 0 Регистрация: 13.05.2009 Сообщений: 3
	15.05.2009, 14:55 [ТС]
	Toxa33rus, Спасибо большое!!!!!Очень помогли) в программе был небольшой недочет, в столбце находится максимум, а в строке минимум. Ну уж буковки я поменять смогла 1

@Sasha_Smirnov 5562 / 1370 / 150 Регистрация: 08.02.2009 Сообщений: 4,109 Записей в блоге: 30
	18.05.2009, 03:33
	Всё же мне понравилась задача! 0