提供VB 破解 “猜数字游戏”的原程序算法, 请进!

哈士奇打嘴仗 2002-04-19 12:09:12
Option Explicit
Const Arrmax = 5039
Private gArr() As Long
Private currArr_Len As Long '当前的数组长度

Private Sub Form_Load()
Dim i As Long
For i = 0 To 3
cboA.AddItem i
cboB.AddItem i
Next
Me.Show
Call Arr_inti
End Sub

Private Sub Arr_inti() '获得5040个可能结果
Dim i, Counter As Long
ReDim gArr(0)
ReDim gArr(Arrmax)

Counter = 0
currArr_Len = Arrmax

For i = 0 To 9999
If Avild(i) Then
gArr(i - Counter) = i
Else
Counter = Counter + 1
End If
Next

lstHistory.Clear
cboLast.Clear
txtInput.Text = ""
End Sub


Private Sub cmdAnswer_Click() '计算 剩余多少个可能的结果
Dim i, j As Long
Dim Counter As Long '统计不符合的数

If Avild2() = False Then Exit Sub
Counter = 0
'计算
For i = 0 To currArr_Len
If bComp(gArr(i), Val(txtInput.Text), Val(cboA.Text), Val(cboB.Text)) Then
gArr(i - Counter) = gArr(i) '移动数组
Else
Counter = Counter + 1
End If
Next

'预览结果
currArr_Len = currArr_Len - Counter
lstHistory.AddItem " " & txtInput & " " & cboA & "A " & cboB & "B " & currArr_Len + 1
cboLast.Clear

For i = 0 To currArr_Len
If gArr(i) < 1000 Then
cboLast.AddItem "0" & Trim(Str(gArr(i)))
Else
cboLast.AddItem Trim(Str(gArr(i)))
End If
Next
End Sub

'比较两个数是否符合 m_A , m_B ;符合 TRUE
Private Function bComp(num1 As Long, num2 As Long, m_A As Long, m_B As Long) As Boolean
Dim Lab1(3), Lab2(3) As Long '输入数组再比较
Dim counterA, counterB As Long
Dim i, j, t As Long

counterA = 0
counterB = 0
bComp = False
Lab1(3) = (num1 + 10000) Mod 10
Lab1(2) = (num1 + 10000) \ 10 Mod 10
Lab1(1) = (num1 + 10000) \ 100 Mod 10
Lab1(0) = (num1 + 10000) \ 1000 Mod 10

Lab2(3) = (num2 + 10000) Mod 10
Lab2(2) = (num2 + 10000) \ 10 Mod 10
Lab2(1) = (num2 + 10000) \ 100 Mod 10
Lab2(0) = (num2 + 10000) \ 1000 Mod 10

'以下两个for 本来可以放在一起的 为了优化分开来做,并加入了 退出判断
For i = 0 To 3
If Lab1(i) = Lab2(i) Then counterA = counterA + 1
For j = 0 To 3
If i <> j And Lab1(i) = Lab2(j) Then counterB = counterB + 1
Next
Next

If counterA = m_A And counterB = m_B Then bComp = True

End Function

Private Function Avild(ByVal Num As Long) As Boolean '没有重复数 True .否则 False 例:Avild(1223) = false
Dim i, j As Long
Dim Lab(3) As Long

Avild = True
Lab(3) = (Num + 10000) Mod 10
Lab(2) = (Num + 10000) \ 10 Mod 10
Lab(1) = (Num + 10000) \ 100 Mod 10
Lab(0) = (Num + 10000) \ 1000 Mod 10

For i = 0 To 3
For j = i + 1 To 3
If Lab(i) = Lab(j) Then
Avild = False
Exit For
End If
Next
Next

End Function

Private Function Avild2() As Boolean '判断数字的输入

End Function
...全文
255 9 打赏 收藏 转发到动态 举报
写回复
用AI写文章
9 条回复
切换为时间正序
请发表友善的回复…
发表回复
holiwood 2010-05-27
  • 打赏
  • 举报
回复
支持一下。
哈士奇打嘴仗 2002-04-29
  • 打赏
  • 举报
回复

把剩下的数字都看成正确答案;
因为正确答案与你猜的数(填入猜数字游戏的数)符合 xA xB 的关系,
所以可能成为正确答案也要符合符合 xA xB 的关系。
于是把把剩下的数字一个一个地与你猜的数(填入猜数字游戏的数)比较,符合 xA xB 的关系的留下来,不符合的去掉。那么多次以后就只剩一个了,它就是正确答案。
OK!


sippey 2002-04-28
  • 打赏
  • 举报
回复
这种算法很多的
哈士奇打嘴仗 2002-04-26
  • 打赏
  • 举报
回复
`````````````````````````````````````````````````````````````````````'
'`````````````````````````````````````````````````````````````````````'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

