いちばん長いしりとり in Other DouKaku?

単語のリストを読み込んで、そのリストにある単語で「しりとり」をします。
一番長くしりとりを続けるためのプログラムを書いてください。
また、単語数に対して、計算量がどのように増えていくかも考えて下さい。

なお、単語リストの一例として
http://www.ais.riec.tohoku.ac.jp/lab/wordlist/index-j.htmlで公開されている
http://www.ais.riec.tohoku.ac.jp/lab/wordlist/fam55_40.txtがあります。

ただし、
・一度使った単語は使わないこと(リストに重複がある可能性は考えなくてよい)
・「ん」で終わる単語を使用するか、リスト内にしりとりを続けられる単語がなくなったときに、しりとりは終了する
・一番最初は、好きな単語から初めてもよい
・「一番長くしりとりを続ける」とは、しりとりが終了するまでに使用する単語数が最大になるよう、しりとりの単語を選ぶことをいう

see: 難聴者のための単語了解度試験用単語リスト

非常に単純な実装。およそO(N!)のため、Nは100前後が限界です。

% longtail <longtail.data

implement Longtail;

include "sys.m";
    sys: Sys;
include "draw.m";
include "bufio.m";
    bufio: Bufio;
    Iobuf: import bufio;
include "string.m";
    str: String;

Longtail: module
{
    init: fn(ctxt: ref Draw->Context, argv: list of string);
};

Word: adt
{
    s: string;
    used: int;
};

MAXRUNE: con 16rffff;

tab := array[MAXRUNE] of list of ref Word;

init(nil: ref Draw->Context, nil: list of string)
{
    sys = load Sys Sys->PATH;
    bufio = load Bufio Bufio->PATH;
    str = load String String->PATH;

    install(sys->fildes(0));

    wstart := ref Word("シリトリ", 0);
    result := chain(wstart);
    for(p := result; p != nil; p = tl p)
        sys->print("%s\n-> ", (hd p).s);
    sys->print("END\n");
}

install(fd: ref Sys->FD)
{
    fin := bufio->fopen(fd, bufio->OREAD);
    while((t := fin.gett(" \t\n")) != nil){
        (t, nil) = str->splitl(t, " \t\n");
        if(t == "")
            continue;
        tab[t[0]] = ref Word(t, 0) :: tab[t[0]];
    }
}

chain(w: ref Word): list of ref Word
{
    longest: list of ref Word;

    w.used = 1;
    lastc := w.s[len w.s - 1];
    for(p := tab[lastc]; p != nil; p = tl p){
        w1 := hd p;
        if(w1.used)
            continue;
        t := chain(w1);
        if(len t > len longest)
            longest = t;
    }
    w.used = 0;
    return w :: longest;
}

何度もすみません、また誤りがあったので訂正します。

よく確認してから投稿します。お目汚し失礼致しました。

67:        for(j = 0; j < n; i++)
68:        {
69:            check[i] = 1;
70:        }
↓
67:        for(j = 0; j < n; j++)
68:        {
69:            check[j] = 1;
70:        }

Ｆ＃で書いてみました。単語の最初と最後の文字の組み合わせで、２次元配列を作り、それをもとにして、全探索しています。計算量はO(N!)だと思います。 100までで、２２個カザアナ-> ナニゴト-> トリモノ-> ノリニゲ-> ゲレツサ-> サンバシ-> シールド-> ドウナガ-> ガイユウ-> ウラガネ-> ネンブツ-> ツジツマ-> マヤカシ-> シタヅミ-> ミズヒキ-> キヤクアシ-> シヨウワル-> ルイベツ-> ツユザム-> ムスビメ-> メイフク-> クタビレが最大のもののひとつです。 130で３２個ですが、これで１分かかりますので限界です。

open System.IO

//小文字を大文字に変換
let ConvH (str:string) =
    str.Replace("ァ","ア").Replace("ィ","イ").Replace("ゥ","ウ").Replace("ェ","エ").Replace("ォ","オ")
        .Replace("ヵ","カ").Replace("ヶ","ケ").Replace("ッ","ツ").Replace("ャ","ヤ").Replace("ュ","ユ")
        .Replace("ョ","ヨ").Replace("ヮ","ワ")
             
//ファイルの文字列を大文字化してリストに収める
let wordList = [
                    use fileReader = new StreamReader("s:\word2.text") 
                    while not fileReader.EndOfStream do
                        let line = fileReader.ReadLine()
                        let strs = line.Split( [| '\t' |])
                        for st in strs do
                            if st <> "" then
                                yield ConvH (st)
                 ]

let IcharSet = List.fold (fun (chset:char Set) (str:string) -> Set.add str.[0] chset) (Set.Empty)  wordList    
let ITcharSet = List.fold (fun (chset:char Set) (str:string) -> Set.add (str.[str.Length - 1]) chset) IcharSet  wordList    
let UsedCharList = Set.to_list ITcharSet //先頭か末尾で使われている文字のリスト

let KanaLen = List.length  UsedCharList

//カナのindexを返す
let posOfKana (ch : char) =
    List.findIndex (fun x -> x = ch) UsedCharList
   
//対応表用の配列　サイズ KanaLen * KanaLen
let respT = [| for i in 0 .. (KanaLen - 1) do
                    yield (Array.create KanaLen 0) |]

for s in wordList do
    let topStr = s.[0]
    let endStr = s.[s.Length - 1]
    let topStrIndex = posOfKana topStr
    let endStrIndex = posOfKana endStr
    respT.[topStrIndex].[endStrIndex] <- respT.[topStrIndex].[endStrIndex] + 1  

let tempWordIndexArr = Array.create wordList.Length 0
let deepestWordIndexArr = Array.create wordList.Length 0                

// topIndex..何で始まるのから調べるか 
let rec search depth deepest topIndex  (arr :int [] []) (indexArr :int []) =
    for i in  0 ..(KanaLen - 1) do
        if arr.[topIndex].[i] > 0 then
            
            indexArr.[depth] <- topIndex
            indexArr.[depth+1] <- i
            arr.[topIndex].[i] <- arr.[topIndex].[i] - 1
            
            if depth + 1 > !deepest then
               deepest := depth + 1
               for i in 0 .. !deepest do
                    deepestWordIndexArr.[i] <- indexArr.[i]
          
            search (depth + 1) deepest i arr indexArr
            
            arr.[topIndex].[i] <- arr.[topIndex].[i] + 1

let maxDepth = ref 0

for i in 0 .. (KanaLen - 1) do
    if Array.sum respT.[i] > 0 then
        search 0 maxDepth i respT tempWordIndexArr

printfn "最大連結個数: %A" !maxDepth   

//結果表示用の補助関数
//index iで始まりjで終わる単語をリストから抜き出して、その単語とその単語を除いたリストを返す
let findAndPop (i,j) lst =
    let rec sub (passedLst : string list)  (yetLst : string list) =
       match yetLst with
       | [] -> failwith "dont find"
       | h :: tl when posOfKana h.[0] = i && posOfKana h.[h.Length - 1] = j 
                -> (h,passedLst @ tl)
       | h :: tl -> sub (passedLst @ [h]) tl
    sub [] lst            

//結果表示用
let rec dispResult lst i =
    if i = !maxDepth then
        ()
    else 
        let (word,remLst) = findAndPop ( deepestWordIndexArr.[i],deepestWordIndexArr.[i+1]) lst
        printf "-> %s" word
        dispResult remLst (i + 1)

dispResult wordList 0

DouKaku?

いちばん長いしりとり

Posted feedbacks - Other

Index

Feed

Other

Link

Pathtraq