四字熟語パズルの作成 in VB.net DouKaku?

与えられた四字熟語のリストから下のように四角く配置することのできる熟語の組み合わせを探すプログラムを作成してください。

出力例:

無憂無風
礼　　林
千　　火
万水千山

知行合一
者　　筆
不　　勾
言語道断

四字熟語は左から右、上から下へ読むものとします。また右上隅の漢字と左下隅の漢字は異なるものでなければいけません。

四字熟語のデータは扱いやすい形(たとえばユニコード文字列のリスト)で与えられていると仮定して構いません。サンプルデータが必要であれば FOR Microsoft IME The四字熟語辞典(データ / 文書作成) にテキスト形式のデータが入っているのでそれを使えると思います。

問題の規模の参考までに、40行程度のPythonスクリプトでこのデータ(重複をのぞいて8312件)を処理してみたところ2.4GHzのCPUで13秒程度かかりました。結果は8133件出力されました。

　コマンドライン引数に、四字熟語を改行で区切って列挙したファイルのパスを指定したものとします。ファイルのパスは複数指定可です。文字コードはUnicodeです。
出力例に含まれる四字熟語を列挙したファイルでは一瞬で例と同じ出力結果が得られました。
　今、ダウンロードしたサンプルを上記形式に加工したファイルを読み込ませて実行しているのですが、待てど暮らせど終わりません。もう1時間程経ってます。
　VB.net一番乗り狙って投稿します。

Module Module1

    Sub Main(ByVal args() As String) '引数に四字熟語をCRLFで区切り列挙したテキストファイルを指定。文字コードはUnicode。ファイルは複数指定可能。
        Dim Ticks As Long = Now.Ticks
        Dim JukugoList As New List(Of String) '四字熟語のリスト  
        '四字熟語リストの読み込みループ
        For Each CmdLine As String In args
            JukugoList.AddRange(System.IO.File.ReadAllLines(CmdLine))
        Next
        JukugoPuzul(JukugoList)
        Console.WriteLine(Now.Ticks - Ticks)
        Console.ReadKey()
    End Sub

    Private Sub JukugoPuzul(ByVal JukugoList As List(Of String))
        Dim Kouho As New List(Of String())
        For Each JukugoTop As String In JukugoList '上
            For Each JukugoRight As String In JukugoList '右
                For Each JukugoBottom As String In JukugoList '下
                    For Each JukugoLeft As String In JukugoList '左
                        If JukugoTop.Substring(3, 1) = JukugoRight.Substring(0, 1) AndAlso _
                        JukugoRight.Substring(3, 1) = JukugoBottom.Substring(3, 1) AndAlso _
                        JukugoBottom.Substring(0, 1) = JukugoLeft.Substring(3, 1) AndAlso _
                        JukugoLeft.Substring(0, 1) = JukugoTop.Substring(0, 1) Then
                            If JukugoTop.Substring(3, 1) <> JukugoBottom.Substring(0, 1) Then '右上隅の漢字と左下隅の漢字は異なるものでなければいけません。
                                Dim Group() As String = {JukugoTop, JukugoRight, JukugoBottom, JukugoLeft}
                                If ChofukuCheck(Kouho, Group) Then
                                    OutPut(Group)
                                    Kouho.Add(Group)
                                End If
                            End If
                        End If
                    Next
                Next
            Next
        Next
    End Sub

    Private Function ChofukuCheck(ByVal List As List(Of String()), ByVal Kouho As String()) As Boolean
        For Each Group As String() In List
            Dim Count As Integer = 0
            For Each Jukugo As String In Group
                For Each Jukugo1 As String In Kouho
                    If Jukugo = Jukugo1 Then
                        Count += 1
                    End If
                Next
            Next
            If Count = 4 Then
                Return False
            End If
        Next
        Return True
    End Function

    Private Sub OutPut(ByVal Group() As String)
        Console.WriteLine(Group(0))
        Console.WriteLine(Group(3).Substring(1, 1) & "　　" & Group(1).Substring(1, 1))
        Console.WriteLine(Group(3).Substring(2, 1) & "　　" & Group(1).Substring(2, 1))
        Console.WriteLine(Group(2) & vbCrLf)
    End Sub

End Module

　高速化しました。
サンプル(重複あり)8,582件
結果12,117件
CPU2.0GHz　610秒orz

Module Module1

    Sub Main(ByVal args() As String) '引数に四字熟語をCRLFで区切り列挙したテキストファイルを指定。文字コードはUnicode。ファイルは複数指定可能。
        Dim Ticks As Long = Now.Ticks
        Dim JukugoList As New List(Of String) '四字熟語のリスト  
        '四字熟語リストの読み込みループ
        For Each CmdLine As String In args
            JukugoList.AddRange(System.IO.File.ReadAllLines(CmdLine))
        Next
        JukugoPuzul(JukugoList)
        Console.WriteLine((Now.Ticks - Ticks) / 10000000L & "秒")
        Console.ReadKey()
    End Sub

    Private Sub JukugoPuzul(ByVal JukugoList As List(Of String))
        Dim Kouho As New List(Of String())
        For Each JukugoTop As String In JukugoList '上
            Dim Top() As Char = JukugoTop.ToCharArray
            For Each JukugoRight As String In JukugoList '右
                Dim Right() As Char = JukugoRight.ToCharArray
                If Top(3) = Right(0) Then
                    For Each JukugoBottom As String In JukugoList '下
                        Dim Bottom() As Char = JukugoBottom.ToCharArray
                        If Right(3) = Bottom(3) Then
                            For Each JukugoLeft As String In JukugoList '左
                                Dim Left() As Char = JukugoLeft.ToCharArray
                                If Bottom(0) = Left(3) AndAlso _
                                Left(0) = Top(0) Then
                                    If Top(3) <> Bottom(0) Then '右上隅の漢字と左下隅の漢字は異なるものでなければいけません。
                                        Dim Group() As String = {JukugoTop, JukugoRight, JukugoBottom, JukugoLeft}
                                        If ChofukuCheck(Kouho, Group) Then
                                            OutPut(Group)
                                            Kouho.Add(Group)
                                        End If
                                    End If
                                End If
                            Next
                        End If
                    Next
                End If
            Next
        Next
        Console.WriteLine(Kouho.Count & "組の組み合わせがありました。")
    End Sub

    Private Function ChofukuCheck(ByVal List As List(Of String()), ByVal Kouho As String()) As Boolean
        For Each Group As String() In List
            Dim Count As Integer = 0
            For Each Jukugo As String In Group
                For Each Jukugo1 As String In Kouho
                    If Jukugo = Jukugo1 Then
                        Count += 1
                    End If
                Next
            Next
            If Count = 4 Then
                Return False
            End If
        Next
        Return True
    End Function

    Private Sub OutPut(ByVal Group() As String)
        Console.WriteLine(Group(0))
        Console.WriteLine(Group(3).Substring(1, 1) & "　　" & Group(1).Substring(1, 1))
        Console.WriteLine(Group(3).Substring(2, 1) & "　　" & Group(1).Substring(2, 1))
        Console.WriteLine(Group(2) & vbCrLf)
    End Sub

End Module

重複無しの8312件を食わせて走らせてみました。
OS:Windows XP Home SP2
CPU:AMD Sempron 3400+ 1.99GHz
メモリ:480MB
処理時間:507.078125秒
件数:12117件

　組み合わせた後に重複チェックをしているので、元データの重複は件数に影響しないようです。
　僕は
>四角く配置することのできる熟語の組み合わせを探すプログラム
と言うところに着目して、同じ熟語の組み合わせなら、四角に組む順番が違っても同一の組み合わせと判断して結果から除いています。
　もっと厳密に定義をすれば件数が揃うんじゃないでしょうか。
　それよりも、この桁違いの遅さは何なんでしょうorz .NETだからって極端に遅いって事も無いと思うのですが…。

DouKaku?

四字熟語パズルの作成

Posted feedbacks - VB.net

Index

Feed

Other

Link

Pathtraq