Tìm lộ trình ngắn nhất

gauchoigameonline · 10/9/20

Dear a/e

Hiện tại mình có bài toán như sau:

Cho n vị trí cộ định, biết trước khoảng cách giữa các điểm với nhau (mỗi điểm đều có khoảng cách đến tất cả các điểm còn lại)

Yêu cầu bài toán là tìm lộ trình ngắn nhất đi qua n điểm, cụ thể

1, Vị trí xuất phát, vị trí kết thúc? (thuộc n vị trí cố định)

2, Lộ trình di chuyển: thứ tự từng vị trí đi qua (tại mỗi Node, lộ trình có thể lặp lại - đi qua Node đó nhiều lần)

※ Map tuyến đường & ví dụ minh họa tham khảo file đính kèm!

>> A/e có cao kiến gì hỗ trợ mình cái nhé. Thank so much!

VetMini · 11/9/20

batman1 đã viết:
Bạn không hiểu ý tác giả rồi.

Bài toán: cho vd. 10 điểm A, B, ..., I, J.
1. Bài của tác giả. Trong tất cả những con đường đi từ A tới J mà đi quả tất cả 10 điểm hãy tìm lộ trình ngắn nhất.

...

Phần tôi thì không hiểu là thớt có hiểu mình muốn gì không?
Bài toán postman buộc phải đi qua mọi điểm. Và mọi đường nối giữa hai điểm đều khả thi.
Mục đích mà thớt nêu ra ở bài #25 là bài toán chỉ đường, không nhất thiết phải qua mọi điểm. Và có một số đường không khả thi (điển hình đường 1 chiều, hay không có đường trực tiếp giữa 2 điểm nào đó)
Hai vấn đề rất khác biệt nhau.

anhduong9x9 · 11/9/20

Mình có đoạn code này cho mọi người tham khảo nhé: Cơ bản nó như sau: Nó sẽ làm theo phương pháp cộng dần quãng đường đi và tìm cái ngắn nhất (Mỗi ô cell là 1 đơn vị quãng đường đi). Đoạn code này có hạn chế như sau và cần mọi người tự nâng cấp code lên nhá:
1) Nó phải lặp khá nhều lần trong vùng bản đồ mà tôi cài ở dạng "Range Name" Nên khi cài đặt với vùng bản đồ lớn nó sẽ chạy lâu.
2) Nó chưa chỉ ra thêm cung đường có cùng độ dài. Cái này tôi sử lý được nhưng tôi ngại quá, mọi người tự sử lý thêm.
3) Tất cả các ô mình bôi đậm ở dòng code bạn có thể thay đổi khi bạn làm bản đồ mới hay cái bảng mới.
3.1) Mình có file đính kèm bên dưới các bạn có thể tham khảo. ^^

