﻿Option Explicit

' 照合はbigram Dice。条番号だけで加点しない。
Public Function RC_Similarity(ByVal leftText As String, ByVal rightText As String) As Double
    Dim a As String, b As String, bag As Object, i As Long, key As String, common As Long
    a = RC_MatchText(leftText): b = RC_MatchText(rightText)
    If a = b Then RC_Similarity = 1: Exit Function
    If Len(a) < 2 Or Len(b) < 2 Then Exit Function
    Set bag = RC_Dict()
    For i = 1 To Len(a) - 1
        key = Mid$(a, i, 2)
        If bag.Exists(key) Then bag(key) = bag(key) + 1 Else bag.Add key, 1
    Next i
    For i = 1 To Len(b) - 1
        key = Mid$(b, i, 2)
        If bag.Exists(key) Then
            If bag(key) > 0 Then common = common + 1: bag(key) = bag(key) - 1
        End If
    Next i
    RC_Similarity = 2# * common / (Len(a) + Len(b) - 2)
End Function

Public Function RC_MatchScore(ByVal nn As Object, ByVal oo As Object, ByVal ni As Long, ByVal oi As Long, ByVal nc As Long, ByVal oc As Long) As Double
    Dim bodyScore As Double, headingScore As Double, proximity As Double
    If nn("kind") <> oo("kind") Then Exit Function
    bodyScore = RC_Similarity(RC_NodeText(nn), RC_NodeText(oo))
    proximity = 1 - Abs(ni / (nc + 1#) - oi / (oc + 1#))
    If nn("kind") = "article" Then
        If Len(nn("heading")) > 0 And Len(oo("heading")) > 0 Then
            headingScore = RC_Similarity(nn("heading"), oo("heading"))
            RC_MatchScore = 0.55 * bodyScore + 0.4 * headingScore + 0.05 * proximity
        Else
            RC_MatchScore = 0.95 * bodyScore + 0.05 * proximity
        End If
    Else
        RC_MatchScore = 0.97 * bodyScore + 0.03 * proximity
    End If
End Function

Public Function RC_NewPair(ByVal nn As Object, ByVal oo As Object, ByVal score As Double, ByVal status As String) As Object
    Dim p As Object, children As Collection
    Set p = RC_Dict(): Set children = New Collection
    p.Add "new", nn: p.Add "old", oo: p.Add "score", score: p.Add "status", status
    p.Add "children", children
    Set RC_NewPair = p
End Function

' 新順を基本とし、未対応の旧は次の対応条の直前へ挿入する。
' 一致候補を全体から確保して移動を扱い、残りは順序付きDPで照合。
Public Function RC_Align(ByVal news As Collection, ByVal olds As Collection, ByVal issues As Collection, ByVal location As String) As Collection
    Dim nc As Long, oc As Long, ni As Long, oi As Long, j As Long, k As Long, z As Long
    Dim mapping() As Long, taken() As Boolean, scores() As Double, status() As String
    Dim best As Double, second As Double, bestOld As Long, oldBest As Double, oldSecond As Double, oldNew As Long
    Dim minimum As Double, remainderReview As Double, changed As Boolean, nn As Object, oo As Object, pair As Object
    Dim result As Collection, children As Collection, emptyChildren As Collection
    Dim newRest As Collection, oldRest As Collection, dp() As Double, action() As Integer, value As Double
    Dim x As Long, y As Long, idx As Variant
    Set result = New Collection: Set emptyChildren = New Collection
    nc = news.Count: oc = olds.Count
    ReDim mapping(0 To nc): ReDim taken(0 To oc): ReDim status(0 To nc)
    ReDim scores(0 To nc, 0 To oc)
    minimum = RC_CHILD_MIN
    If nc > 0 Then
        If news(1)("kind") = "article" Then minimum = RC_ARTICLE_MIN
    ElseIf oc > 0 Then
        If olds(1)("kind") = "article" Then minimum = RC_ARTICLE_MIN
    End If
    remainderReview = RC_CHILD_REMAINDER_REVIEW
    If minimum = RC_ARTICLE_MIN Then remainderReview = minimum - 0.1
    For ni = 1 To nc
        For oi = 1 To oc
            scores(ni, oi) = RC_MatchScore(news(ni), olds(oi), ni, oi, nc, oc)
        Next oi
    Next ni
    ' 相互最良で十分に一意な候補。番号ずれ/移動を先に確保する。
    Do
        changed = False
        For ni = 1 To nc
            If mapping(ni) = 0 Then
                best = 0: second = 0: bestOld = 0
                For oi = 1 To oc
                    If Not taken(oi) Then
                        value = scores(ni, oi)
                        If value > best Then
                            second = best: best = value: bestOld = oi
                        ElseIf value > second Then
                            second = value
                        End If
                    End If
                Next oi
                If bestOld > 0 And best >= minimum And best - second >= RC_AMBIGUITY_MARGIN Then
                    oldBest = 0: oldSecond = 0: oldNew = 0
                    For j = 1 To nc
                        If mapping(j) = 0 Then
                            value = scores(j, bestOld)
                            If value > oldBest Then
                                oldSecond = oldBest: oldBest = value: oldNew = j
                            ElseIf value > oldSecond Then
                                oldSecond = value
                            End If
                        End If
                    Next j
                    If oldNew = ni And oldBest - oldSecond >= RC_AMBIGUITY_MARGIN Then
                        mapping(ni) = bestOld: taken(bestOld) = True: status(ni) = "auto": changed = True
                    End If
                End If
            End If
        Next ni
    Loop While changed
    Set newRest = New Collection: Set oldRest = New Collection
    For ni = 1 To nc
        If mapping(ni) = 0 Then newRest.Add ni
    Next ni
    For oi = 1 To oc
        If Not taken(oi) Then oldRest.Add oi
    Next oi
    ReDim dp(0 To newRest.Count, 0 To oldRest.Count): ReDim action(0 To newRest.Count, 0 To oldRest.Count)
    For x = 1 To newRest.Count
        For y = 1 To oldRest.Count
            dp(x, y) = dp(x - 1, y): action(x, y) = 1
            If dp(x, y - 1) > dp(x, y) Then dp(x, y) = dp(x, y - 1): action(x, y) = 2
            value = scores(newRest(x), oldRest(y))
            If value >= minimum Then
                value = dp(x - 1, y - 1) + value - minimum + 0.01
                If value > dp(x, y) Then dp(x, y) = value: action(x, y) = 3
            End If
        Next y
    Next x
    x = newRest.Count: y = oldRest.Count
    Do While x > 0 And y > 0
        Select Case action(x, y)
        Case 3
            ni = newRest(x): oi = oldRest(y)
            mapping(ni) = oi: taken(oi) = True: status(ni) = "review"
            RC_AddIssue issues, "対応確認", location & " " & news(ni)("id") & " / " & olds(oi)("id"), "類似候補が競合。順序を使った暫定1対1対応。生成した表と入力原文を確認してください。", RC_NodeText(news(ni), True) & vbCrLf & "---旧---" & vbCrLf & RC_NodeText(olds(oi), True)
            x = x - 1: y = y - 1
        Case 2: y = y - 1
        Case Else: x = x - 1
        End Select
    Loop
    ' 強い対応の周囲に未対応だが類似した内容が残る場合は分割/統合候補。
    For ni = 1 To nc
        If mapping(ni) = 0 Then
            For oi = 1 To oc
                If scores(ni, oi) >= remainderReview Then
                    RC_AddIssue issues, "対応確認", location & " " & news(ni)("id"), "新設として全文保全。類似した旧単位があり、分割/統合/対応漏れの可能性。", RC_NodeText(news(ni), True) & vbCrLf & "---旧候補 " & olds(oi)("id") & "---" & vbCrLf & RC_NodeText(olds(oi), True)
                    Exit For
                End If
            Next oi
        End If
    Next ni
    For oi = 1 To oc
        If Not taken(oi) Then
            For ni = 1 To nc
                If scores(ni, oi) >= remainderReview Then
                    RC_AddIssue issues, "対応確認", location & " " & olds(oi)("id"), "削除として全文保全。類似した新単位があり、分割/統合/対応漏れの可能性。", RC_NodeText(olds(oi), True) & vbCrLf & "---新候補 " & news(ni)("id") & "---" & vbCrLf & RC_NodeText(news(ni), True)
                    Exit For
                End If
            Next ni
        End If
    Next oi
    ' 各削除単位の、旧順で次に対応する新単位を求める。
    For ni = 1 To nc + 1
        For oi = 1 To oc
            If Not taken(oi) Then
                k = nc + 1
                For j = oi + 1 To oc
                    For z = 1 To nc
                        If mapping(z) = j Then k = z: Exit For
                    Next z
                    If k <> nc + 1 Then Exit For
                Next j
                If k = ni Then
                    Set pair = RC_NewPair(Nothing, olds(oi), 0, "deleted")
                    Set children = RC_Align(emptyChildren, olds(oi)("children"), issues, location)
                    Set pair("children") = children: result.Add pair
                End If
            End If
        Next oi
        If ni <= nc Then
            Set nn = news(ni): Set oo = Nothing
            If mapping(ni) > 0 Then Set oo = olds(mapping(ni))
            If oo Is Nothing Then
                Set pair = RC_NewPair(nn, oo, 0, "new")
                Set children = RC_Align(nn("children"), emptyChildren, issues, location)
            Else
                Set pair = RC_NewPair(nn, oo, scores(ni, mapping(ni)), status(ni))
                Set children = RC_Align(nn("children"), oo("children"), issues, location & " " & nn("id"))
            End If
            Set pair("children") = children: result.Add pair
        End If
    Next ni
    Set RC_Align = result
End Function

Public Function RC_PairChanged(ByVal pair As Object) As Boolean
    Dim nn As Object, oo As Object, child As Variant
    Set nn = pair("new"): Set oo = pair("old")
    If nn Is Nothing Or oo Is Nothing Then RC_PairChanged = True: Exit Function
    If nn("heading") <> oo("heading") Or nn("prefix") <> oo("prefix") Or nn("gap") <> oo("gap") Or nn("body") <> oo("body") Then RC_PairChanged = True: Exit Function
    For Each child In pair("children")
        If RC_PairChanged(child) Then RC_PairChanged = True: Exit Function
    Next child
End Function
