『川渡りクイズ』とは、特定のルールのもとで、最短手数でボートを移動させるパズルです。「川渡り」や「ボート」は比喩であり、谷を渡るロープウェーや月までロケットを移動させるパターンもあります。
ルールに則って、すべてのボートを対岸まで運ぶには最低何時間必要でしょうか？
大事なルール：
目的：2人で４艘ボートを対岸へ最短時間で運ぶ。最初は２人の漕ぎ手と４艘のボートは左岸にあります。これをすべて右岸に移動します。
移動時間：
ボートA：1時間
ボートB：2時間
ボートC：4時間
ボートD：8時間
移動ルール：
1艘のボートに1人または2人で乗れる。
2人は常に一緒に行動し、同時に出発・到着する。
別々のボートに乗る場合は、遅い方のボートの速度に合わせる。
左岸と右岸を０と１で表現することにします。
４艘のボートがあり、２人の漕ぎ手がいます。
この６つが、左岸(0)にあるか右岸(1)にあるかを次のように表現します。
スタート時はすべてが左岸にあるので、(００００００) と表現できます。
例えば、次の状態は（０１０１１１）と表現できます。
この状態は２進数で表現できるので、そこを利用します。
① VBAのModule1に次のコードを記載します。
Option Explicit
' 「漕ぎ手＋ボート」の数
Const F = 6
' 漕ぎ手Ａ、Ｂ、ボート１～４
Const PLA = 1, PLB = 2 _
, RK1 = 3, RK2 = 4, RK3 = 5, RK4 = 6
' ボート１～４の片道日数
Const RK1_T = 1, RK2_T = 2 _
, RK3_T = 4, RK4_T = 8
' 連想配列を表わす文字列
Const SD As String = "Scripting.Dictionary"
' -------------------------------------------
' * 十進法を二進法に変換
' * ※ワークシート関数DEC2BIN()を利用
' -------------------------------------------
Function wsf_dec2Bin(i, s) As Integer()
Dim ret() As Integer
ReDim ret(s) As Integer
Dim d As String
d = WorksheetFunction.dec2Bin(i, s)
Dim lp: For lp = 1 To s
ret(s - lp + 1) = Mid(d, lp, 1)
Next lp
wsf_dec2Bin = ret
End Function
' -------------------------------------------
' * ボート移動時間関数
' -------------------------------------------
Function getRocketTime(no) As Integer
If no = RK1 Then getRocketTime = RK1_T
If no = RK2 Then getRocketTime = RK2_T
If no = RK3 Then getRocketTime = RK3_T
If no = RK4 Then getRocketTime = RK4_T
End Function
' -------------------------------------------
' * 状態作成
' -------------------------------------------
Function mkState(a, st()) As Object
Dim stCnt As Integer
Dim h As Object: Set h = CreateObject(SD)
'a個の状態を一つずつ検証する
Dim lp1: For lp1 = 0 To a - 1
Dim v '多目的Variant変数
v = wsf_dec2Bin(lp1, F) '二進法変換
If v(PLA) <> v(PLB) Then
'漕ぎ手Ａ、Ｂは同じ位置に居ること
ElseIf lp1 = 3 Or lp1 = 60 Then
'漕ぎ手とボートが別々は有り得ない
' 3⇒(000011), 6⇒(111100)
Else
stCnt = stCnt + 1
ReDim Preserve st(stCnt)
st(stCnt) = lp1
'番地対応配列を作成
h.Add st(stCnt), stCnt
End If
Next lp1
Set mkState = h
End Function
' -------------------------------------------
' * 状態遷移の可否判別
' * a:遷移前/ b:遷移後 (十進法の数字)
' -------------------------------------------
Function chkMv(a, b) As Integer
Dim cnt As Integer '移動件数調査変数
Dim d1, d2 '漕ぎ手の移動方向を示す変数
Dim an1, an2 '二進法変結果を受ける変数
an1 = wsf_dec2Bin(a, F) '二進法変換
an2 = wsf_dec2Bin(b, F) ' 〃
' [条件1] 二人の漕ぎ手は一心同体
If an1(PLA) <> an1(PLB) _
Or an2(PLA) <> an2(PLB) _
Or an1(PLA) = an2(PLA) Then
chkMv = 0: Exit Function '遷移NG
Else
'移動方向を記録
d1 = an1(PLA): d2 = an2(PLA)
End If
' [条件2] ボートの移動台数は１、２台
' 移動方向は漕ぎ手と同じであること
Dim lp: For lp = RK1 To RK4
If an1(lp) = d1 _
And an2(lp) = d2 Then
cnt = cnt + 1
chkMv = getRocketTime(lp)
ElseIf an1(lp) = d2 _
And an2(lp) = d1 Then
chkMv = 0: Exit Function '遷移NG
End If
Next lp
'移動台数が０もしくは３～４台なら遷移NG
If cnt = 0 Or cnt >= 3 Then chkMv = 0
End Function
' -------------------------------------------
' * 状態遷移関数
' -------------------------------------------
Function getMvT(chkS, prc, st) As Integer
'遷移記録の数を調べる。
Dim prcCnt: prcCnt = UBound(prc)
'遷移したことのある状態か調べるフラグ
Dim eFlg: eFlg = False
Dim lp1: For lp1 = chkS To UBound(st)
' 移動可能か調べる。
Dim jdg As Integer
jdg = chkMv(prc(prcCnt), st(lp1))
If jdg > 0 Then
' 遷移した状態を繰り返さない。
' 過去の記録を頼りに判別する。
eFlg = False
Dim lp2: For lp2 = 0 To prcCnt
If st(lp1) = prc(lp2) Then
eFlg = True
Exit For
End If
Next lp2
' 遷移記録にない状態なら遷移する。
If eFlg = False Then
'遷移する。
prcCnt = prcCnt + 1
ReDim Preserve prc(prcCnt)
prc(prcCnt) = st(lp1)
getMvT = jdg
chkS = 1
Exit For
End If
End If
Next lp1
End Function
' -------------------------------------------
' * パズル解析のメイン
' -------------------------------------------
Sub main()
Dim lp1, lp2 'ループカウンタ
'最終結果を格納する配列
Dim rslt As Object
Set rslt = CreateObject(SD)
Dim mintrm: mintrm = 99 '最短時間変数
Dim prc(): ReDim prc(0) '遷移記録配列
Dim prcCnt '遷移記録配列サイズ
Dim trm '経過時間記録変数
'遷移可能な状態を作成する
Dim st()
Dim hs As Object
Set hs = mkState(2 ^ F, st)
'状態を遷移させるさせる際の検証開始位置
Dim sPos: sPos = 1
'状態を次から次へと遷移させる。
Do While (True)
'遷移可能な状態を見付ける。
Dim jdg As Integer
jdg = getMvT( _
sPos _
, prc _
, st)
'移動時間を更新する。
trm = trm + jdg
'遷移記録の配列サイズを調べる。
prcCnt = UBound(prc)
'遷移記録が空なら処理を終了する。
If prcCnt = 0 Then Exit Do
'登場人物の全てが月に移動した状態に
'なっていないか調べる。
If prc(prcCnt) = 2 ^ F - 1 Then
'所要時間が最短記録であれば採用する。
If mintrm > trm Then
mintrm = trm
rslt.RemoveAll
End If
If mintrm = trm Then
rslt.Add rslt.Count, prc
End If
'一つ前の状態に戻して検証を続ける。
Call rv1State(prc, trm, hs, sPos)
prcCnt = prcCnt - 1
ElseIf (prc(prcCnt) <> 2 ^ F - 1 _
And jdg = 0) _
Or mintrm < trm Then
'一つ前の状態に戻して検証を続ける。
Call rv1State(prc, trm, hs, sPos)
prcCnt = prcCnt - 1
End If
Loop
' 処理の終了を表示する。
For lp1 = 0 To rslt.Count - 1
With Range("A1")
.Offset(lp1, 0).Value = mintrm & "days"
.Offset(lp1, 1).Value = 0
prc = rslt.Item(lp1)
For lp2 = 1 To UBound(prc)
.Offset(lp1, lp2 + 1).Value _
= prc(lp2)
Next lp2
End With
Next lp1
End Sub
' -------------------------------------------
' * 状態を一つ戻す
' -------------------------------------------
Sub rv1State(prc(), trm, hs, sPos)
Dim prcCnt: prcCnt = UBound(prc)
'所要時間を一つ前のものに戻す。
trm = trm - chkMv( _
prc(prcCnt - 1) _
, prc(prcCnt))
'検証開始位置を一つ後ろにずらす。
sPos = hs.Item(prc(prcCnt)) + 1
'遷移記録を一つ前のものに戻す。
ReDim Preserve prc(prcCnt - 1)
prcCnt = prcCnt - 1
End Sub
② Sheet1を開いた状態で「main()」を動かしてみましょう。
2通りの答えが得られます。
15時間が最短です！
答えは二通りありますが、そのうちの一つを紹介します。
コメントを残す