Generalized LR法をHaskellで Part2

前回はXML風に木を出力するという機能をつけていましたが、本命はDOT言語に出力する事です。
そっちのほうが確認しやすいからね。というわけで付けてみました。
以下は変更した部分だけ

-- ParseTreeをDOT言語として出力
type IndentLevel = Int
--- インデントをスペースでつける
putIndent :: Handle -> IndentLevel -> IO ()
putIndent h ident = hPutStr h $ take ident (repeat ' ')

--- 辺を出力(始点はかならずforkである)
printEdge :: Handle -> Int -> Int -> ParseTree -> IO ()
printEdge h tid nid (Fork _ _) = hPrintf h "f%d -> f%d;\n" tid nid
printEdge h tid nid (Leaf _) = hPrintf h "f%d -> n%d;\n" tid nid

type MaxId = Int
parseTree2DOT' :: Handle -> MaxId -> ParseTree -> IO Int
parseTree2DOT' h i (Leaf token) = do {
      putIndent h 8;
      hPrintf h "n%d [label=\"%s (%s)\"];\n" i (token^.str) (show (token^.tp));
      return (i+1);
}
parseTree2DOT' h i (Fork ntp ts) = do {
      putIndent h 8;
      hPrintf h "f%d [label=\"%s\"];\n" i (show ntp);
      foldM (\a b -> do {
                  putIndent h 8;
                  printEdge h i a b;
                  parseTree2DOT' h a b;
                  }) (i+1) ts;
}

parseTree2DOT :: Handle -> ParseTree -> IO ()
parseTree2DOT h t@(Fork _ _) = do {
      hPutStrLn h "digraph parsetree {";
      parseTree2DOT' h 0 t;
      hPutStrLn h "}";
}

-- Maybe ParseTreeのListを個別のファイルに出力
type FilenamePrefix = String
outputTrees :: FilenamePrefix -> [Maybe ParseTree] ->  IO ()
outputTrees prefix ts = do {
    foldM_ (\i t -> do {
      withFile (prefix ++ (show i) ++ ".dot") WriteMode (\h -> case (ts !! i) of
                                                                 Just t -> do {parseTree2DOT h t; return (i+1)};
                                                                 Nothing -> return i)
    }) 0 ts;
}

-- 英文を構文解析して生成された構文木を全通りDOTファイルに出力
main = do {
  let trees = generalizedLR englishSentence englishLang in do {
          outputTrees "parse" trees;
  };
}

System.IOのHandleを利用するようにして、出力先を簡単に変えられるようにしました。
出力されるファイルはたとえば以下のような物で。

digraph parsetree {
        f0 [label="S"];
        f0 -> f1;
        f1 [label="NP"];
        f1 -> n2;
        n2 [label="I (Noun)"];
        f0 -> f3;
        f3 [label="VP"];
        f3 -> n4;
        n4 [label="saw (Verb)"];
        f3 -> f5;
        f5 [label="NP"];
        f5 -> f6;
        f6 [label="NP"];
        f6 -> n7;
        n7 [label="a (Det)"];
        f6 -> n8;
        n8 [label="man (Noun)"];
        f5 -> f9;
        f9 [label="PP"];
        f9 -> n10;
        n10 [label="with (Prep)"];
        f9 -> f11;
        f11 [label="NP"];
        f11 -> f12;
        f12 [label="NP"];
        f12 -> n13;
        n13 [label="a (Det)"];
        f12 -> n14;
        n14 [label="telescope (Noun)"];
        f11 -> f15;
        f15 [label="PP"];
        f15 -> n16;
        n16 [label="in (Prep)"];
        f15 -> f17;
        f17 [label="NP"];
        f17 -> n18;
        n18 [label="the (Det)"];
        f17 -> n19;
        n19 [label="park (Noun)"];
}

と綺麗に出力されます。mainの設定ですと、parse0.dot,parse1.dot...というファイルたちに出力されます。
こいつをgraphvizで処理すると

のように構文木が確認できます。望遠鏡が公園に居る感じになってておもしろいですね。