text.treeの使用例

「Gaucheでの文字列の作り方のメモ」だけだとtext.treeの機能がstring-appendやstring-concatenateとあまり変わらないように見えるので、追加で使用例をあげる。
text.treeモジュールは、文字列の断片を集めて文字列を作り、作った文字列をさらに集めてもっと大きな文字列を作り……という場合に使う。実際には途中では文字列を作らずリストにしておき、最後にwrite-treeやtree->stringを呼び出して目的のものを得る。
実際の使用例としてtext.html-liteモジュールがあるのでそれを参照しても良いけど、別の例としてGraphiviz用のファイルを作る場合を考えてみる。例えばSchemeプログラムで有向グラフを扱っていたとして、この有向グラフを画像として出力したい場合になんかにGraphvizを使うことができる。ただし、Graphivizではグラフの記述にDot言語という言語を使っているので、Dot言語のテキストを作らないといけない。

Scheme上ではノードaからノードbへのエッジを(a b)で表していたとすると、Dot言語のテキストでは

a -> b;

となる。有向グラフ全体が

((a b)
 (a c)
 (a d)
 (c d)
 (c e))

というリストで表されていたら、Dot言語では

digraph G {
 a -> b;
 a -> c;
 a -> d;
 c -> d;
 c -> e;
}

と表される。この変換はtext.treeモジュールを使って次のように書ける。文字列のリストが入れ子になっているので、string-appendやstring-concatenateではうまくいかない。

(use text.tree)
(define (dgraph->dot dgraph)
  (list
    "digraph G {\n"
    (map (lambda (x) #`",(car x) -> ,(cadr x);\n") dgraph)
    "}\n"))

(write-tree (dgraph->dot '((a b) (a c) (a d) (c d) (c e))))

直接画像ファイルに変換したいなら、さらに追加して

(use gauche.process)
(define (dgraph->png-file dgraph file)
  (call-with-output-process
    #`"dot -Kdot -Tpng >,|file|"
    (lambda (oport) (write-tree (dgraph->dot dgraph) oport))))

(dgraph->png-file '((a b) (a c) (a d) (c d) (c e)) "g.png")

などと書けば良い。
出力がもっと複雑になるプログラムを書く場合でも、文字列のツリーを作って最後にwrite-treeやtree->stringを使うのは同じ(ただ、こういうプログラムのテストをどうやって書けば良いのかがわからない)。

(use gauche.process)
(use text.tree)

(define get-id
  (let ((count 0))
    (lambda (x)
      (begin0 #`"\"node,|count|\"" (set! count (+ 1 count))))))

(define (sexp->file x file)
  (call-with-output-file
    file
    (lambda (oport) (write-tree  (make-dot-tree x) oport))))

(define (sexp->image-file x file lang)
  (call-with-output-process
    #`"dot -Kdot -T,|lang| >,|file|"
    (lambda (oport) (write-tree  (make-dot-tree x) oport))))

(define (sexp->png-file x file)
  (sexp->image-file x file "png"))

(define (make-dot-tree x)
  (list 
    "digraph list {\n"
    "node [shape=plaintext];\n"
    "size = \"7.0, 7.0\";\n"
    (sexp->dot-tree x)
    "}\n"))

(define (sexp->dot-tree x)
  (cond
    ((pair? x) (pair->dot-tree x))
    ((null? x) (list ""))
    (else (term->dot-tree x))))

(define (term->dot-tree x)
  (list (get-id x)
        (format #f " [label = ~s];\n" (write-to-string x))))

(define (pair->dot-tree x)
  (define (cell-color x)
    (if (null? x)
      "bgcolor=\"gray\""
      ""))
  (define (pair-node-prop pair)
    (list
      " [label=<<table border=\"1\" cellspacing=\"0\">\n"
      "<tr>"
      #`"<td port=\"car\" ,(cell-color (car pair))> </td>"
      #`"<td port=\"cdr\" ,(cell-color (cdr pair))> </td>"
      "</tr>\n</table>>];\n"))

  (let* ((id (get-id x))
         (car-dot (sexp->dot-tree (car x)))
         (car-id (car car-dot))
         (cdr-dot (sexp->dot-tree (cdr x)))
         (cdr-id (car cdr-dot)))
    (list id
          (pair-node-prop x)
          (if (null? (car x))
            ""
            (list #`",|id|:car -> ,|car-id|"
                  (if (pair? (car x)) ":car;\n" "\n")))
          (if (null? (cdr x))
            ""
            (list #`",|id|:cdr -> ,|cdr-id|"
                  (if (pair? (cdr x)) ":car;\n" "\n")
                  #`"{rank = same; ,|id|; ,|cdr-id|;}\n"
                  ))
          car-dot
          cdr-dot)))

実行例:

(define x
  '(define (append xs ys)
     (if (null? xs)
       ys
       (cons (car xs) (append (cdr xs) ys)))))
(sexp->png-file x "append.png")

出力: