tagCANDY CGI VBレスキュー(花ちゃん) の Visual Basic 2010 用 掲示板(VB.NET 掲示板)
VBレスキュー(花ちゃん) の Visual Basic 2010 用 掲示板(VB.NET 掲示板)
[ツリー表示へ]　 [ワード検索]　 [Home]

タイトル ： サンプル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
- 関連一覧ツリー （ をクリックするとツリー全体を一括表示します）

古いスレッドにレスはつけられません。