﻿Option Explicit

Public Function RC_OutputDocument(ByVal pairs As Collection, ByVal newDoc As Object, ByVal oldDoc As Object, ByVal issues As Collection) As Document
    Dim doc As Document, tbl As Table, rows As Collection, pair As Variant, row As Object
    Dim title As String, i As Long, range As range, pageDialog As Object, bodyRows As Long
    Set rows = New Collection
    For Each pair In pairs
        If RC_PairChanged(pair) Then RC_ArticleRows pair, rows, issues
    Next pair
    If newDoc("title") <> oldDoc("title") Then
        Set row = RC_TextRow(newDoc("title"), oldDoc("title"), False, False, issues)
        If rows.Count > 0 Then rows.Add row, Before:=1 Else rows.Add row
    End If
    ' 解析不能でも原文の脱落を避けるため両側に別掲する。
    RC_ExtraRows newDoc("extras"), oldDoc("extras"), rows, issues
    bodyRows = rows.Count
    ' 新規程の末尾にある最新履歴は、新旧共通でも新欄の最後へ原文コピーする。
    RC_HistoryRows newDoc("history"), oldDoc("history"), rows, issues
    Set doc = Application.Documents.Add(Visible:=False)
    With doc.PageSetup
        .PaperSize = RC_PAPER_SIZE
        .Orientation = RC_ORIENTATION
        .TopMargin = MillimetersToPoints(RC_TOP_MARGIN_MM)
        .BottomMargin = MillimetersToPoints(RC_BOTTOM_MARGIN_MM)
        .LeftMargin = MillimetersToPoints(RC_LEFT_MARGIN_MM)
        .RightMargin = MillimetersToPoints(RC_RIGHT_MARGIN_MM)
        .FooterDistance = MillimetersToPoints(RC_FOOTER_MM)
        If RC_USE_LINE_GRID Then .LayoutMode = wdLayoutModeLineGrid Else .LayoutMode = wdLayoutModeDefault
        .DifferentFirstPageHeaderFooter = False
        .OddAndEvenPagesHeaderFooter = False
    End With
    With doc.Styles(wdStyleNormal)
        .Font.Name = RC_BODY_FONT: .Font.NameFarEast = RC_BODY_FONT: .Font.Size = RC_BODY_SIZE
        .Font.Color = RC_Color(RC_BODY_COLOR): .Font.Bold = RC_BODY_BOLD: .Font.Underline = wdUnderlineNone
        With .ParagraphFormat
            .Alignment = RC_BODY_ALIGN
            .SpaceBefore = RC_BODY_BEFORE_PT: .SpaceAfter = RC_BODY_AFTER_PT: .LineSpacingRule = wdLineSpaceSingle
            .DisableLineHeightGrid = Not RC_USE_LINE_GRID: .WidowControl = False: .KeepWithNext = False: .KeepTogether = False
        End With
    End With
    title = RC_TITLE_PREFIX & newDoc("title") & RC_TITLE_SUFFIX
    doc.Content.Text = title & vbCr & RC_LEGEND_TEXT & vbCr
    With doc.Paragraphs(1).Range
        .Style = wdStyleTitle
        .Font.Name = RC_TITLE_FONT: .Font.NameFarEast = RC_TITLE_FONT: .Font.Size = RC_TITLE_SIZE
        .Font.Bold = RC_TITLE_BOLD: .Font.Color = RC_Color(RC_TITLE_COLOR): .Font.Underline = wdUnderlineNone
        .ParagraphFormat.Alignment = RC_TITLE_ALIGN
        .ParagraphFormat.SpaceBefore = 0: .ParagraphFormat.SpaceAfter = RC_TITLE_AFTER_PT
        .ParagraphFormat.KeepWithNext = True
        .ParagraphFormat.Borders.Enable = False
    End With
    With doc.Paragraphs(2).Range
        .Font.Name = RC_LEGEND_FONT: .Font.NameFarEast = RC_LEGEND_FONT: .Font.Size = RC_LEGEND_SIZE
        .Font.Bold = RC_LEGEND_BOLD: .Font.Color = RC_Color(RC_LEGEND_COLOR)
        .ParagraphFormat.Alignment = RC_LEGEND_ALIGN
        .ParagraphFormat.KeepWithNext = True
    End With
    Set range = doc.range(doc.Content.End - 1, doc.Content.End - 1)
    Set tbl = doc.Tables.Add(range, rows.Count + 1, 2)
    tbl.AllowAutoFit = False
    tbl.PreferredWidthType = wdPreferredWidthPoints
    tbl.PreferredWidth = MillimetersToPoints(RC_NEW_COLUMN_MM + RC_OLD_COLUMN_MM)
    tbl.Columns(1).Width = MillimetersToPoints(RC_NEW_COLUMN_MM)
    tbl.Columns(2).Width = MillimetersToPoints(RC_OLD_COLUMN_MM)
    tbl.TopPadding = MillimetersToPoints(RC_CELL_TOP_MM): tbl.BottomPadding = MillimetersToPoints(RC_CELL_BOTTOM_MM)
    tbl.LeftPadding = MillimetersToPoints(RC_CELL_MARGIN_MM): tbl.RightPadding = MillimetersToPoints(RC_CELL_MARGIN_MM)
    tbl.Rows.Alignment = RC_TABLE_ALIGN
    tbl.Rows.HeightRule = wdRowHeightAuto
    tbl.Rows.AllowBreakAcrossPages = RC_ALLOW_ROW_BREAK
    tbl.range.Cells.VerticalAlignment = wdCellAlignVerticalTop
    tbl.range.Font.Name = RC_BODY_FONT: tbl.range.Font.NameFarEast = RC_BODY_FONT
    tbl.range.Font.Size = RC_BODY_SIZE: tbl.range.Font.Bold = RC_BODY_BOLD: tbl.range.Font.Color = RC_Color(RC_BODY_COLOR)
    tbl.range.ParagraphFormat.Alignment = RC_BODY_ALIGN
    tbl.range.ParagraphFormat.SpaceBefore = RC_BODY_BEFORE_PT: tbl.range.ParagraphFormat.SpaceAfter = RC_BODY_AFTER_PT
    tbl.Borders.Enable = False
    RC_SetBorder tbl.Borders(wdBorderTop), RC_OUTER_BORDER
    RC_SetBorder tbl.Borders(wdBorderBottom), RC_OUTER_BORDER
    RC_SetBorder tbl.Borders(wdBorderLeft), RC_OUTER_BORDER
    RC_SetBorder tbl.Borders(wdBorderRight), RC_OUTER_BORDER
    RC_SetBorder tbl.Borders(wdBorderVertical), RC_CENTER_BORDER
    RC_SetBorder tbl.Borders(wdBorderHorizontal), RC_BODY_HORIZONTAL_BORDER
    tbl.Cell(1, 1).range.Text = RC_NEW_LABEL: tbl.Cell(1, 2).range.Text = RC_OLD_LABEL
    With tbl.Rows(1)
        .HeadingFormat = RC_REPEAT_HEADER
        .AllowBreakAcrossPages = False
        .range.Font.Name = RC_HEADER_FONT: .range.Font.NameFarEast = RC_HEADER_FONT: .range.Font.Size = RC_HEADER_SIZE
        .range.Font.Bold = RC_HEADER_BOLD: .range.Font.Color = RC_Color(RC_HEADER_COLOR)
        .range.ParagraphFormat.Alignment = RC_HEADER_ALIGN
        .Shading.BackgroundPatternColor = RC_HeaderFill()
    End With
    RC_SetBorder tbl.Cell(1, 1).Borders(wdBorderBottom), RC_HEADER_BORDER
    RC_SetBorder tbl.Cell(1, 2).Borders(wdBorderBottom), RC_HEADER_BORDER
    For i = 1 To rows.Count
        Set row = rows(i)
        RC_FillCell tbl.Cell(i + 1, 1), row, "new"
        RC_FillCell tbl.Cell(i + 1, 2), row, "old"
    Next i
    If bodyRows = 0 Then
        ' 空の変更表に変更条文を捏造しない。状態は文書プロパティへ。
        doc.BuiltInDocumentProperties("Comments") = "掲載対象の変更はありません。本文・見出し・番号に変更がなく、最新履歴のみ別途掲載します。"
    End If
    ' Normal由来の偶数/先頭ページ用フッターが残っても、全ページに同じ規程名を出す。
    For i = 1 To 3
        With doc.Sections(1).Footers(i).range
            If RC_SHOW_FOOTER Then .Text = RC_FOOTER_PREFIX & newDoc("title") & RC_FOOTER_SUFFIX Else .Text = ""
            .Style = wdStyleFooter
            .Font.Name = RC_FOOTER_FONT: .Font.NameFarEast = RC_FOOTER_FONT: .Font.Size = RC_FOOTER_SIZE
            .Font.Bold = RC_FOOTER_BOLD: .Font.Color = RC_Color(RC_FOOTER_COLOR): .Font.Hidden = False: .Font.Underline = wdUnderlineNone
            .ParagraphFormat.Alignment = RC_FOOTER_ALIGN
            .ParagraphFormat.SpaceBefore = 0: .ParagraphFormat.SpaceAfter = 0: .ParagraphFormat.KeepWithNext = False
        End With
    Next i
    ' LinesPageは実機で整数へ丸められる。ページ設定のLinePitchはtwipsで直接指定する。
    doc.Activate
    If RC_USE_LINE_GRID Then
        Set pageDialog = Application.Dialogs(wdDialogFilePageSetup)
        pageDialog.Update
        pageDialog.LinePitch = CLng(RC_GRID_PT * 20)
        pageDialog.Execute
    End If
    doc.ActiveWindow.View.TableGridlines = False
    ' 見出しのKeepWithNextは保持し、黒い段落書式記号を表示しない。
    doc.ActiveWindow.View.ShowAll = False
    doc.ActiveWindow.View.ShowParagraphs = False
    doc.Repaginate
    Set RC_OutputDocument = doc
