better function, with less noisy trees

.gitignore

@@ -1,2 +1,4 @@
 *.png
+*.dot
+*.svg
 phonetics-feature-tree

phonetics-feature-tree.scm

@@ -1,126 +1,120 @@
-(define (left-child tree)
+(define test-tree
-  (cadr tree))
+  '("1"
-(define (left-child-name tree)
+    ("1-1"
-  (car (left-child tree)))
+     ("1-1-1"
-(define (right-child tree)
+      ("1-1-1-1")
-  (caddr tree))
+      ("1-1-1-2"))
-(define (right-child-name tree)
+     ("1-1-2"
-  (car (right-child tree)))
+      ("1-1-2-1"
-(define (cur-name tree)
+       ("1-1-2-1-1")
-  (car tree))
+       ("1-1-2-1-2")
+       ("1-1-2-1-3")
+       ("1-1-2-1-4")))
+     ("1-1-3"
+      ("1-1-3-1"
+       ("1-1-3-1-1")
+       ("1-1-3-1-2"))))))
 
-(define (to-string phon-tree node-nbr child next-nbr)
+(define (declare-node node-text node-generation)
-  (let ((this-name (string-append "node"
+  (string-append ;; "node"
-                                  (number->string node-nbr)))
+                 (number->string node-generation)
-        (child-name (string-append "node"
+                 "[label=\""
-                                   (number->string next-nbr))))
+                 node-text
-    (string-append child-name
+                 "\"];\n"))
-                   "[label=\""
-                   (cur-name child)
-                   "\"];"
-                   this-name
-                   "--"
-                   child-name
-                   ";\n"
-                   (to-dot-main child next-nbr))))
 
-(define (to-dot-main phon-tree node-nbr)
+(define (make-link previous-node current-node)
-  (let* ((this-name (string-append (number->string node-nbr)
+  (string-append ;; "node"
-                                  "node")))
+                 (number->string previous-node)
-    (if (null? (left-child phon-tree))
+                 " -- "
-        ""
+                 ;; "node"
-        (let ((x (* 2 (+ 1 node-nbr)))
+                 (number->string current-node)
-              (y (* 2 (+ 2 node-nbr))))
+                 ";\n"))
-          (string-append (to-string phon-tree node-nbr
-                                    (left-child phon-tree)
-                                    x)
-                         (to-string phon-tree node-nbr
-                                    (right-child phon-tree)
-                                    y))))))
 
-(define (to-dot phon-tree)
+(define (tree-to-dot-helper tree current-generation previous-generation)
-  (if (null? phon-tree)
+  ;; Helper to ~tree-to-dot~ that translates a Scheme tree with any number of
-      "\n"
+  ;; 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{\n"
+       "graph{node[shape=plaintext];graph[bgcolor=\"transparent\"];\n"
-       "node[shape=plaintext];\n"
+       (declare-node (car tree) 0)
-       "graph[bgcolor=\"transparent\"];\n"
+       (tree-to-dot-helper (cdr tree) 1 0)
-       "node1[label=\""
-       (cur-name phon-tree)
-       "\"];\n"
-
-       (to-dot-main phon-tree 1)
        "}")))
 
 (define vowel-tree
-  '("[vowel]"
-    ("[back]"
-     ("[tense]" () ())
-     ("{tense}" () ()))
-    ("{back}"
-     ("[rnd]"
-      ("[tense]" () ())
-      ("{tense}"
-       ("[high]" ())
-       ("{high}" ())))
-     ("{rnd}"
-      ("[tense]"
-       ("[high]" () ())
-       ("{high}" () ()))
-      ("{tense}"
-       ("[low]" () ())
-       ("{low}" () ()))))))
-(define vowel2-tree
   '("[vowel]"
     ("[back]"
      ("[tense]"
-      ("[high]" () ())
+      ("[high]")
-      ("{high}" () ()))
+      ("{high}"))
      ("{tense}"
-      ("[high]" () ())
+      ("[high]")
-      ("{high}" () ())))
+      ("{high}")))
     ("{back}"
      ("[tense]"
-      ("[high]" () ())
+      ("[high]")
-      ("{high}" () ()))
+      ("{high}"))
      ("{tense}"
-      ("[high]" () ())
+      ("[high]")
-      ("{high}" () ())))))
+      ("{high}")))))
 
 (define cons-tree
   '("[cons]"
     ("[son]"
      ("[dor]"
-      ("[high]" () ())
+      ("[high]")
-      ("{high}" () ()))
+      ("{high}"))
      ("{dor}"
-      ("[cor]" () ())
+      ("[cor]")
-      ("{cor}" () ())))
+      ("{cor}")))
     ("{son}"
      ("[dor]"
       ("[voice]"
-       ("[high]" () ())
+       ("[high]")
-       ("{high}" () ()))
+       ("{high}"))
       ("{voice}"
-       ("[high]" () ())
+       ("[high]")
-       ("{high}" () ())))
+       ("{high}")))
      ("{dor}"
       ("[voice]"
-       ("[cor]" () ())
+       ("[cor]")
-       ("{cor}" () ()))
+       ("{cor}"))
       ("{voice}"
-       ("[cor]" () ())
+       ("[cor]")
-       ("{cor}" () ()))))))
+       ("{cor}"))))))
 
 (define verbs
   '("[verbs]"
     ("[réel]"
-     ("[passé]" () ())
+     ("[passé]")
-     ("{passé}" () ()))
+     ("{passé}"))
     ("{réel}"
-     ("[optatif]" () ())
+     ("[optatif]")
      ("{optatif}"
-      ("[passé]" () ())
+      ("[passé]")
-      ("{passé}" () ())))))
+      ("{passé}")))))
 
-(display (to-dot verbs)) (newline)
+(display (tree-to-dot vowel-tree))