ツイッター出題回答
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く

ExcelマクロVBAとエクセル関数についての私的雑感
公開日:2020-08-24 最終更新日:2020-12-20

VBAで「3Lと5Lのバケツで4Lの水を作る」を解く


マクロ VBA 3Lと5Lのバケツで4Lの水を作る

ツイッターでVBAのお題として出したものです。


昔からよくある問題です。
「3Lと5Lのバケツで4Lの水を作る」
これをVBAを使って自動で求めてみようという事です。

VBA問題:ツイートの記録

【VBA問題】
「3Lと5Lのバケツで4Lの水を作る」
・2つの容器サイズは変えられるように引数で受け取る
 (3,5,4、3,7,5)
・最短手順を出力(複数ある場合は複数)
※ルール
容器は、
・満タンにする
・空にする
・相手が満タンになるまで注ぐ
以上の操作のみ、
この最短手順を示してください。

マクロ VBA 3Lと5Lのバケツで4Lの水を作る
https://twitter.com/yamaoka_ss/status/1297260976333443073


応募お待ちしてます。
難しいですかね、難しいよね、でも頑張ればできますよね、頑張ってやってみましょう。
ひとまず最短手順というのは後回しでも良いです。
バケツは2つ、それぞれ出来る動作は3つ、つまり6通り。
これを繰り返して、どちらかのバケツが4Lになれば良いだけです。

マクロ VBA 3Lと5Lのバケツで4Lの水を作る
https://twitter.com/yamaoka_ss/status/1297380147566264322

応募が無いのでアンケートを取ってみました

応募は来ますかね。
確かに結構難しいですよね。
では、聞いて見ましょう
このアンケートの締め切りは、今夜22時

マクロ VBA 3Lと5Lのバケツで4Lの水を作る
https://twitter.com/yamaoka_ss/status/1297419663551262720


何名かは応募するから待ってとありましたが、過半数の人から「解説しろ」と言われてしまいました。
ということで、以下のように連続ツイートで、解き方考え方、そしてVBA実装方法について説明しました。

回答をいただきました。

マクロ VBA 3Lと5Lのバケツで4Lの水を作る
マクロ VBA 3Lと5Lのバケツで4Lの水を作る
マクロ VBA 3Lと5Lのバケツで4Lの水を作る

解き方考え方、そしてVBA実装方法:連ツイによる説明

説明ツイートの原文は、問題を出したツイートから辿ってください。
以下は、ほぼ原文のままですが一部補正しています。


では説明を考えながら、ゆっくりとツイートしていきます。
まず、このような問題は恐らく相応のアルゴリズムがあり、そのような勉強をしている人は○○探索だろ、みたいなものがるのだろうと思います。
残念ながら私はそのような勉強をしたことが無い、、、
(というか勉強全般しいてないw)


したがって、もっと効率の良い方法や実装方法もあるだろうと思います。
今回に限らず、ゲーム作る時はほぼ毎回そうなのですが、頭の中で考えて持っている知識の範囲で解く方法を考えています。ただし、もちろんその過程で困った時は一部はググって解決します。


今回のVBAも完全独自の今回0から考えたものなので、非効率な部分があるのはご容赦ください。
教科書的な解法を知りたい人は、書籍を探して読んでください。
ただし、大筋では似たようなことをしているのではないかと思います。


2つのバケツがあり、それぞれに行える動作は3つ
・満タンにする
・空にする
・相手の容器に移す
つまり、ある場面での操作は6通り存在します。
これを全パターン試していたら、とても膨大な数になってしまいます。
1→6→6^2→6^3→・・・
数回の手順で数万に達してしまいます。


数が多いだけならPCに委ねれば何とかなるかもしれません。
しかし、無限に繰り返されるパターンが出てくるとPCでもどうしようもなくなってしまいます。
そこで、大抵のゲームには無限に繰り返されることをどこかで制限するルールが存在します。