End Function

Private Sub RC_HistoryRows(ByVal news As Collection, ByVal olds As Collection, ByVal rows As Collection, ByVal issues As Collection)
    Dim dp() As Long, i As Long, j As Long, row As Object, latest As Long, text As String
    ' 履歴の変更・削除はレポートへ保全し、表には最新の新履歴だけを載せる。
    ReDim dp(0 To news.Count + 1, 0 To olds.Count + 1)
    For i = news.Count To 1 Step -1
        For j = olds.Count To 1 Step -1
            If news(i)("raw") = olds(j)("raw") Then
                dp(i, j) = dp(i + 1, j + 1) + 1
            ElseIf dp(i + 1, j) >= dp(i, j + 1) Then
                dp(i, j) = dp(i + 1, j)
            Else
                dp(i, j) = dp(i, j + 1)
            End If
        Next j
    Next i
    i = 1: j = 1
    Do While i <= news.Count Or j <= olds.Count
        If i > news.Count Then
            RC_AddIssue issues, "末尾履歴", "旧 " & olds(j)("id"), "既存履歴の削除/変更をレポートに原文保全。表には新規程の最新履歴を掲載。", olds(j)("raw")
            j = j + 1
        ElseIf j > olds.Count Then
            i = i + 1
        ElseIf news(i)("raw") = olds(j)("raw") Then
            i = i + 1: j = j + 1
        ElseIf dp(i + 1, j) >= dp(i, j + 1) Then
            i = i + 1
        Else
            RC_AddIssue issues, "末尾履歴", "旧 " & olds(j)("id"), "既存履歴の削除/変更をレポートに原文保全。表には新規程の最新履歴を掲載。", olds(j)("raw")
            j = j + 1
        End If
    Loop
    If news.Count = 0 Then Exit Sub
    latest = 1
    For i = 1 To news.Count
        If RC_Regex(RC_HISTORY_PATTERN).Test(news(i)("raw")) Then latest = i
    Next i
    For i = latest To news.Count
        If i > latest Then text = text & vbCr
        text = text & news(i)("raw")
    Next i
    Set row = RC_BlankRow(): row("newText") = text
    row("historyGap") = (rows.Count > 0)
    rows.Add row
