#! /bin/sh

# Generates an SVG diagram from CPSA preskeletons

# This program converts the preskeletons in the input into an SVG
# diagram using Scheme and the GraphVis program dot.  Terms are
# displayed as tooltips in the diagram.

PROG=`basename "$0"`

usage()
{
  echo "Usage: $PROG [OPTIONS] [FILE]"
  echo
  echo "Options:"
  echo "  -o FILE, --output=FILE"
  echo "         write output to FILE (default is standard output)"
  echo "  -h, --help"
  echo "         display this help and exit"
  echo "  -v, --version"
  echo "         output version information and exit"
}

OPTS=`getopt -o hvo: --long help,version,output: -n "$PROG" -- "$@"`

if [ $? -ne 0 ]
then
  echo
  usage
  exit 1
fi

eval set -- "$OPTS"

for o
do
  case "$o" in
    -h|--help)
      usage
      exit 0;;
    -v|--version)
      echo $PROG 1.0
      exit 0;;
    -o|--output)
      output="$2"
      shift 2;;
    --)
      shift
      break;;
  esac
done

SCRIPT='
;;; Converts the preskeletons in the input into GraphViz dot format.
;;; Terms are displayed as tooltips, so this output is usually
;;; converted to SVG.

;;; This program expects its input to be generated by another program,
;;; and therefore does not adequately check its input.

;;; The program reads from the standard input and writes to the
;;; standard output.

;;; The main routine
(define (main)
  (let ((input (get)))			 ; Read input
    (show-all (car input) (cdr input)))) ; Process in

;;; Get the list of preskeletons and the protocols as an alist
(define (get)
  (let loop ((prots '\''()) (skels '\''()))
    (let ((x (read)))
      (cond ((eof-object? x)
	     (cons (reverse prots) (reverse skels)))
	    ((or (not (pair? x))
		 (not (symbol? (car x)))
		 (not (pair? (cdr x)))
		 (not (symbol? (cadr x))))
	     (loop prots skels))
	    ((equal? '\''defprotocol (car x))
	     (loop (cons (cons (cadr x) x) prots) skels))
	    ((equal? '\''defskeleton (car x))
	     (loop prots (cons x skels)))
	    (else (loop prots skels))))))

(define (show-all prots skels)
  (display "digraph cpsa {")
  (newline)				; t is a tag number
  (let loop ((t 0) (skels skels))	; used for labeling
    (cond ((pair? skels)
	   (let ((prot (assoc (cadar skels) prots)))
	     (if prot (show-skel t (cdr prot) (car skels)))
	     (loop (+ t 1) (cdr skels))))
	  (else
	   (display "}")
	   (newline)))))

;;; Print graph header
(define (show-skel tag prot skel)
  (let* ((x (assoc '\''label (cddr skel)))	; Use value of the
	 (label (if x (cadr x) tag))	; label attribute
	 (y (assoc '\''parent (cddr skel))) ; when it appears
	 (parent (and y (cadr y)))
	 (name (cadr prot)))
    (newline)
    (display-outline label parent)
    (display "subgraph cluster")
    (display label)
    (display " {")
    (newline)
    (display "  label = \"")
    (display name)
    (display " ")
    (display label)
    (display "\";")
    (newline)
    (show-strands label 0 (map extract-trace (cdddr prot)) (cdddr skel))))

(define (display-outline label parent)
  (display "c")
  (display label)
  (display " [label = \"")
  (display label)
  (display "\"]; ")
  (newline)
  (cond (parent
	 (display "c")
	 (display parent)
	 (display " -> c")
	 (display label)
	 (display ";")
	 (newline))))

;;; Used to make an alist of role name and their trace
(define (extract-trace role)
  (cons (cadr role) (cdar (cdddr role))))

;;; Print the strands
(define (show-strands label s traces strands )
  (cond ((equal? '\''defstrand (caar strands))
	 (show-strand label s (cdar strands) traces (cdr strands)))
	((equal? '\''deflistener (caar strands))
	 (show-listener label s (cadar strands) traces (cdr strands)))
        (else
	 (let ((result (assoc '\''precedes strands)))
	   (show-order label (if (pair? result) (cdr result) '\''()))))))