Option Explicit.
Public LastColMap As Double
Public LastRowMap As Double
Public C_FCol As Double
Public C_FRow As Double
Public cell_start As Range
Public cell_end As Range
Public SetBackGround As String
Public SetWalls As String
Public Sub FindMinRoad()
Dim cell_current As Range
Dim l_smallest_path As Long
Dim l_col As Long
Dim l_LastRowMap As Long
Dim my_DeleteCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Range(Range("B30").Value).Style = "Good"
Range(Range("B29").Value).Style = "Bad"
Range(Range("B28").Value).Name = "SetUpMapMe"
SetBackGround = Range("B27").Value
SetWalls = Range("B31").Value
LastColMap = Range(Range("B28").Value).Columns.Count + Range(Range("B28").Value).Column - 1
LastRowMap = Range(Range("B28").Value).Row + Range(Range("B28").Value).Rows.Count - 1
C_FCol = Range(Range("B28").Value).Column - 1
C_FRow = Range(Range("B28").Value).Row - 1
Set cell_start = Cells(Range(Range("B29").Value).Row, Range(Range("B29").Value).Column)
Set cell_end = Cells(Range(Range("B30").Value).Row, Range(Range("B30").Value).Column)
Set cell_current = cell_start
cell_current.Value = cell_current.Address & "*" & 0
Do While True
If CheckBy1(cell_current) Then Exit Do
Set cell_current = PathNewSmall(cell_current)
cell_current.Style = "Input"
Loop
Do While True
cell_current.Style = "Accent2"
If CheckBy1(cell_current, False) Then Exit Do
Set cell_current = Range(Split(cell_current, "*")(0))
Loop
For Each my_DeleteCell In [Playground]
If my_DeleteCell.Style <> SetWalls And my_DeleteCell.Style <> "Accent2" Then
my_DeleteCell.Clear
my_DeleteCell.Style = SetBackGround
ElseIf my_DeleteCell.Style = "Accent2" Then
my_DeleteCell.Value = VBA.Split(my_DeleteCell, "*")(1)
End If
Next my_DeleteCell
Range(Range("B30").Value).Interior.Color = 65535
Range(Range("B29").Value).Interior.Color = 10498160
Set cell_start = Nothing
Set cell_end = Nothing
Set cell_current = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Sub Reset()
Dim sName As String
Dim my_DeleteCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Range(Range("B28").Value).Name = "SetUpMapMe"
SetWalls = Range("B31").Value
SetBackGround = Range("B27").Value
For Each my_DeleteCell In [Playground]
If my_DeleteCell.Style <> SetWalls Then
my_DeleteCell.Clear
my_DeleteCell.Style = SetBackGround
End If
Next my_DeleteCell
[Playground].RowHeight = 14
[Playground].ColumnWidth = 2.3
[Playground].WrapText = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Function CheckBy1(ByRef cell_current As Range, Optional b_going_back As Boolean = True) As Boolean ' Ham tra ve True or false
Dim my_cell As Range
If cell_current.Column < LastColMap Then
If cell_current.Column + 1 > C_FCol Then
Set my_cell = cell_current.Offset(0, 1)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Row < LastRowMap Then
If cell_current.Row > C_FRow Then
Set my_cell = cell_current.Offset(1, 0)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Column > 1 Then
If cell_current.Column - 1 > C_FCol Then
Set my_cell = cell_current.Offset(0, -1)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Row > 1 Then
If cell_current.Row - 1 > C_FRow Then
Set my_cell = cell_current.Offset(-1, 0)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
Set my_cell = Nothing
End Function
Public Function NewDataCell(ByRef my_cell As Range, ByRef b_going_back As Boolean, cell_current As Range) As Boolean
If my_cell.Style = IIf(b_going_back, "Good", "Bad") Then NewDataCell = True
If my_cell.Style = SetBackGround Then
my_cell.Style = "Calculation"
my_cell = cell_current.Address & "*" & VBA.Split(cell_current.Value, "*")(1) + 1
End If
End Function
Public Function PathNewSmall(ByRef current_cell As Range) As Range
Dim my_cell As Range
Dim my_result_cell As Range
Dim l_result As Long
l_result = 1000000000
Set my_result_cell = Nothing
For Each my_cell In [Playground]
If my_cell.Style = "Calculation" Then
If VBA.Split(my_cell, "*")(1) < l_result Then
l_result = Split(my_cell, "*")(1)
Set my_result_cell = my_cell
End If
End If
Next my_cell
Set PathNewSmall = my_result_cell
Set my_result_cell = Nothing
End Function

Hi vọng đúng ý chủ thớt. Good luck!

Bài đã được tự động gộp: 11/9/20

À quên mình có hướng dẫn thêm tí là nếu bạn làm bản đồ mới thì cần khái báo định dạng cái vật cản theo đúng cái tên bên dưới hoặc theo một cái tên trong "Styles" cho tường cũng được:

gauchoigameonline · 12/9/20

batman1 đã viết:
Bạn không hiểu ý tác giả rồi.

Bài toán: cho vd. 10 điểm A, B, ..., I, J.
1. Bài của tác giả. Trong tất cả những con đường đi từ A tới J mà đi quả tất cả 10 điểm hãy tìm lộ trình ngắn nhất.

2. Bài toán "đi qua 2 điểm" mà tác giả lưu ý bạn. Trong tất cả những con đường đi từ A tới J tìm lộ trình ngắn nhất.

Nên biết rằng trong bài 2 có thể giữa A và J không có đường trực tiếp. Vậy mọi lộ trình trong trường hợp tổng quát là đường gấp khúc có ít nhất 2 đoạn. Hãy tìm đường gấp khúc ngắn nhất. Không có đòi hỏi đi qua tất cả các điểm đã cho như bài 1. Và thuật toán cho bài 2 tác giả cũng đã biết. Đó là thuật toán Dijkstra.

