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

(in-package :clim-user)


;;; Define :parse-tree, a new graph type for use with format-graph-from-root(s) which
;;; draws things that look more like traditional parse trees than what's produced by
;;; the :tree graph type in McCLIM and Allegro CLIM.
;;;
;;; In both CLIM implementations we only need a minor change in non-leaf node layout,
;;; so ideally we'd just lightly customise the behaviour of layout-graph-nodes. The
;;; CLIM 2.0 spec says that there should be a default graph formatting implementation
;;; where the core methods (i.e. generate-graph-nodes, layout-graph-nodes and
;;; layout-graph-edges) specialise on standard-graph-output-record. So all we'd need
;;; to do define our own class that inherits from s-g-o-r and define a special-purpose
;;; version of layout-graph-nodes. This works fine in McCLIM.
;;;
;;; Unfortunately, Allegro CLIM doesn't does not have a documented graph formatting
;;; protocol, so to use this approach we have to specialise an undocumented internal
;;; class.

(defclass parse-tree-graph-output-record (#+:mcclim standard-graph-output-record
                                          #-:mcclim clim-internals::tree-graph-output-record)
    ())

(define-graph-type :parse-tree parse-tree-graph-output-record)

(defmethod layout-graph-nodes ((graph-output-record parse-tree-graph-output-record)
                               stream arc-drawer arc-drawing-options)
  ;; Assuming that the only thing amiss with the usual layout is the horizontal
  ;; position of non-leaf nodes, start with that layout and then reposition each
  ;; non-leaf node centrally between the mid-points of its first and last child nodes.
  ;; Expects :orientation :vertical
  ;;
  ;; NB this approach to centering only works for trees - applying it to non-tree
  ;; graphs can result in nodes that share a descendant being laid out on top of
  ;; one another.
  ;;
  (call-next-method)
  (labels ((center-horizontally (node)
             (let ((children (graph-node-children node)))
               (map nil #'center-horizontally children)
               (unless (zerop (length children))
                 ;; adjust even unary branches in case the child has moved
                 (let* ((c1 (elt children 0))
                        (cn (elt children (1- (length children))))
                        (mid (- (/ (+ (output-record-position c1)
                                      (/ (bounding-rectangle-width c1) 2)
                                      (output-record-position cn)
                                      (/ (bounding-rectangle-width cn) 2))
                                   2)
                                (/ (bounding-rectangle-width node) 2))))
                   (setf (output-record-position node)
                     (values mid (nth-value 1 (output-record-position node)))))))))
    (map nil #'center-horizontally (graph-root-nodes graph-output-record))))


#|  
(defclass parse-chart-graph-output-record (directed-graph-output-record) ())

(define-graph-type :parse-chart parse-chart-graph-output-record)

(defmethod layout-graph-nodes :around ((graph parse-chart-graph-output-record) 
				       stream arc-drawer options)
  (call-next-method))

(defmethod layout-graph-nodes ((graph parse-chart-graph-output-record) 
			       stream arc-drawer options)
  (declare (ignore stream arc-drawer options))
  (with-slots (root-nodes properties) graph
    (let* ((dx (getf properties :generation-separation))
	   (dy (getf properties :within-generation-separation))
	   (top-layer (loop for node in (graph-node-children (car root-nodes))
			  for i upfrom 1
			  do (setf (slot-value node 'generation-tick) i)
			  collecting node))
	   (widest-layer (sort-layers top-layer)))
      (let ((x dx))
	(loop for layer = top-layer then (next-layer layer)
	    while layer
	    do (let ((y 0)
		     (widest 0)
		     (new-layer (stable-sort 
				 (copy-list layer) #'< 
				 :key #'(lambda (node)
					  (slot-value node 
						      'generation-tick)))))
		 (loop for node in new-layer
		     do (setf (graph-node-x node) x)
			(setf (graph-node-y node) 
			  (incf y (+ 30 dy))) ; (+ (bounding-rectangle-height node) dy)
			(setf widest (max widest 
					  (bounding-rectangle-width node))))
		 (incf x (+ widest dx)))))))
  (tree-recompute-extent graph))
	    
(defun sort-layers (layer)
  (when layer
    (let* ((new-layer 
	    (sort-layers
	     (loop for node in (next-layer layer)
		 do (setf (slot-value node 'generation-tick)
		      (* (/ (length (graph-node-parents node)))
			 (loop for parent in (graph-node-parents node)
			     sum (slot-value parent 'generation-tick))))
		 collecting node))))
      (if (> (length layer) (length new-layer))
	  layer
	new-layer))))

(defun next-layer (layer)
  (loop for node in layer
      appending (loop for child in (graph-node-children node)
		    when (= (graph-node-generation child) 
			    (1+ (graph-node-generation node)))
		    collect child)))
|#