;;; -*- mode:lisp; package: graph; base:10.; -*- ;;;

;;;  LAYOUT

;;;  This file contains code to implement layout algorithms for the
;;; graph editor.
;;;
;;;  It includes TWO TYPES of utilities:

;;;    1.   Facilities to manipulate already-drawn graphs to make
;;;         them look better.
;;;    2.   Facilities to draw graphs from existing structure.
;;;         This second sort may be useful with existing graphs.  You
;;;         could, for example, erase a set of nodes and arcs, pass
;;;         the information to this feature, and have that part of
;;;         the graph re-drawn nicely.



;;;  ****************************************************************
;;;  Necessary Loads, Constants, Declarations.
;;;  ****************************************************************






;;;  ****************************************************************
;;;  Internal Macros, Structure Definitions, FLAVOR definitions.
;;;  ****************************************************************






;;;  ****************************************************************
;;;  Internal Code
;;;  ****************************************************************


;;;  ****************
;;;  Rearranging existing graphs
;;;  ****************

;;;  Top level message.
(defmethod (graph-display-mixin :improve-layout-all-nodes)
	   ()
  (let ((swap-nodes (improve-layout nodes)))
    (when swap-nodes
      (send (car swap-nodes) ':exchange-with (cdr swap-nodes)))))

(defmethod (graph-display-mixin :improve-layout-some-nodes)
	   ()
  (let ((swap-nodes (improve-layout (send self ':select-many-nodes))))
    (when swap-nodes
      (send (car swap-nodes) ':exchange-with (cdr swap-nodes)))))


;;; This method leaves the screen pretty messed up if there are 
;;; designer arcs so we refresh the screen when we aredone.

(defmethod (graph-display-mixin :improve-layout-some-nodes-to-the-max)
	   ()
  (loop with node-list = (send self ':select-many-nodes)
	for swap = (improve-layout node-list)
	until (null swap)
	do (send (car swap) ':exchange-with (cdr swap)))
  (send self ':redraw))

;;;  Top level code to "clean up" a section of a graph.  This will consider
;;; what would happen if you exchanged pairs of nodes in a set.  The approach
;;; used here is typical of hill climbing:  you may make local improvements that
;;; won't work well overall.  Because of this, the implementer should couple
;;; this code with some interaction with the user.
;;;  This routine loops over pairs of nodes in a set until a swap is done,
;;; then returns.  If a swap was done, this returns CONS of the two nodes that
;;; were swapped.  If no swap was done, returns nil.
(defun improve-layout (node-list)
  (loop for node1 in node-list
	if (loop for node2 in node-list
		 if (maybe-swap node1 node2)
		 return (cons node1 node2)
		 finally nil)
	return it
	finally nil))


;;;  This function considers exchanging the position of two nodes, and seeing which
;;; results in fewer overlaps between arcs.  If the exchange results in fewer overlaps,
;;; it returns T.
(defun maybe-swap (node1 node2)
  (with-drawing-inhibited
    (let ((overlaps (+ (send node1 ':compute-arc-overlaps)
		       (send node2 ':compute-arc-overlaps))))
      (send node1 ':exchange-with node2)
      (if (prog1 (< (+ (send node1 ':compute-arc-overlaps)
		       (send node2 ':compute-arc-overlaps))
		    overlaps)
		 (send node1 ':exchange-with node2))
	  t
	  nil))))


;;; Interactive version of below.
(defmethod (basic-node :interactive-exchange-node)
	   ()
  (with-object-flashing self
    (send self ':exchange-with (send window ':select-node))))

;;;  Exchanges two nodes.  Doesn't do anything about guaranteeing overlaps.
(defmethod (basic-node :exchange-with)
	   (node)
  (erase self)
  (erase node)
  (let ((old-x x)
	(old-y y))
    (setq x (send node ':x)
	  y (send node ':y))
    (send node ':set-x old-x)
    (send node ':set-y old-y)
    (loop for arc in arcs do (send arc ':compute-joint-points))
    (loop for arc in (send node ':arcs) do (send arc ':compute-joint-points)))
  (draw self)
  (draw node))

;;;  A method used to compute the number of overlaps between arcs.  This
;;; computes the overlaps of arcs touching this node with other arcs.  An
;;; arc does NOT overlap itself.  Two arcs overlap if any of their segments
;;; intersect.
(defmethod (basic-node :compute-arc-overlaps)
	   ()
  (loop for arc1 in arcs
	sum (loop for arc2 in (send window ':arcs)
		  count (send arc1 ':overlap-p arc2))))


;;;  Returns T if this arc overlaps another arc.  Does this by examining segments.
(defmethod (basic-arc :overlap-p)
	   (arc)
  (unless (eq arc self)
    (loop for (x1 y1 x2 y2 . rest) on joint-points by 'cddr
	  until (null x2)
	  if (loop for (x3 y3 x4 y4 . rest) on (send arc ':joint-points) by 'cddr
		   until (null x4)
		   if (overlap-segment x1 y1 x2 y2 x3 y3 x4 y4)
		   return t
		   finally nil)
	  return t
	  finally nil)))

;;;  Finally, the meat.  Computes whether two line-segments overlap.
(defun overlap-segment (ax1 ay1 ax2 ay2 bx1 by1 bx2 by2)
  ;;  If the lines are parallel, then by definition they don't
  ;; overlap.  (Even if they are colinear, it won't help to swap
  ;; endpoints.
  (unless (parallel-p ax1 ay1 ax2 ay2 bx1 by1 bx2 by2)
    (multiple-value-bind (intx inty)
	(intersection-point ax1 ay1 ax2 ay2 bx1 by1 bx2 by2)
      (and (segment-contains-point ax1 ay1 ax2 ay2 intx inty)
	   (segment-contains-point bx1 by1 bx2 by2 intx inty)))))


;;;  Parallel lines have the same slope.  Careful not to divide by zero.
(defun parallel-p (x1 y1 x2 y2 x3 y3 x4 y4)
  (cond ;; If both segments have 
y = 0, return t.
	((and (= y1 y2) (= y3 y4)) t)
	;; If only one has 
y = 0, nil
	((or (= y1 y2) (= y3 y4)) nil)
	;; Otherwise, compare slopes
	(t (= (// (- x2 x1) (float (- y2 y1)))
	      (// (- x4 x3) (float (- y4 y3)))))))


;;;  Computes the intersection-point of two lines defined by points.
;;; We know the two lines are NOT parallel at this point.
(defun intersection-point (x1 y1 x2 y2 x3 y3 x4 y4)
  (cond ((eq x1 x2)				;If first line is vertical
	 (values x1 (+ (* (// (- y4 y3) (float (- x4 x3))) (- x1 x3)) y3)))
	((eq x3 x4)				;If second line is vertical
	 (values x3 (+ (* (// (- y2 y1) (float (- x2 x1))) (- x3 x1)) y1)))
	(t					;Otherwise, safe to calc slopes.
	 (let* ((slope1 (// (- y2 y1) (float (- x2 x1))))
		(slope2 (// (- y4 y3) (float (- x4 x3))))
		(x (// (- (+ (* slope1 x1) y3) (* slope2 x3) y1)
		       (- slope1 slope2))))
	   (values x (+ (* slope1 (- x x1)) y1))))))

;;;  Returns T if the segment contains the point indicated.  We can
;;; cheat, since we know that the point is on the line defined by
;;; the segment.
(defun segment-contains-point (x1 y1 x2 y2 x y)
  (and (<= (min x1 x2) x (max x1 x2))
       (<= (min y1 y2) y (max y1 y2))))