(define nfa->dot
  (lambda (nfa)
    (define (state->stmts s)
      (define (stringify value)
        (call-with-output-string (lambda (p) (write value p))))
      (define (value->dot-string input)
        (if (number? input) 
            (number->string input)
            (stringify input)))
      (let* ((n (nfa-entry-state s))
             (accepts (nfa-entry-accepts s))
             (transitions (nfa-entry-transitions s))

             (is-accepting-state 
              (and accepts (not (null? accepts))))
             (state-name 
              (cond 
               ((not accepts)   (value->dot-string n))
               ((null? accepts) (value->dot-string n))
               (else (value->dot-string accepts))))
             )
        (define (transition->stmt t)
          (let ((input (transition-token t))
                (n* (transition-target t)))
            (string-append (value->dot-string n)
                           " -> "
                           (value->dot-string n*)
                           (if (null? input)
                               ""
                               (string-append " [label=" 
                                              (stringify
                                               (value->dot-string input)) "]"))
                           "; ")))
        (define (consolidate-transitions ts)
          (if (null? ts)
              ts
              (let loop ((ts (cdr ts))
                         (tokens-so-far (list (transition-token (car ts))))
                         (prev-tgt (transition-target (car ts))))
                (cond
                 ((null? ts) (list (make-transition (reverse tokens-so-far)
                                                    prev-tgt)))
                 ((equal? prev-tgt (transition-target (car ts)))
                  (loop (cdr ts)
                        (cons (transition-token (car ts)) tokens-so-far)
                        prev-tgt))
                 (else 
                  (cons (make-transition (reverse tokens-so-far) prev-tgt)
                        (loop (cdr ts) (list (transition-token (car ts)))
                              (transition-target (car ts)))))))))
        (cons (string-append
               (value->dot-string n)
               " [label=" (stringify state-name)
               ", shape=" (if is-accepting-state "doublecircle" "circle")
               "]"
               "; ")
              (map transition->stmt 
                   (consolidate-transitions transitions)))))
    (map state->stmts nfa)))

(define write-dot
  (lambda (name dot . rest)
    (let ((port (if (null? rest) (current-output-port) (car rest))))
      (display "digraph " port)
      (display name port)
      (display " { " port)
      (newline port)
      (for-each (lambda (nodedecl) 
                  (display "    " port)
                  (display nodedecl port)
                  (newline port))
                (map car dot))
      (for-each (lambda (transitions)
                  (for-each (lambda (transition)
                              (display "    " port)
                              (display transition port)
                              (newline port))
                            transitions))
                (map cdr dot))
      (display " } " port)
      (newline port)
      (flush-output-port port))))