将棋なら千日手、囲碁ならコウのようなものです。
今回のバケツの問題も実はこの制限をしっかりかけています。
それは
「最短手順を示してください。」
最後のこの一文になります。
これが無いと、バケツAを満タン→空、これを繰り返すことが意味を持ってしまうので答えが無限に発生してしまいます。


※以下、バケツ2つを、バケツAとバケツBとして表現しています。

この最短手順がとても重要になります。
それは、ある場面での操作の結果が以前の状態と同じ状態になる操作は意味を為さないという事です。
例えば、
A3L,B5Lとなった場合、次の操作はA3L,B0LまたはA0L,B5Lにしかなりません。
これは最初の操作でどちらかのバケツを満タンにした状態と同じです。


そして過去の状態と同一になった時点で最短手順ではなくなるので、
それ以降の探索は意味がなくなるので打ち切っても良いという事です。
さらに、3つの操作のうち無効な操作が常に存在します。
Aが満タンの時には、
・Aを満タン
・B→A
少なくともこの2つの操作は無効になります。


バケツAとバケツBの状態によって、行える操作は意外に少ないのです。
決して1→6→6^2とは増えていきません。
ある場面の次の状態は大体2~3通りしか存在しません。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
この2点をしっかりプログラミングすれば良いという事です。


言葉では伝わりづらいと思うので、簡単に図を書きました。
この図では、無効な操作および過去に戻ってしまう操作を消しています。
レベル2の(3,5)は先に説明したように(0,5)(3,0)のどちらかになるのでレベル1に戻ってしまいます。
したがってここで終了となっています。
※太線は答えのルートです。

マクロ VBA 3Lと5Lのバケツで4Lの水を作る


これを見て分かるように、実際に行える操作はとても少ないです。
2つのバケツに3通りの操作と考えると途方もなく感じてしまいますが、実際に操作できる数は極めて少ないです。
ただし人間が頭の中で考えた時はそんなにスムーズにいきません。
過去に存在した状態を全て記憶していられないからです。


人間は多くの事を記憶したり膨大な数をこなすことは苦手です。
しかしコンピューターはそれが得意です。
というか、むしろそれしか出来ないと言っても良いと思いますが、、、
再度書きます。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
これをVBAで書けばよいのです。


では、VBA実装の具体例(今回私が書いたVBA)について、簡単に説明していきます。
まず、「バケツ」クラスを作成しました。
ルールの範囲内に限定したプロパティ・メソッドのみ作成しました。
したがって間違って設定させたくないプロパティは読み取り専用プロパティにしています。


Function Create … コンストラクタとして使用
Property Get Name
Property Get MaxValue
Property Get Value
Function Full
Function Emptied … Emptyは予約語
Function Transfer
Sub Receive … Transferで貰う時
※Name,MaxValue,Valueは読み取り専用、他のメソッドで設定


CreateはMeを返します。
Full,Emptied,Transferの戻り型はBooleanです。
操作が有効な場合True/無効な場合False
つまり3つの操作でFalseが返ってきた場合は無効なので打ち切ります。
これで、
・行える操作をしっかり限定する
これが完成です。


続いて、
・過去と同じになったらそのルートは終了
このためには、状態の保存が必要です。
先に出した以下の図、これをそのまま配列として持ちます。
縦のレベルを1次元配列として作り、その各要素の中に横に展開されている複数状態を配列として入れます。
いわゆるジャグ配列です。

マクロ VBA 3Lと5Lのバケツで4Lの水を作る


ここは手法がいろいろありそうです。
単純な1次元だけで展開し、チェーンのようなものを付けていくと言った方法も使われたりするかもしれません。
今回の場合は「最短手順」がキーとなっているので、縦がそのまま手順回数になるので都合が良かったのでこのようにしてみました。