End Sub

Private Sub RC_ExtraRows(ByVal news As Collection, ByVal olds As Collection, ByVal rows As Collection, ByVal issues As Collection)
    Dim i As Long, n As Object, o As Object, nt As String, ot As String
    For i = 1 To news.Count + olds.Count
        If i > news.Count And i > olds.Count Then Exit For
        nt = "": ot = ""
        If i <= news.Count Then nt = news(i)("raw")
        If i <= olds.Count Then ot = olds(i)("raw")
        If nt <> ot Then rows.Add RC_TextRow(nt, ot, False, False, issues)
    Next i
End Sub

Private Sub RC_SetBorder(ByVal border As border, ByVal enabled As Boolean)
    If Not enabled Then
        border.LineStyle = wdLineStyleNone
        Exit Sub
    End If
    border.LineStyle = RC_BORDER_STYLE
    border.LineWidth = RC_BORDER_WIDTH
    border.Color = RC_Color(RC_BORDER_COLOR)
End Sub

Private Function RC_BlankRow() As Object
    Dim row As Object, ns As Collection, os As Collection
    Set row = RC_Dict(): Set ns = New Collection: Set os = New Collection
    row.Add "newText", "": row.Add "oldText", ""
    row.Add "newHeading", 0: row.Add "oldHeading", 0
    row.Add "newHeadingBlank", False: row.Add "oldHeadingBlank", False
    row.Add "newPrefix", 0: row.Add "oldPrefix", 0
    row.Add "newArticle", False: row.Add "oldArticle", False
    row.Add "newNote", "": row.Add "oldNote", ""
    row.Add "historyGap", False
    row.Add "newSpans", ns: row.Add "oldSpans", os
    Set RC_BlankRow = row
