Land of Lisp 第7章

graph.lisp

;; 使い方
;; 有向グラフ (graph->png "graph.dot" *wizard-nodes* *wizard-edges*)
;; 無向グラフ (ugraph->png "ugraph.dot" *wizard-nodes* *wizard-edges*)

(defparameter *wizard-nodes* '((living-room (you are in the living-room.
                                a wizrd is snoring loudly on the couch.))
                               (garden (you are in a beautiful garden.
                                there is a well infront of you.))
                               (attic (you are in the attic.
                                there is a giant welding torch in the corner.))))

(defparameter *wizard-edges* '((living-room (garden west door)
                                            (attic upstairs ladder))
                               (garden (living-room east door))
                               (attic (living-room downstairs ladder))))

(defparameter *max-label-length* 30)

;; 英数字以外の文字を_で置き換える
(defun dot-name (exp)
  (substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp)))

;; *max-label-length*の長さに文字列を丸める
(defun dot-label (exp)
  (if exp
    (let ((str (write-to-string exp :pretty nil)))
      (if (> (length str) *max-label-length*)
          (concatenate 'string (subseq str 0 (- *max-label-length* 3)) "...")
          str))
    ""))

;; nodeのDOT情報を生成する
(defun nodes->dot (nodes)
  (mapc (lambda (node)
          (fresh-line)
          (princ (dot-name (car node)))
          (princ "[label=\"")
          (princ (dot-label node))
          (princ "\"];"))
        nodes))

;; edgeのDOT情報を生成する
(defun edges->dot (edges)
  (mapc (lambda (node)
          (mapc (lambda (edge)
                  (fresh-line)
                  (princ (dot-name (car node)))
                  (princ "->")
                  (princ (dot-name (car edge)))
                  (princ "[label=\"")
                  (princ (dot-label (cdr edge)))
                  (princ "\"];"))
                (cdr node)))
        edges))

;; graph情報(nodes edges)から、DOTデータを生成する
(defun graph->dot (nodes edges)
  (princ "digraph {")
  (nodes->dot nodes)
  (edges->dot edges)
  (fresh-line)
  (princ "}"))

;; thunkの出力からfnameというDOTファイルを作成
;; シェルでdotコマンドを実行しPNG画像を生成する
(defun dot->png (fname thunk)
  ;; with-open-fileの第一引数はstream
  ;; ここでは*standard-output*という標準出力先の格納されたダイナミック変数を渡しており
  ;; このスコープ内での標準出力がfnameへと向かうことになる
  (with-open-file (*standard-output*
                   fname
                   :direction :output
                   :if-exists :supersede)
    ;; thunk呼び出し先でもダイナミック変数の書き換えは有効
    (funcall thunk))
  (ext:shell (concatenate 'string "dot -Tpng -O " fname)))

;; dot->pngをラップしたメソッド
;; graph情報(nodes edges)から、有向グラフのPNG画像を生成する
(defun graph->png (fname nodes edges)
  (dot->png fname
            (lambda ()
              (graph->dot nodes edges))))


;;;;;;;;;; 無向グラフ ;;;;;;;;;;
;; 同じノード同士を結ぶ複数の有向エッジが存在すれば、まとめて一つの無向エッジとして扱う
(defun uedges->dot (edges)
  ;; maplistを使って現在の要素だけでなく残りの要素を走査している
  (maplist (lambda (lst) 
            (mapc (lambda (edge) ;; edge => living-room
                    ;; 現在要素のedge(ex. living-room)が残りの要素に含まれていなければ
                    (unless (assoc (car edge) (cdr lst)) 
                      (fresh-line)
                      (princ (dot-name (caar lst)))
                      (princ "--")
                      (princ (dot-name (car edge)))
                      (princ "[label=\"")
                      (princ (dot-label (cdr edge)))
                      (princ "\"];")))
                  (cdar lst)))
          edges))

(defun ugraph->dot (nodes edges)
  (princ "graph {") ;; ここだけ有向グラフと違う所
  (nodes->dot nodes)
  (uedges->dot edges)
  (fresh-line)
  (princ "}"))

(defun ugraph->png (fname nodes edges)
  (dot->png fname
            (lambda ()
              (ugraph->dot nodes edges))))