問題はこの各要素の中にどのような情報を入れるかになります。
答えにたどり着いたとき、ルート(操作手順)が分かるようにしておかなければなりません。
この時にも、実装方法は大きく分かれると思います。
・開始からのルート情報を入れておく
・親を示すポインタを入れておく


今回私は後者のポインタ方式にしました。
VBAのコード量としては、前者の方が短くて済んだ気がします。
この辺りは、試行回数をどの程度で予測するかによるかもしれません。
何よりその時の気分で決めたしまったというのが本当のところです。


ただし親のポインタといっても、親を探しやすいように、親の位置はしっかりわかるように複数情報を入れました。
実際には使っていない情報も含めて配列に格納しています。
親の情報と自身の情報を目いっぱい入れました。
メモリや処理速度を気にするようなものではないことは分っている事でしたので。


配列に入れた情報は以下です。
・自身ユニーク番号
・親のユニーク番号
・親のレベル内での位置
・自身のレベル
・自身のレベル内での位置
・自身の名前
・実行メソッド
・移す場合の相手の名前
・自身の最大容量
・相手の最大容量
・自身の水量
・相手の水量


この配列にいれる多値はクラスにしました。
やはり、こういう時はユーザー定義型は使えないですね。
以上で準備は完了です。
メインとなるプロシージャーで、2つのバケツに対して3通りのメソッドを答えにたどり着くまで繰り返していきます。


最初にレベル0として、両方が空の状態で配列を作成します。
その後は、レベル内(親のレベル)の配列を順次取り出し、
取り出した情報でバケツ2つを再作成して、3つのメソッドをそれぞれに実行します。
有効なメソッドは順次レベル+1の配列に入れていきます。


親のレベル内の配列全ての処理が終了したら答えがあるかを確認し、答えがあったら、ルートを逆に辿って文字列の配列で返します。
答えが無ければ、レベルを+1してループします。
一応、同一レベルに複数解があれば出るはずなのですが、そのような数値の組み合わせがあるのかどうか分かりません。


以上で説明を終わります。長々とお付き合いくださり感謝申し上げます。
この連ツイと共に、VBAソースコードは明日記事として公開する予定でいます。

作成したVBAの全コード

「バケツ」クラス

オブジェクト名:clsBucket

Option Explicit

Private Name_ As String
Private MaxValue_ As Long
Private Value_ As Long

'**********************************************************************
' コンストラクタとして使用:名前と容量はここでのみ設定
'**********************************************************************

Public Function Create(ByVal argName As String, _
            ByVal argMaxValue As Long, _
            ByVal argValue) As clsBucket
  Name_ = argName
  MaxValue_ = argMaxValue
  Value_ = argValue
  Set Create = Me
End Function

'**********************************************************************
' 公開プロパティ:VBA記述を明確にするためにクラス内では使用しない
'**********************************************************************

Public Property Get Name() As String
  Name = Name_
End Property

Public Property Get MaxValue() As Long
  MaxValue = MaxValue_
End Property

Public Property Get Value() As Long
  Value = Value_
End Property

'**********************************************************************
' 公開メソッド:満タン、空にする、相手に移す
'**********************************************************************

Public Function Full() As Boolean
  If Value_ <> 0 Then
    Full = False
  Else
    Value_ = MaxValue_
    Full = True
  End If
End Function

Public Function Emptied() As Boolean
  If Value_ = 0 Then
    Emptied = False
  Else
    Value_ = 0
    Emptied = True
  End If
End Function

Public Function Transfer(ByVal argObj As clsBucket) As Boolean
  Transfer = False
  
  Dim trnsValue As Long
  '相手の空き容量
  trnsValue = argObj.MaxValue - argObj.Value
  If trnsValue = 0 Then
    Transfer = False
  End If
  
  '持っている量しか移せない
  If Value_ = 0 Then
    Exit Function
  End If
  If trnsValue > Value_ Then
    trnsValue = Value_
  End If
  
  Call argObj.Receive(trnsValue)
  Value_ = Value_ - trnsValue
  
  Transfer = True