Bài toán yêu cầu rất rõ rồi, cho n điểm cố định tìm lộ trình ngắn nhất qua n điểm.
Hình như nhiều bạn đang hiểu đây là bài toán tìm quãng đường đi ngắn nhất giữa 2 điểm đó đấy batman!

Bài đã được tự động gộp: 12/9/20

anhduong9x9 đã viết:
Mình có đoạn code này cho mọi người tham khảo nhé: Cơ bản nó như sau: Nó sẽ làm theo phương pháp cộng dần quãng đường đi và tìm cái ngắn nhất (Mỗi ô cell là 1 đơn vị quãng đường đi). Đoạn code này có hạn chế như sau và cần mọi người tự nâng cấp code lên nhá:
1) Nó phải lặp khá nhều lần trong vùng bản đồ mà tôi cài ở dạng "Range Name" Nên khi cài đặt với vùng bản đồ lớn nó sẽ chạy lâu.
2) Nó chưa chỉ ra thêm cung đường có cùng độ dài. Cái này tôi sử lý được nhưng tôi ngại quá, mọi người tự sử lý thêm.
3) Tất cả các ô mình bôi đậm ở dòng code bạn có thể thay đổi khi bạn làm bản đồ mới hay cái bảng mới.
3.1) Mình có file đính kèm bên dưới các bạn có thể tham khảo. ^^

Option Explicit.
Public LastColMap As Double
Public LastRowMap As Double
Public C_FCol As Double
Public C_FRow As Double
Public cell_start As Range
Public cell_end As Range
Public SetBackGround As String
Public SetWalls As String
Public Sub FindMinRoad()
Dim cell_current As Range
Dim l_smallest_path As Long
Dim l_col As Long
Dim l_LastRowMap As Long
Dim my_DeleteCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Range(Range("B30").Value).Style = "Good"
Range(Range("B29").Value).Style = "Bad"
Range(Range("B28").Value).Name = "SetUpMapMe"
SetBackGround = Range("B27").Value
SetWalls = Range("B31").Value
LastColMap = Range(Range("B28").Value).Columns.Count + Range(Range("B28").Value).Column - 1
LastRowMap = Range(Range("B28").Value).Row + Range(Range("B28").Value).Rows.Count - 1
C_FCol = Range(Range("B28").Value).Column - 1
C_FRow = Range(Range("B28").Value).Row - 1
Set cell_start = Cells(Range(Range("B29").Value).Row, Range(Range("B29").Value).Column)
Set cell_end = Cells(Range(Range("B30").Value).Row, Range(Range("B30").Value).Column)
Set cell_current = cell_start
cell_current.Value = cell_current.Address & "*" & 0
Do While True
If CheckBy1(cell_current) Then Exit Do
Set cell_current = PathNewSmall(cell_current)
cell_current.Style = "Input"
Loop
Do While True
cell_current.Style = "Accent2"
If CheckBy1(cell_current, False) Then Exit Do
Set cell_current = Range(Split(cell_current, "*")(0))
Loop
For Each my_DeleteCell In [Playground]
If my_DeleteCell.Style <> SetWalls And my_DeleteCell.Style <> "Accent2" Then
my_DeleteCell.Clear
my_DeleteCell.Style = SetBackGround
ElseIf my_DeleteCell.Style = "Accent2" Then
my_DeleteCell.Value = VBA.Split(my_DeleteCell, "*")(1)
End If
Next my_DeleteCell
Range(Range("B30").Value).Interior.Color = 65535
Range(Range("B29").Value).Interior.Color = 10498160
Set cell_start = Nothing
Set cell_end = Nothing
Set cell_current = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Sub Reset()
Dim sName As String
Dim my_DeleteCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Range(Range("B28").Value).Name = "SetUpMapMe"
SetWalls = Range("B31").Value
SetBackGround = Range("B27").Value
For Each my_DeleteCell In [Playground]
If my_DeleteCell.Style <> SetWalls Then
my_DeleteCell.Clear
my_DeleteCell.Style = SetBackGround
End If
Next my_DeleteCell
[Playground].RowHeight = 14
[Playground].ColumnWidth = 2.3
[Playground].WrapText = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Function CheckBy1(ByRef cell_current As Range, Optional b_going_back As Boolean = True) As Boolean ' Ham tra ve True or false
Dim my_cell As Range
If cell_current.Column < LastColMap Then
If cell_current.Column + 1 > C_FCol Then
Set my_cell = cell_current.Offset(0, 1)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Row < LastRowMap Then
If cell_current.Row > C_FRow Then
Set my_cell = cell_current.Offset(1, 0)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Column > 1 Then
If cell_current.Column - 1 > C_FCol Then
Set my_cell = cell_current.Offset(0, -1)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
If cell_current.Row > 1 Then
If cell_current.Row - 1 > C_FRow Then
Set my_cell = cell_current.Offset(-1, 0)
CheckBy1 = NewDataCell(my_cell, b_going_back, cell_current)
If CheckBy1 Then Exit Function
End If
End If
Set my_cell = Nothing
End Function
Public Function NewDataCell(ByRef my_cell As Range, ByRef b_going_back As Boolean, cell_current As Range) As Boolean
If my_cell.Style = IIf(b_going_back, "Good", "Bad") Then NewDataCell = True
If my_cell.Style = SetBackGround Then
my_cell.Style = "Calculation"
my_cell = cell_current.Address & "*" & VBA.Split(cell_current.Value, "*")(1) + 1
End If
End Function
Public Function PathNewSmall(ByRef current_cell As Range) As Range
Dim my_cell As Range
Dim my_result_cell As Range
Dim l_result As Long
l_result = 1000000000
Set my_result_cell = Nothing
For Each my_cell In [Playground]
If my_cell.Style = "Calculation" Then
If VBA.Split(my_cell, "*")(1) < l_result Then
l_result = Split(my_cell, "*")(1)
Set my_result_cell = my_cell
End If
End If
Next my_cell
Set PathNewSmall = my_result_cell
Set my_result_cell = Nothing
End Function

