Scheme - Land of Scheme - 単純なリストの先へ(無向グラフを作る)

Land of Lisp
(オライリージャパン)
M.D. Conrad Barski (著) 川合 史朗 (翻訳)
原書: Land of LISP
Learn to Program in Lisp, One Game at a Time!

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche, MIT/GNU Scheme, GNU Guile (処理系)

Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の7章(単純なリストの先へ)、7.4(無向グラフを作る)を Scheme で取り組んでみる。

7.4(無向グラフを作る)

コード(Emacs)

(begin
  (define odd? (lambda (n) (= (remainder n 2) 1)))
  (define map
    (lambda (proc items)
      (if (null? items)
          (quote ())
          (cons (proc (car items))
                (map proc (cdr items))))))
  (define for-each
    (lambda (proc items)
      (if (not (null? items))
          (begin (proc (car items))
                 (for-each proc (cdr items))))))

  (define assoc
    (lambda (obj alist)
      (if (null? alist)
          #f
          (let ((item (car alist)))
            (if (equal? obj (car item))
                item
                (assoc obj (cdr alist)))))))

  (define print (lambda (x) (display x) (newline)))
  
  (define *house* (quote ((walls (mortar (cement)
                                         (water)
                                         (sand)))
                          (windows (glass)
                                   (frame)
                                   (curtains))
                          (roof (shingles)
                                (chimney)))))

  (define *wizard-nodes*
    (quote ((living-room (You are in the living-room. There is a wizard is
                              snoring loudly on the couch.))
            (garden (You are in a beatiful garden. There is a well in front of
                         you.))
            (attic (You are in the attic. There is a giant welding torch in
                        the corner.)))))
  
  (define *wizard-edges* (quote ((living-room (garden west door)
                                              (attic upstairs ladder))
                                 (garden (living-room east door))
                                 (attic (living-room downstairs ladder)))))

  ;; Common Lisp にはあっても、Scheme にない手続きがあったり、kscheme には、
  ;; Scheme の仕様にはあっても、実装してない手続きがまだたくさんあったりするので、
  ;; とりあえず、同様に機能する必要な手続きを定義
  ;; Scheme は (quote 24)は記号 (symbol) ではなく、数値(number) になるみたい。
  ;; ということで、symbol->string で (quote 24) を文字列にできない
  ;; (symbol? (quote 24)) は偽(#f)
  (define object->string
    (lambda (o)
      (cond ((symbol? o) (symbol->string o))
            ((number? o) (number->string o))
            ((null? o) "")
            ((pair? o) (string-append (object->string (car o))
                                      (object->string (cdr o))))
            ((string? o) o))))

  (define substitute-if
    (lambda (o pred exp)
      (if (string? exp)
          (list->string (map (lambda (c1)
                               (if (pred c1)
                                   o
                                   c1))
                             (string->list exp)))
          (map (lambda (item)
                 (if (pred item)
                     o
                     item))
               exp))))

  (define complement
    (lambda (pred)
      (lambda (x)
        (not (pred x)))))

  (define alphanumeric?
    (lambda (x)
      (or (char-alphabetic? x)
          (char-numeric? x))))
  (define dot-name
    (lambda (exp)
      (substitute-if #\_
                     (complement alphanumeric?)
                     (object->string exp))))
  
  (define *max-label-length* 30)

  (define substring
    (lambda (s start end)
      (list->string (string->list s start end))))
  
  (define string-append
    (lambda (s1 s2)
      (list->string (append (string->list s1)
                            (string->list s2)))))

  (define object->string-1
    (lambda (o)
      (cond ((null? o) "")
            ((pair? o)
             (string-append (object->string-1 (car o))
                            (object->string-1 (cdr o))))
            (else
             (string-append
              (cond ((symbol? o) (symbol->string o))
                    ((number? o) (number->string o))
                    ((string? o) o))
              " ")))))

  (define dot-label
    (lambda (exp)
      (if exp
          (let ((s (object->string-1 exp)))
            (if (> (string-length s) *max-label-length*)
                (string-append (substring s 0 (- *max-label-length* 3))
                               "...")
                s))
          "")))

  (define out-file (open-output-file "sample3_1.txt"))
  (define nodes->dot
    (lambda (nodes port)
      (map (lambda (node)
             (newline port)
             (display (dot-name (car node)) port)
             (display "[label=\"" port)
             (display (dot-label node) port)
             (display "\"];" port))
           nodes)))
  
  (define edges->dot
    (lambda (edges port)
      (map (lambda (node)
             (map (lambda (edge)
                    (newline port)
                    (display (dot-name (car node)) port)
                    (display "->" port)
                    (display (dot-name (car edge)) port)
                    (display "[label=\"" port)
                    (display (dot-label (cdr edge)) port)
                    (display "\"];" port))
                  (cdr node)))
           edges)))

  (define graph->dot
    (lambda (nodes edges port)
      (display "digraph{" port)
      (nodes->dot nodes port)
      (edges->dot edges port)
      (display "}" port)))
  
  ;; Common Lisp と違って、Scheme の仕様に、C言語の system 関数みたいな、
  ;; 外部スクリプトを実行する手続きがないっぽかった(?)。
  ;; ということで、kscheme に独自に system 手続きを実装。
  ;; Gauche には、C言語の exec 関数に相当する、sys-exec 等の手続き、
  ;; Guile には system 手続きがあった。
  (define dot->png
    (lambda (fname proc)
      (proc)
      (system (string-append "dot -Tpng -O " fname))))

  (define graph->png
    (lambda (fname nodes edges)
      (dot->png fname
                (lambda ()
                  (let ((out-file (open-output-file fname)))
                    (graph->dot nodes edges out-file)
                    (close-output-port out-file))))))

  (define maplist
    (lambda (proc items)
      (if (not (null? items))
          (begin (proc items)
                 (maplist proc (cdr items))))))

  ;; Common Lisp の mapcar は Scheme の for-each 手続きと同じっぽい(？)
  (for-each print (quote (a b c)))
  (newline)  
  (print (maplist print (quote (a b c))))

  (define uedges->dot
    (lambda (edges port)
      (maplist (lambda (items)
                 (map (lambda (edge)
                        (if (not (assoc (car edge) (cdr items)))
                            (begin (newline port)
                                   (display (dot-name (caar items)) port)
                                   (display "--" port)
                                   (display (dot-name (car edge)) port)
                                   (display "[label=\"" port)
                                   (display (dot-label (cdr edge)) port)
                                   (display "\"];" port))))
                      (cdar items)))
               edges)))

  (define ugraph->dot
    (lambda (nodes edges port)
      (display "graph{" port)
      (nodes->dot nodes port)
      (uedges->dot edges port)
      (display "}" port)))
  
  (define ugraph->png
    (lambda (fname nodes edges)
      (dot->png fname
                (lambda ()
                  (let ((out-file (open-output-file fname)))
                    (ugraph->dot nodes edges out-file)
                    (close-output-port out-file))))))
  
  (ugraph->png "uwizard.dot" *wizard-nodes* *wizard-edges*)
  
  (quote done))

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ kscheme sample4.scm
a
b
c

(a b c)
(b c)
(c)
#<undefined>
done
$ cat uwizard.dot
graph{
living_room[label="living-room You are in the l..."];
garden[label="garden You are in a beatiful..."];
attic[label="attic You are in the attic. ..."];
garden--living_room[label="east door "];
attic--living_room[label="downstairs ladder "];}$ open uwizard.dot.png 
$ 

DOT ファイルから、Graphviz を使って得た無向グラフ。