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.3(グラフを作る)を Scheme で取り組んでみる。

7.3(グラフを作る)

コード(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 print-write (lambda (x) (write x) (newline)))
  (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))))
  
  
  
  (print-write (dot-name (quote living-room)))
  (print-write (dot-name (quote foo!)))
  (print-write (dot-name (quote 24)))

  (print-write (substitute-if #\e char-numeric? "I'm a l33t hack3r!"))

  (print-write (substitute-if 0
                              odd?
                              (quote (1 2 3 4 5 6 7 8))))

  (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 out-file)
             (display (dot-name (car node)) port)
             (display "[label=\"" port)
             (display (dot-label node) port)
             (display "\"];" port))
           nodes)))
  
  (nodes->dot *wizard-nodes* out-file)

  (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)))

  (edges->dot *wizard-edges* out-file)
  
  (define graph->dot
    (lambda (nodes edges port)
      (display "digraph{" port)
      (nodes->dot nodes port)
      (edges->dot edges port)
      (display "}" port)))

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

  (define my-stream (open-output-file "sample3_2.txt"))
  (display "Hello File!" my-stream)

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

  (graph->png "wizard.dot" *wizard-nodes* *wizard-edges*)
  
  (quote done))

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

$ kscheme sample3.scm
"living_room"
"foo_"
"24"
"I'm a leet hacker!"
(0 2 0 4 0 6 0 8)
0
done
$ cat sample3_1.txt 

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. ..."];
living_room->garden[label="west door "];
living_room->attic[label="upstairs ladder "];
garden->living_room[label="east door "];
attic->living_room[label="downstairs ladder "];

digraph{
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. ..."];
living_room->garden[label="west door "];
living_room->attic[label="upstairs ladder "];
garden->living_room[label="east door "];
attic->living_room[label="downstairs ladder "];}


$ cat sample3_2.txt 
Hello File!$ ls wizard.dot*
wizard.dot wizard.dot.png
$ cat wizard.dot  
digraph{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. ..."];
living_room->garden[label="west door "];
living_room->attic[label="upstairs ladder "];
garden->living_room[label="east door "];
attic->living_room[label="downstairs ladder "];}$ open wizard.dot.png
$

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