Source

cl-fgraph / source / graph / graph.lisp

Full commit
(in-package #:fgraph)

(defclass graph ()
  ())

(defgeneric nodes (graph)
  (:documentation "Returns the set of all nodes in GRAPH."))

(defgeneric edges (graph)
  (:documentation "Returns the set of all edges in GRAPH."))

(defmethod empty? ((collection graph))
  (empty? (nodes collection)))

(defgeneric connected? (graph)
  (:documentation "Returns T if there is a path from any node in GRAPH
  to any other node. Returns NIL otherwise."))

(defgeneric complete? (graph)
  (:documentation "Returns T if there is an edge for any two nodes in
  GRAPH. Returns NIL otherwise.")
  (:method ((graph graph))
    (= (size (edges graph))
       (let ((n (size (nodes graph))))
	 (* n (1- n)
	    1/2)))))

(defgeneric tree? (graph)
  (:documentation "Returns T if GRAPH is connected and contains no
  cycles."))

(defgeneric make-graph-edge (graph source target &rest options &key
				   &allow-other-keys)
  (:documentation "Returns an edge between nodes SOURCE and TARGET of
  the edge type used by GRAPH with specified options. SOURCE and
  TARGET need not be in GRAPH."))

(defgeneric add-node (graph node))

(defgeneric add-nodes (graph &rest nodes)
  (:method ((graph graph)
	    &rest nodes)
    (if (not nodes)
	graph
	(apply #'add-nodes
	       (add-node graph (first nodes))
	       (rest nodes)))))

(defgeneric rem-node (graph node))

(defgeneric rem-nodes (graph &rest nodes)
  (:method ((graph graph)
	    &rest nodes)
    (if (not nodes)
	graph
	(apply #'rem-nodes
	       (rem-node graph (first nodes))
	       (rest nodes)))))

(defgeneric add-edge (graph node1 node2 &rest options &key
			    &allow-other-keys))

(defgeneric add-edges (graph source targets &rest options &key
			     &allow-other-keys)
  (:method ((graph graph)
	    source (targets null)
	    &rest options &key &allow-other-keys)
    (declare (ignore source targets options))
    graph)
  (:method ((graph graph)
	    source (targets cons)
	    &rest options &key &allow-other-keys)
    (apply #'add-edges
	   (apply #'add-edge
		  graph source (car targets)
		  options)
	   source (cdr targets)
	   options)))

(defgeneric contains-node? (graph node)
  (:documentation "Returns T when NODE is a node of GRAPH, NIL
  otherwise")
  (:method ((graph graph)
	    node)
    (lookup (nodes graph)
	    node)))

(defgeneric contains-edge? (graph edge)
  (:documentation "Returns T when EDGE is an edge of GRAPH, NIL
  otherwise")
  (:method ((graph graph)
	    edge)
    (lookup (edges graph)
	    edge)))

(defgeneric find-edges (graph &rest options &key source target
			      &allow-other-keys)
  (:documentation "Returns the set of all edges in GRAPH that
  satisifies OPTIONS.")
  (:method ((graph graph)
	    &rest options &key source target &allow-other-keys)
    (declare (ignore source target))
    (filter (lambda (edge)
	      (apply #'edge-properties?
		     edge options))
	    (edges graph))))

(defgeneric rem-edge (graph &rest options &key source target
			    &allow-other-keys))

(defgeneric contract-edge (graph node1 node2 &key contraction-fun)
  (:method ((graph graph)
	    node1 node2 &key (contraction-fun (lambda (a b)
						(declare (ignore b))
						a)))
    (if (not (empty? (find-edges graph
				 :source node1
				 :target node2)))
	(let ((new-node (funcall contraction-fun node1 node2)))
	  (map-graph graph (lambda (graph node)
			     (declare (ignore graph))
			     (if (or (equal? node node1)
				     (equal? node node2))
				 new-node
				 node))))
	graph)))

(defgeneric subdivide-edge (graph node1 node2 new-node &rest options
				  &key &allow-other-keys)
  (:method ((graph graph)
	    node1 node2 new-node &rest options &key &allow-other-keys)
    (if (not (empty? (apply #'find-edges
			    graph
			    :source node1
			    :target node2
			    options)))
	(apply #'add-edge
	       (apply #'add-edge
		      (add-node (apply #'rem-edge
				       graph
				       :source node1
				       :target node2
				       options)
				new-node)
		      node1 new-node options)
	       new-node node2 options)
	graph)))

(defgeneric incident? (graph node1 node2)
  (:documentation "Returns T if NODE1 and NODE2 are connected by an
  edge in GRAPH. Returns NIL otherwise.")
  (:method ((graph graph)
	    node1 node2)
    (not (and (empty? (find-edges graph
				  :source node1
				  :target node2))
	      (empty? (find-edges graph
				  :source node2
				  :target node1))))))

(defgeneric neighbours (graph node &rest options &key
			      &allow-other-keys)
  (:documentation "Returns the set of all nodes N for which there is
  an edge from NODE to N in GRAPH satisfying OPTIONS.")
  (:method ((graph graph)
	    node &rest options &key &allow-other-keys)
    (image (lambda (edge)
	     (target-of edge node))
	   (apply #'find-edges
		  graph
		  :source node
		  options))))

(defgeneric induced-graph (graph nodes)
  (:documentation "Returns the graph induced by NODES in GRAPH."))

(defgeneric sanitized-graph (graph)
  (:documentation "Returns a graph where all nodes reached by edges
  are in the graph.")
  (:method ((graph graph))
    (induced-graph graph (nodes graph))))

(defgeneric graph-union (graph1 graph2)
  (:documentation "Returns the union of GRAPH1 and GRAPH2."))

(defmethod union ((set-or-bag1 graph)
		  (set-or-bag2 graph)
		  &key test test-not)
  (declare (ignore test test-not))
  (graph-union set-or-bag1 set-or-bag2))

(defgeneric graph-intersection (graph1 graph2)
  (:documentation "Returns the intersection of GRAPH1 and GRAPH2."))

(defmethod intersection ((set-or-bag1 graph)
			 (set-or-bag2 graph)
			 &key test test-not)
  (declare (ignore test test-not))
  (graph-intersection set-or-bag1 set-or-bag2))

(defgeneric graph-difference (graph1 graph2))

(defgeneric graph-sum (graph1 graph2))

(defgeneric graph-cross-product (graph1 graph2))

(defgeneric depth-first-search (graph source target &optional
				      predicate)
  (:documentation "Returns a path (if there is one) from SOURCE to
  TARGET in GRAPH and NIL of there is none. The path is found via
  depth first search.")
  (:method ((graph graph)
	    source target &optional predicate)
    (when (and (contains-node? graph source)
	       (contains-node? graph target))
      (if (equal? source target)
	  (seq source)
	  (loop for n in (if predicate
			     (convert 'list
				      (sort (neighbours graph source)
					    predicate))
			     (convert 'list
				      (neighbours graph source)))
	     do (if (equal? n target)
		    (return (seq source target))
		    (awhen (depth-first-search (rem-node graph source)
					       n target predicate)
		      (return (concat (seq source)
				      it)))))))))

(defgeneric breadth-first-search (graph source target &optional
					predicate)
  (:documentation "Returns a path (if there is one) from SOURCE to
  TARGET in GRAPH and NIL of there is none. The path is found via
  breadth first search.")
  (:method ((graph graph)
	    source target &optional (predicate (constantly t)))
    (when (and (contains-node? graph source)
	       (contains-node? graph target))
      (let ((paths (sort (image (lambda (n)
				  (seq n))
				(neighbours graph source))
			 (lambda (a b)
			   (funcall predicate (if (seq? a)
						  (last a)
						  a)
				    (if (seq? b)
					(last b)
					b)))))
	    (visited (set source)))
	(if (equal? source target)
	    (seq source)
	    (loop do
		 (if (empty? paths)
		     (return-from breadth-first-search
		       nil)
		     (let* ((path (lookup paths 0))
			    (end (last path)))
		       (if (equal? end target)
			   (return-from breadth-first-search
			     (concat (seq source)
				     path))
			   (setf
			    paths
			    (concat (subseq paths 1)
				    (image
				     (lambda (n)
				       (concat path (seq n)))
				     (sort (set-difference (neighbours
							    graph
							    end)
							   visited)
					   predicate)))
			    visited (with visited end)))))))))))

(defgeneric normal-spanning-tree (graph root &optional predicate)
  (:documentation "Returns a normal spanning tree of GRAPH with root
  ROOT."))

(defgeneric breadth-spanning-tree (graph root &optional predicate)
  (:documentation "Returns a spanning tree of GRAPH obtained by doing
  a breadth first traversal of GRAPH starting at ROOT."))

#|
;;; Problem: How to combine edges? When using a priority queue to do
;;; dijkstra we need to know how far a certain node is from the root
;;; and not only from its parent.
(defgeneric dijkstra-spanning-tree (graph root predicate)
  (:documentation "Returns a spanning tree of GRAPH obtained by doing
  a traversal as in dijkstras algorithm starting at ROOT. PREDICATE
  should be a function from two edges to a boolean and should return T
  if the first edge is 'shorter' than the second edge and NIL
  otherwise."))|#

(defgeneric graph-complement (graph)
  (:documentation "Returns the graph with all nodes of GRAPH so that
  for any nodes N1 and N2 there is an edge from N1 to N2 in the
  resulting graph if there is no edge from N1 to N2 in GRAPH."))

(defgeneric contract-graph (graph op root &key start leaf
				  child-order)
  ;; CHILD-ORDER should be a function of 4 arguments (NODE1 EDGE1
  ;; NODE2 EDGE2) and should return a boolean. This function is used
  ;; to sort the neighbours of root
  (:method ((graph graph)
	    (op function)
	    root &key start leaf (child-order (constantly t)))
    (let ((visited (empty-set)))
      (labels ((contract (root nodes)
		 (format t "~&Contracting ~A with ~A."
			 root nodes)
		 (if (null nodes)
		     root
		     (contract (if (contains? visited (car nodes))
				   root
				   (funcall op root
					    (traverse (first nodes))))
			       (rest nodes))))
	       (traverse (root)
		 (format t "~&Traversing ~A, neighbours ~A."
			 root (neighbours graph root))
		 (if (contains? visited root)
		     leaf
		     (progn
		       (setf visited (with visited root))
		       (contract
			(funcall op start root)
			(sort (convert
			       'list
			       (set-difference (neighbours graph root)
					       visited))
			      child-order))))))
	(traverse root)))))

(defgeneric map-graph (graph op)
  (:documentation "Maps function OP over all nodes of GRAPH. OP Should
  be a function that takes two arguments, the first being the graph
  over which OP is mapped and the second being the node processed."))