读 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.