features-tree/tree-to-dot.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Features Tree, creates graphviz-compatible files from Scheme trees.
;; Copyright (C) 2019 Lucien "Phundrak" Cartier-Tilet
;;
;; This program is free software: you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free Software
;; Foundation, either  version 3 of the  License, or (at your  option) any later
;; version.
;;
;; This program is distributed  in the hope that it will  be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR  A PARTICULAR  PURPOSE.  See  the GNU  General  Public  License for  more
;; details.
;;
;; You should have received a copy of  the GNU General Public License along with
;; this program. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


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

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

(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\"];"
       (declare-node (car tree) 0)
       (tree-to-dot-helper (cdr tree) 1 0)
       "}")))

(define vowels
  '("[vowel]"
    ("[back]"
     ("[tense]"
      ("[high]" ("ü"))
      ("{high}" ("ö")))
     ("{tense}"
      ("[high]" ("u"))
      ("{high}" ("o"))))
    ("{back}"
     ("[tense]"
      ("[high]" ("y"))
      ("{high}" ("ë")))
     ("{tense}"
      ("[high]" ("i"))
      ("{high}" ("e"))))))

(define syntax-tree
  '("S"
    ("Obl")
    ("S'"
     ("NPerg"
      ("NP"))
     ("VP"
      ("NPdat"
       ("NP"))
      ("VP'"
       ("NPabs"
        ("NP"
         ("S")
         ("NP'"
          ("Adj")
          ("N"))))
       ("V'"
        ("Mood")
        ("Tense")
        ("V")
        ("Neg")))))))

(display (tree-to-dot vowels))