;;; Show a non-listener strand
(define (show-strand label s strand traces strands)
  (let ((role (car strand))
	(height (cadr strand))
	(env (cddr strand)))
    (show-cluster label s)
    (display "    label = \"")		; Use role as
    (display role)			; cluster label
    (display "\";")
    (newline)
    (show-strand-nodes label s (assoc role traces) height env)
    (show-strand-edges label s height)
    (display "  }")
    (newline))
  (show-strands label (+ s 1) traces strands))

(define (show-cluster label s)
  (newline)
  (display "  subgraph cluster")
  (display label)
  (display "_")
  (display s)
  (display " {")
  (newline)				; Use strand for all
  (display "    node [label = \"")	; node labels in this
  (display s)				; cluster
  (display "\"];")
  (newline))

(define (show-strand-nodes label s trace height env)
  (if (not trace)
      (error "Bad role name")
      (let loop ((n 0) (trace (cdr trace)))
	(cond ((< n height)
	       (show-node label s n (subst (car trace) env))
	       (loop (+ n 1) (cdr trace)))))))

;;; Show a node with the term as a tooltip
(define (show-node label s n term)
  (display "    ")
  (display-node label s n)
  (display " [tooltip = \"")
  (show-term term)
  (display "\"];")
  (newline))

;;; Writes a term while quoting strings properly
(define (show-term term)
  (define (show-term-list terms)
    (cond ((pair? terms)
	   (display " ")
	   (show-term (car terms))
	   (show-term-list (cdr terms)))
	  (else
	   (display ")"))))
  (cond ((string? term)
	 (display "\"")
	 (display term)
	 (display "\""))
	((pair? term)
	 (display "(")
	 (show-term (car term))
	 (show-term-list (cdr term)))
	(else
	 (display term))))

(define (display-node label s n)
  (display "l")
  (display label)
  (display "s")
  (display s)
  (display "n")
  (display n))

;;; Substitute symbols for values in the given environment
(define (subst exp env)
  (define (substitute exp)
    (cond ((symbol? exp)
	   (let ((alist (assoc exp env)))
	     (if alist
		 (cadr alist)
		 exp)))
	  ((pair? exp)
	   (cons (car exp) (map substitute (cdr exp))))
	  (else exp)))
  (substitute exp))

(define (show-strand-edges label s height)
  (display "    ")
  (display-node label s 0)
  (let loop ((n 1))
    (cond ((>= n height)
	   (display ";")
	   (newline))
	  (else
	   (display " -> ")
	   (display-node label s n)
	   (loop (+ n 1))))))

(define (show-listener label s term traces strands)
  (show-cluster label s)
  (display "    label = \"\";")
  (newline)
  (show-node label s 0 (list '\''recv term))
  (display "  }")
  (newline)
  (show-strands label (+ s 1) traces strands))

(define (show-order label orderings)
  (cond ((pair? orderings)
	 (let ((hd (caar orderings))
	       (tl (cadar orderings)))
	   (display "  ")
	   (display-node label (car hd) (cadr hd))
	   (display " -> ")
	   (display-node label (car tl) (cadr tl))
	   (display ";")
	   (newline)
	   (show-order label (cdr orderings))))
	(else
	 (display "}")
	 (newline))))

(main)
'

case $# in
  0)
    if [ -z "$output" ]
    then
      guile -c "$SCRIPT" | dot -Tsvg
    else
      guile -c "$SCRIPT" | dot -Tsvg -o "$output"
    fi
    break;;
  1)
    if [ -z "$output" ]
    then
      guile -c "$SCRIPT" < "$1" | dot -Tsvg
    else
      guile -c "$SCRIPT" < "$1" | dot -Tsvg -o "$output"
    fi
    break;;
  *)
    echo Too many input files
    echo
    usage
    exit 1;;
esac