Option Explicit
Const Arrmax = 5039
Private gArr() As Long
Private currArr_Len As Long '当前的数组长度

Private Sub Form_Load()
Dim i As Long
For i = 0 To 3
cboA.AddItem i
cboB.AddItem i
Next
Me.Show
Call Arr_inti
End Sub


Private Sub Arr_inti() '获得5040个可能结果
Dim i, Counter As Long
ReDim gArr(0)
ReDim gArr(Arrmax)

Counter = 0
currArr_Len = Arrmax

For i = 0 To 9999
If Avild(i) Then
gArr(i - Counter) = i
Else
Counter = Counter + 1
End If
Next

lstHistory.Clear
cboLast.Clear
txtInput.Text = ""
End Sub


Private Sub cmdAnswer_Click() '计算 剩余多少个可能的结果
Dim i, j As Long
Dim Counter As Long '统计不符合的数

If Avild2() = False Then Exit Sub
Counter = 0
'计算
For i = 0 To currArr_Len
If bComp(gArr(i), Val(txtInput.Text), Val(cboA.Text), Val(cboB.Text)) Then
gArr(i - Counter) = gArr(i) '移动数组
Else
Counter = Counter + 1
End If
Next

'预览结果
currArr_Len = currArr_Len - Counter
lstHistory.AddItem " " & txtInput & " " & cboA & "A " & cboB & "B " & currArr_Len + 1
cboLast.Clear

For i = 0 To currArr_Len
If gArr(i) < 1000 Then
cboLast.AddItem "0" & Trim(Str(gArr(i)))
Else
cboLast.AddItem Trim(Str(gArr(i)))
End If
Next
End Sub

'比较两个数是否符合 m_A , m_B ;符合 TRUE
Private Function bComp(num1 As Long, num2 As Long, m_A As Long, m_B As Long) As Boolean
Dim Lab1(3), Lab2(3) As Long '输入数组再比较
Dim counterA, counterB As Long
Dim i, j, t As Long

counterA = 0
counterB = 0
bComp = False
Lab1(3) = (num1 + 10000) Mod 10
Lab1(2) = (num1 + 10000) \ 10 Mod 10
Lab1(1) = (num1 + 10000) \ 100 Mod 10
Lab1(0) = (num1 + 10000) \ 1000 Mod 10

Lab2(3) = (num2 + 10000) Mod 10
Lab2(2) = (num2 + 10000) \ 10 Mod 10
Lab2(1) = (num2 + 10000) \ 100 Mod 10
Lab2(0) = (num2 + 10000) \ 1000 Mod 10

'以下两个for 本来可以放在一起的 为了优化分开来做,并加入了 退出判断
For i = 0 To 3
If Lab1(i) = Lab2(i) Then counterA = counterA + 1
Next
If counterA <> m_A Then Exit Function

For i = 0 To 3
For j = 0 To 3
If i <> j And Lab1(i) = Lab2(j) Then counterB = counterB + 1
If counterB > m_B Then Exit Function
Next
Next

If counterA = m_A And counterB = m_B Then bComp = True

End Function

Private Function Avild(ByVal Num As Long) As Boolean '没有重复数 True .否则 False 例:Avild(1223) = false
Dim i, j As Long
Dim Lab(3) As Long

Avild = True
Lab(3) = (Num + 10000) Mod 10
Lab(2) = (Num + 10000) \ 10 Mod 10
Lab(1) = (Num + 10000) \ 100 Mod 10
Lab(0) = (Num + 10000) \ 1000 Mod 10

For i = 0 To 3
For j = i + 1 To 3
If Lab(i) = Lab(j) Then
Avild = False
Exit For
End If
Next
Next

End Function

Private Function Avild2() As Boolean '判断输入
If Avild(Val(txtInput.Text)) = False Then
MsgBox "请正确输入数字", vbInformation
txtInput.SetFocus
Exit Function
End If
If cboA > 4 Or cboA < 0 Or cboB > 4 Or cboB < 0 Or (Val(cboA.Text) + Val(cboB.Text)) > 4 Then
MsgBox "请正确输入比较值 A B ", vbInformation
cboA.SetFocus
Exit Function
End If
Avild2 = True
End Function


Private Sub cboLast_Click()
txtInput = Trim(cboLast.Text)
SendKeys "{TAB}"
SendKeys "{END}"
End Sub

Private Sub txtInput_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 Then
If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
KeyAscii = 0
End If
End If
End Sub

Private Sub cmdNewGame_Click()
Call Arr_inti
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cboA_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 Then
If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
KeyAscii = 0
End If
End If
End Sub
Private Sub cboB_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 Then
If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
KeyAscii = 0
End If
End If
End Sub
Private Sub cboLast_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 Then
If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
KeyAscii = 0
End If
End If
End Sub