End Function

Private Function RC_TextRow(ByVal news As String, ByVal olds As String, ByVal allNew As Boolean, ByVal allOld As Boolean, ByVal issues As Collection) As Object
    Dim row As Object, diff As Object
    Set row = RC_BlankRow()
    row("newText") = news: row("oldText") = olds
    If allNew Or allOld Then
        If allNew Then RC_AddSpan row("newSpans"), 1, Len(news)
        If allOld Then RC_AddSpan row("oldSpans"), 1, Len(olds)
    Else
        Set diff = RC_Diff(news, olds)
        Set row("newSpans") = diff("new"): Set row("oldSpans") = diff("old")
        If diff("fallback") Then RC_AddIssue issues, "下線", "長文", "差分サイズ上限のため、共通先頭/末尾を除く範囲にまとめて下線。Wordで調整可能。", news & vbCrLf & olds
    End If
    Set RC_TextRow = row
End Function

Private Sub RC_ArticleRows(ByVal pair As Object, ByVal rows As Collection, ByVal issues As Collection)
    Dim nn As Object, oo As Object, child As Variant, first As Boolean, nh As String, oh As String
    Set nn = pair("new"): Set oo = pair("old")
    If oo Is Nothing Then
        RC_WholeRows nn, rows, True, True, issues
    ElseIf nn Is Nothing Then
        RC_WholeRows oo, rows, False, True, issues
    Else
        nh = nn("heading"): oh = oo("heading"): first = True
        For Each child In pair("children")
            RC_UnitRows child, rows, nh, oh, False, issues
            nh = "": oh = "": first = False
        Next child
    End If
End Sub

Private Sub RC_WholeRows(ByVal node As Object, ByVal rows As Collection, ByVal newSide As Boolean, ByVal first As Boolean, ByVal issues As Collection)
    Dim child As Variant, row As Object, text As String, key As String, other As String
    If newSide Then key = "new": other = "old" Else key = "old": other = "new"
    If node("kind") = "article" Then
        For Each child In node("children")
            RC_WholeRows child, rows, newSide, first, issues
            If first Then
                Set row = rows(rows.Count - RC_DescendantCount(child))
                RC_PrependHeading row, key, node("heading"), True
                If Len(node("heading")) > 0 Then
                    row(other & "Text") = vbCr & row(other & "Text")
                    row(other & "HeadingBlank") = True
                End If
            End If
            first = False
        Next child
        Exit Sub
    End If
    Set row = RC_BlankRow(): text = node("raw")
    row(key & "Text") = text
    row(key & "Prefix") = Len(node("prefix"))
    row(key & "Article") = RC_Regex(RC_ARTICLE_PATTERN).Test(text)
    RC_AddSpan row(key & "Spans"), 1, Len(text)
    If first Then
        If newSide Then row(other & "Text") = RC_NEW_NOTE Else row(other & "Text") = RC_DELETED_NOTE
        row(other & "Note") = row(other & "Text")
    End If
    rows.Add row
    For Each child In node("children")
        RC_WholeRows child, rows, newSide, False, issues
    Next child
