スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

再帰処理にはまる(その2) 


vAry = Array(0, 1.1, 4.4, 3.3, 2.2) という配列があった時、
何組かの同じ配列を使って総当たりで、たし算しましょう。
その結果、重複する数値は排除して小さい順に表示しましょう。

例えば、
A = Array(0, 1.1, 4.4, 3.3, 2.2)
B = Array(0, 1.1, 4.4, 3.3, 2.2)
C = Array(0, 1.1, 4.4, 3.3, 2.2)
の3つを使って、
A(0)+B(0)+C(0)= や A(0)+B(0)+C(1)= や A(0)+B(0)+C(2)= ・・・・・
A(0)+B(1)+C(0)= や A(0)+B(1)+C(1)= や A(0)+B(1)+C(2)= ・・・・・
・・・・
A(4)+B(3)+C(0)= や A(4)+B(3)+C(1)= や A(4)+B(3)+C(2)= ・・・・・
A(4)+B(4)+C(0)= や A(4)+B(4)+C(1)= や A(4)+B(4)+C(2)= ・・・・・
の結果、重複を排除して小さい順に
 0
 1.1
 2.2
 3.3
 4.4
 5.5
 6.6
 7.7
 8.8
 9.9
 11
 12.1
 13.2


サンプルファイルは 再帰処理にはまる(その1) にあります
再帰処理にはまる(その3) も読んでいただければと
 

1)ベタで考える【標準モジュール:Pat2n】


1-1)総当たりの結果を格納する配列を用意する

まず、対象を配列で作成したら、計算誤差をなくすために CCur 変換しておきます。
何組使ってやるかは iCount で指定するように

基本の配列を1組分作っておきます。
次の組を処理する際、全ての結果を格納できるように領域を確保して総当たり計算
これを必要な組分繰り返します。

その後、重複分の値を排除する為に Dictionary を使用します。
値をキーとして利用することで、重複を排除できます。
排除後のキーを取得して、昇順に並び変えて表示します。

Public Sub Sample1()
  Dim vAry As Variant
  Dim vBase As Variant
  Dim vTmp As Variant
  Dim dic As Object
  Dim i As Long, jB As Long, jA As Long, k As Long

  Const iCount As Long = 3


  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  For i = 0 To UBound(vAry)
    vAry(i) = CCur(vAry(i))
  Next

  vBase = vAry
  For i = 2 To iCount
    ReDim vTmp((UBound(vBase) + 1) * (UBound(vAry) + 1) - 1)
    k = 0
    For jB = 0 To UBound(vBase)
      For jA = 0 To UBound(vAry)
        vTmp(k) = vBase(jB) + vAry(jA)
        k = k + 1
      Next
    Next
    vBase = vTmp
    vTmp = Empty
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(vBase)
    dic.Item(vBase(i)) = Null
  Next
  vBase = dic.keys
  Set dic = Nothing

  For i = 0 To UBound(vBase) - 1
    For k = i + 1 To UBound(vBase)
      If (vBase(k) < vBase(i)) Then
        vTmp = vBase(i)
        vBase(i) = vBase(k)
        vBase(k) = vTmp
      End If
    Next
  Next

  For i = 0 To UBound(vBase)
    Debug.Print vBase(i)
  Next
End Sub

 
組数が多くなってくると、全計算結果を格納する領域の確保が問題になってくると思います。
そこで、2組目、3組目と処理をしていく中で、重複を排除した結果だけを覚えておきましょう。
その結果と、次の組を総当たりで・・・・・この時も重複は排除しておきましょう。

それが次の例となります。

1-2)計算結果のみを Dictionary で管理

Public Sub Sample2()
  Dim vAry As Variant
  Dim vBase As Variant
  Dim vTmp As Variant
  Dim dic As Object
  Dim i As Long, j As Long

  Const iCount As Long = 3


  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  Set dic = CreateObject("Scripting.Dictionary")

  For i = 0 To UBound(vAry)
    vAry(i) = CCur(vAry(i))
    dic.Item(vAry(i)) = Null
  Next

  For i = 2 To iCount
    vBase = dic.keys
    dic.RemoveAll
    For Each vTmp In vBase
      For j = 0 To UBound(vAry)
        dic.Item(vTmp + vAry(j)) = Null
      Next
    Next
  Next
  vBase = dic.keys
  Set dic = Nothing

  For i = 0 To UBound(vBase) - 1
    For j = i + 1 To UBound(vBase)
      If (vBase(j) < vBase(i)) Then
        vTmp = vBase(i)
        vBase(i) = vBase(j)
        vBase(j) = vTmp
      End If
    Next
  Next

  For i = 0 To UBound(vBase)
    Debug.Print vBase(i)
  Next
End Sub

 
組数が多くなってくると、この方法が一番良いようです。


VBA記述での例にはなりませんが、せっかく Access を使っているので、
テーブルを用意して、クエリで直積を利用して・・・このクエリを作れるように
作られるクエリは
SELECT DISTINCT (Q1.値+Q2.値+Q3.値) AS 値
FROM T1 AS Q1, T1 AS Q2, T1 AS Q3;
てな感じになります。
また、クエリを手動/VBA で作成した時のプロパティの違いも確認したいかなっていうレベルで以下
(テーブルは「T1」として用意しています)

Public Sub DataMakeT1()
  Dim vAry As Variant
  Dim i As Long

  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  For i = 0 To UBound(vAry)
    vAry(i) = CCur(vAry(i))
  Next

  With CurrentDb
    .Execute "DELETE * FROM T1;"
    With .OpenRecordset("T1")
      For i = 0 To UBound(vAry)
        .AddNew
        .Fields("値") = vAry(i)
        .Update
      Next
      .Close
    End With
  End With
End Sub



Public Sub QueryMakeQ_T1()
  Dim sSql As String
  Dim sS As String
  Dim i As Long

  Const sQuery As String = "Q_T1"
  Const iCount As Long = 3


  sSql = ""
  sS = ""
  For i = 1 To iCount
    sSql = sSql & "+Q" & i & ".値"
    sS = sS & ", T1 AS Q" & i
  Next
  sSql = "(" & Mid(sSql, 2) & ") AS 値"
  sS = Mid(sS, 3)

  sSql = "SELECT DISTINCT " & sSql & " FROM " & sS & ";"

  On Error Resume Next
  DoCmd.Close acQuery, sQuery, acSaveNo
  With CurrentDb
    .QueryDefs.Delete sQuery
    .CreateQueryDef sQuery, sSql
    .QueryDefs.Refresh
    With .QueryDefs(sQuery).Fields("値")
      .Properties.Append .CreateProperty("Format", dbText, "General Number")
      .Properties.Append .CreateProperty("DecimalPlaces", dbByte, 4)
    End With
  End With
  DoCmd.OpenQuery sQuery
End Sub

Public Sub ChkPrp()
  Dim prp As DAO.Property

  Const sQuery As String = "Q_T1"

  On Error Resume Next
  With CurrentDb
    With .QueryDefs(sQuery).Fields("値")
      For Each prp In .Properties
        Debug.Print prp.Name,
        Debug.Print prp.Type,
        Debug.Print prp.Value,
        Debug.Print ""
      Next
    End With
  End With
End Sub

 

2)再帰処理で考える【標準モジュール:Pat2r】


2-1)重複結果を Dictionary のキーで管理

総当たりする部分を再帰処理にします。
計算結果を Dictionary のキーとして利用し重複を排除します。

Dim dic As Object

Private Sub ReCallCurAdd(iNst As Long, vAry As Variant, cSrc As Currency)
  Dim v As Variant
  Dim c As Currency

  For Each v In vAry
    c = cSrc + v
    If (iNst <= 1) Then
      dic.Item(c) = Null
    Else
      Call ReCallCurAdd(iNst - 1, vAry, c)
    End If
  Next
End Sub

Public Sub Sample1()
  Dim vAry As Variant
  Dim vBase As Variant
  Dim vTmp As Variant
  Dim i As Long, jB As Long, jA As Long, k As Long

  Const iCount As Long = 3


  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  For i = 0 To UBound(vAry)
    vAry(i) = CCur(vAry(i))
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  Call ReCallCurAdd(iCount, vAry, 0)
  vBase = dic.keys
  Set dic = Nothing

  For i = 0 To UBound(vBase) - 1
    For k = i + 1 To UBound(vBase)
      If (vBase(k) < vBase(i)) Then
        vTmp = vBase(i)
        vBase(i) = vBase(k)
        vBase(k) = vTmp
      End If
    Next
  Next

  For i = 0 To UBound(vBase)
    Debug.Print vBase(i)
  Next
End Sub

 

2-2)重複しない結果を都度整列生成

基本的には2-1)と同じですが、Dictionary 部分の使い方が変わってきます。
重複しない結果が得られたら・・・・・
これ、Dictionary に設定する時に管理している個数に変化があったかで判別しています。
変化あったら重複しない値だった・・・・なので、自分で都度昇順に格納していきます。

Dim dic As Object
Dim cAry As Variant ' Sample2 で使用

