用 VB.NET 实现的非确定性计算例子
读 SICP 时，一直对非确定性计算比较感兴趣，今天终于有时间做了一个例子。发现用自动回溯的思想是可以很简单的实现的，呵呵。这个解法的代码还不完备，有很多缺陷，但是基本上可以说明问题了。
所谓的非确定性计算的典型例子是“爱因斯坦谜题”，比如这个：
贝克、库伯、弗莱舍、米勒和斯麦尔住在一个五层公寓楼的不同层，贝克不住在顶层，库伯不住在底层，弗莱舍不住在顶层
也不住在底层。米勒住的比库伯高，斯麦尔不住在弗莱舍相邻的层，弗莱舍不住在库伯相邻的层。请问他们各住在哪层？
(SICP Page 290).
(原书题目叙述有误：“米勒住的比库伯高一层” 应该是 “米勒住的比库伯高“）。
（注：开发环境 Visual Studio 2010）
核心实现：
Public Class NonDeterministicEngine
Private _paramDict As New List(Of Tuple(Of String, IEnumerator))
'Private _predicateDict As New List(Of Tuple(Of Func(Of Object, Boolean), IEnumerable(Of String)))
Private _predicateDict As New List(Of Tuple(Of Object, IList(Of String)))
Public Sub AddParam(ByVal name As String, ByVal values As IEnumerable)
_paramDict.Add(New Tuple(Of String, IEnumerator)(name, values.GetEnumerator()))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(1, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(2, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(3, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(4, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(5, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(6, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Object, Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(7, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Public Sub AddRequire(ByVal predicate As Func(Of Object, Object, Object, Object, Object, Object, Object, Object, Boolean), ByVal paramNames As IList(Of String))
CheckParamCount(8, paramNames)
_predicateDict.Add(New Tuple(Of Object, IList(Of String))(predicate, paramNames))
End Sub
Sub CheckParamCount(ByVal count As Integer, ByVal paramNames As IList(Of String))
If paramNames.Count <> count Then
Throw New Exception("Parameter count does not match.")
End If
End Sub
Public Property IterationOver As Boolean
Private _firstTime As Boolean = True
Public ReadOnly Property Current As Dictionary(Of String, Object)
Get
If IterationOver Then
Return Nothing
Else
Dim _nextResult = New Dictionary(Of String, Object)
For Each item In _paramDict
Dim iter = item.Item2
_nextResult.Add(item.Item1, iter.Current)
Next
Return _nextResult
End If
End Get
End Property
Function MoveNext() As Boolean
If IterationOver Then
Return False
End If
If _firstTime Then
For Each item In _paramDict
Dim iter = item.Item2
iter.MoveNext()
Next
_firstTime = False
Return True
Else
Dim canMoveNext = False
Dim iterIndex = _paramDict.Count - 1
canMoveNext = _paramDict(iterIndex).Item2.MoveNext
If canMoveNext Then
Return True
End If
Do While Not canMoveNext
iterIndex = iterIndex - 1
If iterIndex = -1 Then
Return False
IterationOver = True
End If
canMoveNext = _paramDict(iterIndex).Item2.MoveNext
If canMoveNext Then
For i = iterIndex + 1 To _paramDict.Count - 1
Dim iter = _paramDict(i).Item2
iter.Reset()
iter.MoveNext()
Next
Return True
End If
Loop
End If
End Function
Function GetNextResult() As Dictionary(Of String, Object)
While MoveNext()
Dim result = Current
If Satisfy(result) Then
Return result
End If
End While
Return Nothing
End Function
Function Satisfy(ByVal result As Dictionary(Of String, Object)) As Boolean
For Each item In _predicateDict
Dim pred = item.Item1
Select Case item.Item2.Count
Case 1
Dim p1 = DirectCast(pred, Func(Of Object, Boolean))
Dim v1 = result(item.Item2(0))
If Not p1(v1) Then
Return False
End If
Case 2
Dim p2 = DirectCast(pred, Func(Of Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
If Not p2(v1, v2) Then
Return False
End If
Case 3
Dim p3 = DirectCast(pred, Func(Of Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
If Not p3(v1, v2, v3) Then
Return False
End If
Case 4
Dim p4 = DirectCast(pred, Func(Of Object, Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
Dim v4 = result(item.Item2(3))
If Not p4(v1, v2, v3, v4) Then
Return False
End If
Case 5
Dim p5 = DirectCast(pred, Func(Of Object, Object, Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
Dim v4 = result(item.Item2(3))
Dim v5 = result(item.Item2(4))
If Not p5(v1, v2, v3, v4, v5) Then
Return False
End If
Case 6
Dim p6 = DirectCast(pred, Func(Of Object, Object, Object, Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
Dim v4 = result(item.Item2(3))
Dim v5 = result(item.Item2(4))
Dim v6 = result(item.Item2(5))
If Not p6(v1, v2, v3, v4, v5, v6) Then
Return False
End If
Case 7
Dim p7 = DirectCast(pred, Func(Of Object, Object, Object, Object, Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
Dim v4 = result(item.Item2(3))
Dim v5 = result(item.Item2(4))
Dim v6 = result(item.Item2(5))
Dim v7 = result(item.Item2(6))
If Not p7(v1, v2, v3, v4, v5, v6, v7) Then
Return False
End If
Case 8
Dim p8 = DirectCast(pred, Func(Of Object, Object, Object, Object, Object, Object, Object, Object, Boolean))
Dim v1 = result(item.Item2(0))
Dim v2 = result(item.Item2(1))
Dim v3 = result(item.Item2(2))
Dim v4 = result(item.Item2(3))
Dim v5 = result(item.Item2(4))
Dim v6 = result(item.Item2(5))
Dim v7 = result(item.Item2(6))
Dim v8 = result(item.Item2(7))
If Not p8(v1, v2, v3, v4, v5, v6, v7, v8) Then
Return False
End If
Case Else
Throw New NotSupportedException
End Select
Next
Return True
End Function
End Class
下面是测试代码：
（更新：增加了八皇后问题的解法，能求出所有92个解）
Module Module1
Sub Main()
Test1()
Console.WriteLine("====================================================")
Test2()
Console.WriteLine("====================================================")
Test3()
Console.ReadLine()
End Sub
Sub Test1()
Dim engine = New NonDeterministicEngine()
engine.AddParam("a", {1, 2, 3, 4, 5, 6})
engine.AddParam("b", {1, 2, 3, 4, 5, 6, 7, 8, 9, 10})
engine.AddRequire(Function(a) As Boolean
Return a > 2 AndAlso a < 9
End Function, {"a"})
engine.AddRequire(Function(b) As Boolean
Return b > 5 AndAlso b <= 10
End Function, {"b"})
engine.AddRequire(Function(a, b) As Boolean
Return a = b - 1
End Function, {"a", "b"})
Dim result = engine.GetNextResult()
While Not result Is Nothing
Console.WriteLine("a = " & result("a") & ", b = " & result("b"))
result = engine.GetNextResult()
End While
Console.WriteLine("Calculation ended.")
End Sub
Sub Test2()
' 贝克、库伯、弗莱舍、米勒和斯麦尔住在一个五层公寓楼的不同层，贝克不住在顶层，库伯不住在底层，弗莱舍不住在顶层
' 也不住在底层。米勒住的比库伯高，斯麦尔不住在弗莱舍相邻的层，弗莱舍不住在库伯相邻的层。请问他们各住在哪层？
' (SICP Page 290).
' (原书题目叙述有误：“米勒住的比库伯高一层” 应该是 “米勒住的比库伯高“）。
Dim engine = New NonDeterministicEngine()
engine.AddParam("baker", {1, 2, 3, 4, 5})
engine.AddParam("cooper", {1, 2, 3, 4, 5})
engine.AddParam("fletcher", {1, 2, 3, 4, 5})
engine.AddParam("miller", {1, 2, 3, 4, 5})
engine.AddParam("smith", {1, 2, 3, 4, 5})
engine.AddRequire(Function(baker) As Boolean
Return baker <> 5
End Function, {"baker"})
engine.AddRequire(Function(cooper) As Boolean
Return cooper <> 1
End Function, {"cooper"})
engine.AddRequire(Function(fletcher) As Boolean
Return fletcher <> 1 And fletcher <> 5
End Function, {"fletcher"})
engine.AddRequire(Function(miller, cooper) As Boolean
'Return miller = cooper + 1
Return miller > cooper
End Function, {"miller", "cooper"})
engine.AddRequire(Function(smith, fletcher) As Boolean
Return smith <> fletcher + 1 And smith <> fletcher - 1
End Function, {"smith", "fletcher"})
engine.AddRequire(Function(fletcher, cooper) As Boolean
Return fletcher <> cooper + 1 And fletcher <> cooper - 1
End Function, {"fletcher", "cooper"})
engine.AddRequire(Function(a, b, c, d, e) As Boolean
Return a <> b And a <> c And a <> d And a <> e And b <> c And b <> d And b <> e And c <> d And c <> e And d <> e
End Function, {"baker", "cooper", "fletcher", "miller", "smith"})
Dim result = engine.GetNextResult()
While Not result Is Nothing
Console.WriteLine(String.Format("baker: {0}, cooper: {1}, fletcher: {2}, miller: {3}, smith: {4}",
result("baker"),
result("cooper"),
result("fletcher"),
result("miller"),
result("smith")))
result = engine.GetNextResult()
End While
Console.WriteLine("Calculation ended.")
End Sub
Sub Test3()
' 八皇后问题的解法
Dim engine = New NonDeterministicEngine()
' 设 a - h 分别代表第 1 - 8 行上的皇后，则只要对每个皇后求出对应的列号即可。
engine.AddParam("a", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("b", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("c", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("d", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("e", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("f", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("g", {1, 2, 3, 4, 5, 6, 7, 8})
engine.AddParam("h", {1, 2, 3, 4, 5, 6, 7, 8})
' 检查是否在同一个斜线上
Dim NotInTheSameDiagonalLine = Function(cols As IList) As Boolean
For i = 0 To cols.Count - 2
For j = i + 1 To cols.Count - 1
If j - i = Math.Abs(cols(j) - cols(i)) Then
Return False
End If
Next
Next
Return True
End Function
engine.AddRequire(Function(a, b, c, d, e, f, g, h) As Boolean
Return a <> b AndAlso a <> c AndAlso a <> d AndAlso a <> e AndAlso a <> f AndAlso a <> g AndAlso a <> h AndAlso b <> c AndAlso b <> d AndAlso b <> e AndAlso b <> f AndAlso b <> g AndAlso b <> h AndAlso c <> d AndAlso c <> e AndAlso c <> f AndAlso c <> g AndAlso c <> h AndAlso d <> e AndAlso d <> f AndAlso d <> g AndAlso d <> h AndAlso e <> f AndAlso e <> g AndAlso e <> h AndAlso f <> g AndAlso f <> h AndAlso g <> h AndAlso NotInTheSameDiagonalLine({a, b, c, d, e, f, g, h})
End Function,
{"a", "b", "c", "d", "e", "f", "g", "h"})
Dim result = engine.GetNextResult()
While Not result Is Nothing
Console.WriteLine("(1,{0}), (2,{1}), (3,{2}), (4,{3}), (5,{4}), (6,{5}), (7,{6}), (8,{7})",
result("a"),
result("b"),
result("c"),
result("d"),
result("e"),
result("f"),
result("g"),
result("h"))
result = engine.GetNextResult()
End While
Console.WriteLine("Calculation ended.")
End Sub
End Module
输出结果如下：
a = 5, b = 6 a = 6, b = 7 Calculation ended. ==================================================== baker: 3, cooper: 2, fletcher: 4, miller: 5, smith: 1 Calculation ended. ==================================================== (1,1), (2,5), (3,8), (4,6), (5,3), (6,7), (7,2), (8,4) (1,1), (2,6), (3,8), (4,3), (5,7), (6,4), (7,2), (8,5) (1,1), (2,7), (3,4), (4,6), (5,8), (6,2), (7,5), (8,3) (1,1), (2,7), (3,5), (4,8), (5,2), (6,4), (7,6), (8,3) (1,2), (2,4), (3,6), (4,8), (5,3), (6,1), (7,7), (8,5) (1,2), (2,5), (3,7), (4,1), (5,3), (6,8), (7,6), (8,4) (1,2), (2,5), (3,7), (4,4), (5,1), (6,8), (7,6), (8,3) (1,2), (2,6), (3,1), (4,7), (5,4), (6,8), (7,3), (8,5) (1,2), (2,6), (3,8), (4,3), (5,1), (6,4), (7,7), (8,5) (1,2), (2,7), (3,3), (4,6), (5,8), (6,5), (7,1), (8,4) (1,2), (2,7), (3,5), (4,8), (5,1), (6,4), (7,6), (8,3) (1,2), (2,8), (3,6), (4,1), (5,3), (6,5), (7,7), (8,4) (1,3), (2,1), (3,7), (4,5), (5,8), (6,2), (7,4), (8,6) (1,3), (2,5), (3,2), (4,8), (5,1), (6,7), (7,4), (8,6) (1,3), (2,5), (3,2), (4,8), (5,6), (6,4), (7,7), (8,1) (1,3), (2,5), (3,7), (4,1), (5,4), (6,2), (7,8), (8,6) (1,3), (2,5), (3,8), (4,4), (5,1), (6,7), (7,2), (8,6) (1,3), (2,6), (3,2), (4,5), (5,8), (6,1), (7,7), (8,4) (1,3), (2,6), (3,2), (4,7), (5,1), (6,4), (7,8), (8,5) (1,3), (2,6), (3,2), (4,7), (5,5), (6,1), (7,8), (8,4) (1,3), (2,6), (3,4), (4,1), (5,8), (6,5), (7,7), (8,2) (1,3), (2,6), (3,4), (4,2), (5,8), (6,5), (7,7), (8,1) (1,3), (2,6), (3,8), (4,1), (5,4), (6,7), (7,5), (8,2) (1,3), (2,6), (3,8), (4,1), (5,5), (6,7), (7,2), (8,4) (1,3), (2,6), (3,8), (4,2), (5,4), (6,1), (7,7), (8,5) (1,3), (2,7), (3,2), (4,8), (5,5), (6,1), (7,4), (8,6) (1,3), (2,7), (3,2), (4,8), (5,6), (6,4), (7,1), (8,5) (1,3), (2,8), (3,4), (4,7), (5,1), (6,6), (7,2), (8,5) (1,4), (2,1), (3,5), (4,8), (5,2), (6,7), (7,3), (8,6) (1,4), (2,1), (3,5), (4,8), (5,6), (6,3), (7,7), (8,2) (1,4), (2,2), (3,5), (4,8), (5,6), (6,1), (7,3), (8,7) (1,4), (2,2), (3,7), (4,3), (5,6), (6,8), (7,1), (8,5) (1,4), (2,2), (3,7), (4,3), (5,6), (6,8), (7,5), (8,1) (1,4), (2,2), (3,7), (4,5), (5,1), (6,8), (7,6), (8,3) (1,4), (2,2), (3,8), (4,5), (5,7), (6,1), (7,3), (8,6) (1,4), (2,2), (3,8), (4,6), (5,1), (6,3), (7,5), (8,7) (1,4), (2,6), (3,1), (4,5), (5,2), (6,8), (7,3), (8,7) (1,4), (2,6), (3,8), (4,2), (5,7), (6,1), (7,3), (8,5) (1,4), (2,6), (3,8), (4,3), (5,1), (6,7), (7,5), (8,2) (1,4), (2,7), (3,1), (4,8), (5,5), (6,2), (7,6), (8,3) (1,4), (2,7), (3,3), (4,8), (5,2), (6,5), (7,1), (8,6) (1,4), (2,7), (3,5), (4,2), (5,6), (6,1), (7,3), (8,8) (1,4), (2,7), (3,5), (4,3), (5,1), (6,6), (7,8), (8,2) (1,4), (2,8), (3,1), (4,3), (5,6), (6,2), (7,7), (8,5) (1,4), (2,8), (3,1), (4,5), (5,7), (6,2), (7,6), (8,3) (1,4), (2,8), (3,5), (4,3), (5,1), (6,7), (7,2), (8,6) (1,5), (2,1), (3,4), (4,6), (5,8), (6,2), (7,7), (8,3) (1,5), (2,1), (3,8), (4,4), (5,2), (6,7), (7,3), (8,6) (1,5), (2,1), (3,8), (4,6), (5,3), (6,7), (7,2), (8,4) (1,5), (2,2), (3,4), (4,6), (5,8), (6,3), (7,1), (8,7) (1,5), (2,2), (3,4), (4,7), (5,3), (6,8), (7,6), (8,1) (1,5), (2,2), (3,6), (4,1), (5,7), (6,4), (7,8), (8,3) (1,5), (2,2), (3,8), (4,1), (5,4), (6,7), (7,3), (8,6) (1,5), (2,3), (3,1), (4,6), (5,8), (6,2), (7,4), (8,7) (1,5), (2,3), (3,1), (4,7), (5,2), (6,8), (7,6), (8,4) (1,5), (2,3), (3,8), (4,4), (5,7), (6,1), (7,6), (8,2) (1,5), (2,7), (3,1), (4,3), (5,8), (6,6), (7,4), (8,2) (1,5), (2,7), (3,1), (4,4), (5,2), (6,8), (7,6), (8,3) (1,5), (2,7), (3,2), (4,4), (5,8), (6,1), (7,3), (8,6) (1,5), (2,7), (3,2), (4,6), (5,3), (6,1), (7,4), (8,8) (1,5), (2,7), (3,2), (4,6), (5,3), (6,1), (7,8), (8,4) (1,5), (2,7), (3,4), (4,1), (5,3), (6,8), (7,6), (8,2) (1,5), (2,8), (3,4), (4,1), (5,3), (6,6), (7,2), (8,7) (1,5), (2,8), (3,4), (4,1), (5,7), (6,2), (7,6), (8,3) (1,6), (2,1), (3,5), (4,2), (5,8), (6,3), (7,7), (8,4) (1,6), (2,2), (3,7), (4,1), (5,3), (6,5), (7,8), (8,4) (1,6), (2,2), (3,7), (4,1), (5,4), (6,8), (7,5), (8,3) (1,6), (2,3), (3,1), (4,7), (5,5), (6,8), (7,2), (8,4) (1,6), (2,3), (3,1), (4,8), (5,4), (6,2), (7,7), (8,5) (1,6), (2,3), (3,1), (4,8), (5,5), (6,2), (7,4), (8,7) (1,6), (2,3), (3,5), (4,7), (5,1), (6,4), (7,2), (8,8) (1,6), (2,3), (3,5), (4,8), (5,1), (6,4), (7,2), (8,7) (1,6), (2,3), (3,7), (4,2), (5,4), (6,8), (7,1), (8,5) (1,6), (2,3), (3,7), (4,2), (5,8), (6,5), (7,1), (8,4) (1,6), (2,3), (3,7), (4,4), (5,1), (6,8), (7,2), (8,5) (1,6), (2,4), (3,1), (4,5), (5,8), (6,2), (7,7), (8,3) (1,6), (2,4), (3,2), (4,8), (5,5), (6,7), (7,1), (8,3) (1,6), (2,4), (3,7), (4,1), (5,3), (6,5), (7,2), (8,8) (1,6), (2,4), (3,7), (4,1), (5,8), (6,2), (7,5), (8,3) (1,6), (2,8), (3,2), (4,4), (5,1), (6,7), (7,5), (8,3) (1,7), (2,1), (3,3), (4,8), (5,6), (6,4), (7,2), (8,5) (1,7), (2,2), (3,4), (4,1), (5,8), (6,5), (7,3), (8,6) (1,7), (2,2), (3,6), (4,3), (5,1), (6,4), (7,8), (8,5) (1,7), (2,3), (3,1), (4,6), (5,8), (6,5), (7,2), (8,4) (1,7), (2,3), (3,8), (4,2), (5,5), (6,1), (7,6), (8,4) (1,7), (2,4), (3,2), (4,5), (5,8), (6,1), (7,3), (8,6) (1,7), (2,4), (3,2), (4,8), (5,6), (6,1), (7,3), (8,5) (1,7), (2,5), (3,3), (4,1), (5,6), (6,8), (7,2), (8,4) (1,8), (2,2), (3,4), (4,1), (5,7), (6,5), (7,3), (8,6) (1,8), (2,2), (3,5), (4,3), (5,1), (6,7), (7,4), (8,6) (1,8), (2,3), (3,1), (4,6), (5,2), (6,5), (7,7), (8,4) (1,8), (2,4), (3,1), (4,3), (5,6), (6,2), (7,7), (8,5) Calculation ended.