End Sub

Private Function RC_DescendantCount(ByVal node As Object) As Long
    Dim child As Variant, count As Long
    For Each child In node("children")
        count = count + 1 + RC_DescendantCount(child)
    Next child
    RC_DescendantCount = count
End Function

Private Sub RC_UnitRows(ByVal pair As Object, ByVal rows As Collection, ByVal nh As String, ByVal oh As String, ByVal whole As Boolean, ByVal issues As Collection)
    Dim nn As Object, oo As Object, row As Object, child As Variant, diff As Object, fullBody As Boolean
    Dim beforeCount As Long
    Set nn = pair("new"): Set oo = pair("old")
    beforeCount = rows.Count
    If nn Is Nothing Then
        RC_WholeRows oo, rows, False, True, issues
    ElseIf oo Is Nothing Then
        RC_WholeRows nn, rows, True, True, issues
    Else
        fullBody = (nn("body") <> oo("body")) Or nn("kind") = "history" Or nn("kind") = "unknown"
        For Each child In pair("children")
            If RC_PairChanged(child) Then fullBody = True
        Next child
        Set row = RC_BlankRow()
        RC_RenderSide row, "new", nn, fullBody, RC_UNCHANGED_NOTE
        RC_RenderSide row, "old", oo, fullBody, RC_OMITTED_NOTE
        Set diff = RC_Diff(nn("prefix"), oo("prefix"))
        RC_CopySpans diff("new"), row("newSpans"), 0
        RC_CopySpans diff("old"), row("oldSpans"), 0
        If fullBody Then
            Set diff = RC_Diff(nn("body"), oo("body"))
            RC_CopySpans diff("new"), row("newSpans"), Len(nn("prefix")) + Len(nn("gap"))
            RC_CopySpans diff("old"), row("oldSpans"), Len(oo("prefix")) + Len(oo("gap"))
            If diff("fallback") Then RC_AddIssue issues, "下線", nn("id"), "長文の下線を共通先頭/末尾以外の一区間として暫定設定。", nn("body") & vbCrLf & oo("body")
        End If
        rows.Add row
        For Each child In pair("children")
            RC_UnitRows child, rows, "", "", whole, issues
        Next child
    End If
    If rows.Count > beforeCount Then
        Set row = rows(beforeCount + 1)
        RC_PrependHeading row, "new", nh, False
        RC_PrependHeading row, "old", oh, False
        Set diff = RC_Diff(nh, oh)
        RC_CopySpans diff("new"), row("newSpans"), 0
        RC_CopySpans diff("old"), row("oldSpans"), 0
    End If
End Sub

Private Sub RC_RenderSide(ByVal row As Object, ByVal key As String, ByVal node As Object, ByVal fullBody As Boolean, ByVal note As String)
    If fullBody Then
        row(key & "Text") = node("raw")
    Else
        ' 番号は左に残し、注記はセル中央の中央揃えタブへ置く。
        row(key & "Text") = node("prefix") & vbTab & note
        row(key & "Note") = note
    End If
    row(key & "Prefix") = Len(node("prefix"))
    row(key & "Article") = RC_Regex(RC_ARTICLE_PATTERN).Test(node("raw"))
End Sub

Private Sub RC_CopySpans(ByVal source As Collection, ByVal target As Collection, ByVal offset As Long)
    Dim span As Variant
    For Each span In source
        RC_AddSpan target, span("start") + offset, span("length")
    Next span
End Sub

Private Sub RC_PrependHeading(ByVal row As Object, ByVal key As String, ByVal heading As String, ByVal underlined As Boolean)
    Dim span As Variant
    If Len(heading) = 0 Then Exit Sub
    row(key & "Text") = heading & vbCr & row(key & "Text")
    row(key & "Heading") = Len(heading)
    For Each span In row(key & "Spans")
        span("start") = span("start") + Len(heading) + 1
    Next span
    If underlined Then RC_AddSpan row(key & "Spans"), 1, Len(heading)