Private Sub CurAdd2(cSrc As Currency)
  Dim i As Long
  Dim j As Long

  If (IsEmpty(cAry)) Then
    ReDim cAry(0)
    cAry(0) = cSrc
  Else
    For i = 0 To UBound(cAry)
      If (cAry(i) > cSrc) Then
        ReDim Preserve cAry(UBound(cAry) + 1)
        For j = UBound(cAry) - 1 To i Step -1
          cAry(j + 1) = cAry(j)
        Next
        cAry(i) = cSrc
        Exit For
      End If
    Next
    If (i > UBound(cAry)) Then
      ReDim Preserve cAry(i)
      cAry(i) = cSrc
    End If
  End If
End Sub

Private Sub ReCallCurAdd2(iNst As Long, vAry As Variant, cSrc As Currency)
  Dim v As Variant
  Dim c As Currency
  Dim i As Long

  For Each v In vAry
    c = cSrc + v
    If (iNst <= 1) Then
      i = dic.Count
      dic.Item(c) = Null
      If (dic.Count <> i) Then Call CurAdd2(c)
    Else
      Call ReCallCurAdd2(iNst - 1, vAry, c)
    End If
  Next
End Sub

Public Sub Sample2()
  Dim vAry As Variant
  Dim i As Long

  Const iCount As Long = 3


  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  For i = 0 To UBound(vAry)
    vAry(i) = CCur(vAry(i))
  Next

  cAry = Empty
  Set dic = CreateObject("Scripting.Dictionary")
  Call ReCallCurAdd2(iCount, vAry, 0)
  Set dic = Nothing

  For i = 0 To UBound(cAry)
    Debug.Print cAry(i)
  Next
End Sub

 

2-3)重複しない組み合わせを事前に求める

今回は足し算でそう時間がかかるものではありませんが、考え方として・・・・
総当たりで計算するのではなく、計算が必要なケースを探します。
この時再帰処理を使用します。
元の配列数と同じ中身 0 の変数を用意し、どのケースがあるか調べます。
このケースの管理に Dictionary を使用します。
Dictionary に格納される内容としては、"0,3;1,0;2,0;3,0;4,0" のような文字列になります。
これは、
A(0)+B(0)+C(1)= や A(0)+B(1)+C(0)= や A(1)+B(0)+C(0)=
これら全て計算する必要はなく (0) を2回、(1) を1回のケースですね・・・・
この場合、"0,2;1,1;2,0;3,0;4,0" とするルールを決めました。
";" 区切りで、その中を "," で区切って (0) が配列参照の添え字に、(1) が回数に

(実際に必要な "0,2;1,1" だけの方が良かったのかも・・・・)

必要なケースだけやったとしても、計算結果が重複しない保証はないので、
また Dictionary を使って重複排除

Dim dic As Object

Private Sub ReCallMake3(iNst As Long, vAry As Variant)
  Dim i As Long, j As Long
  Dim sS As String
  Dim vWrkAry As Variant

  For i = 0 To UBound(vAry)
    vWrkAry = vAry
    vWrkAry(i) = vWrkAry(i) + 1
    If (iNst <= 1) Then
      sS = ""
      For j = 0 To UBound(vWrkAry)
        sS = sS & ";" & j & "," & vWrkAry(j)
      Next
      dic.Item(Mid(sS, 2)) = Null
    Else
      Call ReCallMake3(iNst - 1, vWrkAry)
    End If
  Next
End Sub

Public Sub Sample3()
  Dim vAry As Variant
  Dim vWrkAry As Variant
  Dim vBase As Variant
  Dim vTmp As Variant
  Dim i As Long, j As Long
  Dim vKs As Variant, vK As Variant
  Dim vAs As Variant, vA As Variant
  Dim c As Currency, cW As Currency

  Const iCount As Long = 3


  vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'  vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

  vWrkAry = vAry
  For i = 0 To UBound(vWrkAry)
    vWrkAry(i) = 0
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  Call ReCallMake3(iCount, vWrkAry)

  vKs = dic.keys
  dic.RemoveAll

  For Each vK In vKs
    c = 0
    For Each vAs In Split(vK, ";")
      vA = Split(vAs, ",")
      cW = vAry(CLng(vA(0)))
      For i = 1 To CLng(vA(1))
        c = c + cW
      Next
    Next
    dic.Item(c) = Null
  Next
  vBase = dic.keys
  Set dic = Nothing

  For i = 0 To UBound(vBase) - 1
    For j = i + 1 To UBound(vBase)
      If (vBase(j) < vBase(i)) Then
        vTmp = vBase(i)
        vBase(i) = vBase(j)
        vBase(j) = vTmp
      End If
    Next
  Next

  For i = 0 To UBound(vBase)
    Debug.Print vBase(i)
  Next
End Sub

 

5、6組ぐらいまでなら再帰も使えるかも・・・・・
それ以上だと・・・・・・・・・

この処理では、1-2)が格段に速い、良いですね。
50組でもソコソコの応答があるし・・・・・
関連記事

2012/03/12

Category: やってみる

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/120-fa0f1c96
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。