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

タイトル サンプル2
投稿日: 2023/02/12(Sun) 12:54
投稿者魔界の仮面弁士
> ・参考 URL (Excel VBA 版)では、合致する組み合わせを複数列挙していましたが、
>  今回のコードは「合致する組み合わせを一つ見つけたら、そこで探索終了」としています。

先程の Function FindCombination は「最初に見つけたもの」を返す実装でしたが
今度の Function FindCombinations は、「条件に合致したものすべて」を
位置情報も含めて列挙するようにしてあります。(最小値と最大値を指定する仕様に変更)


> ・[番号]は無視して、[寸法]の組み合わせのみを管理しています。そのため、
>  No12097 にて『詳細値:60, 500, 25』という結果が例示されていましたが、このコードでは
>  昇順に並んだ『詳細値:25, 60, 500』という結果で出力されます。

条件に合致したもの組み合わせに対して、位置番号も併せて得られるようにしてみました。
これにより、重複値をもつ一覧であっても、どちらが選択されたのか分かるようになっています。

たとえば、585 という値を 60+500+25 の組み合わせを作成した場合に、
  詳細値:[0]=60, [5]=500, [8]=25
  詳細値:[5]=500, [7]=60, [8]=25
のように、位置番号の異なる重複値だった場合、それらは異なる組み合わせとして扱われます。
※各組み合わせは、位置番号順にて返されます。


ただし、複数の組み合わせを列挙するようになったため、アイテム数が多くなると、
列挙が開始されるまでに長い時間がかかってしまいます。

管理情報が増えたため、コードとしては少し複雑に見えるかも知れませんが、
探索ロジックは先の No12102 のサンプルと同一です。

そのため、このコードを読み解くのであれば、
先に No12102 の手順を把握してからの方が良いと思います。


ただし今回のコードは、 No12091 の「最も近い組み合わせを獲得したい」を優先しており、
「最小値を超えたけれど、もっと最大値に近い組み合わせがある」場合、必ずしも列挙されません。
そのため、すべての組み合わせが得られるわけではありません。
(それでも一応、当初の目的には合致しているはず…)

Dim 値一覧 = {1, 2, 3, 4, 5}
result = FindCombinations(1,  5, 値一覧) '1 以上  5 以下の組み合わせ

上記の場合、
 5 = 1+4, 2+3, 5
 4 = 1+3, 4
 3 = 1+2, 3
が列挙されますが、下記の組み合わせは取りこぼされます。
 2 = 2 → 2+3 にすれば、最大値により近くなるため
 1 = 1 → 1+4 にすれば、最大値により近くなるため


------
寸法一覧:10個
 [0]=60
 [1]=57
 [2]=54
 [3]=45
 [4]=42
 [5]=500
 [6]=1000
 [7]=60
 [8]=25
 [9]=57

設定値:570〜590
 合計値:587 組み合わせ:1件
  詳細値:[3]=45, [4]=42, [5]=500
 合計値:585 組み合わせ:2件
  詳細値:[0]=60, [5]=500, [8]=25
  詳細値:[5]=500, [7]=60, [8]=25
 合計値:582 組み合わせ:2件
  詳細値:[1]=57, [5]=500, [8]=25
  詳細値:[5]=500, [8]=25, [9]=57
 合計値:579 組み合わせ:1件
  詳細値:[2]=54, [5]=500, [8]=25
 合計値:570 組み合わせ:1件
  詳細値:[3]=45, [5]=500, [8]=25

'-------------
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
    Sub Main()
        'No12097 の設問
        Dim 値一覧 As Integer() = {60, 57, 54, 45, 42, 500, 1000, 60, 25, 57}
        複数探索(570, 590, 値一覧)

        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 結果 = FindCombinations(最小設定値, 最大設定値, 寸法一覧)
        If 結果.Count = 0 Then
            Console.WriteLine("抽出できませんでした。")
        Else
            For Each result In 結果.OrderByDescending(Function(x) x.Key)
                Console.WriteLine(" 合計値:{0} 組み合わせ:{1}件", result.Key, result.Value.Count)
                For Each values In result.Value
                    Console.WriteLine("  詳細値:" & String.Join(", ", values.OrderBy(Function(x) x.Item1).Select(Function(v) String.Format("[{0}]={1}", v.Item1, v.Item2))))
                Next
            Next
        End If
    End Sub

    ''' <summary>合計値が範囲内となる組み合わせを列挙する</summary>
    ''' <param name="minValue">探索したい合計値の下限</param>
    ''' <param name="maxValue">探索したい合計値の上限</param>
    ''' <param name="values">「Key = 合計値, Value = (Index, 値)の組み合わせ」の一覧</param>
    Public Function FindCombinations(minValue As Integer, maxValue As Integer, ParamArray values As Integer()) As SortedDictionary(Of Integer, List(Of Tuple(Of Integer, Integer)()))
        If minValue > maxValue Then Throw New ArgumentOutOfRangeException("minValue", minValue, "minValue は maxValue 以下である必要があります。")
        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", "自然数が必要です。")

        '設定値を超えるものは除外した上で、[値]の昇順に並べる
        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))
                Dim item = node
                Do
                    result.Push(item.Value)
                    item = item.Parent
                Loop Until item Is root OrElse item Is Nothing
                Return result.ToArray()
            End Function

        '探索処理
        Dim maxIndex = ordered.GetUpperBound(0)
        Dim edges As New SortedDictionary(Of Integer, List(Of Tuple(Of Integer, Integer)()))()
        Dim Search As Action(Of Integer, Node) =
            Sub(index, parent)
                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)        '超過しないなら抽出
                        Search(i + 1, nextNode)     '再帰して次の組み合わせを選ぶ
                    End If
                Next
                If parent.Count = 0 Then
                    If parent.Total >= minValue Then
                        '最低値条件をクリアした終端を登録
                        Dim lst As List(Of Tuple(Of Integer, Integer)()) = Nothing
                        If Not edges.TryGetValue(parent.Total, lst) Then
                            lst = New List(Of Tuple(Of Integer, Integer)())()
                            edges.Add(parent.Total, lst)
                        End If
                        lst.Add(GetValueArray(parent))
                    End If
                End If
            End Sub

        '探索実行
        Search(0, root)
        Return edges
    End Function
End Module

- 関連一覧ツリー をクリックするとツリー全体を一括表示します)

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