;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Clim-User -*-
;;;; Time-stamp: <95/10/02 11:11:07 pbjakewa>

;;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
;;;;
;;;;       File:  graph-um.lisp
;;;;     Author:  Bruce Jakeway
;;;;       Date:  1995 September
;;;;
;;;;    Project:  HealthDoc
;;;; Supervisor:  Chrysanne DiMarco
;;;;
;;;; PURPOSE
;;;; -------
;;;; This file allows the upper model to be graphed.  The output is meant for
;;;;   the dot grapher from AT&T.  You can graph the full hierarchy of the
;;;;   upper model below any concept.
;;;;
;;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=



(defun istr (concept)
  "Concept basename."
  (let ((name (intern (object-name concept))))
    (if name name concept)))

(defun uistr (concept)
  "Underscores instead of hyphens."
  (substitute #\_ #\- (string (istr concept))))

(defun graph-um (&key (init-concept 'um-thing) (filename "upper-model.dot"))
  "Graph upper model."
  (with-open-file (stream filename :direction :output :if-exists :rename)
    (format stream "~&graph G {~%  node [shape=plaintext];~%  ratio=auto;~%  ~
                    page=\"8.5,11\";~%  margin=.5;~%  rankdir=LR~%~%")
#| ; to print on one big page:
    (format stream "~&graph G {~%  node [shape=plaintext];~%  ratio=fill;~%  ~
                    size=\"20,22.5\";~%  page=\"23.5,23.5\";~%  margin=.5;~%  ~
                    rotate=90;~%  rankdir=LR~%~%")
|#
    (loop for old-concepts = nil then (cons concept old-concepts)
	for concept-list = (if (listp init-concept) init-concept
			     (list init-concept))
	then (nconc (rest concept-list) subconcepts)
	while concept-list
	for concept = (first concept-list)
	for subconcepts = (loom::get-subconcepts
			   (find-concept concept :ignore-package-p t)
			   :direct-p t)
	do (unless (member concept old-concepts)
	     (when (find #\- (string (istr concept)))
	       (format stream "  ~A [label=\"~A\"];~%" (uistr concept)
		       (istr concept)))
	     (mapc #'(lambda (conc)
		       (format stream "  ~A -- ~A;~%" (uistr concept)
			       (uistr conc)))
		   subconcepts)))
    (format stream "}")))
