;;; Copyright (c) 1991-2001 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen
;;; see LICENSE for conditions

;;;; A COMMON LISP GRAPHICAL GRAPH PACKAGE

(in-package :lkb)

;;; There are 2 entry points: graph-display-layout and graph-display-output.
;;; See file ':worksheet.lsp' for some example calls. More detailed 
;;; documentation to follow.

;;; (in-package 'user)

;;; hacked by aac for lkb type hierarchy display - some changes for type hierarchy
;;; chart, and parse tree display (special customisation for former controlled
;;; by *type-display*

;;; calls externally-defined graphics functions draw-line-x-y, move-to-x-y
;;; (and draw-circular-link-x-y but only in case of circularities, which won't
;;; occur in lkb)
;;;
;;; (defmacro draw-line-x-y (stream from-x from-y to-x to-y dashing) ...)
;;;
;;; (defmacro move-to-x-y (stream x y) ...)
;;;
;;; (defmacro draw-circular-link-x-y (stream centre-x centre-y semi-major-axis 
;;;      horizontalp) ...)

(defstruct
   (graph-description
      (:constructor make-graph-description
         (user-root max-x max-y node-width-function node-height horizontalp nodes))
      (:print-function
         (lambda (x stream level)
            (declare (ignore level))
            (print-unreadable-object (x stream :type t :identity t)
               (format stream "~A ~A" (graph-description-user-root x)
                  (graph-description-horizontalp x))))))
   (user-root nil :read-only t)
   (max-x nil :read-only t)
   (max-y nil :read-only t)
   (node-width-function nil :read-only t)
   (node-height nil :read-only t)
   (horizontalp nil :read-only t)
   (nodes nil :read-only t))

(defconstant +maximum-pixel-dimension+ #x7fff)

(defstruct graph-node
   depth parents daughters reverse-links cached-width relative-offset x y)

(defstruct
   (dummy-graph-node (:include graph-node)
      (:constructor make-dummy-graph-node
         (depth parents daughters reverse-links cached-width relative-offset x y))))

(defstruct
   (proper-graph-node (:include graph-node)
      (:constructor make-proper-graph-node
         (depth parents daughters reverse-links cached-width relative-offset x y
            contents)))
   (contents nil :read-only t))


(defvar *graph-node-table* nil)
#+procyon (proclaim '(pro:always-bound *graph-node-table*))

(defconstant max-node-height 256)
(defconstant max-node-width 1000)


(defmacro get-node-width (node node-width-function)
   `(or (graph-node-cached-width ,node)
      (get-checked-node-width ,node-width-function ,node)))

(defun get-checked-node-width (node-width-function node)
   (let ((w (funcall node-width-function 
               (proper-graph-node-contents node))))
      (if (and (integerp w) (<= 0 w max-node-width))
         (setf (graph-node-cached-width node) w)
         (error "Width of node ~S is not an integer in the range 0-~D."
            (proper-graph-node-contents node) max-node-width))))


(defun graph-display-function-error (arg-name function-name)
   (error "The ~A argument to ~S is not a function." arg-name function-name))


;;; Entry point 1

(defun graph-display-layout (user-root node-daughter-function node-width-function
      node-height horizontalp)
   (unless (functionp node-daughter-function)
      (graph-display-function-error "NODE-DAUGHTER-FUNCTION" 'graph-display-layout))
   (unless (functionp node-width-function)
      (graph-display-function-error "NODE-WIDTH-FUNCTION" 'graph-display-layout))
   (unless (and (integerp node-height) (< 0 node-height max-node-height))
      (error "The NODE-HEIGHT argument to ~S is not an integer in the range 1-~D."
         'graph-display-layout max-node-height))
   (let ((root
            (make-proper-graph-node 0 nil nil nil nil nil nil nil user-root))
         (*graph-node-table*
            (make-hash-table :test #'eq)))
      (setf (gethash user-root *graph-node-table*) root)
      (graph-assign-depths user-root root (list root) node-daughter-function)
      (setq *graph-node-table* nil)
      (let
         ((node-depths-table 
               (graph-add-dummy-nodes root
                  (make-array 1 :initial-element (list root)))))
         ;; lkb hack - only allow reordering with type hierarchy. Need to do it
         ;; otherwise full grammar initially too wide
         (when *type-display* (graph-assign-x-ordering node-depths-table))
         (let*
            ((max-width
                  (graph-assign-x-positions
                     node-depths-table node-width-function 
                     (+ node-height 
                        8) ; was 5 - increased for lkb
                     horizontalp))
               (max-depth
                  (graph-assign-y-positions
                     node-depths-table node-width-function (+ node-height 17) 
                     horizontalp)))
            (make-graph-description user-root
               (if horizontalp max-depth max-width)
               (if horizontalp max-width max-depth)
               node-width-function node-height horizontalp node-depths-table)))))


(defun graph-assign-depths (user-node node parents-visited node-daughter-function)
   (check-node-depth node)
   (loop for user-daughter in (funcall node-daughter-function user-node)
      do
      (let ((daughter (gethash user-daughter *graph-node-table*)))
         (cond
            ((null daughter)
               (setq daughter
                  (make-proper-graph-node (1+ (graph-node-depth node))
                     (list node) nil nil nil nil nil nil user-daughter))
               (setf (gethash user-daughter *graph-node-table*) daughter)
               (push daughter (graph-node-daughters node))
               (graph-assign-depths
                  user-daughter daughter (cons daughter parents-visited)
                  node-daughter-function))
            ((member daughter parents-visited :test #'eq)
               ;; circular link - reverse its direction, don't set up 
               ;; link if it goes from daughter directly back to itself
               (cond
                  ((eq node daughter)
                     (push daughter (graph-node-reverse-links daughter)))
                  ((and (eq daughter (cadr parents-visited))
                        (< (graph-node-depth node)
                           (+ (graph-node-depth daughter) 2)))
                     ;; already a direct forward connection from parent at 
                     ;; level just above this one - move node down one level 
                     ;; and insert a dummy node so that forward and backward 
                     ;; links can follow different paths 
                     (setf (graph-node-depth node) 
                        (+ (graph-node-depth daughter) 2))
                     (graph-update-depths node)
                     (let ((new
                              (make-dummy-graph-node (1+ (graph-node-depth daughter))
                                 (list daughter) (list node) (list node) nil nil nil
                                 nil)))
                        (push new (graph-node-parents node))
                        (push new (graph-node-daughters daughter))
                        (push new (graph-node-reverse-links daughter))))
                  (t
                     (push daughter (graph-node-parents node))
                     (push node (graph-node-daughters daughter))
                     (push node (graph-node-reverse-links daughter)))))
            (t
               ;; daughter has been created before - its daughters must 
               ;; also have been done then
               (when (<= (graph-node-depth daughter) (graph-node-depth node))
                  ;; daughter is currently above level it should be - set its
                  ;; depth to just below here and update depths of all its 
                  ;; direct and indirect descendants
                  (setf (graph-node-depth daughter) (1+ (graph-node-depth node)))
                  (graph-update-depths daughter))
               (push node (graph-node-parents daughter))
               (push daughter (graph-node-daughters node)))))))


(defun graph-update-depths (node)
   (check-node-depth node)
   (loop for daughter in (the list (graph-node-daughters node))
      when (<= (graph-node-depth daughter) (graph-node-depth node))
      do
      (setf (graph-node-depth daughter) (1+ (graph-node-depth node)))
      (graph-update-depths daughter)))


(defun check-node-depth (node)
   (when (> (graph-node-depth node) (- +maximum-pixel-dimension+ 10))
      (error "Graph has too many levels for ~S to handle." 'graph-display-layout)))


;;;

(defun graph-add-dummy-nodes (node table)
   (loop for daughter in (the list (graph-node-daughters node))
      do
      (let ((depth (graph-node-depth daughter)))
         (when (>= depth (length (the simple-vector table)))
            (let ((new-table
                     (make-array (1+ depth) :initial-element nil)))
               (replace new-table table)
               (setq table new-table)))
         (when (> depth (1+ (graph-node-depth node)))
            ;; daughter currently lower than just below here - connect
            ;; to here with dummy nodes
            (setf (graph-node-daughters node)
               (delete daughter (the list (graph-node-daughters node)) :test #'eq))
            (setf (graph-node-parents daughter)
               (delete node (the list (graph-node-parents daughter)) :test #'eq))
            (let ((reversep
                     (member daughter (graph-node-reverse-links node) :test #'eq)))
               (when reversep
                  (setf (graph-node-reverse-links node)
                     (delete daughter (the list (graph-node-reverse-links node))
                        :test #'eq)))
               (graph-connect-dummy-nodes node daughter table reversep)))
         (unless (member daughter (svref table depth) :test #'eq)
            (push daughter (svref table depth))
            (setq table
               (graph-add-dummy-nodes daughter table)))))
   table)


(defun graph-connect-dummy-nodes (higher lower table reversep)
   (loop for depth from (1+ (graph-node-depth higher))
      to (1- (graph-node-depth lower))
      do
      (let ((new
               (make-dummy-graph-node depth (list higher) nil nil nil nil nil 
                  nil)))
         (push new (svref table depth))
         (push new (graph-node-daughters higher))
         (when reversep
            (push new (graph-node-reverse-links higher)))
         (setq higher new)))
   (push higher (graph-node-parents lower))
   (setf (graph-node-daughters higher) (list lower))
   (when reversep
      (setf (graph-node-reverse-links higher) (list lower))))


;;;

(defun graph-assign-x-ordering (node-depths-table)
   (loop for node in (the list (svref node-depths-table 0)) 
      do
      (setf (graph-node-relative-offset node) 0))
   (let ((max-depth
            (1- (length (the simple-vector node-depths-table)))))
      (loop for iteration from 1 to 2
         do
         (loop for depth from 1 to max-depth
            do
            (graph-assign-x-ordering-up/down depth node-depths-table 1))
         (unless (eql iteration 2)
            (loop for depth from (1- max-depth) downto 0
               do
               (graph-assign-x-ordering-up/down depth node-depths-table -1))))))


(defun graph-assign-x-ordering-up/down (depth node-depths-table direction)
   (loop for node in (the list (svref node-depths-table depth))
      do 
      (let ((parents/children 
               (if (minusp direction) (graph-node-daughters node) 
                  (graph-node-parents node))))
         (setf (graph-node-relative-offset node) 
            (if parents/children 
               (truncate
                  (let ((sum 0))
                     (loop for parent/child in (the list parents/children)
                        do 
                        (incf sum (graph-node-relative-offset parent/child)))
                     sum)
                  (length (the list parents/children)))
               (graph-node-relative-offset node)))))
   (setf (svref node-depths-table depth) 
      (stable-sort (svref node-depths-table depth) 
         #'(lambda (n1 n2)
             (< (graph-node-relative-offset n1) (graph-node-relative-offset n2)))))
   (let ((n 0))
      (loop for node in (the list (svref node-depths-table depth))
         do 
         (when (eql n +maximum-pixel-dimension+)
            (error "Graph has too many nodes in a single level for ~S to handle."
               'graph-display-layout))
         (setf (graph-node-relative-offset node) n)
         (incf n))))


;;;

(defun graph-assign-x-positions (node-depths-table node-width-function 
      separation horizontalp)
   (loop for node in (the list (svref node-depths-table 0))
      do
      (setf (graph-node-x node) 0))
   (let ((total-depth
            (1- (length (the simple-vector node-depths-table))))
         (max-width 0))
      (loop for iteration from 1 to 2
         do
         (loop for depth from 1 to total-depth ; child <- mean of parents
            do
            (setq max-width
               (max max-width
                  (graph-assign-x-positions-up/down depth node-depths-table 
                     node-width-function 
                     (if (and *type-display* (<= depth 2)) ; hack for type hierarchy to
                        (* separation 2)                   ; increase vertical separation
                        separation)                        ; at first 2 levels
                     horizontalp 1))))
         (loop for depth from (1- total-depth) downto 0 ; parent <- mean of children
            do
            (when (or (not *type-display*)
                     ;; in type display - mid-point of children unless we've done 1
                     ;; iteration and it's got too dense at this depth 
                     (eql iteration 1)
                     (< (length (svref node-depths-table depth)) 20))
               (setq max-width
                  (max max-width
                     (graph-assign-x-positions-up/down depth node-depths-table 
                        node-width-function 
                        (if (and *type-display* (<= depth 2))
                           (* separation 2)
                           separation) 
                        horizontalp -1))))))
      ;; if possible move unary children on right fringe and leaves directly under parent
      (loop for depth from 1 to total-depth
         do
         (setq max-width
            (max max-width
               (graph-assign-x-positions-fringe depth node-depths-table
                  node-width-function
                  (if (and *type-display* (<= depth 2))
                     (* separation 2)
                     separation)))))
       ;; shift x coords back down to zero
       (let ((min-x most-positive-fixnum)
             (max-first-width 0))
         (loop for depth from 0 to total-depth
            do
            (unless horizontalp
               (let ((first-node (car (svref node-depths-table depth))))
                  (when (and first-node (not (dummy-graph-node-p first-node)))
                     (setq max-first-width
                        (max (get-node-width first-node node-width-function)
                           max-first-width)))))
            (loop for node in (the list (svref node-depths-table depth))
               do
               (setq min-x (min min-x (graph-node-x node)))))
         (decf min-x (truncate (+ max-first-width separation) 2))
         (loop for depth from 0 to total-depth
            do
            (loop for node in (the list (svref node-depths-table depth))
               do
               (decf (graph-node-x node) min-x)))
         (decf max-width min-x))
      (+ max-width separation)))


(defun graph-assign-x-positions-fringe (depth node-depths-table node-width-function
      separation &aux (max-width 0))
   (loop for node in (reverse (svref node-depths-table depth))
      with fringep = t
      with last-x = 0
      for half-width = (if (dummy-graph-node-p node) 0
                           (truncate (get-node-width node node-width-function) 2))
      do
      (cond
         ((or (cdr (graph-node-parents node))
              (>= (graph-node-x node) (graph-node-x (car (graph-node-parents node))))))
         (fringep
            (setf (graph-node-x node) (graph-node-x (car (graph-node-parents node)))))
         ((and (null (graph-node-daughters node))
               (< (graph-node-x node) (- last-x half-width)))
            (setf (graph-node-x node)
               (min (- last-x half-width) (graph-node-x (car (graph-node-parents node)))))))
      (setq max-width (max max-width (+ (graph-node-x node) half-width)))
      (setq fringep nil)
      (setq last-x (- (graph-node-x node) half-width separation)))
   max-width)


(defun graph-assign-x-positions-up/down (depth node-depths-table
      node-width-function separation horizontalp direction &aux (last-x 0))
   (loop for node in (the list (svref node-depths-table depth))
      do
      (let* ((parents/children
               (if (minusp direction) (graph-node-daughters node)
                  (graph-node-parents node)))
             (desired-x
               (if parents/children
                  (truncate
                     (let ((sum 0))
                        (loop for parent/child in (the list parents/children)
                           do
                           (incf sum (graph-node-x parent/child)))
                        sum)
                     (length (the list parents/children)))
                  (graph-node-x node))))
         (setf (graph-node-x node) desired-x)))
   (when (or *type-display* (and *chart-display* (> depth 2)))
      (setf (svref node-depths-table depth)
         (sort (svref node-depths-table depth)
            #'(lambda (n1 n2) (< (graph-node-x n1) (graph-node-x n2))))))
   (let ((n 0) (prev-dummy-node-p nil)
         (dummy-separation (truncate (* separation 2) 3)))
      (loop for node in (the list (svref node-depths-table depth))
         do
         (when
            (>= last-x
               (- +maximum-pixel-dimension+ max-node-width (* (+ max-node-height 5) 2)))
            (error "Graph is too wide for ~S to handle. There is room for only ~A out ~
                    of ~A nodes/links at depth ~A."
               'graph-display-layout (1- n) (length (svref node-depths-table depth))
               (1+ depth)))
         (let* ((dummy-node-p (dummy-graph-node-p node))
                (half-width
                  (if (or horizontalp dummy-node-p) 0
                     (truncate (get-node-width node node-width-function) 2))))
            (when (eql last-x 0) (setq last-x half-width))
            (setf (graph-node-x node)
               (max (graph-node-x node)
                  (+ last-x ; no room so have to go further out
                     (if (or dummy-node-p prev-dummy-node-p) dummy-separation separation)
                     half-width)))
            (setq last-x (+ (graph-node-x node) half-width))
            (setq prev-dummy-node-p dummy-node-p))
         (incf n)))
   last-x)


;;;

(defun graph-assign-y-positions (node-depths-table node-width-function separation
      horizontalp)
   (let ((current 1))
      (loop for depth from 0 to
         (1- (length (the simple-vector node-depths-table)))
         do
         (when
            (>= current
               (- +maximum-pixel-dimension+ max-node-width max-node-height 17))
            (error "Graph is too deep for ~S to handle." 'graph-display-layout))
         (loop for node in (the list (svref node-depths-table depth))
            do
            (setf (graph-node-y node) current))
         (setq current
            (+ current separation
               (if horizontalp
                  (let ((max-width 0))
                     (loop for node in (the list (svref node-depths-table depth))
                        do
                        (setq max-width
                           (max max-width
                              (if (dummy-graph-node-p node) 0
                                 (get-node-width node node-width-function)))))
                     max-width)
                  0))))
      current))


;;; Entry point 2
;;;
;;; Note that the x and y fields in nodes run vertically and horizontally
;;; respectively when the output format is horizontal. Max-x and max-y in
;;; the description structure run in the conventional directions, though.

(defun graph-display-output (stream description node-print-function
      &optional link-draw-function)
   (unless (and (streamp stream) (output-stream-p stream))
      (error "The STREAM argument to ~S is not a stream open for output."
         'graph-display-output))
   (unless (graph-description-p description)
      (error "The DESCRIPTION argument to ~S is not a graph-description."
         'graph-display-output))
   (unless (functionp node-print-function)
      (graph-display-function-error "NODE-PRINT-FUNCTION" 'graph-display-output))
   (funcall
      (if (graph-description-horizontalp description)
         'graph-display-horizontally 'graph-display-vertically)
      stream node-print-function
      (or link-draw-function
         #'(lambda (str parent child x1 y1 x2 y2 reversep)
             (declare (ignore parent child))
             (draw-line-x-y str x1 y1 x2 y2 reversep)))
      (graph-description-node-width-function description)
      (graph-description-node-height description)
      (graph-description-nodes description)))


;;; display type hierarchy / chart horizontally

(defun graph-display-horizontally (stream node-print-function link-draw-function
      node-width-function node-height node-depths-table)
   (let ((half-node-height (1- (truncate node-height 2))))
      (loop for depth from (if *type-display* 0 1)
                 to (1- (length (the simple-vector node-depths-table)))
         do
         (loop for node in (the list (svref node-depths-table depth))
            do
            (when (or *type-display* (and *chart-display* (> depth 1)))
               (loop for parent in (the list (graph-node-parents node))
                  do
                  ;; x and y positions for nodes are top left of label
                  (funcall link-draw-function stream
                     (and (proper-graph-node-p parent)
                        (proper-graph-node-contents parent))
                     (and (proper-graph-node-p node)
                        (proper-graph-node-contents node))
                     (if (dummy-graph-node-p parent) (graph-node-y parent)
                        (+ (graph-node-y parent) 1
                           (get-node-width parent node-width-function)))
                     (+ (graph-node-x parent) half-node-height)
                     (if (dummy-graph-node-p node) (graph-node-y node)
                        (- (graph-node-y node) 2))
                     (+ (graph-node-x node) half-node-height)
                     (member node (graph-node-reverse-links parent) :test #'eq))))
            (unless (dummy-graph-node-p node)
               (move-to-x-y stream (graph-node-y node) (graph-node-x node))
               (funcall node-print-function stream 
                  (proper-graph-node-contents node))
               (when (member node (graph-node-reverse-links node) :test #'eq)
                  (draw-circular-link-x-y stream
                     (+ (graph-node-y node)
                        (get-node-width node node-width-function))
                     (+ (graph-node-x node) half-node-height)
                     node-height t)))))))


;;; display parse tree vertically

(defun graph-display-vertically (stream node-print-function link-draw-function
      node-width-function node-height node-depths-table)
   (loop for depth from 0 to (1- (length (the simple-vector node-depths-table)))
      do
      (loop for node in (the list (svref node-depths-table depth))
         do
         (loop for parent in (the list (graph-node-parents node))
            do
            ;; x and y positions for nodes are in middle of top of label
            (funcall link-draw-function stream
               (and (proper-graph-node-p parent)
                  (proper-graph-node-contents parent))
               (and (proper-graph-node-p node)
                  (proper-graph-node-contents node))
               (graph-node-x parent)
               (if (dummy-graph-node-p parent) (graph-node-y parent)
                  (1- (+ (graph-node-y parent) node-height)))
               (graph-node-x node)
               (1- (graph-node-y node))
               (member node (graph-node-reverse-links parent) :test #'eq)))
         (unless (dummy-graph-node-p node)
            (move-to-x-y stream
               (- (graph-node-x node)
                  (truncate (get-node-width node node-width-function) 2))
               (graph-node-y node))
            (funcall node-print-function stream (proper-graph-node-contents node))
            (when (member node (graph-node-reverse-links node) :test #'eq)
               (draw-circular-link-x-y stream
                  (+ (graph-node-x node)
                     (truncate (get-node-width node node-width-function) 2))
                  (+ (graph-node-y node) (1- (truncate node-height 2)))
                  node-height nil))))))


;;; End of file