Land of Lisp 第8章

grand_theft_wumps.lisp

(load "graph_util")

(defparameter *congestion-city-nodes* nil)
(defparameter *congestion-city-edges* nil)
(defparameter *visited-nodes* nil)
(defparameter *node-num* 30)
(defparameter *edge-num* 45)
(defparameter *worm-num* 3)
(defparameter *cop-odds* 15)

(defun random-node ()
  (1+ (random *node-num*)))

(defun edge-pair (a b)
  (unless (eql a b)
    (list (cons a b) (cons b a))))

(defun make-edge-list ()
  (apply #'append (loop repeat *edge-num*
                        collect (edge-pair (random-node) (random-node)))))

;; 与えられたノードを起点とする全てのエッジを返す
;; *param*  node => 17, edge_list => ((17 . 20) (17 . 3) (1 . 2))
;; *return* ((17 . 20) (17 . 3))
(defun direct-edges (node edge-list)
  (remove-if-not (lambda (x)
                   (eql (car x) node))
                 edge-list))

;; nodeを起点としてそこから到達可能なノードのリストを返す
(defun get-connected (node edge-list)
  (let ((visited nil))
    (labels ((traverse (node)
              (unless (member node visited)
                (push node visited)
                (mapc (lambda (edge)
                        (traverse (cdr edge)))
                      (direct-edges node edge-list)))))
      (traverse node))
    visited))

;; *param* nodes => (1 2 ... *node-num*)
(defun find-islands (nodes edge-list)
  (let ((islands nil))
    (labels ((find-island (nodes)
              (let* ((connected (get-connected (car nodes) edge-list))
                     (unconnected (set-difference nodes connected)))
                (push connected islands)
                (when unconnected
                  (find-island unconnected)))))
      (find-island nodes))
    islands))

(defun connect-with-bridges (islands)
  (when (cdr islands)
    (append (edge-pair (caar islands) (caadr islands))
            (connect-with-bridges (cdr islands)))))


(defun connect-all-islands (nodes edge-list)
  (append (connect-with-bridges (find-islands nodes edge-list)) edge-list))

(defun make-city-edges ()
  (let* ((nodes (loop for i from 1 to *node-num*
                      collect i))
         (edge-list (connect-all-islands nodes (make-edge-list)))
         (cops (remove-if-not (lambda (x)
                                (zerop (random *cop-odds*)))
                              edge-list)))
    (add-cops (edges-to-alist edge-list) cops)))

(defun edges-to-alist (edge-list)
  (mapcar (lambda (node1)
            (cons node1
                  (mapcar (lambda (edge)
                            (list (cdr edge)))
                          (remove-duplicates (direct-edges node1 edge-list)
                                              :test #'equal))))
          (remove-duplicates (mapcar #'car edge-list))))

(defun add-cops (edge-alist edges-with-cops)
  (mapcar (lambda (x)
            (let ((node1 (car x))
                  (node1-edges (cdr x)))
              (cons node1
                    (mapcar (lambda (edge)
                              (let ((node2 (car edge)))
                                (if (intersection (edge-pair node1 node2)
                                                  edges-with-cops
                                                  :test #'equal)
                                  (list node2 'cops)
                                  edge)))
                            node1-edges))))
          edge-alist))

graph_util.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 wizard is snoring loudly on the couch.))
                               (garden (you are in a beautiful garden.
                                there is a well in front 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))))