End Sub

Private Sub RC_FillCell(ByVal cell As cell, ByVal row As Object, ByVal key As String)
    Dim range As range, part As range, span As Variant, offset As Long, heading As Long, prefix As Long
    Dim note As String
    Set range = cell.range.Duplicate: range.End = range.End - 1
    range.Text = row(key & "Text")
    Set range = cell.range.Duplicate
    range.End = range.Start + Len(row(key & "Text"))
    range.Font.Name = RC_BODY_FONT: range.Font.NameFarEast = RC_BODY_FONT
    range.Font.Size = RC_BODY_SIZE: range.Font.Bold = RC_BODY_BOLD: range.Font.Color = RC_Color(RC_BODY_COLOR): range.Font.Underline = wdUnderlineNone
    With range.ParagraphFormat
        .Alignment = RC_BODY_ALIGN
        .SpaceBefore = RC_BODY_BEFORE_PT: .SpaceAfter = RC_BODY_AFTER_PT: .LineSpacingRule = wdLineSpaceSingle
        .DisableLineHeightGrid = Not RC_USE_LINE_GRID: .KeepWithNext = False: .KeepTogether = False: .WidowControl = False
    End With
    heading = row(key & "Heading"): prefix = row(key & "Prefix")
    If heading > 0 Then
        Set part = cell.range.Duplicate: part.End = part.Start + heading
        part.Font.Name = RC_HEADING_FONT: part.Font.NameFarEast = RC_HEADING_FONT
        part.Font.Size = RC_HEADING_SIZE: part.Font.Bold = RC_HEADING_BOLD: part.Font.Color = RC_Color(RC_HEADING_COLOR)
        part.ParagraphFormat.SpaceBefore = RC_HEADING_BEFORE_PT
        part.ParagraphFormat.KeepWithNext = True
        offset = heading + 1
    ElseIf row(key & "HeadingBlank") Then
        ' 反対側の見出し1行を空け、注記を第1項の開始行にそろえる。
        Set part = cell.range.Paragraphs(1).range
        part.Font.Name = RC_HEADING_FONT: part.Font.NameFarEast = RC_HEADING_FONT: part.Font.Size = RC_HEADING_SIZE
        part.ParagraphFormat.SpaceBefore = RC_HEADING_BEFORE_PT
        part.ParagraphFormat.KeepWithNext = True
        offset = 1
    End If
    If row(key & "Article") And prefix > 0 Then
        Set part = cell.range.Duplicate: part.Start = part.Start + offset: part.End = part.Start + prefix
        part.Font.Name = RC_HEADING_FONT: part.Font.NameFarEast = RC_HEADING_FONT
        part.Font.Size = RC_HEADING_SIZE: part.Font.Bold = RC_HEADING_BOLD: part.Font.Color = RC_Color(RC_HEADING_COLOR)
    End If
    note = row(key & "Note")
    If Len(note) > 0 Then
        Set part = range.Duplicate: part.Start = part.Start + offset
        With part.ParagraphFormat
            .LeftIndent = 0: .RightIndent = 0: .FirstLineIndent = 0
            .TabStops.ClearAll
            If prefix > 0 Then
                .Alignment = wdAlignParagraphLeft
                .TabStops.Add Position:=(cell.Width - cell.LeftPadding - cell.RightPadding) * RC_NOTE_TAB_POSITION, Alignment:=RC_NOTE_TAB_ALIGN, Leader:=wdTabLeaderSpaces
            Else
                .Alignment = RC_NOTE_ALIGN
                cell.VerticalAlignment = wdCellAlignVerticalTop
            End If
        End With
    End If
    If row("historyGap") Then cell.range.Paragraphs(1).Format.SpaceBefore = RC_HISTORY_GAP_PT
    For Each span In row(key & "Spans")
        If span("start") > 0 And span("start") + span("length") - 1 <= Len(row(key & "Text")) Then
            Set part = cell.range.Duplicate
            part.Start = part.Start + span("start") - 1: part.End = part.Start + span("length")
            part.Font.Underline = RC_DIFF_UNDERLINE
        End If
    Next span
End Sub