哈士奇打嘴仗 2002-04-26
  • 打赏
  • 举报
回复

Begin VB.Label Label3
BackColor = &H0080C0FF&
Caption = "A"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 255
Left = 2160
TabIndex = 12
Top = 840
Width = 255
End
Begin VB.Label Label2
BackColor = &H0080C0FF&
Caption = "Return:"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 255
Left = 240
TabIndex = 11
Top = 840
Width = 1095
End
End
Begin VB.Frame Frame1
BackColor = &H0080C0FF&
Caption = "Answer List:"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 3015
Left = 240
TabIndex = 6
Top = 1680
Width = 5655
Begin VB.ListBox lstHistory
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000040&
Height = 1950
Left = 240
TabIndex = 7
Top = 840
Width = 3495
End
Begin VB.ComboBox cboLast
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000040&
Height = 2490
Left = 4080
Style = 1 'Simple Combo
TabIndex = 8
Top = 360
Width = 1335
End
Begin VB.Label Label5
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
Caption = "History: Bequeath:"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 375
Left = 240
TabIndex = 14
Top = 360
Width = 3495
End
End
Begin VB.CommandButton cmdExit
BackColor = &H0080C0FF&
Caption = "Exit"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 4320
MaskColor = &H000000FF&
Style = 1 'Graphical
TabIndex = 5
Top = 1200
Width = 1455
End
Begin VB.CommandButton cmdAnswer
BackColor = &H0080C0FF&
Caption = "Compute"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 4320
MaskColor = &H000000FF&
Style = 1 'Graphical
TabIndex = 3
Top = 240
Width = 1455
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
'`````````````````````````````````````````````````````````````````````'
'````````````````重写程序记事 2002-4-13 `````````````````````````'
'`````````````````````````````````````````````````````````````````````'
'````````````````与上一版本不同的是: ````````````````````````````````'
'``````````````````不再使用数据库;```````````````````````````````````'
'````````````````用移动数组的方法,程序清晰明了执行效率更高。``````````'
'````````````````发觉自己编程水平日渐提高:-)````````````````````````'
'````````````````发觉编程真的这么简单`````````````````````````````````'
'`````````````````````````````````````````````````````````````````````'
'````````````````略使用了些计算方法,相信聪明的读者都能看懂````````````'
'`````````````````(其实真正起作用的也就3个函数)`````````````````````'
'````````````````编程真的就这么简单!`````````````````````````````````'
'
哈士奇打嘴仗 2002-04-26
  • 打赏
  • 举报
回复
’全部代码:(你自己编译吧)

VERSION 5.00
Begin VB.Form frmMain
BackColor = &H0080C0FF&
Caption = "Un_Guess"
ClientHeight = 4920
ClientLeft = 4995
ClientTop = 3360
ClientWidth = 6045
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4920
ScaleWidth = 6045
Begin VB.CommandButton cmdNewGame
BackColor = &H0080C0FF&
Caption = "Replay"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 4320
MaskColor = &H000000FF&
Style = 1 'Graphical
TabIndex = 4
Top = 720
UseMaskColor = -1 'True
Width = 1455
End
Begin VB.Frame Frame2
BackColor = &H0080C0FF&
Caption = "Game Feedback:"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 1455
Left = 240
TabIndex = 9
Top = 120
Width = 3735
Begin VB.ComboBox cboB
BeginProperty DataFormat
Type = 1
Format = "0"
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 1
EndProperty
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000040&
Height = 330
ItemData = "frmMain.frx":0442
Left = 2520
List = "frmMain.frx":0444
TabIndex = 2
Text = "0"
Top = 840
Width = 735
End
Begin VB.ComboBox cboA
BeginProperty DataFormat
Type = 1
Format = "0"
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 1
EndProperty
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000040&
Height = 330
Left = 1320
TabIndex = 1
Text = "0"
Top = 840
Width = 735
End
Begin VB.TextBox txtInput
BeginProperty DataFormat
Type = 1
Format = "0"
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 1
EndProperty
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000040&
Height = 375
Left = 1320
MaxLength = 4
TabIndex = 0
Top = 360
Width = 1935
End
Begin VB.Label Label1
BackColor = &H0080C0FF&
Caption = "Input:"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 255
Left = 240
TabIndex = 10
Top = 360
Width = 1095
End
Begin VB.Label Label4
BackColor = &H0080C0FF&
Caption = "B"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00004080&
Height = 255
Left = 3360
TabIndex = 13
Top = 840
Width = 255
End
hillmanweb 2002-04-20
  • 打赏
  • 举报
回复
看了,不懂
哈士奇打嘴仗 2002-04-20
  • 打赏
  • 举报
回复
看看也给分!
哈士奇打嘴仗 2002-04-19
  • 打赏
  • 举报
回复
请教更快更好的解决方法!
谢谢!指点

7,763

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