End Function

Public Sub Receive(ByVal argValue As Long)
  Value_ = Value_ + argValue
End Sub

「配列格納情報」クラス

オブジェクト名:clsManage

Option Explicit

'親の情報
Public ParentNo As Long
Public ParentIndex As Long

'自身の情報
Public No As Long
Public Level As Long
Public IndexInLevel As Long
Public OpeObject As String
Public OpeMethod As String
Public OpeTarget As String

'Aが自身、Bが相手
Public A_MaxValue As Long
Public B_MaxValue As Long
Public A_Value As Long
Public B_Value As Long

標準モジュール

'**********************************************************************
' 結果をイミディエイトに見やすいように出力
'**********************************************************************

Public Sub PrintProcedure(ByVal A As Long, _
             ByVal B As Long, _
             ByVal C As Long)
  Dim ans, v1, v2, cnt
  
  ans = ShortestProcedure(A, B, C)
  Debug.Print vbLf & "■A=" & A & ",B=" & B & " → " & C
  
  If IsEmpty(ans) Then
    Debug.Print "答えを見つけられませんでした。"
    Exit Sub
  End If
  
  cnt = 1
  For Each v1 In ans
    Debug.Print "手順" & cnt
    For Each v2 In v1
      Debug.Print v2
    Next
  Next
End Sub

'**********************************************************************
' バケツは引数の順にA,Bとしています。
'**********************************************************************

'容量の違う2つのバケツから指定容量を作り出す
Public Function ShortestProcedure(ByVal A As Long, _
                 ByVal B As Long, _
                 ByVal C As Long) As Variant
  Dim AryStatus 'ジャグ配列
  Dim ParentAry() As clsManage
  Dim CurAry() As clsManage
  
  Dim cntNo As Long '全体件数、ユニーク番号
  Dim CurLevel As Long '現在処理中のレベル
  Dim IndexInLevel As Long '同一レベル内の件数
  cntNo = 0
  CurLevel = 0
  
  Dim BucketA As New clsBucket
  Dim BucketB As New clsBucket
  
  '以降と統一する為にジャグ配列にする
  ReDim CurAry(0)
  Set CurAry(0) = CreateStatus(cntNo, 0, 0, CurLevel, 0, "", "", "", _
                 BucketA.Create("A", A, 0), _
                 BucketB.Create("B", B, 0))
  ReDim AryStatus(CurLevel)
  AryStatus(CurLevel) = CurAry
  
  '目的の数値になるまで繰り返す。
  Dim i As Long
  Do
    '親レベルの配列を取り出す
    ParentAry = AryStatus(CurLevel)
    
    '現在レベルの配列の用意
    CurLevel = CurLevel + 1
    ReDim Preserve AryStatus(CurLevel)
    IndexInLevel = 0 '同一レベル内の件数
    
    '親レベルの配列をループ
    ReDim CurAry(0)
    For i = LBound(ParentAry) To UBound(ParentAry)
      'Aバケツのメソッド3種類を全てトライしてみる
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Full")
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Emptied")
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Transfer")
      'Bバケツのメソッド3種類を全てトライしてみる
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Full")
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Emptied")
      Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Transfer")
    Next
    AryStatus(CurLevel) = CurAry
    
    '親レベルから次に進めなかった場合は解なし
    If CurAry(0) Is Nothing Then Exit Function
    
    '目的の数値があればループを抜ける
    If AryExist(AryStatus, C) Then Exit Do
    
    '念の為100レベルで終了
    If CurLevel > 100 Then Exit Function
    
    DoEvents '万一の時に止めやすいように
  Loop
  
  '目的の数値に到達する手順の文字列作成
  ShortestProcedure = AnswerProcedure(AryStatus, C)
End Function

'指定バケツの指定メソッドを実行し、結果が有効な状態なら配列に追加
Private Sub TryStatus(ByRef AryStatus, _
           ByVal argParent As clsManage, _
           ByRef CurAry() As clsManage, _
           ByRef IndexInLevel As Long, _
           ByRef cntNo As Long, _
           ByVal argLevel As Long, _
           ByVal argAB As String, _
           ByVal argOpe As String)
  Dim BucketA As New clsBucket
  Dim BucketB As New clsBucket
  Set BucketA = BucketA.Create("A", argParent.A_MaxValue, argParent.A_Value)
  Set BucketB = BucketB.Create("B", argParent.B_MaxValue, argParent.B_Value)
  
  '操作オブジェクトと相手オブジェクトの特定
  Dim targetObj1 As clsBucket
  Dim targetObj2 As clsBucket
  Select Case argAB
    Case BucketA.Name
      Set targetObj1 = BucketA
      Set targetObj2 = BucketB
    Case BucketB.Name
      Set targetObj1 = BucketB
      Set targetObj2 = BucketA
    Case Else
      Err.Raise Number:=9991, Description:="そんなバケツはない"
  End Select
  
  'メソッド
  Select Case argOpe
    Case "Full", "Emptied"
      If Not CallByName(targetObj1, argOpe, VbMethod) Then Exit Sub
    Case "Transfer"
      If Not CallByName(targetObj1, argOpe, VbMethod, targetObj2) Then Exit Sub
    Case Else
      Err.Raise Number:=9992, Description:="そんなメソッドはない!"
  End Select
  
  '既に同一状態が存在していたらスキップする
  If AryExist(AryStatus, BucketA.Value, BucketB.Value) Then Exit Sub
  
  '全体件数(ユニークNo)をカウントアップ
  cntNo = cntNo + 1
  
  '保存用の状態を作成
  Dim tmpStatus As clsManage
  Set tmpStatus = CreateStatus(cntNo, argParent.No, argParent.IndexInLevel, argLevel, IndexInLevel, targetObj1.Name, argOpe, targetObj2.Name, BucketA, BucketB)
  
  '配列に追加する
  ReDim Preserve CurAry(IndexInLevel) As clsManage
  Set CurAry(IndexInLevel) = tmpStatus
  IndexInLevel = IndexInLevel + 1
End Sub

'配列(ジャグ配列と通常配列の両対応)に目的の数値があるか
Private Function AryExist(ByRef argAry, _
             ByVal Avalue As Long, _
             Optional ByVal Bvalue As Long = -1) As Boolean
  AryExist = True
  Dim vItem, vChild
  For Each vItem In argAry
    If Not IsEmpty(vItem) Then
      If IsArray(vItem) Then
        For Each vChild In vItem
          If ValueExist(vChild.A_Value, vChild.B_Value, Avalue, Bvalue) Then
            Exit Function
          End If
        Next
      Else
        If ValueExist(vItem.A_Value, vItem.B_Value, Avalue, Bvalue) Then
          Exit Function
        End If
      End If
    End If
  Next
  AryExist = False
End Function

'AB両方の数値確認、または、ある数字の存在確認
Private Function ValueExist(ByVal Avalue1 As Long, _
              ByVal Bvalue1 As Long, _
              ByVal Avalue2 As Long, _
              Optional ByVal Bvalue2 As Long = -1) As Boolean
  ValueExist = True
  
  If Bvalue2 < 0 Then
    If Avalue1 = Avalue2 Or _
      Bvalue1 = Avalue2 Then
      Exit Function
    End If
  Else
    If Avalue1 = Avalue2 And _
      Bvalue1 = Bvalue2 Then
      Exit Function
    End If
  End If
  
  ValueExist = False
End Function

