features-tree/phonetics-feature-tree.scm

(define (declare-node node-text node-generation)
  (string-append ;; "node"
                 (number->string node-generation)
                 "[label=\""
                 node-text
                 "\"];\n"))

(define (make-link previous-node current-node)
  (string-append ;; "node"
                 (number->string previous-node)
                 " -- "
                 ;; "node"
                 (number->string current-node)
                 ";\n"))

(define (tree-to-dot-helper tree current-generation previous-generation)
  ;; Helper to ~tree-to-dot~ that translates a Scheme tree with any number of
  ;; children per node to a corresponding graphviz file that can be executed from
  ;; dot.
  ;; Arguments:
  ;; - tree :: tree to convert
  ;; - current-generation :: Generation number, incremented when changing from a node
  ;;      to another node from the same generation, multiplied by 10 when going from
  ;;      a node to one of its children.
  ;; - previous-generation :: Generation number from previous named node
  (cond ((null? tree) "")
        ((atom? (car tree)) ;; '("text" () () ())
         (string-append (declare-node (car tree) current-generation)
                        (make-link previous-generation current-generation)
                        (tree-to-dot-helper (cdr tree)
                                            (+ 1 (* 10 current-generation))
                                            current-generation)))
        ((list? (car tree)) ;; '(() () () ())
         (string-append (tree-to-dot-helper (car tree) ;; child of current node
                                            current-generation
                                            previous-generation)
                        (tree-to-dot-helper (cdr tree) ;; sibling of current node
                                            (+ 1 current-generation)
                                            previous-generation)))))

(define (tree-to-dot tree)
  ;; Returns a graphviz’s dot-compatible string representing a Scheme tree
  (if (null? tree) ""
      (string-append
       "graph{node[shape=plaintext];graph[bgcolor=\"transparent\"];\n"
       (declare-node (car tree) 0)
       (tree-to-dot-helper (cdr tree) 1 0)
       "}")))

(define vowel-tree
  '("[vowel]"
    ("[back]"
     ("[tense]"
      ("[high]")
      ("{high}"))
     ("{tense}"
      ("[high]")
      ("{high}")))
    ("{back}"
     ("[tense]"
      ("[high]")
      ("{high}"))
     ("{tense}"
      ("[high]")
      ("{high}")))))

(define cons-tree
  '("[cons]"
    ("[son]"
     ("[dor]"
      ("[high]")
      ("{high}"))
     ("{dor}"
      ("[cor]")
      ("{cor}")))
    ("{son}"
     ("[dor]"
      ("[voice]"
       ("[high]")
       ("{high}"))
      ("{voice}"
       ("[high]")
       ("{high}")))
     ("{dor}"
      ("[voice]"
       ("[cor]")
       ("{cor}"))
      ("{voice}"
       ("[cor]")
       ("{cor}"))))))

(define verbs
  '("[verbs]"
    ("[réel]"
     ("[passé]")
     ("{passé}"))
    ("{réel}"
     ("[optatif]")
     ("{optatif}"
      ("[passé]")
      ("{passé}")))))

(display (tree-to-dot vowel-tree))