Amazon.co.jp： Land of LISP: Learn to Program in Lisp, One Game at a Time!: Conrad, M.D. Barski: 洋書 (http://landoflisp.com/ ) 第7章 "Going Beyond Basic Lists " にある graphviz 関連の処理 (http://landoflisp.com/graph-util.lisp ) に機能をいくつか追加し、sbcl向けに書き換えた。
subgraphs, nodes, edges, options にそれぞれ値を登録する。
| * 分類 | * 備考 |
| nodes | ノードの内部名と外部表示用の文字列(label)。後者を省略したら前者を外部に表示する。 |
| edges | ノード間の名称と外部表示用の文字列(label)。後者を省略したら何も表示しない。 |
| options | その他の設定処理を担う。 |
| subgraphs | サブグラフ用に設定する。 |
nodes と edges については、処理過程で options に統合するようにしている。
dot言語形式の文字列を出力するには digraph->dot か graph->dot を使う。
(digraph->dot *nodes* *edges* *options* *subgraphs*)
digraph G {
subgraph cluster_0 {
fontname="APJapanesefont";
label=blechmusik;
node [style=filled, fontname="APJapanesefont"];
color=blue;
nuri -> kuro -> kiri;
}
subgraph cluster_1 {
fontname="APJapanesefont";
label=kouy;
node [style=filled, fontname="APJapanesefont"];
color=red;
geta -> new;
geta -> jis;
}
subgraph cluster_2 {
fontname="APJapanesefont";
label=mogy;
node [style=filled, fontname="APJapanesefont"];
color=brown;
hiyori;
}
graph [label="下駄配列の派生図", fontname="APJapanesefont", labelloc=t, rankdir="LR"];
node [fontname="APJapanesefont"];
kuro -> hiyori [label=""];
geta [label="下駄配列"];
nuri [label="塗り下駄配列"];
jis [label="新JIS下駄配列"];
hiyori [label="日和下駄配列"];
new [label="新下駄配列"];
kuro [label="黒塗り下駄配列"];
kiri [label="黒塗り桐下駄配列"];
geta -> nuri [label=""];
geta -> hiyori [label=""];
kiri -> kuro [label=""];
}
画像を生成するには x->png や x->jpg を使う。
(x->png "z:/output.dot" #'digraph->dot *nodes* *edges* *options* *subgraphs*)
;; ========================================
;; 日本語用フォント例
;; ========================================
;; APJapanesefont
;; あんずもじ
;; http://www8.plala.or.jp/p_dolce/
;; ========================================
;;
;; ========================================
(defparameter *max-label-length* 30)
(defparameter *indent-column* 4)
(defparameter *graph-type* "digraph")
;; ========================================
;;
;; ========================================
(defparameter *subgraphs* '(
(
(:style filled)
(:fontname "APJapanesefont")
(:label blechmusik)
((node) (:style filled)
(:fontname "APJapanesefont"))
(:color blue)
((nuri kuro kiri))
)
(
(:style filled)
(:fontname "APJapanesefont")
(:label kouy)
((node) (:style filled)
(:fontname "APJapanesefont"))
(:color red)
((geta new))
((geta jis))
)
(
(:style filled)
(:fontname "APJapanesefont")
(:label mogy)
((node) (:style filled)
(:fontname "APJapanesefont"))
(:color brown)
((hiyori))
)
))
(defparameter *options* '(
(graph
(:label "下駄配列の派生図")
(:fontname "APJapanesefont")
(:labelloc t)
(:rankdir "LR")
)
(node
(:fontname "APJapanesefont")
)
((kuro hiyori))
))
(defparameter *nodes* '(
(geta ("下駄配列"))
(nuri ("塗り下駄配列"))
(jis ("新JIS下駄配列"))
(hiyori ("日和下駄配列"))
(new ("新下駄配列"))
(kuro ("黒塗り下駄配列"))
(kiri ("黒塗り桐下駄配列"))
))
(defparameter *edges* '(
(geta
;; (new)
(nuri)
;; (jis)
(hiyori)
)
(nuri
;; (kuro)
)
(kuro
(hiyori)
;; (kiri)
)
(kiri
(kuro)
)
))
;; ========================================
;;
;; ========================================
(ql:quickload :cl-ppcre)
(defun name-and-value->attr (name value)
(format nil "~A=~A" (downcase-string-or-add-double-quotation name)
(downcase-string-or-add-double-quotation value)))
(defun downcase-string-or-add-double-quotation (x)
(format nil (if (stringp x) "\"~A\"" "~(~A~)") x))
(defun from-to (from to)
(format nil "~@{~A~}" from (sign-of-connect-nodes) to))
(defun from-to* (lst)
(with-output-to-string (s)
(loop for (first . rest) on lst
do
(princ (dot-name first) s)
(when (car rest) (format s " ~A " (sign-of-connect-nodes))))))
(defun attr* (lst)
(with-output-to-string (s)
(loop for ((name value) . rest) on lst
do
(princ (name-and-value->attr name value) s)
(when rest (princ ", " s)))))
(defun :-p (x)
(eql (elt (format nil "~S" x) 0) #\:))
(defun indent-for-reading ()
(format t "~V@{~A~:*~}" *indent-column* " "))
(defun print-subgraph (subgraph)
(let ((i -1))
(mapc (lambda (graph)
(indent-for-reading)
;; cluster_ を小文字で表示しないと、subgraph が正常に表示されない
(format t "~(~A~) ~(~A~)~D ~A" "subgraph" "cluster_" (incf i) "{")
(loop for (first . rest) in (cdr graph)
do
(fresh-line)
(indent-for-reading)
(indent-for-reading)
(cond
;; color=lightgrey;
((and (symbolp first)
(:-p first))
(format t "~A;" (name-and-value->attr first (car rest))))
;; node [style=filled,color=white];
((listp first)
(princ (from-to* first))
(when rest
(princ " [")
(princ (attr* rest))
(princ "]"))
(princ ";")
)
))
(fresh-line)
(indent-for-reading)
(format t "}")
(fresh-line))
subgraph)))
;; ========================================
;;
;; ========================================
;; (nodes->alist *nodes*)
;; (edges->alist *edges*)
;; (nodes->alist-string *nodes*)
;; (edges->alist-string *edges*)
;; (options->alist-string *options*)
;; (nodes->hash-table *nodes*)
;; (edges->hash-table *edges*)
;; (options->hash-table *options*)
;; (merge-alist *nodes* *edges* *options*)
(defun nodes->alist (nodes)
(loop for node in nodes
with alist = nil
do (setf alist (acons (car node)
(dot-label (cadr node))
alist))
finally (return alist)))
(defun edges->alist (edges)
(loop for (from . to) in edges
with alist = nil
do (dolist (dest to)
(setf alist (acons (list from (car dest))
(dot-label (cdr dest))
alist)))
finally (return alist)))
(defun nodes->alist-string (x)
(x->alist-string #'nodes->alist x
:type "nodes"))
(defun edges->alist-string (x)
(x->alist-string #'edges->alist x
:type "nodes"))
(defun options->alist-string (x)
(x->alist-string #'(lambda (x) x) x
:type "options"))
(defun x->alist-string (fn x &key (type nil))
(mapcar (lambda (lst)
(case type
("nodes" (cons (dot-label (car lst)) (cdr lst)))
(otherwise (if (listp (car lst))
(cons (from-to (caar lst) (cadar lst)) (cdr lst))
(cons (dot-label (car lst)) (cdr lst))))))
(funcall fn x)))
(defun collect-hash-keys (hash-table)
(loop for key
being the hash-keys of hash-table
collect key))
(defun nodes->hash-table (x)
(x->hash-table (nodes->alist-string x)))
(defun edges->hash-table (x)
(x->hash-table (edges->alist-string x)))
(defun options->hash-table (x)
(x->hash-table (options->alist-string x)))
(defun x->hash-table (x)
(loop for lst in x
with ht = (make-hash-table :test #'equalp)
do (setf (gethash (car lst) ht) (cdr lst))
finally (return ht)))
(defun merge-alist (nodes edges options)
(labels ((nodes-hash-table ()
(nodes->hash-table nodes))
(edges-hash-table ()
(edges->hash-table edges))
(nodes-names-list ()
(collect-hash-keys (nodes-hash-table)))
(edges-names-list ()
(collect-hash-keys (edges-hash-table)))
(options-names-list ()
(collect-hash-keys (options->hash-table options)))
(intern-list (lst)
(mapcar (lambda (x) (intern x)) lst))
(set-difference-eqaul (a b)
(set-difference a b :test 'equal))
(intersection-eqaul (a b)
(intersection a b :test 'equal))
(add-new-nodes-or-edges (options comp-list hash-table)
(let* ((options-name-list (collect-hash-keys (options->hash-table options)))
(diff-list (set-difference-eqaul comp-list options-name-list)))
(mapc (lambda (x)
(let ((x-list (ppcre:split (sign-of-connect-nodes) x)))
(if (= 1 (length x-list))
;; nodes
(setf options (append options `((,(intern x) (:label ,(gethash x hash-table))))))
;; edges
(setf options (append options `((,(intern-list x-list) (:label ,(gethash x hash-table))))))
)))
diff-list)
options))
(add-attr (options comp-list hash-table old-options)
(let* ((old-options-name-list (collect-hash-keys (options->hash-table old-options)))
(intersection-list (intersection-eqaul comp-list old-options-name-list)))
(mapcar (lambda (x)
(let* ((name (if (listp (car x))
(from-to (caar x) (cadar x))
(dot-label (car x)))))
(if (member name intersection-list :test #'equal)
(multiple-value-bind (string exists)
(gethash name hash-table)
(append x `((:label ,string)))
)
x)
))
options)
))
)
(let ((new-options options))
(loop for (names-list hash-table)
in `((,(nodes-names-list) ,(nodes-hash-table))
(,(edges-names-list) ,(edges-hash-table)))
do
(setf new-options (add-new-nodes-or-edges new-options names-list hash-table))
(setf new-options (add-attr new-options names-list hash-table options)))
new-options)
))
;; ========================================
;;
;; ========================================
;; cf., Land of Lisp
(defun dot-name (exp)
(string-downcase (substitute-if #\_ (complement #'alphanumericp)
(prin1-to-string exp))))
;; cf., Land of Lisp
(defun dot-label (exp)
(labels ((show-double-quotation (s)
(ppcre:regex-replace-all "\"" s "\\\\\"")))
(if exp
(let ((s (show-double-quotation
(format nil (if (listp exp) "~{~A~^ ~}" "~A") exp))))
(if (> (length s) *max-label-length*)
(concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...")
s))
"")))
(defun sign-of-connect-nodes ()
(if (string= "digraph" *graph-type*) "->" "--"))
;; ========================================
;;
;; ========================================
(defun options->dot (options)
(loop for (name-raw . attr) in options
do
(let ((name (if (listp name-raw)
(from-to* name-raw)
(dot-name name-raw))))
(fresh-line)
(indent-for-reading)
(princ name)
(princ " [")
(princ (attr* attr))
(princ "];")
)))
(defun x->dot (nodes edges &optional (options nil) (subgraph nil))
(format t "~A G {" *graph-type*)
(fresh-line)
(print-subgraph subgraph)
(options->dot (merge-alist nodes edges options))
(fresh-line)
(princ "}"))
(defun graph->dot (nodes edges &optional (options nil) (subgraph nil))
(let ((*graph-type* "graph"))
(x->dot nodes edges options subgraph)))
(defun digraph->dot (nodes edges &optional (options nil) (subgraph nil))
(let ((*graph-type* "digraph"))
(x->dot nodes edges options subgraph)))
;; ========================================
;; generate a image file
;; ========================================
(defun dot->x (fname filetype thunk)
(with-open-file (*standard-output*
fname
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(funcall thunk))
(sb-ext:run-program "dot" (list (concatenate 'string "-T" filetype) "-O" fname) :search t))
(defun x->png (fname fn &rest args)
(dot->x fname "png" (lambda () (apply fn args))))
(defun x->gif (fname fn &rest args)
(dot->x fname "gif" (lambda () (apply fn args))))
(defun x->jpg (fname fn &rest args)
(dot->x fname "jpg" (lambda () (apply fn args))))