'状態を保存する管理データ作成
Private Function CreateStatus(ByVal aNo As Long, _
               ByVal aParentNo As Long, _
               ByVal aParentIndex As Long, _
               ByVal aLevel As Long, _
               ByVal aIndexInLevel As Long, _
               ByVal aOpeObject As String, _
               ByVal aOpeMethod As String, _
               ByVal aOpeTarget As String, _
               ByVal aObj1 As clsBucket, _
               ByVal aObj2 As clsBucket) As clsManage
  Set CreateStatus = New clsManage
  With CreateStatus
    .No = aNo
    .ParentNo = aParentNo
    .ParentIndex = aParentIndex
    .Level = aLevel
    .IndexInLevel = aIndexInLevel
    .OpeObject = aOpeObject
    .OpeMethod = aOpeMethod
    .OpeTarget = aOpeTarget
    .A_Value = aObj1.Value
    .B_Value = aObj2.Value
    .A_MaxValue = aObj1.MaxValue
    .B_MaxValue = aObj2.MaxValue
  End With
End Function

'**********************************************************************
' 解を見つけた後の回答作成
'**********************************************************************

'状態を保持したジャグ配列から目的の数値を見つけて手順をジャグ配列で戻す
Private Function AnswerProcedure(ByRef AryStatus, _
                 ByVal argValue As Long) As Variant
  Dim ansAry()
  Dim cnt As Long
  Dim vItem, vChild
  For Each vItem In AryStatus
    If Not IsEmpty(vItem) Then
      If IsArray(vItem) Then
        For Each vChild In vItem
          If ValueExist(vChild.A_Value, vChild.B_Value, argValue) Then
            ReDim Preserve ansAry(cnt)
            ansAry(cnt) = CreateProcedure(AryStatus, vChild.No, vChild.Level, vChild.IndexInLevel)
          End If
        Next
      End If
    End If
  Next
  AnswerProcedure = ansAry
End Function

'指定NOから順に親を辿り手順を配列として作成
Private Function CreateProcedure(ByRef AryStatus, _
                 ByVal aNo As Long, _
                 ByVal aLevel As Long, _
                 ByVal aIndexInLevel As Long) As String()
  Dim outAry() As String
  Dim tmpString As String
  Dim cnt As Long
  Dim tmpManage As clsManage
  Do
    Set tmpManage = AryStatus(aLevel)(aIndexInLevel)
    ReDim Preserve outAry(cnt)
    tmpString = tmpManage.OpeObject & "." & _
          tmpManage.OpeMethod & _
          IIf(tmpManage.OpeMethod = "Transfer", "(" & tmpManage.OpeTarget & ")", "")
    tmpString = Replace(tmpString, "Full", "満タン  ")
    tmpString = Replace(tmpString, "Emptied", "空にする ")
    tmpString = Replace(tmpString, "Transfer", "相手に注ぐ")
    tmpString = Left(tmpString & Space(10), 10)
    tmpString = tmpString & " A=" & tmpManage.A_Value & _
                ",B=" & tmpManage.B_Value
    outAry(cnt) = tmpString
    
    If tmpManage.ParentNo = 0 Then Exit Do
    
    aNo = tmpManage.ParentNo
    aLevel = aLevel - 1
    aIndexInLevel = tmpManage.ParentIndex
    cnt = cnt + 1
    
    DoEvents '万一の時に止めやすいように
  Loop
  
  '配列を逆転させるDim i As Long
  Dim ary() As String, i As Long
  ReDim ary(LBound(outAry) To UBound(outAry))
  For i = LBound(outAry) To UBound(outAry)
    ary(UBound(outAry) + LBound(outAry) - i) = outAry(i)
  Next
  CreateProcedure = ary
End Function

実際のメインとなるプロシージャーは、
ShortestProcedure
これになります。

PrintProcedure
こちらは、あくまでイミディエイト ウィンドウにきれいに表示するためのプロシージャーです。

VBAで「3Lと5Lのバケツで4Lの水を作る」を解いた結果

