#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do vcg-convert)' -s $0 "$@" # -*- scheme -*-
!#
;;; vcg-convert --- format transformation: vcg to/from sexp

;; Copyright (C) 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: vcg-convert COMMAND [FILENAME]
;;
;; If COMMAND is ‘to-sexp’ then FILENAME is taken to be in vcg
;; format; display its sexp format representation to stdout.
;; This discards C++-style comments (ie, "/*...*/" and "//...").
;;
;; If COMMAND is ‘to-vcg’ then FILENAME is taken to be in sexp
;; format; display its vcg format representation to stdout.
;;
;; If FILENAME is omitted or "-" (single hyphen), read from stdin.
;;
;; Presently, operation relies on the external program sed(1).
;; This means to say that there is a hackish text transform going on
;; in the background instead of ``proper'' parsing/unparsing, resulting
;; in strange behavior for certain valid inputs.

;;; Code:

(define-module (ttn-do vcg-convert)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv))
  #:use-module ((ice-9 popen) #:select (open-input-pipe
                                        open-output-pipe
                                        close-pipe))
  #:autoload (ttn-do pp) (pp)
  #:use-module ((ttn-do zzz personally) #:select (fs)))

(define vcg->sexp.sed
  (fs "sed '~A~A~A~A~A~A~A'"
      "s,//.*,,;"
      "s,/[*].*[*]/, ,g;"
      "s/\\([a-z][a-z._0-9]*\\) *:/#:\\1 /g;"
      "s/{/(/g;"
      "s/}/)/g;"
      "s/\\(classname\\|infoname\\) \\([0-9][0-9]*\\) *:/#:\\1 \\2 /g;"
      "s/\\(colorentry\\) \\([0-9][0-9]*\\) *:/#:\\1 \\2 /g"))

(define (read-vcg)
  (let* ((port (current-input-port))
         (name (port-filename port))
         (p (open-input-pipe vcg->sexp.sed)))
    (let ((first (read p)))
      (or (and (keyword? first) (eq? #:graph first))
          (error "bad vcg file (first form not #:graph keyword):"
                 )))
    (let ((form (read p)))
      (let loop ((ls form))             ; validate/munge in place
        (cond ((null? ls))
              ((not (keyword? (car ls)))
               (error "bad vcg file (missing keyword):"
                      (list (port-filename port) (car ls))))
              (else
               (case (car ls)
                 ((#:node)
                  (let nloop ((nls (cadr ls)))
                    (or (null? nls)
                        (case (car nls)
                          ((#:loc)
                           (let* ((orig (cadr nls))
                                  (reformed (cons (list-ref orig 1)
                                                  (list-ref orig 3)))
                                  (new-tail (cddr nls)))
                             (set-cdr! nls (cons reformed new-tail))
                             (nloop new-tail)))
                          (else
                           (nloop (cddr nls))))))
                  (loop (cddr ls)))
                 ((#:edge)
                  ;; (clean-edge! (cdr ls))
                  (loop (cddr ls)))
                 ((#:classname #:infoname)
                  (let* ((last-to-be-collected (list-cdr-ref ls 2))
                         (new-tail (cdr last-to-be-collected)))
                    (set-cdr! last-to-be-collected '())
                    (set-cdr! ls (cons (cdr ls) new-tail)) ; raise int-string
                    (loop new-tail)))
                 ((#:colorentry)
                  (let* ((last-to-be-collected (list-cdr-ref ls 4))
                         (new-tail (cdr last-to-be-collected)))
                    (set-cdr! last-to-be-collected '())
                    (set-cdr! ls (cons (cdr ls) new-tail)) ; raise i-r-g-b
                    (loop new-tail)))
                 (else
                  ;; va bene
                  (loop (cddr ls)))))))
      form)))

(define sexp->vcg.sed
  (fs
   "sed '~A~A~A~A~A~A'"
   "s/#:\\(colorentry\\) (\\([0-9][0-9]*\\) \\([0-9 ]*\\))/\\1 \\2 : \\3/g;"
   "s/#:\\(\\(class\\|info\\)name\\) (\\([0-9][0-9]*\\) \\(\".*\"\\))/\\1 \\3 : \\4/g;"
   "s/\\(#:loc (\\)\\([0-9][0-9]*\\) [.] \\([0-9][0-9]*)\\)/\\1#:x \\2 #:y \\3/g;"
   "s/(/{/g;"
   "s/)/}/g;"
   "s/#:\\([a-z][a-z._0-9]*\\)/\\1:/g"))

(define (write-vcg vcg)
  (let ((p (open-output-pipe sexp->vcg.sed)))
    (display "#:graph" p)
    (newline p)
    (pretty-print vcg p)
    (close-pipe p)))

(define (out-sexp)
  (pp (read-vcg)))

(define (out-vcg)
  (write-vcg (read)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (and (= 1 (length args))
       (error "missing arg (command)"))
  (let ((command (case (string->symbol (cadr args))
                   ((to-sexp) out-sexp)
                   ((to-vcg)  out-vcg)
                   (else (error "bad command")))))
    (or (and (= 3 (length args))
             (string=? "-" (caddr args)))
        (= 2 (length args))
        (set-current-input-port (open-input-file (caddr args))))
    (command)))

;;; vcg-convert ends here