fork download
copy 
  1. #lang racket
  2.  
  3. (require srfi/1 srfi/13 srfi/14)
  4.  
  5. (define *wizard-nodes* '((living-room (you are in the living-room.
  6.                                           a wizard is snoring loudly on the couch.))
  7.                          (garden (you are in a beautiful garden.
  8.                                      there is a well in front of you.))
  9.                          (attic (you are in the attic.
  10.                                     there is a giant welding torch in the corner.))))
  11.  
  12. (define *wizard-edges* '((living-room (garden west door)  
  13.                                      (attic upstairs ladder))
  14.                          (garden (living-room east door))
  15.                          (attic (living-room downstairs ladder))))
  16.  
  17. (define (dot-name exp)
  18.   (regexp-replace #px"[^[:alnum:]]+" (format "~a" exp) "_"))
  19.  
  20. (define *max-label-length* 30)
  21.  
  22. (define (dot-label exp)
  23.   (if (null? exp)
  24.      ""
  25.      (let ((s (string-delete (char-set #\tab #\newline) (format "~a" exp))))
  26.        (if (> (string-length s) *max-label-length*)
  27.           (string-append (substring s 0 (- *max-label-length* 3)) "...")
  28.           s))))
  29.  
  30. (define (nodes->dot nodes)
  31.   (for-each (lambda (node)
  32.               (newline)
  33.               (display (dot-name (car node)))
  34.               (display "[label=\"")
  35.               (display (dot-label node))
  36.               (display "\"];"))
  37.            nodes))
  38.  
  39. (define (edges->dot edges)
  40.   (for-each (lambda(node)
  41.               (for-each (lambda (edge)
  42.                           (newline)
  43.                           (display (dot-name (car node)))
  44.                           (display "->")
  45.                           (display (dot-name (car edge)))
  46.                           (display "[label=\"")
  47.                           (display (dot-label (cdr edge)))
  48.                           (display "\"];"))
  49.                        (cdr node)))
  50.            edges))
  51.  
  52. (define (graph->dot nodes edges)
  53.   (display "digraph{")
  54.   (nodes->dot nodes)
  55.   (edges->dot edges)
  56.   (display "}"))
  57.  
  58. (define (uedges->dot edges)
  59.   (pair-for-each (lambda (lst)
  60.                    (for-each (lambda (edge)
  61.                                (unless (assq (car edge) (cdr lst))
  62.                                  (newline)
  63.                                  (display (dot-name (caar lst)))
  64.                                  (display "--")
  65.                                  (display (dot-name (car edge)))
  66.                                  (display "[label=\"")
  67.                                  (display (dot-label (cdr edge)))
  68.                                  (display "\"];")))
  69.                             (cdar lst)))
  70.                 edges))
  71.  
  72. (define (ugraph->dot nodes edges)
  73.   (display "graph{")
  74.   (nodes->dot nodes)
  75.   (uedges->dot edges)
  76.   (display "}"))
  77.  
  78. (define (dot->png fname thunk)
  79.   (with-output-to-file fname
  80.     #:exists 'replace
  81.     thunk)
  82.   (system (string-append "dot -Tpng -O " fname)))
  83.  
  84. (define (graph->png fname nodes edges)
  85.   (dot->png fname
  86.            (lambda ()
  87.              (graph->dot nodes edges))))
  88.  
  89. (define (ugraph->png fname nodes edges)
  90.   (dot->png fname
  91.            (lambda ()
  92.              (ugraph->dot nodes edges))))
  93.  
  94. ;;(define (run)
  95. ;;  (ugraph->png "wizard" *nodes* *edges*))
Success #stdin #stdout 0.64s 92908KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/fgrL0P
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!