Sub 検証テスト()
  Call PrintProcedure(3, 5, 4)
  Call PrintProcedure(3, 6, 4)
  Call PrintProcedure(3, 7, 5)
  Call PrintProcedure(4, 5, 3)
  Call PrintProcedure(4, 6, 5)
  Call PrintProcedure(4, 7, 5)
  Call PrintProcedure(5, 7, 4)
  Call PrintProcedure(5, 7, 6)
End Sub

実行結果は、イミディエイト ウィンドウに以下のように出力されます。

■A=3,B=5 → 4
手順1
B.満タン      A=0,B=5
B.相手に注ぐ(A) A=3,B=2
A.空にする     A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン      A=2,B=5
B.相手に注ぐ(A) A=3,B=4
■A=3,B=6 → 4
答えを見つけられませんでした。
■A=3,B=7 → 5
手順1
B.満タン      A=0,B=7
B.相手に注ぐ(A) A=3,B=4
A.空にする     A=0,B=4
B.相手に注ぐ(A) A=3,B=1
A.空にする     A=0,B=1
B.相手に注ぐ(A) A=1,B=0
B.満タン      A=1,B=7
B.相手に注ぐ(A) A=3,B=5
■A=4,B=5 → 3
手順1
A.満タン      A=4,B=0
A.相手に注ぐ(B) A=0,B=4
A.満タン      A=4,B=4
A.相手に注ぐ(B) A=3,B=5
■A=4,B=6 → 5
答えを見つけられませんでした。
■A=4,B=7 → 5
手順1
A.満タン      A=4,B=0
A.相手に注ぐ(B) A=0,B=4
A.満タン      A=4,B=4
A.相手に注ぐ(B) A=1,B=7
B.空にする     A=1,B=0
A.相手に注ぐ(B) A=0,B=1
A.満タン      A=4,B=1
A.相手に注ぐ(B) A=0,B=5
■A=5,B=7 → 4
手順1
B.満タン      A=0,B=7
B.相手に注ぐ(A) A=5,B=2
A.空にする     A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン      A=2,B=7
B.相手に注ぐ(A) A=5,B=4
■A=5,B=7 → 6
手順1
B.満タン      A=0,B=7
B.相手に注ぐ(A) A=5,B=2
A.空にする     A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン      A=2,B=7
B.相手に注ぐ(A) A=5,B=4
A.空にする     A=0,B=4
B.相手に注ぐ(A) A=4,B=0
B.満タン      A=4,B=7
B.相手に注ぐ(A) A=5,B=6

同一手順回数で複数の解があれば出るはずなのですが、、、
そういうことは無いのかもしれません、ちょっと無駄な事をしたかもしれない、、、

おまけ:アニメーションさせてみました

マクロ VBA 3Lと5Lのバケツで4Lの水を作る

もともとお遊びではありますが、
このアニメーションはさらにおまけなので、VBAコードはかなり適当に書いたものになります。
少しでも参考になればと思い、追加で掲載しました。

Option Explicit

Sub ビジュアル動作()
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim A As Long, B As Long, C As Long
  A = ws.Range("B2").Value
  B = ws.Range("B3").Value
  C = ws.Range("B4").Value
  Call VusualBacket(A, B, C, ws.Range("D2"))
End Sub