Hi vọng đúng ý chủ thớt. Good luck!

Bài đã được tự động gộp: 11/9/20

À quên mình có hướng dẫn thêm tí là nếu bạn làm bản đồ mới thì cần khái báo định dạng cái vật cản theo đúng cái tên bên dưới hoặc theo một cái tên trong "Styles" cho tường cũng được: View attachment 245403

Tuy không phải đúng theo ý mình muốn (bài toán yêu cầu tìm lộ trình ngắn nhất đi qua n điểm chứ không phải là bài toán tìm đường đi ngắn nhất giữa 2 điểm) nhưng bạn đã rất nhiệt tình giúp mình.
Cảm ơn bạn nhiều nhé!

gauchoigameonline · 12/9/20

VetMini đã viết:
Phần tôi thì không hiểu là thớt có hiểu mình muốn gì không?
Bài toán postman buộc phải đi qua mọi điểm. Và mọi đường nối giữa hai điểm đều khả thi.
Mục đích mà thớt nêu ra ở bài #25 là bài toán chỉ đường, không nhất thiết phải qua mọi điểm. Và có một số đường không khả thi (điển hình đường 1 chiều, hay không có đường trực tiếp giữa 2 điểm nào đó)
Hai vấn đề rất khác biệt nhau.

Bài toán mình đưa ra yêu cầu rất cụ thể mà bạn. Nó chính là chính là bài toán Postman đó.
Trong map mình gửi những vị trí cố định được tô màu cam trên các tuyến đường đi.
Lộ trình phải đi qua toàn bộ những vị trí màu cam này.
Lộ trình có thể đi lặp lại nhiều lần trên vị trí cố định (ví dụ như bạn nói A không đi được đến C vì AC là đường 1 chiều thì lộ trình là A→B→C→B→D...)
Nói chung đi kiểu gì thì đi cũng phải qua toàn bộ những vị trí màu cam đó.
Còn về việc đi từ A→B, từ B→C....cũng sẽ phải là tuyến đường đi ngắn nhất (mình đã xử lý được bằng thuật toán Dijska)

Tìm lộ trình ngắn nhất

gauchoigameonline

Thành viên chính thức

File đính kèm

VetMini

Ăn cùng góc phố

anhduong9x9

Người qua đường. Xin cảm ơn!

File đính kèm

gauchoigameonline

Thành viên chính thức

gauchoigameonline

Thành viên chính thức

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng