四条线连接九个点

香川群子

lsdongjh 发表于 2013-6-19 08:45
根据题目的含义,我记得点上是不能重复的,当年的数据老师说过,正确的解法如下:

其他的解法是有问题的,并不 ...

如果不要重复经过……那么螺旋形就绝对可以做到。


至于线条数最少，那还是要允许重复，否则不行。

即，问题可以重新描述为：
【用最少的一笔画线条，覆盖所有点。】


另，据我所知，凡是一笔画，都是允许某些点被重复经过的。
因为n数较大时，不重复而能做到一笔到底是不可能实现的。

wcymiss

有重复的话5阶8条线就可以了。

banjinjiu

wcymiss 发表于 2013-6-20 08:13
有重复的话5阶8条线就可以了。

一定是有规则限制的，不然就不好玩了，画的线必须是直的，或者说是直线，我觉得还是点不能重复，如果是线不能重复就没意义了。请wcymiss老师出出点子，写写算法

香川群子

彻底完成。增加了自动画线。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address = "$A$1" Then
   
3.         If [a1] = 0 Then n = InputBox("", "", 11) Else n = [a1]
   
4.         [c3].Resize(n, n).Name = "Rng"
   
5.         Call kagawa(n)
   
6.         [a1].Activate
   
7.     End If
   
8. End Sub
   
9. Sub kagawa(n)
   
10.    
    
11.     For Each shp In ActiveSheet.Shapes
    
12.         shp.Delete
    
13.     Next
    
14.    
    
15.     [b2:iv256].Clear
    
16.     [c3].Resize(n, n) = 1
    
17.    
    
18.     '起点
    
19.     [b2].Offset(n).Activate
    
20.     ActiveCell.Interior.ColorIndex = 8
    
21.     ActiveCell = ChrW(8594)
    
22.     With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2)
    
23.    
    
24.         '横線1(水平線1)
    
25.         For i = 1 To n + 1
    
26.             ActiveCell.Offset(, 1).Activate
    
27.             ActiveCell.Interior.ColorIndex = 6
    
28.             If ActiveCell = 1 Then ActiveCell = "*"
    
29.         Next
    
30.         ActiveCell = ChrW(8598)
    
31.         .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
32.         k = k + 1
    
33.         
    
34.         '右斜線1
    
35.         For i = 1 To n
    
36.             ActiveCell.Offset(-1, -1).Activate
    
37.             ActiveCell.Interior.ColorIndex = 6
    
38.             If ActiveCell = 1 Then ActiveCell = "*"
    
39.         Next
    
40.         ActiveCell = ChrW(8595)
    
41.         .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
42.         k = k + 1
    
43.         
    
44.         
    
45.         '縦線1(垂直線1)
    
46.         y = Round((2 * n - 4) / 3)
    
47.         t = Int((n - 1) / 3)
    
48.         For i = 1 To n + t
    
49.             ActiveCell.Offset(1).Activate
    
50.             ActiveCell.Interior.ColorIndex = 6
    
51.             If ActiveCell = 1 Then ActiveCell = "*" Else If ActiveCell = "" Then ActiveCell = ChrW(8595)
    
52.         Next
    
53.         ActiveCell = ChrW(8599)
    
54.         .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
55.         k = k + 1
    
56.         
    
57.         '左斜線、横線、縦線　繰り返す
    
58.         For j = 1 To y
    
59.             '左斜線
    
60.             For i = 1 To n + t - j
    
61.                 ActiveCell.Offset(-1, 1).Activate
    
62.                 ActiveCell.Interior.ColorIndex = 6
    
63.                 If ActiveCell = 1 Then ActiveCell = "*" Else If ActiveCell = "" Then ActiveCell = ChrW(8599)
    
64.             Next
    
65.             ActiveCell = ChrW(8592)
    
66.             .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
67.             k = k + 1
    
68.             If Application.Sum(Range("Rng")) = 0 Then Exit For
    
69.             
    
70.             '左横線
    
71.             For i = 1 To n + t - j - 1
    
72.                 ActiveCell.Offset(, -1).Activate
    
73.                 ActiveCell.Interior.ColorIndex = 6
    
74.                 If ActiveCell = 1 Then ActiveCell = "*" Else If ActiveCell = "" Then ActiveCell = ChrW(8592)
    
75.             Next
    
76.             .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
77.             k = k + 1
    
78.             
    
79.             '下縦線
    
80.             For i = 1 To n + t - j
    
81.                 ActiveCell.Offset(1).Activate
    
82.                 ActiveCell.Interior.ColorIndex = 6
    
83.                 If ActiveCell = 1 Then ActiveCell = "*" Else If ActiveCell = "" Then ActiveCell = ChrW(8595)
    
84.             Next
    
85.             ActiveCell = ChrW(8599)
    
86.             .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
87.             k = k + 1
    
88.             If Application.Sum(Range("Rng")) = 0 Then Exit For
    
89.         Next
    
90.         
    
91.         ActiveCell.Interior.ColorIndex = 8
    
92.         ActiveCell = ChrW(9678)
    
93.         ActiveCell.CurrentRegion.HorizontalAlignment = xlCenter
    
94.         ActiveCell.CurrentRegion.VerticalAlignment = xlCenter
    
95. 
    
96.         .ConvertToShape.Select
    
97.     End With
    
98.     Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadDiamond
    
99.     Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    
100.    
     
101.     Application.StatusBar = n & "x" & n & " = " & k & " (t= " & t & ")"
     
102.    
     
103. End Sub

复制代码

香川群子

增加了螺旋式一笔到底的画线程序。

结果发现，螺旋式所需的线条也并不是很多，相等或只相差一条线而已。

香川群子

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address = "$A$1" Then
   
3.         If [a1] = 0 Then n = InputBox("", "", 11) Else n = [a1]
   
4.         [c3].Resize(n, n).Name = "Rng"
   
5.         Call kagawa(n)
   
6.         [a1].Activate
   
7.     End If
   
8. End Sub
   
9. Sub kagawa(n)
   
10.    
    
11.     For Each shp In ActiveSheet.Shapes
    
12.         shp.Delete
    
13.     Next
    
14.    
    
15.     [b2:iv256].Clear
    
16.     [c3].Resize(n, n) = 1
    
17.    
    
18.     '起点
    
19.     [b3].Activate
    
20.     ActiveCell.Interior.ColorIndex = 8
    
21.     ActiveCell = ChrW(8594)
    
22.    
    
23.     With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2)
    
24.         ActiveCell.Offset(, 1).Activate
    
25.         r = 1
    
26.         Do
    
27.             ActiveCell.Interior.ColorIndex = 6
    
28.             ActiveCell = "*"
    
29.             If r = 1 Then
    
30.                 If ActiveCell.Offset(, 1) = 1 Then
    
31.                     ActiveCell.Offset(, 1).Activate
    
32.                 Else
    
33.                     .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
34.                     ActiveCell.Offset(1).Activate
    
35.                     r = 4: k = k + 1
    
36.                 End If
    
37.             ElseIf r = 4 Then
    
38.                 If ActiveCell.Offset(1) = 1 Then
    
39.                     ActiveCell.Offset(1).Activate
    
40.                 Else
    
41.                     .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
42.                     ActiveCell.Offset(, -1).Activate
    
43.                     r = 2: k = k + 1
    
44.                 End If
    
45.             ElseIf r = 2 Then
    
46.                 If ActiveCell.Offset(, -1) = 1 Then
    
47.                     ActiveCell.Offset(, -1).Activate
    
48.                 Else
    
49.                     .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
50.                     ActiveCell.Offset(-1).Activate
    
51.                     r = 3: k = k + 1
    
52.                 End If
    
53.             ElseIf r = 3 Then
    
54.                 If ActiveCell.Offset(-1) = 1 Then
    
55.                     ActiveCell.Offset(-1).Activate
    
56.                 Else
    
57.                     .AddNodes msoSegmentLine, msoEditingAuto, ActiveCell.Left + ActiveCell.Width / 2, ActiveCell.Top + ActiveCell.Height / 2
    
58.                     ActiveCell.Offset(, 1).Activate
    
59.                     r = 1: k = k + 1
    
60.                 End If
    
61.             End If
    
62.         Loop Until ActiveCell = "*"
    
63.         
    
64.         If n Mod 2 Then ActiveCell.Offset(-1).Activate Else ActiveCell.Offset(1).Activate
    
65.         ActiveCell.Interior.ColorIndex = 8
    
66.         ActiveCell = ChrW(9678)
    
67.         ActiveCell.CurrentRegion.HorizontalAlignment = xlCenter
    
68.         ActiveCell.CurrentRegion.VerticalAlignment = xlCenter
    
69. 
    
70.         .ConvertToShape.Select
    
71.     End With
    
72.     Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadDiamond
    
73.     Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    
74.    
    
75.     Application.StatusBar = n & "x" & n & " = " & k & " circle lines"
    
76.    
    
77. End Sub
    

复制代码

banjinjiu

香川群子 发表于 2013-6-20 13:27

S形的线也只相差一条线，应该说一笔画是最少的线。可以这么理解吗？我还是认为如果点重复，那可能线也重复了，都重复了，就没意义了。比如，三阶的，像“雪”的下面，这样的图形行吗？

香川群子

banjinjiu 发表于 2013-6-20 09:14
一定是有规则限制的，不然就不好玩了，画的线必须是直的，或者说是直线，我觉得还是点不能重复，如果是 ...

S形螺旋 或者 中心漩涡螺旋，都是点、线都不会重复的。

实际使用直线线段也并不很多。

S形会有很多种变体……但本质是一样的。

我的附件做了VBA自动画线，效果不错。


点阵线条.rar (39.47 KB, 下载次数: 16)

2013-6-20 23:43 上传

点击文件名下载附件