agstick版主的捡金币问题

lxdexcel · 发表于 2024-5-3 17:03

Option Explicit
Dim map() As Long
Dim path() As Variant
Private Sub cmdCount_Click()
Dim n&, x&, y&, x1&, y1&, k&, p&
n = Range("m2")
Range("p4") = count(n, map, path)
Cells(n, n).Interior.Color = RGB(225, 0, 0) Xor RGB(0, 155, 21)
x = n - 1
x1 = n - 1
For k = 2 * n - 2 To 1 Step -1
p = path(k)(x)(x1)
If (p = 2) Or (p = 3) Then x = x - 1
y = k - 1 - x
Cells(y + 1, x + 1).Interior.Color = RGB(225, 0, 0)
If (p = 1) Or (p = 3) Then x1 = x1 - 1
y1 = k - 1 - x1
Cells(y1 + 1, x1 + 1).Interior.Color = RGB(0, 155, 21) Xor Cells(y1 + 1, x1 + 1).Interior.Color
Next
End Sub
Private Sub cmdStat_Click()
Dim n&, num&, max&, i&, j&
Range("a1:j10").ClearContents
Range("a1:j10").Interior.Pattern = xlPatternNone
n = Range("m2")
num = Range("n2")
max = Range("o2")
If n < 1 Or n > 15 Then MsgBox "格子个数超出范围": Exit Sub
If num > n * n Then MsgBox "个数超出范围": Exit Sub
createMap n, num, max, map
For i = 0 To n - 1
For j = 0 To n - 1
If map(i, j) > 0 Then Cells(j + 1, i + 1) = map(i, j)
Next
Next
End Sub
Sub createMap(n As Long, num As Long, max As Long, map() As Long)
Dim temp&(), i&, r&, s&, last&, m&
last = n * n - 1
ReDim temp(0 To last)
ReDim map(0 To n, 0 To n)
For i = 0 To last
temp(i) = i
Next
VBA.Randomize
For i = 0 To num - 1
s = Int(max * Rnd + 1)
r = Int(Rnd * (last - i))
m = temp(r)
map(m Mod n, m \ n) = s
temp(r) = temp(last - i)
Next
End Sub
Function count(n As Long, map() As Long, path() As Variant) As Long
Dim k&, x&, y&, x1&, y1&, xs&, xe&, last&, cur&, before&
Dim p() As Variant
Dim p1() As Byte
Dim state() As Long
last = n * 2 - 2
ReDim path(0 To last)
ReDim state(1, n - 1, n - 1)
state(0, 0, 0) = map(0, 0)
before = 0
For k = 1 To last
If k < n Then
xs = 0
xe = k
Else
xs = k - (n - 1)
xe = n - 1
End If
ReDim p(xs To xe)
Dim s1&, s&, s0&, sMax&
cur = before Xor 1
For x = xs To xe
ReDim p1(x To xe)
y = k - x
s = map(x, y)
For x1 = x To xe
sMax = 0
y1 = k - x1
s1 = map(x1, y1)
If y > 0 Then
If x1 > 0 And x <> x1 Then
s0 = state(before, x, x1 - 1) + s + s1
If s0 >= sMax Then
sMax = s0
p1(x1) = 1
End If
End If
If y1 > 0 Then
s0 = state(before, x, x1) + s
If x <> x1 Then s0 = s0 + s1
If s0 >= sMax Then
sMax = s0
p1(x1) = 0
End If
End If
End If
If x > 0 Then
If x1 > 0 Then
s0 = state(before, x - 1, x1 - 1) + s
If x <> x1 Then s0 = s0 + s1
If s0 >= sMax Then
sMax = s0
p1(x1) = 3
End If
End If
If y1 > 0 Then
s0 = state(before, x - 1, x1) + s
If x <> x1 Then s0 = s0 + s1
If s0 >= sMax Then
sMax = s0
p1(x1) = 2
End If
End If
End If
state(cur, x, x1) = sMax
Next
p(x) = p1
Next
path(k) = p
before = cur
Next
count = state(before, x - 1, x1 - 1)
End Function

复制代码

779846526 · 发表于 2024-9-29 17:51

lxdexcel 发表于 2024-5-3 17:03

收藏下，备用，谢谢大神分享

一招秒杀 · 发表于 2024-9-29 21:11

标记一下，只需要1条巧妙的语句就能瞬间秒杀它，或者明天的吧，哪里需要好几十、超百行代码，开发语言的代差真是太大了，看到那么多代码，我想直接撞墙，这就是你们心中的优秀作品，我能想到的只是 S 山。

一招秒杀 · 发表于 2024-10-1 09:28

lxdexcel 发表于 2024-5-3 17:03

吹出去的牛，哭着也要实现，1句7行，暴力解决，
以前面的数据为例，最大和1127有48条线路。
这次7行代码一定比 155行代码更容易看懂，更不容易出错，更容易修改。

一招秒杀 · 发表于 2024-10-1 09:52

本帖最后由一招秒杀于 2024-10-1 10:03 编辑

几乎一半代码是重复的，还可以把代码精简到 1句4行。

yynrzwh · 发表于 2024-10-1 10:31

一招秒杀发表于 2024-10-1 09:52
几乎一半代码是重复的，还可以把代码精简到 1句4行。

的确牛逼！！

		自动登录	找回密码
密码			免费注册

[讨论] agstick版主的捡金币问题

评分