Sub VusualBacket(ByVal A As Long, _
         ByVal B As Long, _
         ByVal C As Long, _
         ByVal argRng As Range)
  Dim ws As Worksheet
  Set ws = argRng.Worksheet
  
  argRng.Value = "バケツ" & A & "Lとバケツ" & B & "Lから" & C & "Lを作る"
  
  Dim TopPos As Long
  Dim UnitHeight As Long
  TopPos = argRng.Offset(3).Top
  UnitHeight = argRng.Offset(3).RowHeight
  Call BacketAdjust(ws.Shapes("バケツ枠A2"), A, ws.Shapes("バケツ枠A1"), A, TopPos, UnitHeight)
  Call BacketAdjust(ws.Shapes("バケツ枠B2"), B, ws.Shapes("バケツ枠B1"), B, TopPos, UnitHeight)
  
  Dim spA As Shape
  Dim spB As Shape
  Set spA = ws.Shapes("バケツA")
  Set spB = ws.Shapes("バケツB")
  
  Call BacketAdjust(spA, 0, spB, 0, TopPos, UnitHeight)
  
  Dim ans, v, str, num1, num2, cnt
  ans = ShortestProcedure(A, B, C)
  If IsEmpty(ans) Then
    MsgBox "答えを見つけられませんでした。"
    Exit Sub
  End If
  
  For Each v In ans(0)
    DoEvents
    Application.Wait Now() + TimeSerial(0, 0, 1)
    cnt = cnt + 1
    argRng.Offset(1).Value = cnt & "回. " & v
    DoEvents
    Application.Wait Now() + TimeSerial(0, 0, 1)
    str = Right(v, 7)
    num1 = Mid(str, 3, 1)
    num2 = Mid(str, 7, 1)
    Call BacketAdjustAni(spA, num1, spB, num2, TopPos, UnitHeight)
  Next
End Sub

Function BacketAdjust(ByVal spA As Shape, _
           ByVal numA As Long, _
           ByVal spB As Shape, _
           ByVal numB As Long, _
           ByVal TopPos As Long, _
           ByVal UnitHeight As Long)
  spA.Height = UnitHeight * numA
  spB.Height = UnitHeight * numB
  spA.Top = TopPos + UnitHeight * (9 - numA)
  spB.Top = TopPos + UnitHeight * (9 - numB)
End Function

Function BacketAdjustAni(ByVal spA As Shape, _
             ByVal numA As Long, _
             ByVal spB As Shape, _
             ByVal numB As Long, _
             ByVal TopPos As Long, _
             ByVal UnitHeight As Long)
  numA = numA * 10
  numB = numB * 10
  
  Dim BeforeNumA As Long, BeforeNumB As Long
  BeforeNumA = spA.Height / UnitHeight * 10
  BeforeNumB = spB.Height / UnitHeight * 10
  
  Dim sA As Long, sB As Long
  sA = IIf(BeforeNumA > numA, -1, 1)
  sB = IIf(BeforeNumB > numB, -1, 1)
  
  Dim hA As Long, hB As Long
  hA = BeforeNumA
  hB = BeforeNumB
  Do
    If hA <> numA Then
      hA = hA + sA
      spA.Height = UnitHeight * (hA / 10)
      spA.Top = TopPos + UnitHeight * (9 - (hA / 10))
    End If
    If hB <> numB Then
      hB = hB + sB
      spB.Height = UnitHeight * (hB / 10)
      spB.Top = TopPos + UnitHeight * (9 - (hB / 10))
    End If
    DoEvents
    If hA = numA And hB = numB Then Exit Do
    Application.Wait [NOW()+"0:0:0.05"]
  Loop
End Function

シートの設定がありますので、
以下よりダウンロードできるようにしてあります。

zipとxlsmを用意しました。


他のゲーム(数独、オセロ、将棋、囲碁)も含めたダウンロード一覧は以下になります。




同じテーマ「ツイッター出題回答 」の記事

「VBA Match関数の限界」についての誤解
VBAで数値を漢数字に変換する方法
囲碁で相手の石を囲んで取るアルゴリズム
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く
言語依存の関数を使用できるFormulaLocal
配列のUBoundがLBoundがより小さいことはあり得るか
コレクションの要素を削除する場合
greeenはgreenに、greeeeeNをGReeeeNに変換
数値変数の値を別の変数を使わずに入れ替える
Rangeオブジェクトを受け取り"行数,列数"で埋める
数式の関数の使用回数、関数名を配列で返す


新着記事NEW ・・・新着記事一覧を見る

TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。


このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