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

タイトル サンプル
投稿日: 2023/02/12(Sun) 10:52
投稿者魔界の仮面弁士
> Windows10
> vb.net 2010使用しています。

手元に VB2010 が無いので、
「VB2022 + .NET Framework 4」のコンソールアプリで作りました。

VB2010 当時の文法仕様だけで書いたつもりですが、
コンパイル エラーが出るようならご指摘ください。
→追記:VB2010 での動作を確認しました。(VB2008 では動きません)


・基本的なアルゴリズムは、最初の質問にあった Excel VBA 版の「木構造と枝刈りロジック」と同じです。
 https://blog-imgs-67-origin.fc2.com/h/a/t/hatenachips/VBASearchSumAlgo.png
 VBA 版では、ソート処理部を自作(クイックソート)していましたが、こちらは LINQ で処理しています。



・参考 URL (Excel VBA 版)では、合致する組み合わせを複数列挙していましたが、
 今回のコードは「合致する組み合わせを一つ見つけたら、そこで探索終了」としています。

・合致しない場合はより近い値を求める…というルールだったので、発見できない時は
 設定値を 1 ずつ減らして、再度探索しなおすという方式を採っています。

・No12091 の設問と No12093 の「最大桁数は4桁になります。最小桁数は2桁です。」の要件が
 矛盾するため、値リストの条件として No12095 の「自然数のみです。」を採用しています。

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


'-------------
Option Strict On

Public Class Node
    Inherits List(Of Node)
    Public ReadOnly Value As Integer    '選択された[値]
    Public ReadOnly Parent As Node      'ひとつ前に選択した[値]
    Public ReadOnly Total As Integer    '祖先からここまでの[値]の合計
    Public Sub New(Parent As Node, Value As Integer)
        Me.Value = Value
        Me.Parent = Parent
        Total = Value + If(Parent Is Nothing, 0, Parent.Total)
    End Sub
End Class

Module Module1
    Sub Main()
        'No12097 の設問
        Dim 値一覧1 As Integer() = {60, 57, 54, 45, 42, 500, 1000, 60, 25, 57}

        'No.12091 の設問
        Dim 値一覧2 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}


        '『設定値:590 合計値:587 詳細値:42, 45, 500』
        探索(590, 値一覧1)

        '『設定値:586 合計値:585 詳細値:25, 60, 500』
        探索(586, 値一覧1)

        '『設定値:88792 合計値:88792 詳細値:1011, 1245, 1497, 2887, 2994, 3296, 3517, 4101, 4366, 4655, 6290, 6494, 14116, 14823, 17500』
        探索(88792, 値一覧2)

        Console.ReadKey()
    End Sub

    Sub 探索(設定値 As Integer, 寸法一覧 As Integer())
        Console.Write("設定値:{0} ", 設定値)
        Dim 結果 As Integer() = {}
        For 設定値 = 設定値 To 設定値 - 20 Step -1
            結果 = FindCombination(設定値, 寸法一覧)
            If 結果.Length > 0 Then Exit For
        Next
        If 結果.Length = 0 Then
            Console.WriteLine("抽出できませんでした。")
        Else
            Console.WriteLine("合計値:{0} 詳細値:{1}", 結果.Sum(), String.Join(", ", 結果.Select(Function(寸法) CStr(寸法))))
        End If
    End Sub

    ''' <summary>合計値が完全一致する組み合わせを探す</summary>
    ''' <param name="targetValue">設定値</param>
    ''' <param name="values">値リスト</param>
    ''' <returns>最初に見つけたものを一つだけ返す</returns>
    Public Function FindCombination(targetValue As Integer, ParamArray values As Integer()) As Integer()
        If values Is Nothing OrElse values.Length = 0 Then Throw New ArgumentNullException("values")
        'If values.Any(Function(v) v < 10 OrElse v > 9999) Then Throw New ArgumentOutOfRangeException("values", "2〜4桁の自然数が必要です。")
        If values.Any(Function(v) v <= 0) Then Throw New ArgumentOutOfRangeException("values", "自然数が必要です。")

        '設定値を超えるものは除外した上で、[値]の昇順に並べる
        Dim ordered As Integer() = (From v In values Where v <= targetValue Order By v).ToArray()

        '探索処理
        Dim maxIndex = ordered.GetUpperBound(0)
        Dim edge As Node = Nothing  '発見した組み合わせ
        Dim Search As Action(Of Integer, Node) =
            Sub(index, parent)
                If Not edge Is Nothing Then Return  '既に発見済み
                For i = index To maxIndex
                    Dim nextValue = ordered(i)      '値を昇順に抽出
                    Dim nextNode As New Node(parent, nextValue)
                    If nextNode.Total <= targetValue Then
                        parent.Add(nextNode)        '超過しないなら抽出
                        If nextNode.Total = targetValue Then
                            edge = nextNode         '目標値に達したので探索終了
                            Return
                        Else
                            Search(i + 1, nextNode) '再帰して次の組み合わせを選ぶ
                        End If
                    End If
                Next
            End Sub

        '探索実行
        Dim root As New Node(Nothing, 0)
        Search(0, root)
        If edge Is Nothing Then
            '見つからなかった
            Return New Integer(-1) {}
        Else
            Dim result As New Stack(Of Integer)()
            Dim e = edge
            Do
                result.Push(e.Value)
                e = e.Parent
            Loop Until e Is root
            Return result.ToArray()
        End If
    End Function
End Module

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

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