タイトル : サンプル3 投稿日 : 2023/02/12(Sun) 15:30 投稿者 : 魔界の仮面弁士
> ただし、発見したすべての組み合わせを列挙するようにしたため、 > アイテム数が多くなると、列挙が開始されるまでに長い時間がかかるようになっています。 No12103「サンプル2」 No12105「サンプル2改」の実装は、 探索が終了するまで、結果が返されない仕様でした。 そこで応答を早くするため、まだ探索を完全に終えていなくても、 条件を満たす組み合わせをひとつ見つけるごとに、随時通知するようにしてみました。 組み合わせが多いと完了まで時間がかかる点は変わりませんが、 結果を表示し始めるまでの応答開始が早くなるというメリットがあります。 さらに、必要に応じて列挙を中断できるよう、キャンセル処理も可能な仕組みを追加してあります。 VB2010 という制限があるため、Iterator / Yield を利用することはできないので、 代わりにデリゲートで通知する方針にしています。(あるいはイベントで通知する方法にしても良いでしょう) '------------ Option Strict On Public Class Node Inherits List(Of Node) Public ReadOnly Value As Tuple(Of Integer, Integer) '選択された[位置番号]と[値] Public ReadOnly Parent As Node 'ひとつ前に選択した[値] Public ReadOnly Total As Integer '祖先からここまでの[値]の合計 Public Sub New(Parent As Node, Index As Integer, Value As Integer) Me.Value = Tuple.Create(Index, Value) Me.Parent = Parent Total = Value + If(Parent Is Nothing, 0, Parent.Total) End Sub End Class Module Module1 ''' <summary>探索された組み合わせの一つを通知するデリゲート。</summary> ''' <param name="cancel">既定値は False。True を渡すと列挙が中断される。</param> ''' <param name="total">組み合わせの合計数。</param> ''' <param name="values">組み合わせの内容。Item1 はインデックス、Item2 が値を示す。</param> Public Delegate Sub CombinationReceivedDelegate(ByRef cancel As Boolean, total As Integer, values As Tuple(Of Integer, Integer)()) Sub Main() Dim 値一覧1 As Integer() = {1, 2, 3, 4, 5} 反復探索(1, 15, 値一覧1) '31通りの組み合わせ 'No12097 の設問 Dim 値一覧2 As Integer() = {60, 57, 54, 45, 42, 500, 1000, 60, 25, 57} 反復探索(570, 590, 値一覧2) '7通りの組み合わせ 'No.12091 の設問 Dim 値一覧3 As Integer() = {5988, 2994, 1245, 3296, 19777, 1497, 14823, 13177, 37885, 5988, 6290, 6038, 22653, 28474, 29564, 26871, 23844, 4366, 4101, 14116, 7037, 17500, 24062, 23644, 17717, 25162, 9461, 19788, 29762, 25099, 28935, 1011, 4655, 22234, 9589, 30377, 10081, 2887, 24336, 3517, 16020, 6494, 16745, 24100, 28340, 24825, 13382, 6801, 19893, 28700} '反復探索(88792, 88792, 値一覧3) '条件を満たす組み合わせがとても多いので、途中でメモリ不足になると思います…。 Console.ReadKey() End Sub Sub 反復探索(最小設定値 As Integer, 最大設定値 As Integer, 寸法一覧 As Integer()) Console.WriteLine("寸法一覧:{0}個", 寸法一覧.Length) For i = 0 To 寸法一覧.Length - 1 Console.WriteLine(" [{0}]={1}", i, 寸法一覧(i)) Next Console.WriteLine() Console.WriteLine("設定値:{0}〜{1}", 最小設定値, 最大設定値) 'Dim limit As Integer = 30 '30件で中断する場合 Dim progress As CombinationReceivedDelegate = Sub(ByRef cancel As Boolean, total As Integer, values As Tuple(Of Integer, Integer)()) 'limit -= 1 Console.WriteLine("合計値:{0} 詳細値:{1}", total, String.Join(", ", values.OrderBy(Function(x) x.Item1).Select(Function(v) String.Format("[{0}]={1}", v.Item1, v.Item2)))) 'cancel = limit <= 0 '途中で列挙を止めたい場合は True をセットする End Sub Dim count As Integer = SearchCombinations(progress, 最小設定値, 最大設定値, 寸法一覧) If count = 0 Then Console.WriteLine("抽出できませんでした。") ElseIf count > 0 Then Console.WriteLine("総計 {0} 件の組み合わせを抽出しました。", count) Else Console.WriteLine("抽出処理が中断されました。{0} 件まで抽出されています。", -count) End If Console.WriteLine() End Sub ''' <summary>合計値が範囲内となる組み合わせを列挙する</summary> ''' <param name="progress">列挙結果を得るためのデリゲート。</param> ''' <param name="minValue">探索したい合計値の下限</param> ''' <param name="maxValue">探索したい合計値の上限</param> ''' <param name="values">値の一覧</param> ''' <returns>列挙完了数。列挙が中断された場合は、そこまでの列挙件数×-1 を返す。</returns> Public Function SearchCombinations(progress As CombinationReceivedDelegate, minValue As Integer, maxValue As Integer, ParamArray values As Integer()) As Integer If minValue > maxValue Then Throw New ArgumentOutOfRangeException("minValue", minValue, "minValue は maxValue 以下である必要があります。") If minValue <= 0 Then Throw New ArgumentOutOfRangeException("minValue", "自然数が必要です。") If values Is Nothing OrElse values.Length = 0 Then Throw New ArgumentNullException("values") If values.Any(Function(v) v <= 0) Then Throw New ArgumentOutOfRangeException("values", "自然数が必要です。") 'デリゲートが無ければ列挙しない。 If progress Is Nothing Then Return 0 '設定値を超えるものは除外した上で、[値]の昇順に並べる Dim ordered = ( From v In values.Select(Function(value, index) New With {Key index, value}) Where v.value <= maxValue Order By v.value, v.index ).ToArray() Dim root As New Node(Nothing, -1, 0) 'Node から値リストを作る Dim GetValueArray As Func(Of Node, Tuple(Of Integer, Integer)()) = Function(node) Dim result As New Stack(Of Tuple(Of Integer, Integer)) If Not node Is root Then Dim item = node Do result.Push(item.Value) item = item.Parent Loop Until item Is root OrElse item Is Nothing End If Return result.ToArray() End Function '探索処理 Dim maxIndex = ordered.GetUpperBound(0) Dim cancel As Boolean = False Dim count As Integer = 0 Dim Search As Action(Of Integer, Node) = Sub(index, parent) If cancel Then Return For i = index To maxIndex Dim nextItem = ordered(i) '値を昇順に抽出 Dim nextNode As New Node(parent, nextItem.index, nextItem.value) If nextNode.Total <= maxValue Then parent.Add(nextNode) '超過しないなら抽出 If minValue <= nextNode.Total Then '最低値条件をクリアした終端を、順次通知する progress.Invoke(cancel, nextNode.Total, GetValueArray(nextNode)) count += 1 If cancel Then Return End If Search(i + 1, nextNode) '再帰して次の組み合わせを選ぶ End If Next End Sub '探索実行 Search(0, root) '列挙件数を返す(キャンセルされたときはマイナス値にする) Return count * If(cancel, -1, 1) End Function End Module |