出个编程小题目：n个人围成圈报数踢出最后剩下几号？

香川群子 · 发表于 2016-10-18 10:45

本帖最后由香川群子于 2016-10-18 10:52 编辑

题目：
有n个人围成一圈，顺序排号。
从第一个人开始报数（例如从1到3报数），凡报到3的人退出圈子，问最后留下的是原来第几号的那位。

扩展到报数t（t<n），报数到t的人退出圈子。

例如 n=10、t=3，那么：
1、2、3、4、5、6、7、8、9、10，第1轮去掉3、6、9，剩下10、1、2、4、5、7、8，
第2轮去掉2、7，剩下8、10、1、4、5，
第3轮去掉1，剩下4、5、8、10，
第4轮去掉8，剩下10、4、5，
第5轮去掉5，剩下10、4、（10、4），
第6轮去掉10，最后剩下4，就是答案。

小花鹿 · 发表于 2016-10-18 11:04

不是数到3才去掉吗，为什么10会去掉？

Chip_Kenny · 发表于 2016-10-18 12:02

老師, 我用了字典方法:

Sub zz()
Dim d As Object, n&, j%, Msg$
Set d = CreateObject("scripting.dictionary")
n = InputBox("Numbers", , 10)
For i = 1 To n
d(i) = ""
Next
k = d.keys
Do
For i = 0 To UBound(k)
If Len(k(i)) Then j = j + 1
If j = 3 Then d.Remove (k(i)): k(i) = "": j = 0
Next
Loop Until d.Count = 1
MsgBox "最后剩下是:" & d.keys()(0)
Set d = Nothing
End Sub

复制代码

yjh_27 · 发表于 2016-10-18 13:49

Sub aa()
n = 10
m = 3
ReDim arr(1 To n)
For i = 1 To n
arr(i) = i
Next
Do While UBound(arr) > 1
r = r + 1
Range("a1").Resize(1, UBound(arr)).Offset(r, 0) = arr
arr = bb(arr, m)
Loop
MsgBox arr(1)
End Sub
Function bb(a, b)
Dim arr()
arr = a
n = 0
k = (b - 1) \ UBound(arr) + 1
For i = 1 To UBound(arr) * k
ii = (i - 1) Mod UBound(arr) + 1
m = i Mod b
If m > 0 Then
n = n Mod UBound(arr) + 1
arr(n) = arr(ii)
End If
Next
ReDim brr(1 To n)
For i = 1 To n
If i > m Then
brr(i) = arr(i - m)
Else
brr(i) = arr(n - m + i)
End If
Next
bb = brr
End Function

复制代码

香川群子 · 发表于 2016-10-18 14:28

小花鹿发表于 2016-10-18 11:04
不是数到3才去掉吗，为什么10会去掉？

因为是围成一圈，所以当剩余人数不足3人时，会重复去数前面的人。

第5轮去掉5，最后一剩下10、4、（10、4），
那么从10号报数=1、4号报数=2，接下来还是10号要报数=3了……于是被踢出圈子，终于只剩下4号1个人。

香川群子 · 发表于 2016-10-18 14:31

Chip_Kenny 发表于 2016-10-18 12:02
老師, 我用了字典方法:

你的代码可以修改一下，减少无效循环。

Sub zz()
Dim d As Object, n&, j%, Msg$
Set d = CreateObject("scripting.dictionary")
n = InputBox("Numbers", , 10)
t = InputBox("Step Length", , 3)
For i = 1 To n
d(i) = ""
Next
'k = d.keys
Do
k = d.keys '读取字典内容(更新后的剩余人数)
For i = 0 To UBound(k)
j = j + 1: If j = t Then d.Remove (k(i)): j = 0
Next
Loop Until d.Count = 1
MsgBox d.keys()(0)
Set d = Nothing
End Sub

复制代码

这样显然不用在k数组中反复循环，判断是否数组对应内容为空白了。

如果投机取巧，那么第一次加入字典时就可以去掉j=t的部分。

Chip_Kenny · 发表于 2016-10-18 14:40

受教,獲益,謝謝

香川群子 · 发表于 2016-10-18 14:42

本帖最后由香川群子于 2016-10-18 14:52 编辑

第一次加入字典时即去掉第1轮次的代码：

Sub zz()
Dim d As Object, n&, j%, Msg$
Set d = CreateObject("scripting.dictionary")
n = InputBox("Numbers", , 10)
t = InputBox("Step Length", , 3)
For i = 0 To n - 1 Step t
For j = 1 To t - 1
d(i + j) = "": If i + j = n Then Exit For
Next
Next
j = n Mod t '重新计算剩余j值
Do
k = d.keys
For i = 0 To UBound(k)
j = j + 1: If j = t Then d.Remove (k(i)): j = 0
Next
Loop Until d.Count = 1
MsgBox d.keys()(0)
Set d = Nothing
End Sub

复制代码

Chip_Kenny · 发表于 2016-10-18 15:04

香川群子发表于 2016-10-18 14:42
第一次加入字典时即去掉第1轮次的代码：

香老師的精益求精指導, 衷心多謝。

香川群子 · 发表于 2016-10-18 15:11

Chip_Kenny 发表于 2016-10-18 12:02
老師, 我用了字典方法:

按你原来的思路，但不用字典，只用数组也可以的：

Sub test1()
Dim i&, j&, k&, n&, t&
n = 12 '圈内总人数
t = 3 '踢出圈子的步长
ReDim a&(1 To n)
For i = 0 To n - 1 Step t
For j = 1 To t - 1
a(i + j) = i + j: If i + j = n Then Exit For
Next
Next
j = n Mod t '第1轮尾巴剩余人数 j<t
k = n - (n - j) / t '第一轮以后剩余人数k
Do
For i = 1 To n
If a(i) Then j = j + 1: If j = t Then a(i) = 0: j = 0: k = k - 1
Next
Loop Until k = 1 '反复检查直至剩余人数k=1
For i = 1 To n
If a(i) Then Exit For '还需要找到这最后一个人
Next
MsgBox i
End Sub

复制代码

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

[讨论] 出个编程小题目：n个人围成圈报数踢出最后剩下几号？

最新热点 /1