--- /dev/null
+Copyright (c) 2004-2005 Gary Warren King (gwking@metabang.com)
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
--- /dev/null
+;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-
+
+#|
+
+|#
+
+(in-package :common-lisp-user)
+(defpackage "ASDF-CL-GRAPH" (:use #:cl #:asdf))
+(in-package "ASDF-CL-GRAPH")
+
+(unless (find-system 'asdf-system-connections nil)
+ (when (find-package 'asdf-install)
+ (print "Trying to install asdf-system-connections with ASDF-Install...")
+ (funcall (intern "INSTALL" "ASDF-INSTALL") 'asdf-system-connections)))
+;; give up with a useful (?) error message
+(unless (find-system 'asdf-system-connections nil)
+ (error "The CL-Graph system requires ASDF-SYSTEM-CONNECTIONS. See
+http://www.cliki.net/asdf-system-connections for details and download
+instructions."))
+
+(asdf:operate 'asdf:load-op 'asdf-system-connections)
+
+(defsystem cl-graph
+ :version "0.8"
+ :author "Gary Warren King <gwking@metabang.com>"
+ :maintainer "Gary Warren King <gwking@metabang.com>"
+ :licence "MIT Style License"
+ :description "Graph manipulation utilities for Common Lisp"
+ :components ((:module "dev"
+ :components ((:file "package")
+ (:file "api"
+ :depends-on ("package"))
+ (:file "macros"
+ :depends-on ("package"))
+ (:file "graph"
+ :depends-on ("api"))
+ (:file "graph-container"
+ :depends-on ("graph"))
+ (:file "graph-matrix"
+ :depends-on ("graph"))
+ (:file "graph-metrics"
+ :depends-on ("graph"))
+ (:file "graph-algorithms"
+ :depends-on ("graph"))
+ (:file "graphviz-support"
+ :depends-on ("graph"))
+
+ (:static-file "notes.text")))
+ (:module "website"
+ :components ((:module "source"
+ :components ((:static-file "index.lml"))))))
+
+ :depends-on (metatilities
+ cl-containers
+ metabang-bind
+ cl-mathstats
+ asdf-system-connections ; makes ASDF-Install get this automatically
+ ))
+
+;;; ---------------------------------------------------------------------------
+
+(asdf:defsystem-connection cl-graph-and-cl-variates
+ :requires (cl-graph cl-variates)
+ :components ((:module "dev"
+ :components ((:file "graph-and-variates")
+ (:file "graph-generation"
+ :depends-on ("graph-and-variates"))))))
--- /dev/null
+(in-package cl-graph)
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-vertex-container (graph initial-size)
+ (:documentation "Make-vertex-container is called during graph creation and can be used to create specialized containers to hold graph vertexes."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-edge-container (graph initial-size)
+ (:documentation "Make-edge-container is called during graph creation and can be used to create specialized containers to hold graph edges."))
+
+;;; ---------------------------------------------------------------------------
+;;; API
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-graph (graph-type &key)
+ (:documentation "Create a new graph of type `graph-type'. Graph type can be
+a symbol naming a sub-class of basic-graph or a list. If it is a list of symbols naming
+different classes. If graph-type is a list, then a class which has all of the listed
+classes as superclasses will be found (or created). In either case, the new graph will
+be created as if with a call to make-instance."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-edge-for-graph (graph vertex-1 vertex-2
+ &key edge-type edge-class &allow-other-keys)
+ (:documentation "It should not usually necessary to call this in user code. Creates a new edge between vertex-1 and vertex-2 for the graph. If the edge-type and edge-class are not specified, they will be determined from the defaults of the graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric add-edge (graph edge &rest args &key force-new?)
+ (:documentation "Add-edge adds an existing edge to a graph. As add-edge-between-vertexes is generally more natural to use, this method is rarely called."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric add-edge-between-vertexes (graph value-or-vertex-1 value-or-vertex-2
+ &rest args &key if-duplicate-do
+ edge-type)
+ (:documentation "Adds an edge between two vertexes and returns it.
+If force-new? is true,
+the edge is added even if one already exists.
+If the vertexes are not
+found in the graph, they will be added \(unless :error-if-not-found? is
+true\). The class of the edge can be specified using :edge-class or
+:edge-type. If :edge-type is used, it can be either :directed or
+:undirected; the actual class of the edge will be determined by using
+the edge-types of the graph. If neither :edge-type nor :edge-class is
+specified, then a directed edge will be created.
+
+If-duplicate-do is used when the 'same' edge is added more than once. It can be
+either a function on one variable or :ignore or :force. If it is :ignore, then
+the previously added edge is returned; if it is :force, then another edge is
+added between the two vertexes; if it is a function, then this function will
+be called with the previous edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric delete-edge (graph edge)
+ (:documentation "Delete the `edge' from the `graph' and returns it."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric delete-edge-between-vertexes (graph value-or-vertex-1
+ value-or-vertex-2 &rest args)
+ (:documentation "Finds an edge in the graph between the two specified vertexes. If values (i.e., non-vertexes) are passed in, then the graph will be searched for matching vertexes."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric add-vertex (graph value-or-vertex &key if-duplicate-do)
+ (:documentation "Adds a vertex to a graph. If called with a vertex, then this vertex is added. If called with a value, then a new vertex is created to hold the value. If-duplicate-do can be one of :ignore, :force, :replace, :replace-value or a function. The default is :ignore."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric delete-vertex (graph value-or-vertex)
+ (:documentation "Remove a vertex from a graph. The 'vertex-or-value' argument can be
+a vertex of the graph or a 'value' that will find a vertex via a call to find-vertex. A
+graph-vertex-not-found-error will be raised if the vertex is not found or is not part of
+the graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-vertex (graph value &optional error-if-not-found?)
+ (:documentation "Search 'graph' for a vertex with element 'value'. The search is fast but inflexible because it uses an associative-container. If you need more flexibity, see search-for-vertex."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric search-for-vertex (graph value &key key test error-if-not-found?)
+ (:documentation "Search 'graph' for a vertex with element 'value'. The 'key' function is applied to each element before that element is compared with the value. The comparison is done using the function 'test'. If you don't need to use key or test, then consider using find-vertex instead."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-edge (graph edge &optional error-if-not-found?)
+ (:documentation "Search `graph` for an edge whose vertexes match `edge`. This means that `vertex-1` of the edge in the graph must match `vertex-1` of `edge` and so forth. Wil signal an error of type `graph-edge-not-found-error` unless `error-if-not-found?` is nil. [?? Unused. Remove?]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-edge-between-vertexes (graph value-or-vertex-1 value-or-vertex-2
+ &key error-if-not-found?)
+ (:documentation "Searches `graph` for an edge that connects vertex-1 and vertex-2. [?? Ignores error-if-not-found? Does directedness matter? need test]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric source-vertex (edge)
+ (:documentation "Returns the source-vertex of a directed edge. Compare with `vertex-1`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric target-vertex (edge)
+ (:documentation "Returns the target-vertex of a directed edge. Compare with `vertex-2`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-edges (graph-or-vertex fn)
+ (:documentation "Calls `fn` on each edge of graph or vertex."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-source-edges (vertex fn)
+ (:documentation "In a directed graph, calls `fn` on each edge of a vertex that begins at vertex. In an undirected graph, this is equivalent to `iterate-edges`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-target-edges (vertex fn)
+ (:documentation "In a directed graph, calls `fn` on each edge of a vertex that ends at vertex. In an undirected graph, this is equivalent to `iterate-edges`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-children (vertex fn)
+ (:documentation "Calls fn on every vertex that is either connected to vertex by an undirected edge or is at the target end of a directed edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric has-children-p (vertex)
+ (:documentation "In a directed graph, returns true if vertex has any edges that point from vertex to some other vertex (cf. iterate-target-edges). In an undirected graph, `has-children-p` is testing only whether or not the vertex has any edges."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric has-parent-p (vertex)
+ (:documentation "In a directed graph, returns true if vertex has any edges that point from some other vertex to this vertex (cf. iterate-source-edges). In an undirected graph, `has-parent-p` is testing only whether or not the vertex has any edges."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-parents (vertex fn)
+ (:documentation "Calls fn on every vertex that is either connected to vertex by an undirected edge or is at the source end of a directed edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-neighbors (vertex fn)
+ (:documentation "Calls fn on every vertex adjecent to vertex See also iterate-children and iterate-parents."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric renumber-vertexes (graph)
+ (:documentation "Assign a number to each vertex in a graph in some unspecified order. [?? internal]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric renumber-edges (graph)
+ (:documentation "Assign a number to each edge in a graph in some unspecified order. [?? internal]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-directed-free-tree (graph root)
+ (:documentation "Returns a version of graph which is a directed free tree
+rooted at root."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric in-undirected-cycle-p (graph start-vertex &optional marked previous)
+ (:documentation "Return true if-and-only-if an undirected cycle in graph is reachable from start-vertex."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric undirected-edge-p (edge)
+ (:documentation "Returns true if-and-only-if edge is undirected"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric directed-edge-p (edge)
+ (:documentation "Returns true if-and-only-if edge is directed"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric tagged-edge-p (edge)
+ (:documentation "Returns true if-and-only-if edge's tag slot is t"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric untagged-edge-p (edge)
+ (:documentation "Returns true if-and-only-if edge's tage slot is nil"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric adjacentp (graph vertex-1 vertex-2)
+ (:documentation "Return true if vertex-1 and vertex-2 are connected by an edge. [?? compare with vertices-share-edge-p and remove one or maybe call one directed-adjacentp]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-filtered-graph (old-graph test-fn &optional graph-completion-method depth)
+ (:documentation "Takes a GRAPH and a TEST-FN (a single argument function
+returning NIL or non-NIL), and filters the graph nodes according to
+the test-fn (those that return non-NIL are accepted), returning
+a new graph with only nodes corresponding to those in the
+original graph that satisfy the test (the nodes in the new graph
+are new, but their values and name point to the same contents of
+the original graph). There are four options for how the new
+graph is filled-out, depending on the following keywords passed
+to the optional GRAPH-COMPLETION-METHOD argument:
+
+* NIL (default)
+
+ New graph has only nodes that correspond to those in
+ the original graph that pass the test. NO LINKS are
+ reproduced.
+
+* :COMPLETE-LINKS
+
+ New graph has only nodes that pass, but reproduces
+ corresponding links between passing nodes in the
+ original graph.
+
+* :COMPLETE-CLOSURE-NODES-ONLY
+
+ New graph also includes nodes corresponding to the
+ transitive closure(s) that include the passign nodes
+ in the original graph. NO LINKS are reproduced.
+
+* :COMPLETE-CLOSURE-WITH-LINKS
+
+ Same as above, except corresponding links are reproduced.
+
+For both transitive closure options, an additional optional argument,
+DEPTH, specifies how many links away from a source vertex to travel
+in gathering vertexes of the closure. E.g., a depth of 1 returns the
+source vertex and the parents and children of that vertex (all vertexes
+one link away from the source). The default value is NIL, indicating
+that all vertexes are to be included, no matter their depth. This
+value is ignored in non closure options."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric project-bipartite-graph
+ (new-graph existing-graph vertex-class vertex-classifier)
+ (:documentation "Creates the unimodal bipartite projects of existing-graph with
+vertexes for each vertex of existing graph whose `vertex-classifier` is eq to `vertex-class` and where an edge existing between two vertexes of the graph if and only if they are connected to a shared vertex in the existing-graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric assortativity-coefficient (mixing-matrix)
+ (:documentation "An assortative graph is one where vertexes of the same type are more likely to
+have edges between them. The \(discrete\) assortativity-coefficient measures how
+assortative a graph is based on its mixing matrix. The definition we use is from
+Mixing Patterns in Networks by Mark Newman. See the citation 'newman200-mixing' in moab
+or the URL 'http://arxiv.org/abs/cond-mat/0209450'."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric graph->dot (graph output
+ &key
+ graph-formatter
+ vertex-key
+ vertex-labeler
+ vertex-formatter
+ edge-key
+ edge-labeler
+ edge-formatter)
+ (:documentation
+ "Generates a description of `graph` in DOT file format. The formatting can be altered using `graph->dot-properties,` `vertex->dot,` and `edge->dot` as well as `edge-formatter,` `vertex-formatter,` `vertex-labeler,` and `edge-labeler`. These can be specified directly in the call to `graph->dot` or by creating subclasses of basic-graph, basic-vertex and basic-edge.
+
+The output can be a stream or pathname or one of the values `nil` or `t`. If output is `nil`, then graph->dot returns a string containing the DOT description. If it is `t`, then the DOT description is written to *standard-output*.
+
+Here is an example;
+
+ (let ((g (make-container 'graph-container :default-edge-type :directed)))
+ (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b))
+ (graph->dot g nil))
+
+ \"digraph G {
+ E []
+ C []
+ B []
+ A []
+ D []
+ F []
+ E->F []
+ B->C []
+ B->D []
+ A->B []
+ D->E []
+ D->F []
+ }\"
+
+For more information about DOT file format, search the web for 'DOTTY' and
+'GRAPHVIZ'."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric graph->dot-properties (g stream)
+ (:documentation "Unless a different graph-formatter is specified, this method is called by graph->dot to output graph-properties onto a stream. The function can assume that the openning and closing brackets will be taken care of by the graph->dot."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric vertex->dot (vertex stream)
+ (:documentation "Unless a different vertex-formatter is specified with a keyword argument, this is used by graph->dot to output vertex formatting for `vertex` onto the `stream`. The function can assume that openning and closing square brackets and label have already been taken care of."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric edge->dot (edge stream)
+ (:documentation "Used by graph->dot to output edge formatting for `edge` onto the `stream`. The function can assume that openning and closing square brackets and label have already been taken care of."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-Gnm (generator graph n m &key)
+ (:documentation "Generate a 'classic' random graph G(n, m) with n vertexes and m edges."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-Gnp (generator graph n p &key)
+ (:documentation "Generate the Erd\"os-R\'enyi random graph G\(n, p\). I.e., a graph with n vertexes where
+each possible edge appears with probability p. This implementation is from Efficient Generation
+of Large Random Networks \(see batagelj-generation-2005 in doab\)."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-undirected-graph-via-assortativity-matrix
+ (generator graph-class size edge-count kind-matrix assortativity-matrix
+ vertex-labeler &key)
+ (:documentation "This generates a random graph with 'size' vertexes.
+The vertexes can be in multiple different classes and the number of vertexes in each class is specified in the 'kind-matrix'. If the matrix has all fixnums, then it specifies the counts and these should add up to the size. If the kind-matrix contains non-fixnums then the values are treated as ratios.
+
+The assortativity-matrix specifies the number of edges between vertexes of different kinds.
+
+The vertex-labeler is a function of two parameters: the vertex kind and the index. It should return whatever the 'value' of the vertex ought to be."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-undirected-graph-via-vertex-probabilities
+ (generator graph-class size kind-matrix probability-matrix vertex-labeler)
+ (:documentation "Generate an Erd\"os-R/'enyi like random graph having multiple vertex kinds. See the function
+Gnp for the simple one vertex kind method.
+
+Generator and graph-class specify the random number generator used and the class of the graph produced; Size
+the number of vertexes. Kind matrix is a vector of ratios specifying the distribution of vertex kinds {0 ... \(1- k\)}.
+The probability-matrix is a k x k matrix specifying the probability that two vertexes of the row-kind and the
+column-kind will have an edge between them. vertex-labeler is a function of two arguments \(the kind and the vertex number\)
+called to create values for vertexes. It will be called only once for each vertex created.
+
+The clever sequential sampling technique in this implementation is from Efficient Generation
+of Large Random Networks \(see batagelj-generation-2005 in moab\)."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-scale-free-graph
+ (generator graph size kind-matrix add-edge-count
+ other-vertex-kind-samplers vertex-labeler &key)
+ (:documentation "Generates a 'scale-free' graph using preferential attachment -- too damn slow.
+
+Size is the number of vertexes;
+kind-matrix is as in generate-undirected-graph-via-assortativity-matrix, etc.;
+add-edge-count is the number of edges to add for each vertex;
+other-vertex-kind-samplers are confusing...; and
+vertex-labeler is used to create vertex elements \(as in other generators\)."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-assortative-graph-with-degree-distributions
+ (generator graph
+ edge-count assortativity-matrix
+ average-degrees
+ degree-distributions
+ vertex-labeler
+ &key)
+ (:documentation ""))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-simple-preferential-attachment-graph (generator graph size minimum-degree)
+ (:documentation "Generate a simple scale-free graph using the preferential attachment
+mechanism of Barabasi and Albert. The implementation is from Efficient Generation
+of Large Random Networks \(see batagelj-generation-2005 in moab\). Self-edges are possible."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric generate-preferential-attachment-graph
+ (generator graph size kind-matrix minimum-degree
+ assortativity-matrix
+ &key)
+ (:documentation "Generate a Barabasi-Albert type scale free graph with multiple vertex kinds.
+
+The idea behind this implementation is from Efficient Generation
+of Large Random Networks \(see batagelj-generation-2005 in moab\)."))
+
+
+;;; ---------------------------------------------------------------------------
+;;; more
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-vertex-for-graph (graph &key &allow-other-keys)
+ (:documentation "Creates a new vertex for graph `graph`. The keyword arguments include:
+
+* vertex-class : specify the class of the vertex
+* element : specify the `element` of the vertex
+
+and any other initialization arguments that make sense for the vertex class."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric tag-all-edges (thing)
+ (:documentation "Sets the `tag` of all the edges of `thing` to true. [?? why does this exist?\]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric untag-all-edges (thing)
+ (:documentation "Sets the `tag` of all the edges of `thing` to nil. [?? why does this exist?\]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric untag-edges (edges)
+ (:documentation "Sets the `tag` of all the edges of `thing` to true. [?? why does this exist?\]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric tag-edges (edges)
+ (:documentation "Sets the `tag` of all the edges of `thing` to true. [?? why does this exist?\]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric replace-vertex (graph old new)
+ (:documentation "Replace vertex `old` in graph `graph` with vertex `new`. The edge structure of the graph is maintained."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric add-edge-to-vertex (edge vertex)
+ (:documentation "Attaches the edge `edge` to the vertex `vertex`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric source-edges (vertex &optional filter)
+ (:documentation "Returns a list of the source edges of `vertex`. [?? Could be a defun]."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric target-edges (vertex &optional filter)
+ (:documentation "Returns a list of the target edges of `vertex`. [?? Could be a defun]."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric child-vertexes (vertex &optional filter)
+ (:documentation "Returns a list of the vertexes to which `vertex` is connected by an edge and for which `vertex` is the source vertex. If the connecting edge is undirected, then the vertex is always counted as a source. [?? Could be a defun]."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric parent-vertexes (vertex &optional filter)
+ (:documentation "Returns a list of the vertexes to which `vertex` is connected by an edge and for which `vertex` is the target vertex. If the connecting edge is undirected, then the vertex is always counted as a target. [?? Could be a defun]."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric neighbor-vertexes (vertex &optional filter)
+ (:documentation "Returns a list of the vertexes to which `vertex` is connected by an edge disregarding edge direction. In a directed graph, neighbor-vertexes is the union of parent-vertexes and child-vertexes. [?? Could be a defun]."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric number-of-neighbors (vertex)
+ (:documentation "Returns the number of neighbors of `vertex` (cf. `neighbor-vertexes`). [?? could be a defun]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric in-cycle-p (graph start-vertex)
+ (:documentation "Returns true if `start-vertex` is in some cycle in `graph`. This uses child-vertexes to generate the vertexes adjacent to a vertex."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric iterate-vertexes (thing fn)
+ (:documentation "Calls `fn` on each of the vertexes of `thing`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric edges (thing)
+ (:documentation "Returns a list of the edges of `thing`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric vertex-count (graph)
+ (:documentation "Returns the number of vertexes in `graph`. [?? could be a defun]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric vertexes (thing)
+ (:documentation "Returns a list of the vertexes of `thing`."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric source-edge-count (vertex)
+ (:documentation "Returns the number of source edges of vertex (cf. source-edges). [?? could be a defun]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric target-edge-count (vertex)
+ (:documentation "Returns the number of target edges of vertex (cf. target-edges). [?? could be a defun]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric graph-roots (graph)
+ (:documentation "Returns a list of the roots of graph. A root is defined as a vertex with no source edges \(i.e., all of the edges are out-going\). (cf. rootp) [?? could be a defun]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric rootp (vertex)
+ (:documentation "Returns true if `vertex` is a root vertex \(i.e., it has no incoming \(source\) edges\)."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-vertex-if (thing predicate &key key)
+ (:documentation "Returns the first vertex in `thing` for which the `predicate` function returns non-nil. If the `key` is supplied, then it is applied to the vertex before the predicate is."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-edge-if (graph fn &key key)
+ (:documentation "Returns the first edge in `thing` for which the `predicate` function returns non-nil. If the `key` is supplied, then it is applied to the edge before the predicate is."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-edges-if (thing predicate)
+ (:documentation "Returns a list of edges in `thing` for which the `predicate` returns non-nil. [?? why no key function?]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric find-vertexes-if (thing predicate)
+ (:documentation "Returns a list of vertexes in `thing` for which the `predicate` returns non-nil. [?? why no key function?]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric force-undirected (graph)
+ (:documentation "Ensures that the graph is undirected (possibly by calling change-class on the edges)."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric traverse-elements (thing style fn)
+ (:documentation "WIP"))
+
+(defgeneric traverse-elements-helper (thing style marker fn)
+ (:documentation "WIP"))
+
+(defgeneric any-undirected-cycle-p (graph)
+ (:documentation "Returns true if there are any undirected cycles in `graph`."))
+
+(defgeneric edge-count (vertex)
+ (:documentation "Returns the number of edges attached to `vertex`. Compare with the more flexible `vertex-degree`."))
+
+(defgeneric topological-sort (graph)
+ (:documentation "Returns a list of vertexes sorted by the depth from the roots of the graph. See also assign-level and graph-roots."))
+
+(defgeneric assign-level (vertex level)
+ (:documentation "Sets the depth of `vertex` to level and then recursively sets the depth of all of the children of `vertex` to \(1+ level\)."))
+
+(defgeneric depth (graph)
+ (:documentation "Returns the maximum depth of the vertexes in graph assuming that the roots are of depth 0 and that each edge distance from the roots increments the depth by one."))
+
+(defgeneric make-vertex-edges-container (vertex container-class &rest args)
+ (:documentation "Called during the initialization of a vertex to create the create the container used to store the edges incident to the vertex. The initarg :vertex-edges-container-class can be used to alter the default container class."))
+
+(defgeneric other-vertex (edge value-or-vertex)
+ (:documentation "Assuming that the value-or-vertex corresponds to one of the vertexes for `edge`, this method returns the other vertex of `edge`. If the value-or-vertex is not part of edge, then an error is signaled. [?? Should create a new condition for this]"))
+
+(defgeneric find-edge-between-vertexes-if
+ (graph value-or-vertex-1 value-or-vertex-2 fn &key error-if-not-found?)
+ (:documentation "Finds and returns an edge between value-or-vertex-1 and value-or-vertex-2 if one exists. Unless error-if-not-found? is nil, then a error will be signaled. [?? Error not signal, need test.]"))
+
+(defgeneric vertices-share-edge-p (vertex-1 vertex-2)
+ (:documentation "Return true if vertex-1 and vertex-2 are connected by an edge. [?? Compare adjacentp]"))
+
+(defgeneric graph-edge-mixture-matrix (graph vertex-classifier &key edge-weight)
+ (:documentation "Return the `mixing-matrix` of graph based on the classifier and the edge-weight function. The mixing matrix is a matrix whose runs and columns represent each class of vertex in the graph. The entries of the matrix show the total number of edges between vertexes of the two kinds. [?? Edge-weight is not used; also compare with graph-mixture-matrix.]"))
+
+(defgeneric graph-mixing-matrix (graph vertex-classifier &key edge-weight)
+ (:documentation "Return the `mixing-matrix` of graph based on the classifier and the edge-weight function. The mixing matrix is a matrix whose runs and columns represent each class of vertex in the graph. The entries of the matrix show the total number of edges between vertexes of the two kinds. [?? Edge-weight is not used; also compare with graph-edge-mixture-matrix.]"))
+
+(defgeneric connected-components (graph)
+ (:documentation "Returns a union-find-container representing the connected-components of `graph`."))
+
+(defgeneric connected-component-count (graph)
+ (:documentation "Returns the number of connected-components of graph."))
+
+(defgeneric find-connected-components (graph)
+ (:documentation "Returns a list of sub-graphs of `graph` where each sub-graph is a different connected component of graph. Compare with connected-components and connected-component-count."))
+
+(defgeneric initialize-vertex-data (graph)
+ (:documentation ""))
+
+(defgeneric breadth-first-visitor (graph source fn)
+ (:documentation ""))
+
+(defgeneric breadth-first-search-graph (graph source)
+ (:documentation ""))
+
+(defgeneric mst-find-set (vertex)
+ (:documentation ""))
+
+(defgeneric mst-make-set (vertex)
+ (:documentation ""))
+
+(defgeneric mst-tree-union (v1 v2)
+ (:documentation ""))
+
+(defgeneric mst-link (v1 v2)
+ (:documentation ""))
+
+(defgeneric add-edges-to-graph (graph edges &key if-duplicate-do)
+ (:documentation ""))
+
+(defgeneric make-graph-from-vertexes (vertex-list)
+ (:documentation "Create a new graph given a list of vertexes \(which are assumed to be from the same graph\). The new graph contains all of the vertexes in the list and all of the edges between any vertexes on the list."))
+
+(defgeneric edge-lessp-by-weight (edge-1 edge-2)
+ (:documentation "Returns true if the weight of edge-1 is strictly less than the weight of edge-2."))
+
+(defgeneric minimum-spanning-tree (graph &key edge-sorter)
+ (:documentation "Returns a minimum spanning tree of graph if one exists and nil otherwise."))
+
+(defgeneric connected-graph-p (graph &key edge-sorter)
+ (:documentation "Returns true if graph is a connected graph and nil otherwise."))
+
+(defgeneric edge-lessp-by-direction (edge-1 edge-2)
+ (:documentation "Returns true if and only if edge-1 is undirected and edge-2 is directed."))
+
+(defgeneric out-edge-for-vertex-p (edge vertex)
+ (:documentation "Returns true if the edge is connected to vertex and is either an undirected edge or a directed edge for which vertex is the source vertex of the edge."))
+
+(defgeneric dfs (graph root fn &key out-edge-sorter)
+ (:documentation ""))
+
+(defgeneric dfs-visit (graph u fn sorter)
+ (:documentation ""))
+
+(defgeneric dfs-tree-edge-p (edge)
+ (:documentation ""))
+
+(defgeneric dfs-back-edge-p (edge)
+ (:documentation ""))
+
+(defgeneric dfs-forward-edge-p (edge)
+ (:documentation ""))
+
+(defgeneric dfs-cross-edge-p (edge)
+ (:documentation ""))
+
+(defgeneric dfs-edge-type (edge)
+ (:documentation ""))
+
+(defgeneric map-over-all-combinations-of-k-vertexes (graph k fn)
+ (:documentation ""))
+
+(defgeneric map-over-all-combinations-of-k-edges (vertex k fn)
+ (:documentation ""))
+
+(defgeneric complete-links (new-graph old-graph)
+ (:documentation "Add edges between vertexes in the new-graph for which the matching vertexes in the old-graph have edges. The vertex matching is done using `find-vertex`."))
+
+(defgeneric subgraph-containing (graph vertex &optional depth)
+ (:documentation "Returns a new graph that is a subset of `graph` that contains `vertex` and all of the other vertexes that can be reached from vertex by paths of less than or equal of length `depth`. If depth is not specified, then the entire sub-graph reachable from vertex will be returned. [?? Edge weights are always assumed to be one.]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric weight (edge)
+ (:documentation "Returns the weight of an edge. This defaults to 1.0 and can only be altered if the edge is a sub-class of `weighted-edge-mixin`."))
--- /dev/null
+;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-
+
+#|
+
+Copyright 199?-2002 Experimental Knowledge Systems Lab, University of Massachusetts Amherst
+Professor Paul Cohen, Director
+
+Author: Westy, et. al. (most recent working over by Gary King, Brent Heeringa, Louis Theran)
+
+|#
+
+(in-package :COMMON-LISP-USER)
+
+;;; ---------------------------------------------------------------------------
+;;; glu Utilities
+;;; ---------------------------------------------------------------------------
+
+(glu-define-logical-pathname-translations (cl-graph)
+ (source)
+ (utils (:back :back "utils" "dev"))
+ (lift (:back :back "lift" "dev")))
+
+;;; ---------------------------------------------------------------------------
+
+(setf (glu-system-source-file 'lift)
+ "cl-graph:lift;lift.system")
+
+
+;;; ---------------------------------------------------------------------------
+;;; system definition
+;;; ---------------------------------------------------------------------------
+
+(define-glu-system :cl-graph
+ ((("package"
+
+ "macros"
+ "graph"
+ "graph-container"
+ "graph-matrix"
+ "graph-metrics"
+ #+NotYet "graph-generation"
+ "graph-algorithms"
+ "graphviz-support"))
+
+ ;; associates
+ (("notes")
+ :associates? t))
+
+ :base-dir "cl-graph:source;"
+ :bin-identifiers (:platform :vendor)
+ :include-in-menu nil
+ :top-level nil
+ :depends-on (:metatilities :cl-containers metabang.bind :cl-mathstats)
+ :test-system :test-cl-graph)
+
+;;; ---------------------------------------------------------------------------
+
+(define-glu-system :test-cl-graph
+ ("test-graph"
+ "test-graph-container"
+ "test-graph-metrics"
+ "test-graph-algorithms")
+ :base-dir "cl-graph:source;"
+ :bin-identifiers (:platform :vendor)
+ :include-in-menu nil
+ :top-level nil
+ :depends-on (:cl-graph))
+
+
+;;; ***************************************************************************
+;;; * End of File *
+;;; ***************************************************************************
--- /dev/null
+(in-package cl-graph)
+
+;;; make a simple graph
+(let ((g (make-container 'graph-container)))
+ (loop for v in '(a b c d e) do
+ (add-vertex g v))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
+ (add-edge-between-vertexes g v1 v2))
+ g)
+
+;;; make a directed graph
+;; adding the vertexes up front not really necessary
+(let ((g (make-container 'graph-container :default-edge-type :directed)))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
+ (add-edge-between-vertexes g v1 v2))
+ g)
+
+
+;;; make a graph, find some things
+(let ((g (make-container 'graph-container)))
+ (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
+ (add-edge-between-vertexes g src dst))
+
+ (print (find-vertex g 'a))
+ (print (find-vertex g 'q nil))
+ (print (find-edge-between-vertexes g 'a 'b))
+ (print (find-edge-between-vertexes g 'a 'f :error-if-not-found? nil))
+
+ (format t "~%Neighbors of vertex A:")
+ (iterate-neighbors (find-vertex g 'a) #'print))
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+(defun roots-and-child-function->graph (roots child-function max-depth)
+ (let ((g (make-graph 'graph-container)))
+ (labels ((init-vertex (vertex depth)
+ (when (or (not max-depth) (< depth max-depth))
+ (unless (find-vertex g vertex nil)
+ (add-vertex g vertex)
+ (loop for child in (funcall child-function vertex) do
+ (init-vertex child (1+ depth))
+ (add-edge-between-vertexes g vertex child))))))
+ (loop for root in roots do
+ (init-vertex root 0)))
+ g))
+
+;;; ---------------------------------------------------------------------------
+
+(defun class-hierarchy->dot (base-class-or-classes output &key (filter (constantly t)))
+ (metabang.graph:graph->dot
+ (roots-and-child-function->graph
+ (ensure-list base-class-or-classes)
+ (lambda (cname)
+ (when (funcall filter cname)
+ (mapcar #'class-name (mopu:direct-subclasses (find-class cname)))))
+ nil)
+ output
+ :graph-formatter (lambda (g stream)
+ (declare (ignore g))
+ (format stream "rankdir=LR"))
+
+ :vertex-labeler (lambda (vertex stream)
+ (format stream "~(~A~)" (symbol-name (element vertex))))
+
+ :vertex-formatter (lambda (vertex stream)
+ (when (subtypep (element vertex) 'containers::concrete-container)
+ (format stream "color=\"blue\", style=\"filled\", fontcolor=\"white\", fillcolor=\"blue\"")))))
+
+;;; ---------------------------------------------------------------------------
+
+#+Test
+(class-hierarchy->dot 'abstract-container
+ nil
+ :filter (lambda (class-name)
+ (not (subtypep class-name 'containers::abstract-generator))))
+
+
+#+Test
+(class-hierarchy->dot '(containers::abstract-generator
+ containers::transforming-iterator-mixin
+ containers::basic-filtered-iterator-mixin
+ containers::circular-iterator-mixin)
+ "thousand-parsers:iterators.dot")
\ No newline at end of file
--- /dev/null
+(in-package metatilities)
+
+#|
+color by tag weight
+|#
+
+(defclass* delicious-post ()
+ ((post-time nil ia :initarg :time)
+ (tags nil ia :initarg :tag)
+ (hash nil ia)
+ (extended nil ia)
+ (description nil ia)
+ (post-href nil ia :initarg :href)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object delicious-post) &key)
+ (setf (tags object) (make-tags-canonical (tags object))))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-tags-canonical (tags)
+ (:documentation "Help convert del.icio.us tags into a canonicl form."))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric make-tag-canonical (tag)
+ (:documentation "Help convert del.icio.us tags into a canonicl form."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-tags-canonical ((tags list))
+ (mapcar #'make-tag-canonical tags))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-tags-canonical ((tags string))
+ (make-tags-canonical (tokenize-string tags :delimiter #\ )))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-tag-canonical ((tag symbol))
+ tag)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-tag-canonical ((tag string))
+ (form-keyword (string-upcase tag)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun determine-tag-counts (delicious-post-file)
+ "Returns a list of tags and their counts from a delicious-post-file."
+ (bind ((posts (xmls::parse delicious-post-file))
+ (tags (collect-elements
+ ;; the first two elements of posts aren't tags
+ (cddr posts)
+ :transform
+ (lambda (post-info)
+ (let ((tags (find "tag" (second post-info)
+ :test #'string-equal
+ :key #'first)))
+ (when tags
+ (tokenize-string (second tags) :delimiter #\ )))))))
+ (element-counts
+ (flatten tags)
+ :test #'equal
+ :sort #'>
+ :sort-on :counts)))
+
+#+Example
+;; this is what a post looks like after it's been transformed by xmls
+("post"
+ (("time" "2005-11-21T15:25:47Z")
+ ("tag" "yoga health exercise amherst")
+ ("hash" "9aad47baf972813c8202b43a56e95a61")
+ ("description" "Yoga Center Amherst, Massachusetts")
+ ("href" "http://www.yogacenteramherst.com/")))
+
+(defun parse-delicious-posts (delicious-post-file)
+ "Transform a delicious post file into a list of post objects."
+ (collect-elements
+ (cddr (xmls::parse delicious-post-file))
+ :transform
+ (lambda (post-info)
+ (apply #'make-instance
+ 'delicious-post
+ (loop for (name value) in (second post-info) nconc
+ (list (form-keyword (string-upcase name)) value))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun create-bipartite-tag/post-graph (delicious-post-file)
+ "Creates a bipartite graph of tags, posts and the links between them from
+a delicious post file."
+ (bind ((posts (parse-delicious-posts delicious-post-file))
+ (g (cl-graph:make-graph 'cl-graph:graph-container)))
+ (iterate-elements
+ posts
+ (lambda (post)
+ (iterate-elements
+ (tags post)
+ (lambda (tag)
+ (cl-graph:add-edge-between-vertexes g post tag)))))
+ g))
+
+;;; ---------------------------------------------------------------------------
+
+#+Example
+;; all tags
+(cl-graph:graph->dot
+ (cl-graph:project-bipartite-graph
+ (cl-graph:make-graph 'cl-graph:graph-container
+ :default-edge-class 'cl-graph:weighted-edge)
+ (create-bipartite-tag/post-graph #P"user-home:temporary;all-posts.xml")
+ 'keyword
+ (compose 'type-of 'element))
+ "user-home:temporary;all-tags.dot"
+ :vertex-labeler (lambda (vertex stream)
+ (format stream "~(~A~)" (symbol-name (element vertex))))
+ :edge-formatter (lambda (edge stream)
+ (format stream "weight=~D" (cl-graph:weight edge))))
+
+;;; ---------------------------------------------------------------------------
+
+#+Example
+(cl-graph:graph->dot
+ (cl-graph:make-filtered-graph
+ (cl-graph:project-bipartite-graph
+ (cl-graph:make-graph 'cl-graph:graph-container
+ :default-edge-class 'cl-graph:weighted-edge)
+ (create-bipartite-tag/post-graph #P"user-home:temporary;all-posts.xml")
+ 'keyword
+ (compose 'type-of 'element))
+ (lambda (v)
+ (search "lisp" (symbol-name (element v)) :test #'string-equal))
+ :complete-closure-with-links
+ 1)
+ "user-home:temporary;lisp-tags-20051125.dot"
+ :vertex-labeler (lambda (vertex stream)
+ (format stream "~(~A~)" (symbol-name (element vertex))))
+ :edge-formatter (lambda (edge stream)
+ (format stream "weight=~D" (cl-graph:weight edge))))
+
--- /dev/null
+
+'(graphml
+ (graph
+ (node id="n0")
+ (node id="n1")
+ (node id="n2")
+ (node id="n3")
+ (node id="n4")
+ (node id="n5")
+ (node id="n6")
+ (node id="n7")
+ (node id="n8")
+ (node id="n9")
+ (node id="n10")
+ (edge source="n0" target="n2")
+ (edge source="n1" target="n2")
+ (edge source="n2" target="n3")
+ (edge source="n3" target="n5")
+ (edge source="n3" target="n4")
+ (edge source="n4" target="n6")
+ (edge source="n6" target="n5")
+ (edge source="n5" target="n7")
+ (edge source="n6" target="n8")
+ (edge source="n8" target="n7")
+ (edge source="n8" target="n9")
+ (edge source="n8" target="n10")))
+
+
+'(graph-container nil
+ (node id="n0")
+ (node id="n1")
+ (node id="n2")
+ (node id="n3")
+ (node id="n4")
+ (node id="n5")
+ (node id="n6")
+ (node id="n7")
+ (node id="n8")
+ (node id="n9")
+ (node id="n10")
+ (edge source="n0" target="n2")
+ (edge source="n1" target="n2")
+ (edge source="n2" target="n3")
+ (edge source="n3" target="n5")
+ (edge source="n3" target="n4")
+ (edge source="n4" target="n6")
+ (edge source="n6" target="n5")
+ (edge source="n5" target="n7")
+ (edge source="n6" target="n8")
+ (edge source="n8" target="n7")
+ (edge source="n8" target="n9")
+ (edge source="n8" target="n10"))
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;;;
+;;; ---------------------------------------------------------------------------
+
+(defstruct (vertex-datum (:conc-name "NODE-") (:type list))
+ (color nil)
+ (depth most-positive-fixnum)
+ (parent nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-vertex-data ((graph basic-graph))
+ (let ((vertex-data (make-container 'simple-associative-container)))
+ (iterate-vertexes graph (lambda (v)
+ (setf (item-at vertex-data v)
+ (make-vertex-datum :color :white))))
+ (values vertex-data)))
+
+;;; ---------------------------------------------------------------------------
+;;; breadth-first-search by GWK
+;;; ---------------------------------------------------------------------------
+
+(defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
+ (breadth-first-visitor graph (find-vertex graph source) fn))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
+ ;; initialize
+ (let ((vertex-data (initialize-vertex-data graph))
+ (queue (make-container 'basic-queue)))
+
+ (let ((source-datum (item-at vertex-data source)))
+ (setf (node-color source-datum) :grey
+ (node-depth source-datum) 0)
+ (enqueue queue source)
+
+ (loop until (empty-p queue) do
+ (let* ((current-vertex (first-item queue))
+ (current (item-at vertex-data current-vertex)))
+ ;(format t "~%~A:" current-vertex)
+ (iterate-children current-vertex
+ (lambda (child-vertex)
+ ;(format t "~A " child-vertex)
+ (let ((child (item-at vertex-data child-vertex)))
+ (when (eq (node-color child) :white)
+ (setf (node-color child) :grey
+ (node-depth child) (1+ (node-depth current))
+ (node-parent child) current-vertex)
+ (enqueue queue child-vertex)))))
+
+ (dequeue queue)
+ (setf (node-color current) :black)
+ (funcall fn current-vertex)))
+
+ vertex-data)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod breadth-first-search-graph ((graph basic-graph) (source t))
+ (breadth-first-search-graph graph (find-vertex graph source)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
+ ;; initialize
+ (let ((vertex-data (initialize-vertex-data graph))
+ (queue (make-container 'basic-queue)))
+
+ (let ((source-datum (item-at vertex-data source)))
+ (setf (node-color source-datum) :grey
+ (node-depth source-datum) 0)
+ (enqueue queue source)
+
+ (loop until (empty-p queue) do
+ (let* ((current-vertex (first-item queue))
+ (current (item-at vertex-data current-vertex)))
+ ;(format t "~%~A:" current-vertex)
+ (iterate-children current-vertex
+ (lambda (child-vertex)
+ ;(format t "~A " child-vertex)
+ (let ((child (item-at vertex-data child-vertex)))
+ (when (eq (node-color child) :white)
+ (setf (node-color child) :grey
+ (node-depth child) (1+ (node-depth current))
+ (node-parent child) current-vertex)
+ (enqueue queue child-vertex)))))
+
+ (dequeue queue)
+ (setf (node-color current) :black)))
+
+ vertex-data)))
+
+;;; ---------------------------------------------------------------------------
+;;; single-source-shortest-paths - gwk
+;;; ---------------------------------------------------------------------------
+
+#+NotYet
+(defmethod single-source-shortest-paths ((graph basic-graph))
+ (let ((vertex-data (initialize-vertex-data graph))
+ (queue (make-container 'priority-queue-on-container 'binary-search-tree)))
+ (let ((source-datum (item-at vertex-data source)))
+ (setf (node-depth source-datum) 0))
+ ))
+
+;;; ---------------------------------------------------------------------------
+;;; connected-components - gwk
+;;; ---------------------------------------------------------------------------
+
+(defmethod connected-components ((graph basic-graph))
+ (let ((union (make-container 'union-find-container)))
+ (iterate-vertexes
+ graph
+ (lambda (v) (insert-item union v)))
+ (iterate-edges
+ graph
+ (lambda (e)
+ (let ((node-1 (representative-node union (vertex-1 e)))
+ (node-2 (representative-node union (vertex-2 e))))
+ (unless (eq (find-set node-1) (find-set node-2))
+ (graft-nodes node-1 node-2)))))
+ (iterate-elements union 'find-set)
+ union))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod connected-component-count ((graph basic-graph))
+ ;;?? Gary King 2005-11-28: Super ugh
+ (size
+ (remove-duplicates
+ (collect-elements
+ (connected-components graph)
+ :transform #'parent)))
+
+ #+Fails
+ ;;?? Gary King 2005-11-28: fails on big graphs? iterator design
+ ;;?? Gary King 2005-11-28: ideally we don't want to cons up the list at all
+ (size
+ (collect-elements
+ (make-iterator (connected-components graph) :unique t :transform #'parent))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-connected-components ((graph basic-graph))
+ (collect-elements
+ (make-iterator (connected-components graph) :unique t :transform #'parent)
+ :transform
+ (lambda (component)
+ (subgraph-containing graph (element component)
+ most-positive-fixnum))))
+
+#+Alternate
+(defmethod find-connected-components ((graph basic-graph))
+ (let ((result nil)
+ (found-elements (make-container 'simple-associative-container)))
+ (iterate-elements
+ (connected-components graph)
+ (lambda (component)
+ (let ((element (element (parent component))))
+ (unless (item-at found-elements element)
+ (setf (item-at found-elements element) t)
+
+ (push (subgraph-containing graph (element component)
+ most-positive-fixnum)
+ result)))))
+
+ result))
+
+
+
+;;; ---------------------------------------------------------------------------
+;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
+;;; ---------------------------------------------------------------------------
+
+(defmethod mst-find-set ((vertex basic-vertex))
+ #+ignore
+ (unless (previous-node vertex)
+ (return-from mst-find-set nil))
+ (unless (eq vertex (previous-node vertex))
+ (setf (previous-node vertex) (mst-find-set (previous-node vertex))))
+ (previous-node vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod mst-make-set ((vertex basic-vertex))
+ (setf (previous-node vertex) vertex
+ (rank vertex) 0))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
+ (mst-link (mst-find-set v1) (mst-find-set v2)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
+ (cond ((> (rank v1) (rank v2))
+ (setf (previous-node v2) v1))
+ (t (setf (previous-node v1) v2)
+ (when (= (rank v1) (rank v2))
+ (incf (rank v2))))))
+
+;;; ---------------------------------------------------------------------------
+;;; jjm's implementation of mst depends on this
+;;; todo - figure out some what to add and edge we create to a graph rather
+;;; than always using add-edge-between-vertexes interface
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edges-to-graph ((graph basic-graph) (edges list)
+ &key (if-duplicate-do :ignore))
+ (iterate-elements
+ edges
+ (lambda (edge)
+ (bind ((v1 (element (source-vertex edge)))
+ (v2 (element (target-vertex edge))))
+ (add-edge-between-vertexes
+ graph v1 v2 :edge-class (type-of edge)
+ :edge-type (if (directed-edge-p edge)
+ :directed
+ :undirected)
+ :value (value edge)
+ :edge-id (edge-id edge)
+ :element (element edge)
+ :tag (tag edge)
+ :graph graph
+ :color (color edge)
+ :if-duplicate-do if-duplicate-do))))
+ graph)
+
+;;; ---------------------------------------------------------------------------
+;;; for completeness
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-graph-from-vertexes ((vertex-list list))
+ (bind ((edges-to-keep nil)
+ (g (copy-template (graph (first vertex-list)))))
+
+ (iterate-elements
+ vertex-list
+ (lambda (v)
+ (add-vertex g (element v))
+ (iterate-elements
+ (edges v)
+ (lambda (e)
+ (when (and (member (vertex-1 e) vertex-list)
+ (member (vertex-2 e) vertex-list))
+ (pushnew e edges-to-keep :test #'eq))))))
+
+ (iterate-elements
+ edges-to-keep
+ (lambda (e)
+ (bind ((v1 (source-vertex e))
+ (v2 (target-vertex e)))
+ ;;?? can we use copy here...
+ (add-edge-between-vertexes
+ g (element v1) (element v2)
+ :edge-type (if (directed-edge-p e)
+ :directed
+ :undirected)
+ :if-duplicate-do :force
+ :edge-class (type-of e)
+ :value (value e)
+ :edge-id (edge-id e)
+ :element (element e)
+ :tag (tag e)
+ :graph g
+ :color (color e)))))
+ g))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
+ (< (weight e1) (weight e2)))
+
+;;; ---------------------------------------------------------------------------
+;;; minumum spanning tree
+;;; ---------------------------------------------------------------------------
+
+
+(defmethod minimum-spanning-tree ((graph basic-graph)
+ &key
+ (edge-sorter #'edge-lessp-by-weight))
+ (bind ((result nil))
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (mst-make-set v)))
+
+ (loop for edge in (sort (edges graph) edge-sorter) do
+ (bind ((v1 (source-vertex edge))
+ (v2 (target-vertex edge)))
+
+ (unless (eq (mst-find-set v1)
+ (mst-find-set v2))
+ (push edge result)
+ (mst-tree-union v1 v2)))
+ finally
+ (return
+ (cond ((= (length result) (- (length (vertexes graph)) 1))
+ (values t result))
+ (t (values nil result)))))))
+
+;;; ---------------------------------------------------------------------------
+
+#+ignore ;;; shit
+(defmethod minimum-spanning-tree ((vertex-list list)
+ &key
+ (edge-sorter #'edge-lessp-by-weight))
+ (bind ((result nil)
+ (v-edges (remove-duplicates
+ (flatten (mapcar #'edges vertex-list)) :test #'eq)))
+
+ (iterate-container
+ vertex-list
+ (lambda (v)
+ (mst-make-set v)))
+
+
+
+ (loop for edge in (sort v-edges edge-sorter) do
+ (bind ((v1 (source-vertex edge))
+ (v2 (target-vertex edge))
+ (v1-set (mst-find-set v1))
+ (v2-set (mst-find-set v2)))
+
+ (when (or (not v1-set)
+ (not v2-set))
+ (return-from minimum-spanning-tree nil))
+
+
+ (unless (eq (mst-find-set v1)
+ (mst-find-set v2))
+ (push edge result)
+ (mst-tree-union v1 v2)))
+ finally
+ (return
+ (cond ((= (length result) (- (length vertex-list) 1))
+ (values t result))
+ (t (values nil result)))))))
+
+;;; ---------------------------------------------------------------------------
+;;; uses mst to determine if the graph is connected
+;;; ---------------------------------------------------------------------------
+
+(defmethod connected-graph-p ((graph basic-graph) &key
+ (edge-sorter 'edge-lessp-by-weight))
+ (minimum-spanning-tree graph :edge-sorter edge-sorter))
+
+
+;;; ---------------------------------------------------------------------------
+
+#+test
+(bind ((g (make-container 'graph-container)))
+ (add-edge-between-vertexes g :v :y :edge-type :directed)
+ (add-edge-between-vertexes g :u :x :edge-type :directed)
+ (add-edge-between-vertexes g :x :v :edge-type :directed)
+ (add-edge-between-vertexes g :u :v :edge-type :directed)
+ (add-edge-between-vertexes g :y :x :edge-type :directed)
+ (add-edge-between-vertexes g :w :y :edge-type :directed)
+ (add-edge-between-vertexes g :w :z :edge-type :directed)
+ (add-edge-between-vertexes g :z :z :edge-type :directed
+ :if-duplicate-do :force)
+ (minimum-spanning-tree g))
+
+;;; ---------------------------------------------------------------------------
+;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
+;;; a tree (still faster even if it does). Will decide later if which to use
+;;; ignoring for now -jjm
+;;; ---------------------------------------------------------------------------
+
+#+not-yet
+(defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
+ (let ((a nil)
+ (union (make-container 'union-find-container))
+ (edges (sort (edges graph) #'< :key weight)))
+ (iterate-vertexes
+ graph (lambda (v) (insert-item union v)))
+ (dolist (edge edges)
+ (let ((node-1 (representative-node union (vertex-1 edge)))
+ (node-2 (representative-node union (vertex-2 edge))))
+ (unless (eq (find-set node-1) (find-set node-2))
+ (graft-nodes node-1 node-2)
+ (push edge a))))
+
+ (values a)))
+
+;;; ---------------------------------------------------------------------------
+
+#+test
+(loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
+ (fluid-bind (((random-seed *random-generator*) 1))
+ (bind ((g (generate-undirected-graph-via-vertex-probabilities
+ *random-generator* (make-instance 'graph-container :default-edge-type :directed)
+ 100
+ #(0.8 0.2)
+ #2A((0.2 0.1) (nil 0.2))
+ (lambda (kind count)
+ (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
+ ))
+ (timeit (:report :values)
+ (loop for n from 1 to 100 do
+ (funcall f g (lambda (a b)
+ (declare (ignore a b))
+ 0)))))))
+
+;;; ---------------------------------------------------------------------------
+;;; end minimum spanning tree
+;;; ---------------------------------------------------------------------------
+
+
+;;; ---------------------------------------------------------------------------
+;;; depth-first-search - clrs2
+;;; todo - figure out how to name this depth-first-search, which is already
+;;; defined in search.lisp
+;;; ---------------------------------------------------------------------------
+
+;;; ---------------------------------------------------------------------------
+;;; should probably make this special
+;;; ---------------------------------------------------------------------------
+
+(defparameter *depth-first-search-timer* -1)
+
+;;; ---------------------------------------------------------------------------
+;;; undirected edges are less than edges that are directed
+;;; ---------------------------------------------------------------------------
+
+#+ignore ;;; incorrect, methinks - jjm
+(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
+ (cond ((or (every #'directed-edge-p (list e1 e2))
+ (every #'undirected-edge-p (list e1 e2)))
+ t)
+ ((and (undirected-edge-p e1) (directed-edge-p e2))
+ t)
+ (t nil)))
+
+(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
+ (and (undirected-edge-p e1) (directed-edge-p e2)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
+ (cond ((and (directed-edge-p edge)
+ (eq vertex (source-vertex edge)))
+ t)
+ ((and (undirected-edge-p edge)
+ (or (eq vertex (source-vertex edge))
+ (eq vertex (target-vertex edge))))
+ t)
+ (t nil)))
+
+;;; ---------------------------------------------------------------------------
+;;; depth-first-search
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs ((graph basic-graph) (root t) fn &key
+ (out-edge-sorter #'edge-lessp-by-direction))
+ (dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
+ (out-edge-sorter #'edge-lessp-by-direction))
+ (setf *depth-first-search-timer* -1)
+
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (setf (color v) :white
+ (previous-node v) nil
+ (discovery-time v) -1
+ (finish-time v) -1)))
+
+ (iterate-edges
+ graph
+ (lambda (e)
+ (setf (color e) nil)))
+
+ (loop with vl = (remove root (vertexes graph) :test #'eql)
+ for v in (push root vl) do
+ (when (eql (color v) :white)
+ (dfs-visit graph v fn out-edge-sorter)))
+
+ (values
+ (sort (copy-list (vertexes graph)) #'< :key #'finish-time)
+ graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-visit ((graph graph-container) (u basic-vertex)
+ fn sorter)
+
+
+ (incf *depth-first-search-timer*)
+ (setf (color u) :gray
+ (discovery-time u) *depth-first-search-timer*)
+
+
+ (loop for edge in (sort (collect-elements
+ (edges u)
+ :filter (lambda (e)
+ (out-edge-for-vertex-p e u))) sorter) do
+ (bind ((v (other-vertex edge u)))
+
+ (unless (color edge)
+ (setf (color edge) (color v)))
+
+ (when (eql (color v) :white)
+ (setf (previous-node v) u)
+ (funcall fn v)
+ (dfs-visit graph v fn sorter))))
+
+ (incf *depth-first-search-timer*)
+
+ (setf (color u) :black
+ (finish-time u) *depth-first-search-timer*))
+
+;;; ---------------------------------------------------------------------------
+;;; from clrs2
+;;; ---------------------------------------------------------------------------
+
+#+test
+(bind ((g (make-container 'graph-container)))
+ (add-edge-between-vertexes g :v :y :edge-type :directed)
+ (add-edge-between-vertexes g :u :x :edge-type :directed)
+ (add-edge-between-vertexes g :x :v :edge-type :directed)
+ (add-edge-between-vertexes g :u :v :edge-type :directed)
+ (add-edge-between-vertexes g :y :x :edge-type :directed)
+ (add-edge-between-vertexes g :w :y :edge-type :directed)
+ (add-edge-between-vertexes g :w :z :edge-type :directed)
+ (add-edge-between-vertexes g :z :z :edge-type :directed
+ :if-duplicate-do :force)
+ (assert (equal '(:X :Y :V :U :Z :W)
+ (mapcar #'element (dfs g :u #'identity)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-tree-edge-p ((edge graph-container-edge))
+ (eql (color edge) :white))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-back-edge-p ((edge graph-container-edge))
+ (eql (color edge) :gray))
+
+;;; ---------------------------------------------------------------------------
+;;; not correct - has to look at combination of discovery-time and finish-time
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-forward-edge-p ((edge graph-container-edge))
+ (warn "implementation is not correct.")
+ (unless (and (dfs-tree-edge-p edge)
+ (dfs-back-edge-p edge))
+ (< (discovery-time (source-vertex edge))
+ (discovery-time (target-vertex edge)))))
+
+;;; ---------------------------------------------------------------------------
+;;; not correct - has to look at combination of discovery-time and finish-time
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-cross-edge-p ((edge graph-container-edge))
+ (warn "implementation is not correct.")
+ (unless (and (dfs-tree-edge-p edge)
+ (dfs-back-edge-p edge))
+ (> (discovery-time (source-vertex edge))
+ (discovery-time (target-vertex edge)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dfs-edge-type ((edge graph-container-edge))
+ (cond ((dfs-tree-edge-p edge)
+ :tree)
+ ((dfs-back-edge-p edge)
+ :back)
+ ((dfs-forward-edge-p edge)
+ :forward)
+ ((dfs-cross-edge-p edge)
+ :cross)
+ (t nil)))
+
+;;; ---------------------------------------------------------------------------
+;;; end dfs
+;;; ---------------------------------------------------------------------------
+
+;;; ---------------------------------------------------------------------------
+;;; mapping functions
+;;; ---------------------------------------------------------------------------
+
+;;; ---------------------------------------------------------------------------
+;;; over vertexes
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
+ (bind ((vertex-count (size graph))
+ (symbols (make-list k :initial-element vertex-count))
+ (vertexes (vertexes graph)))
+ (iterate-over-indexes
+ symbols
+ (lambda (vertex-indexes)
+ (when (apply #'< vertex-indexes)
+ (funcall fn (mapcar (lambda (vertex-index)
+ (nth-element vertexes vertex-index))
+ vertex-indexes)))))))
+
+;;; ---------------------------------------------------------------------------
+
+#+test
+(bind ((result nil)
+ (g (make-container 'graph-container)))
+ (add-edge-between-vertexes g :u :v :edge-type :directed)
+ (add-edge-between-vertexes g :u :x :edge-type :directed)
+ (add-edge-between-vertexes g :x :v :edge-type :directed)
+ (add-edge-between-vertexes g :v :y :edge-type :directed)
+ (add-edge-between-vertexes g :y :x :edge-type :directed)
+ (add-edge-between-vertexes g :w :y :edge-type :directed)
+ (add-edge-between-vertexes g :w :z :edge-type :directed)
+
+ (map-over-all-combinations-of-k-vertexes
+ g
+ 4
+ (lambda (vertex-list)
+ (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
+ (when (mst-kruskal graph-from-vertexes #'identity-sorter)
+ (push graph-from-vertexes result)))))
+ result)
+
+;;; ---------------------------------------------------------------------------
+;;; over edges
+;;; todo: merge these two defs
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
+ (bind ((edge-count (edge-count graph))
+ (symbols (make-list k :initial-element edge-count))
+ (edges (edges graph)))
+ (print symbols)
+ (iterate-over-indexes
+ symbols
+ (lambda (edge-indexes)
+ (when (apply #'< edge-indexes)
+ (funcall fn (mapcar (lambda (edge-index)
+ (nth-element edges edge-index))
+ edge-indexes)))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
+ (bind ((edge-count (edge-count vertex))
+ (symbols (make-list k :initial-element edge-count))
+ (edges (edges vertex)))
+ (print symbols)
+ (iterate-over-indexes
+ symbols
+ (lambda (edge-indexes)
+ (when (apply #'< edge-indexes)
+ (funcall fn (mapcar (lambda (edge-index)
+ (nth-element edges edge-index))
+ edge-indexes)))))))
+;;; ---------------------------------------------------------------------------
+
+#+test
+(map-over-all-combinations-of-k-edges
+ (generate-undirected-graph-via-verex-probabilities
+ *random-generator* 'graph-container
+ 10
+ #(0.8 0.2)
+ #2A((0.2 0.1) (nil 0.2))
+ (lambda (kind count)
+ (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
+ 2
+ (lambda (es)
+ (format t "~%")
+ (mapc (lambda (e)
+ (format t "~A -- ~A " (element (vertex-1 e)) (element (vertex-2 e))))
+ es)))
+
+
+
+
+
+;;; ***************************************************************************
+;;; * End of File *
+;;; ***************************************************************************
\ No newline at end of file
--- /dev/null
+(in-package cl-user)
+
+#+Ignore
+(shadowing-import
+ (list cl-variates:*random-generator*
+ cl-variates:random-seed
+ cl-variates:integer-random
+ cl-variates:uniform-random
+ cl-variates:random-boolean
+ cl-variates:shuffle-elements!
+ cl-variates:random-number-generator
+ cl-variates:next-element)
+ "CL-GRAPH")
+
+(use-package (find-package "CL-VARIATES")
+ (find-package "CL-GRAPH"))
+
--- /dev/null
+
+#| simple-header
+
+$Id: graph-container.lisp,v 1.12 2005/07/20 20:39:09 moody Exp $
+
+Copyright 1992 - 2003 Experimental Knowledge Systems Lab,
+University of Massachusetts Amherst MA, 01003-4610
+Professor Paul Cohen, Director
+
+Author: Gary King
+
+DISCUSSION
+
+|#
+
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;;; class defs
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-container (iteratable-container-mixin
+ non-associative-container-mixin
+ initial-contents-mixin
+ basic-graph
+ container-uses-nodes-mixin)
+ ()
+ (:default-initargs
+ :vertex-class 'graph-container-vertex
+ :directed-edge-class 'graph-container-directed-edge
+ :undirected-edge-class 'graph-container-edge)
+ (:export-p t)
+ (:documentation "A graph container is essentially an adjacency list graph representation [?? The Bad name comes from it being implemented with containers... ugh]"))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-container-edge (basic-edge)
+ ((vertex-1 nil ir "`Vertex-1` is one of the two vertexes that an edge connects. In a directed-edge, `vertex-1` is also the `source-edge`.")
+ (vertex-2 nil ir "`Vertex-2` is one of the two vertexes that an edge connects. In a directed edge, `vertex-2` is also the `target-vertex`."))
+ (:export-slots vertex-1 vertex-2)
+ (:export-p t)
+ (:documentation "This is the root class for edges in graph-containers. It adds vertex-1 and vertex-2 slots."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod print-object ((object graph-container-edge) stream)
+ (print-unreadable-object (object stream :type t)
+ (format stream "<~A ~A ~A>" (vertex-1 object) (vertex-2 object)
+ (value object))))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* weighted-edge (weighted-edge-mixin graph-container-edge)
+ ()
+ (:export-p t)
+ (:documentation "A weighted edge is both a weighted-edge-mixin and a graph-container-edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-container-vertex (basic-vertex)
+ ((vertex-edges nil r))
+ (:export-p t)
+ (:default-initargs
+ :vertex-edges-container-class 'vector-container)
+ (:documentation "A graph container vertex keeps track of its edges in the the vertex-edges slot. The storage for this defaults to a vector-container but can be changed using the vertex-edges-container-class initarg."))
+
+;;; ---------------------------------------------------------------------------
+
+#+COPYING
+(defcopy-methods graph-container-vertex :copy-all t)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-vertex-edges-container ((vertex graph-container-vertex)
+ container-class &rest args)
+ (apply #'make-container container-class args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object graph-container-vertex) &key
+ vertex-edges-container-class)
+ (setf (slot-value object 'vertex-edges)
+ (make-vertex-edges-container object vertex-edges-container-class)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-vertex-container ((graph graph-container) initial-size)
+ (make-container 'simple-associative-container
+ :initial-size initial-size
+ :test (vertex-test graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-edge-container ((graph graph-container) initial-size)
+ (make-container 'vector-container :initial-size initial-size
+ :fill-pointer 0))
+
+
+;;; ---------------------------------------------------------------------------
+;;; graph-container-directed-edge
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-container-directed-edge (directed-edge-mixin
+ graph-container-edge)
+ ()
+ (:export-p t)
+ (:documentation "A graph-container-directed-edge is both a directed-edge-mixin and a graph-container-edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object graph-container-directed-edge)
+ &key source-vertex target-vertex)
+ (when (and source-vertex (vertex-1 object))
+ (error "Specify source-vertex or vertex-1, but not both"))
+ (when (and target-vertex (vertex-2 object))
+ (error "Specify target-vertex or vertex-2, but not both"))
+ (when source-vertex
+ (setf (slot-value object 'vertex-1) source-vertex))
+ (when target-vertex
+ (setf (slot-value object 'vertex-2) target-vertex)))
+
+;;; ---------------------------------------------------------------------------
+;;; vertex-1 is defined to be the source vertex of an undirected edge
+;;; ---------------------------------------------------------------------------
+
+(defmethod source-vertex ((edge graph-container-edge))
+ (vertex-1 edge))
+
+;;; ---------------------------------------------------------------------------
+;;; vertex-2 is defined to be the target vertex of an undirected edge
+;;; ---------------------------------------------------------------------------
+
+(defmethod target-vertex ((edge graph-container-edge))
+ (vertex-2 edge))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod other-vertex ((edge graph-container-edge)
+ (v graph-container-vertex))
+ (cond ((eq v (vertex-1 edge))
+ (values (vertex-2 edge)))
+
+ ((eq v (vertex-2 edge))
+ (values (vertex-1 edge)))
+
+ (t (error "Vertex ~A not part of Edge ~A" v edge))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod other-vertex ((edge graph-container-edge)
+ (value t))
+ (other-vertex edge (find-vertex edge value)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge ((graph graph-container) (edge graph-container-edge)
+ &key force-new?)
+ (declare (ignore force-new?))
+
+ (bind ((vertex-1 (vertex-1 edge))
+ (vertex-2 (vertex-2 edge)))
+
+ (cond ((eq vertex-1 vertex-2)
+ (add-edge-to-vertex edge vertex-1))
+ (t
+ (add-edge-to-vertex edge vertex-1)
+ (add-edge-to-vertex edge vertex-2))))
+ edge)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge-to-vertex :around ((edge graph-container-edge)
+ (vertex graph-container-vertex))
+ (insert-item (vertex-edges vertex) edge))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-node-for-container ((graph graph-container) (node t) &key)
+ (make-vertex-for-graph graph :element node))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edge-between-vertexes ((graph graph-container)
+ (vertex-1 graph-container-vertex)
+ (vertex-2 graph-container-vertex)
+ &key error-if-not-found?)
+ (declare (ignore error-if-not-found?))
+ (search-for-match (vertex-edges vertex-1)
+ (lambda (edge)
+ (eq vertex-2 (other-vertex edge vertex-1)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edge-between-vertexes-if ((graph graph-container)
+ (vertex-1 graph-container-vertex)
+ (vertex-2 graph-container-vertex)
+ fn
+ &key error-if-not-found?)
+ (declare (ignore error-if-not-found?))
+ (search-for-match (vertex-edges vertex-1)
+ (lambda (edge)
+ (and (eq vertex-2 (other-vertex edge vertex-1))
+ (funcall fn edge)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edge-between-vertexes-if ((graph graph-container)
+ (value-1 t)
+ (value-2 t)
+ fn
+ &key error-if-not-found?)
+ (bind ((v1 (find-vertex graph value-1 error-if-not-found?))
+ (v2 (find-vertex graph value-2 error-if-not-found?)))
+ (find-edge-between-vertexes-if
+ graph v1 v2 fn
+ :error-if-not-found? error-if-not-found?)))
+
+;;; ---------------------------------------------------------------------------
+
+
+(defmethod find-edge ((graph graph-container) (edge graph-container-edge)
+ &optional error-if-not-found?)
+ (find-edge-between-vertexes
+ graph (vertex-1 edge) (vertex-2 edge)
+ :error-if-not-found? error-if-not-found?))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-edge ((graph graph-container) (edge graph-container-edge))
+ (delete-item (vertex-edges (vertex-1 edge)) edge)
+ (delete-item (vertex-edges (vertex-2 edge)) edge)
+ edge)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-edges ((graph graph-container) fn)
+ (iterate-elements (graph-edges graph) fn))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-edges ((vertex graph-container-vertex) fn)
+ (iterate-elements (vertex-edges vertex) fn))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-source-edges ((vertex graph-container-vertex) fn)
+ (iterate-elements (vertex-edges vertex)
+ (lambda (edge)
+ (when (or (undirected-edge-p edge)
+ (eq vertex (target-vertex edge)))
+ (funcall fn edge)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-target-edges ((vertex graph-container-vertex) fn)
+ (iterate-elements (vertex-edges vertex)
+ (lambda (edge)
+ (when (or (undirected-edge-p edge)
+ (eq vertex (source-vertex edge)))
+ (funcall fn edge)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-children ((vertex graph-container-vertex) fn)
+ (iterate-target-edges vertex
+ (lambda (edge)
+ (funcall fn (other-vertex edge vertex)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-parents ((vertex graph-container-vertex) fn)
+ (iterate-source-edges vertex
+ (lambda (edge)
+ (funcall fn (other-vertex edge vertex)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-neighbors ((vertex graph-container-vertex) fn)
+ (iterate-edges vertex
+ (lambda (edge)
+ (funcall fn (other-vertex edge vertex)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod vertexes ((edge graph-container-edge))
+ (collect-using #'iterate-vertexes nil edge))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod has-children-p ((vertex graph-container-vertex))
+ (iterate-target-edges vertex
+ (lambda (edge)
+ (declare (ignore edge))
+ (return-from has-children-p t)))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod has-parent-p ((vertex graph-container-vertex))
+ (iterate-source-edges vertex
+ (lambda (edge)
+ (declare (ignore edge))
+ (return-from has-parent-p t)))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod vertices-share-edge-p ((vertex-1 graph-container-vertex)
+ (vertex-2 graph-container-vertex))
+ (iterate-target-edges vertex-1
+ (lambda (e)
+ (when (or (eq (target-vertex e) vertex-2)
+ (eq (source-vertex e) vertex-2))
+ (return-from vertices-share-edge-p t))))
+
+ (iterate-source-edges vertex-1
+ (lambda (e)
+ (when (or (eq (target-vertex e) vertex-2)
+ (eq (source-vertex e) vertex-2))
+ (return-from vertices-share-edge-p t))))
+
+ (values nil))
+
+
+;;; ***************************************************************************
+;;; * End of File *
+;;; ***************************************************************************
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+(export '(generate-Gnp
+ generate-Gnm
+ generate-undirected-graph-via-assortativity-matrix
+ generate-undirected-graph-via-vertex-probabilities
+ generate-multi-group-graph-fixed
+ #+Ignore generate-girvan-newman-graph
+ generate-scale-free-graph
+ generate-assortative-graph-with-degree-distributions
+
+ generate-simple-preferential-attachment-graph
+ generate-preferential-attachment-graph
+
+ generate-acquaintance-network
+ generate-acquaintance-network-until-stable
+
+ generate-graph-by-resampling-edges
+
+ sample-edge
+ basic-edge-sampler
+ weighted-edge-sampler
+ simple-group-id-generator
+ simple-group-id-parser
+
+ make-degree-sampler
+ poisson-vertex-degree-distribution
+ power-law-vertex-degree-distribution))
+
+;;; ---------------------------------------------------------------------------
+;;; classes
+;;; ---------------------------------------------------------------------------
+
+(defclass* generated-graph-mixin ()
+ ((generation-method nil ir)
+ (random-seed nil ir)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun save-generation-information (graph generator method)
+ ;; No
+ ;; (setf (random-seed generator) (random-seed generator))
+ (unless (typep graph 'generated-graph-mixin)
+ (change-class graph (find-or-create-class
+ 'basic-graph (list 'generated-graph-mixin
+ (class-name (class-of graph))))))
+ (setf (slot-value graph 'generation-method) method
+ (slot-value graph 'random-seed) (random-seed generator)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun simple-group-id-generator (kind count)
+ (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun simple-group-id-parser (vertex)
+ (parse-integer (subseq (symbol-name (element vertex)) 1 3)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; generate-Gnp
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-Gnp (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-Gnp
+ generator (make-instance graph-class) n p :label label))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-Gnp (generator (graph basic-graph) n p &key (label 'identity))
+ (let ((v 1)
+ (w -1)
+ (log-1-p (log (- 1 p))))
+ (save-generation-information graph generator 'generate-gnp)
+ (loop for i from 0 to (1- n) do
+ (add-vertex graph (funcall label i)))
+ (loop while (< v n) do
+ (let ((r (uniform-random generator 0d0 1d0)))
+ (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
+ (loop while (and (>= w v) (< v n)) do
+ (setf w (- w v)
+ v (1+ v)))
+ (when (< v n)
+ (add-edge-between-vertexes
+ graph (funcall label v) (funcall label w)))))
+
+ graph))
+
+;;; ---------------------------------------------------------------------------
+;;; generate-Gnm
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-Gnm (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-Gnm
+ generator (make-instance graph-class) n p :label label))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-Gnm (generator (graph basic-graph) n m &key (label 'identity))
+ (let ((max-edge-index (1- (combination-count n 2))))
+ #+Ignore
+ (save-generation-information graph generator 'generate-gnm)
+ (loop for i from 0 to (1- n) do
+ (add-vertex graph (funcall label i)))
+ (loop for i from 0 to (1- m) do
+ (loop
+ until (let* ((i (integer-random generator 0 max-edge-index))
+ (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
+ (w (- i (/ (* v (1- v)) 2)))
+ (label-v (funcall label v))
+ (label-w (funcall label w)))
+ (unless (find-edge-between-vertexes
+ graph label-v label-w :error-if-not-found? nil)
+ (add-edge-between-vertexes graph label-v label-w)))))
+
+ graph))
+
+#+Ignore
+(pro:with-profiling
+ (setf g (generate-gnm
+ *random-generator*
+ 'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
+ )
+
+;;; ---------------------------------------------------------------------------
+
+(defun vertex-group (v)
+ (aref (symbol-name (element v)) 1))
+
+;;; ---------------------------------------------------------------------------
+
+(defun in-group-degree (v &key (key 'vertex-group))
+ (vertex-degree
+ v :edge-filter (lambda (e ov)
+ (declare (ignore e))
+ (in-same-group-p v ov key))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun in-same-group-p (v1 v2 key)
+ (eq (funcall key v1) (funcall key v2)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun out-group-degree (v &key (key 'vertex-group))
+ (vertex-degree
+ v :edge-filter (lambda (e ov)
+ (declare (ignore e))
+ (not (in-same-group-p v ov key)))))
+
+;;; ---------------------------------------------------------------------------
+;;; generate-undirected-graph-via-assortativity-matrix
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-undirected-graph-via-assortativity-matrix
+ (generator (graph-class symbol) size edge-count
+ kind-matrix assortativity-matrix vertex-creator
+ &key (duplicate-edge-function 'identity))
+ (generate-undirected-graph-via-assortativity-matrix
+ generator (make-instance graph-class) size edge-count
+ kind-matrix assortativity-matrix vertex-creator
+ :duplicate-edge-function duplicate-edge-function))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-undirected-graph-via-assortativity-matrix
+ (generator graph size edge-count
+ kind-matrix assortativity-matrix vertex-creator
+ &key (duplicate-edge-function 'identity))
+ (let* ((kind-count (array-dimension assortativity-matrix 0))
+ (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
+ #'<))
+ (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
+ (vertex-sampler (make-array kind-count))
+ (edge-kinds (sample-edges-for-assortative-graph
+ generator edge-count assortativity-matrix))
+ )
+ (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
+
+ (loop for vertex-kind from 0 to (1- kind-count)
+ for count in vertex-kind-counts do
+ (setf (aref vertex-sampler vertex-kind)
+ (make-array (second count))))
+
+ (let ((current-kind 0)
+ (current-count 0)
+ (current-vertexes (aref vertex-sampler 0)))
+ ;; add vertexes
+ (loop for kind in vertex-kinds
+ for i from 0 do
+ (when (not (eq current-kind kind))
+ (setf current-count 0
+ current-kind kind
+ current-vertexes (aref vertex-sampler current-kind)))
+ (let ((vertex (funcall vertex-creator kind i)))
+ (setf (aref current-vertexes current-count) vertex)
+ (add-vertex graph vertex)
+ (incf current-count)))
+
+ (loop for (from-kind to-kind) in edge-kinds do
+ (let ((v1 nil)
+ (v2 nil))
+ (if (= from-kind to-kind)
+ (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
+ generator 2)))
+ (setf v1 (first sample) v2 (second sample)))
+ (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
+ v2 (sample-element (aref vertex-sampler to-kind) generator)))
+ (add-edge-between-vertexes
+ graph
+ v1
+ v2
+ :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
+
+ (values graph)))
+
+;;; ---------------------------------------------------------------------------
+;;; generate-undirected-graph-via-verex-probabilities
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-undirected-graph-via-vertex-probabilities
+ (generator (graph-class symbol) size
+ kind-matrix probability-matrix vertex-creator)
+ (generate-undirected-graph-via-vertex-probabilities
+ generator (make-instance graph-class) size
+ kind-matrix probability-matrix vertex-creator))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-undirected-graph-via-vertex-probabilities
+ (generator graph size
+ kind-matrix probability-matrix vertex-creator)
+ (let* ((kind-count (array-dimension probability-matrix 0))
+ (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
+ #'<))
+ (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
+ (vertex-sampler (make-array kind-count)))
+ (save-generation-information graph generator
+ 'generate-undirected-graph-via-vertex-probabilities)
+
+ ;; initialize vertex bookkeeping
+ (loop for vertex-kind from 0 to (1- kind-count)
+ for count in vertex-kind-counts do
+ (setf (aref vertex-sampler vertex-kind)
+ (make-array (second count))))
+
+ ;; add vertexes
+ (let ((current-kind 0)
+ (current-count 0)
+ (current-vertexes (aref vertex-sampler 0)))
+ (loop for kind in vertex-kinds
+ for i from 0 do
+ (when (not (eq current-kind kind))
+ (setf current-count 0
+ current-kind kind
+ current-vertexes (aref vertex-sampler current-kind)))
+ (let ((vertex (funcall vertex-creator kind i)))
+ (setf (aref current-vertexes current-count) vertex)
+ (add-vertex graph vertex)
+ (incf current-count))))
+
+ #+Ignore
+ ;; adjust probabilities
+ (loop for (kind-1 count-1) in vertex-kind-counts do
+ (loop for (kind-2 count-2) in vertex-kind-counts
+ when (<= kind-1 kind-2) do
+ (format t "~%~6,6F ~6,6F"
+ (aref probability-matrix kind-1 kind-2)
+ (float (/ (aref probability-matrix kind-1 kind-2)
+ (* count-1 count-2))))
+ (setf (aref probability-matrix kind-1 kind-2)
+ (float (/ (aref probability-matrix kind-1 kind-2)
+ (* count-1 count-2))))))
+
+ ;; add edges
+ (flet ((add-one-edge (k1 k2 a b)
+ (add-edge-between-vertexes
+ graph
+ (aref (aref vertex-sampler k1) a)
+ (aref (aref vertex-sampler k2) b))))
+ (loop for (kind-1 count-1) in vertex-kind-counts do
+ (loop for (kind-2 count-2) in vertex-kind-counts
+ when (<= kind-1 kind-2) do
+ (if (eq kind-1 kind-2)
+ (sample-edges-of-same-kind
+ generator count-1 (aref probability-matrix kind-1 kind-2)
+ (lambda (a b)
+ (add-one-edge kind-1 kind-2 a b)))
+ (sample-edges-of-different-kinds
+ generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
+ (lambda (a b)
+ (add-one-edge kind-1 kind-2 a b)))))))
+ (values graph)))
+
+
+#+Debug
+(defmethod generate-undirected-graph-via-vertex-probabilities
+ (generator graph size
+ kind-matrix probability-matrix vertex-creator)
+ (let* ((kind-count (array-dimension probability-matrix 0))
+ (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
+ #'<))
+ (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
+ (vertex-sampler (make-array kind-count)))
+
+ (loop for vertex-kind from 0 to (1- kind-count)
+ for count in vertex-kind-counts do
+ (setf (aref vertex-sampler vertex-kind)
+ (make-array (second count))))
+
+ (let ((current-kind 0)
+ (current-count 0)
+ (current-vertexes (aref vertex-sampler 0)))
+ ;; add vertexes
+ (loop for kind in vertex-kinds
+ for i from 0 do
+ (when (not (eq current-kind kind))
+ (setf current-count 0
+ current-kind kind
+ current-vertexes (aref vertex-sampler current-kind)))
+ (let ((vertex (funcall vertex-creator kind i)))
+ (setf (aref current-vertexes current-count) vertex)
+ (add-vertex graph vertex)
+ (incf current-count))))
+
+ (let ((xxx 0))
+ (flet ((add-one-edge (k1 k2 a b)
+ (incf xxx)
+ (add-edge-between-vertexes
+ graph
+ (aref (aref vertex-sampler k1) a)
+ (aref (aref vertex-sampler k2) b))))
+ (loop for (kind-1 count-1) in vertex-kind-counts do
+ (loop for (kind-2 count-2) in vertex-kind-counts
+ when (<= kind-1 kind-2) do
+ (setf xxx 0)
+ (if (eq kind-1 kind-2)
+ (sample-edges-of-same-kind
+ generator count-1 (aref probability-matrix kind-1 kind-2)
+ (lambda (a b)
+ (add-one-edge kind-1 kind-2 a b)))
+ (sample-edges-of-different-kinds
+ generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
+ (lambda (a b)
+ (add-one-edge kind-1 kind-2 a b))))
+ (format t "~%~A ~A ~A ~A -> ~A"
+ count-1 count-2 kind-1 kind-2 xxx)))))
+ (values graph)))
+
+
+#+Test
+(generate-undirected-graph-via-vertex-probabilities
+ *random-generator* 'graph-container
+ 30
+ #(0.8 0.2)
+ #2A((0.1 0.02) (0.02 0.6))
+ (lambda (kind count)
+ (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun sample-edges-of-same-kind (generator n p fn)
+ (when (plusp p)
+ (let ((v 1)
+ (w -1)
+ (log-1-p (log (- 1 p))))
+ (loop while (< v n) do
+ (let ((r (uniform-random generator 0d0 1d0)))
+ (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
+ (loop while (and (>= w v) (< v n)) do
+ (setf w (- w v)
+ v (1+ v)))
+ (when (< v n)
+ (funcall fn v w)))))))
+
+#+Test
+(sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun sample-edges-of-different-kinds (generator rows cols p fn)
+ (when (plusp p)
+ (let ((v 1)
+ (w -1)
+ (log-1-p (log (- 1 p))))
+ (loop while (< v rows) do
+ (let ((r (uniform-random generator 0d0 1d0)))
+ (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
+ (loop while (and (>= w cols) (< v rows)) do
+ (setf w (- w cols)
+ v (1+ v)))
+ (when (< v rows)
+ (funcall fn v w)))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun poisson-vertex-degree-distribution (z k)
+ (/ (* (expt z k) (expt +e+ (- z)))
+ (factorial k)))
+
+#|
+We know the probability of finding a vertex of degree k is p_k. We want to sample
+from this distribution
+|#
+
+;;; ---------------------------------------------------------------------------
+
+(defun power-law-vertex-degree-distribution (kappa k)
+ (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun create-specified-vertex-degree-distribution (degrees)
+ (lambda (z k)
+ (declare (ignore z k))
+ degrees))
+
+;;; ---------------------------------------------------------------------------
+
+(defun make-degree-sampler (p_k &key (generator *random-generator*)
+ (max-degree 1000)
+ (min-probability 0.0001))
+ (let ((wsc (make-container 'containers:weighted-sampling-container
+ :random-number-generator generator
+ :key #'second))
+ (total 0.0)
+ (max-k 0))
+ (loop for k = 0 then (1+ k)
+ for p = (funcall p_k k)
+ until (or (and max-degree (> k max-degree))
+ (and min-probability (< (- 1.0 total) min-probability))) do
+ (incf total p)
+ (setf max-k k)
+ (insert-item wsc (list k p)))
+ (when (plusp (- 1.0 total))
+ (insert-item wsc (list (1+ max-k) (- 1.0 total))))
+ (lambda ()
+ (first (next-element wsc)))))
+
+;;; ---------------------------------------------------------------------------
+
+#+Old
+(defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
+ (let ((c (make-container 'weighted-sampling-container
+ :random-number-generator generator
+ :key (lambda (item)
+ (aref assortativity-matrix (first item) (second item))))))
+ (dotimes (i (array-dimension assortativity-matrix 0))
+ (dotimes (j (array-dimension assortativity-matrix 1))
+ (insert-item c (list i j))))
+ (loop repeat edge-count collect
+ (next-element c))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
+ (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
+ (loop repeat edge-count collect
+ (funcall s))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
+ (let ((c (make-container 'weighted-sampling-container
+ :random-number-generator generator
+ :key (lambda (item)
+ (aref assortativity-matrix (first item) (second item))))))
+ (dotimes (i (array-dimension assortativity-matrix 0))
+ (dotimes (j (array-dimension assortativity-matrix 1))
+ (insert-item c (list i j))))
+ (lambda () (next-element c))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
+ (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
+ ;; use kind-matrix as counts
+ (assert (= size (sum-of-array-elements kind-matrix)))
+ (coerce (shuffle-elements!
+ (make-array size
+ :initial-contents
+ (loop for i = 0 then (1+ i)
+ for count across kind-matrix nconc
+ (make-list count :initial-element i)))
+ :generator generator)
+ 'list))
+
+ (t
+ ;; use kind-matrix as ratios to sample
+ (let* ((c (make-container 'weighted-sampling-container
+ :random-number-generator generator
+ :key (lambda (item)
+ (aref kind-matrix item)))))
+ (dotimes (i (array-dimension kind-matrix 0))
+ (insert-item c i))
+ (loop repeat size collect
+ (next-element c))))))
+
+#+Test
+(sample-vertexes-for-mixed-graph
+ *random-generator*
+ 50 #2A((0.258 0.016 0.035 0.013)
+ (0.012 0.157 0.058 0.019)
+ (0.013 0.023 0.306 0.035)
+ (0.005 0.007 0.024 0.016)))
+
+#+Test
+(sample-edges 50 #2A((0.258 0.016 0.035 0.013)
+ (0.012 0.157 0.058 0.019)
+ (0.013 0.023 0.306 0.035)
+ (0.005 0.007 0.024 0.016)))
+#+Test
+(let ((a #2A((0.258 0.016 0.035 0.013)
+ (0.012 0.157 0.058 0.019)
+ (0.013 0.023 0.306 0.035)
+ (0.005 0.007 0.024 0.016)))
+ (c (make-container 'weighted-sampling-container :key #'second)))
+ (dotimes (i 4)
+ (dotimes (j 4)
+ (insert-item c (list (list i j) (aref a i j)))))
+ (element-counts
+ (loop repeat 1000 collect
+ (next-element c))
+ :key #'first
+ :test #'equal))
+
+#+Test
+(let ((a #2A((0.258 0.016 0.035 0.013)
+ (0.012 0.157 0.058 0.019)
+ (0.013 0.023 0.306 0.035)
+ (0.005 0.007 0.024 0.016)))
+ (c (make-container 'weighted-sampling-container :key #'second)))
+ (pro:with-profiling
+ (loop repeat 100000 do
+ (next-element c))))
+
+#+Test
+(defun foo (percent-bad percent-mixing)
+ (let ((kind-matrix (make-array 2 :initial-element 0d0))
+ (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
+ (setf (aref kind-matrix 0) (- 1d0 percent-bad)
+ (aref kind-matrix 1) percent-bad
+ (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
+ (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
+ (aref mixing-matrix 1 0) percent-mixing
+ (aref mixing-matrix 0 1) percent-mixing)
+ (normalize-matrix kind-matrix)
+ (setf mixing-matrix (normalize-matrix mixing-matrix))
+ (values kind-matrix
+ mixing-matrix)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; girvan-newman-test-graphs
+;;; ---------------------------------------------------------------------------
+
+(defun generate-girvan-newman-graph (generator graph-class z-in)
+ (warn "This is broken!")
+ (bind ((g (make-instance graph-class))
+ (group-count 4)
+ (group-size 32)
+ (edge-count 16)
+ (z-out (- edge-count z-in))
+ (vertexes (make-container 'simple-associative-container))
+ (groups (make-container 'alist-container)))
+ (save-generation-information g generator
+ 'generate-girvan-newman-graph)
+ (labels ((make-id (group index)
+ (form-keyword "A" group "0" index))
+
+ (choose-inner-id (group id)
+ (check-type group fixnum)
+ (check-type id symbol)
+ (loop
+ (let ((other (sample-element (item-at groups group :needs-in) generator)))
+ (when (and #+Ignore
+ (not (eq id other))
+ #+Ignore
+ (not (find-edge-between-vertexes
+ g id other :error-if-not-found? nil)))
+ (return-from choose-inner-id other)))))
+
+ (choose-outer-id (from-group id)
+ (declare (ignore id))
+
+ (check-type from-group fixnum)
+ (loop
+ (bind ((other-group (integer-random generator 0 (- group-count 2)))
+ (other (sample-element
+ (item-at groups (if (= from-group other-group)
+ (1+ other-group)
+ other-group) :needs-out)
+ generator)))
+ (when (and other
+ #+Ignore
+ (not (find-edge-between-vertexes
+ g id other :error-if-not-found? nil)))
+ (return-from choose-outer-id other)))))
+
+ (make-in-edge (from to)
+ (let ((group (gn-id->group from)))
+ (when (zerop (decf (first (item-at vertexes from))))
+ (setf (item-at groups group :needs-in)
+ (remove from (item-at groups group :needs-in))))
+ (when (zerop (decf (first (item-at vertexes to))))
+ (setf (item-at groups group :needs-in)
+ (remove to (item-at groups group :needs-in))))
+ (add-edge-between-vertexes
+ g from to :edge-type :undirected
+ :if-duplicate-do (lambda (e) (incf (weight e))))))
+
+ (make-out-edge (from to)
+ (let ((group-from (gn-id->group from))
+ (group-to (gn-id->group to)))
+ (when (zerop (decf (second (item-at vertexes from))))
+ (setf (item-at groups group-from :needs-out)
+ (remove from (item-at groups group-from :needs-out))))
+ (when (zerop (decf (second (item-at vertexes to))))
+ (setf (item-at groups group-to :needs-out)
+ (remove to (item-at groups group-to :needs-out))))
+
+ (add-edge-between-vertexes
+ g from to :edge-type :undirected
+ :if-duplicate-do (lambda (e) (incf (weight e)))))))
+
+ ;; vertexes
+ (loop for group from 0 to (1- group-count) do
+ (loop for index from 0 to (1- group-size) do
+ (let ((id (make-id group index)))
+ (setf (item-at vertexes id) (list z-in z-out))
+ (when (plusp z-in)
+ (push id (item-at groups group :needs-in)))
+ (when (plusp z-out)
+ (push id (item-at groups group :needs-out))))))
+
+ ;; create edges
+ (loop for group from 0 to (1- group-count) do
+ (loop for index from 0 to (1- group-size) do
+ (let ((from (make-id group index)))
+ (print from)
+ (loop while (plusp (first (item-at vertexes from))) do
+ (make-in-edge from (choose-inner-id group from)))
+ (loop while (plusp (second (item-at vertexes from))) do
+ (make-out-edge from (choose-outer-id group from)))))))
+
+ (values g)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun gn-id->group (id)
+ (parse-integer (subseq (symbol-name id) 1 2)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun collect-edge-counts (g)
+ (let ((vertexes (make-container 'simple-associative-container
+ :initial-element-fn (lambda () (list 0 0)))))
+ (iterate-edges
+ g
+ (lambda (e)
+ (bind ((v1 (vertex-1 e))
+ (v2 (vertex-2 e))
+ (id1 (element v1))
+ (id2 (element v2)))
+ (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
+ (incf (first (item-at vertexes id1)) (weight e))
+ (incf (first (item-at vertexes id2)) (weight e)))
+ (t
+ (incf (second (item-at vertexes id1)) (weight e))
+ (incf (second (item-at vertexes id2)) (weight e)))))))
+ (sort
+ (collect-key-value
+ vertexes
+ :transform (lambda (k v) (list k (first v) (second v))))
+ #'string-lessp
+ :key #'first)))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* weighted-sampler-with-lookup-container ()
+ ((sampler nil r)
+ (lookup nil r)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
+ &key random-number-generator key)
+ (setf (slot-value object 'sampler)
+ (make-container 'weighted-sampling-container
+ :random-number-generator random-number-generator
+ :key key)
+ (slot-value object 'lookup)
+ (make-container 'simple-associative-container)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod insert-item ((container weighted-sampler-with-lookup-container)
+ (item t))
+ (let ((node (nth-value 1 (insert-item (sampler container) item))))
+ ;;?? remove
+ (assert (not (null node)))
+ (setf (item-at-1 (lookup container) item) node)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-node ((container weighted-sampler-with-lookup-container)
+ (item t))
+ (item-at-1 (lookup container) item))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-node ((container weighted-sampler-with-lookup-container)
+ (node t))
+ ;; not going to worry about the hash table
+ (delete-node (sampler container) node))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod next-element ((container weighted-sampler-with-lookup-container))
+ (next-element (sampler container)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-scale-free-graph
+ (generator graph size kind-matrix add-edge-count
+ other-vertex-kind-samplers
+ vertex-creator
+ &key (duplicate-edge-function 'identity))
+ (let* ((kind-count (array-dimension kind-matrix 0))
+ (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
+ (vertex-sampler (make-array kind-count)))
+ (save-generation-information graph generator 'generate-scale-free-graph)
+ (flet ((sample-existing-vertexes (for-kind)
+ ;; return list of vertexes to attach based on preferential attachment
+ (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
+ add-edge-count generator) collect
+ (let ((vertex (next-element (aref vertex-sampler other-kind))))
+ (unless vertex
+ (loop for i from 0
+ for nil across vertex-sampler
+ until vertex do
+ (setf vertex (next-element (aref vertex-sampler i))
+ other-kind i)))
+
+ ;;?? remove. this should never happen
+ (unless vertex (break))
+
+ (list vertex other-kind))))
+ (update (kind thing)
+ ;; handle bookkeeping for changed vertex degree
+ (bind ((sampler (aref vertex-sampler kind))
+ (node (find-node sampler thing)))
+ (delete-node sampler node)
+ (insert-item sampler thing))))
+
+ ;; set up samplers
+ (loop for i from 0
+ for nil across vertex-sampler do
+ (setf (aref vertex-sampler i)
+ (make-container 'weighted-sampler-with-lookup-container
+ :random-number-generator generator
+ :key (lambda (vertex)
+ (1+ (vertex-degree vertex))))))
+
+ ;; add vertexes and edges
+ (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
+ for i from 0 do
+ (let* ((element (funcall vertex-creator kind i))
+ (vertex (add-vertex graph element)))
+ (when (> i add-edge-count)
+ (loop for (other other-kind) in (sample-existing-vertexes kind) do
+ (update other-kind other)
+ ;;?? remove
+ (if (or (null kind) (null other)) (break))
+ (add-edge-between-vertexes
+ graph vertex other
+ :if-duplicate-do
+ (lambda (e) (funcall duplicate-edge-function e)))))
+ (insert-item (aref vertex-sampler kind) vertex)))
+
+ graph)))
+
+;;; ---------------------------------------------------------------------------
+
+#+Test
+(defun poisson-connector (count generator)
+ (let* ((ts (poisson-random generator 2))
+ (cs (poisson-random generator 2))
+ (rest (- count ts cs)))
+ (loop for tick = t then (not tick) while (minusp rest) do
+ (incf rest)
+ (if tick (decf ts) (decf cs)))
+ (shuffle-elements!
+ (append (make-list (truncate rest) :initial-element 0)
+ (make-list (truncate ts) :initial-element 1)
+ (make-list (truncate cs) :initial-element 2))
+ :generator generator)))
+
+#+Test
+(setf (ds :g-1100)
+ (generate-scale-free-graph
+ *random-generator*
+ (make-container 'graph-container :default-edge-type :undirected)
+ 1100
+ #(1000 50 50)
+ 10
+ (list
+ (lambda (count generator)
+ (declare (ignore generator))
+ (make-list count :initial-element 0))
+ #'poisson-connector
+ #'poisson-connector)
+ (lambda (kind count)
+ (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
+
+#+Test
+(pro:with-profiling
+ (generate-scale-free-graph
+ *random-generator*
+ (make-container 'graph-container :default-edge-type :undirected)
+ 10000
+ #(1.0)
+ 10
+ (list
+ (lambda (count generator)
+ (declare (ignore generator))
+ (make-list count :initial-element 0)))
+ (lambda (kind count)
+ (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
+
+#|
+(pro:with-profiling
+ (generate-scale-free-graph
+ *random-generator*
+ (make-container 'graph-container :default-edge-type :undirected)
+ 1000
+ #(1.0)
+ 3
+ (list
+ (lambda (count generator)
+ (declare (ignore generator))
+ (make-list count :initial-element 0)))
+ (lambda (kind count)
+ (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
+
+
+;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
+;;; 102,959,032 words consed
+Execution time profile from 2078 samples
+ Parents
+Function
+ Children Relative Absolute Consing Conses
+----
+%%check-keywords 99% 99% 100,970,656
+ sample-existing-vertexes 62%
+ insert-item <weighted-sampler-with-lookup-container> <t> 32%
+ add-vertex <basic-graph> <t> 2%
+ update 1%
+ add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
+ form-keyword 1%
+ iterate-container <contents-as-array-mixin> <t> 1%
+----
+ %%check-keywords 100%
+sample-existing-vertexes 62% 61% 62,577,336
+ walk-tree-nodes <bst-node> <t> 99%
+ uniform-random 1%
+----
+ sample-existing-vertexes 100%
+walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
+ #<anonymous function #xaa2070e> 77%
+ +-2 3%
+ element-weight <weighted-sampling-container> <t> 2%
+ >=-2 2%
+ %double-float+-2! 1%
+ %%one-arg-dcode 1%
+----
+ walk-tree-nodes <bst-node> <t> 98%
+ %%before-and-after-combined-method-dcode 2%
+#<anonymous function #xaa2070e> 48% 47% 48,156,256
+ iterate-container <contents-as-array-mixin> <t> 73%
+ %%1st-two-arg-dcode 9%
+ iterate-edges <graph-container-vertex> <t> 6%
+ constantly 4%
+ iterate-elements <abstract-container> <t> 2%
+----
+ #<anonymous function #xaa2070e> 99%
+ %vertex-degree 1%
+iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
+ other-vertex <graph-container-edge> <graph-container-vertex> 43%
+ %%nth-arg-dcode 20%
+ #<anonymous function #x271d31e> 10%
+----
+ insert-item <weighted-sampler-with-lookup-container> <t> 92%
+ %make-std-instance 3%
+ update 3%
+ %%standard-combined-method-dcode 1%
+ %call-next-method 1%
+%%before-and-after-combined-method-dcode 34% 34% 34,400,720
+ insert-item <binary-search-tree> <bst-node> 90%
+ #<anonymous function #xaa2070e> 2%
+ shared-initialize <standard-object> <t> 2%
+ %%one-arg-dcode 1%
+ %double-float+-2! 1%
+ +-2 1%
+----
+ %%check-keywords 100%
+insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
+ %%before-and-after-combined-method-dcode 100%
+----
+ %%before-and-after-combined-method-dcode 100%
+insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
+ %vertex-degree 84%
+ vertex-degree 5%
+----
+ insert-item <binary-search-tree> <bst-node> 99%
+ #<anonymous function #xaa2070e> 1%
+%vertex-degree 26% 25% 25,870,312
+ #<anonymous function #xa7cee86> 68%
+ %aref1 3%
+ %std-slot-value-using-class 1%
+ slot-id-value 1%
+ %%one-arg-dcode 1%
+ iterate-container <contents-as-array-mixin> <t> 1%
+----
+ %vertex-degree 99%
+ iterate-container <contents-as-array-mixin> <t> 1%
+#<anonymous function #xa7cee86> 18% 17% 17,420,592
+ %maybe-std-slot-value-using-class 8%
+ %%one-arg-dcode 8%
+ %std-slot-value-using-class 8%
+ slot-id-value 5%
+ vertex-1 <graph-container-edge> 5%
+ #<anonymous function #x271d31e> 1%
+----
+ iterate-container <contents-as-array-mixin> <t> 99%
+ #<anonymous function #xa7cee86> 1%
+other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
+ %%one-arg-dcode 1%
+----
+ iterate-container <contents-as-array-mixin> <t> 95%
+ %%check-keywords 3%
+ %%before-and-after-combined-method-dcode 1%
+ initialize-instance (around) <basic-initial-contents-mixin> 1%
+%%nth-arg-dcode 7% 9% 9,238,560
+----
+ #<anonymous function #xaa2070e> 93%
+ walk-tree-nodes <bst-node> <t> 5%
+ %%before-and-after-combined-method-dcode 2%
+%%1st-two-arg-dcode 5% 5% 4,802,264
+----
+ iterate-container <contents-as-array-mixin> <t> 96%
+ #<anonymous function #xa7cee86> 3%
+ shared-initialize <standard-object> <t> 1%
+#<anonymous function #x271d31e> 4% 4% 4,012,368
+----
+ #<anonymous function #xaa2070e> 100%
+iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
+----
+ #<anonymous function #xa7cee86> 59%
+ %vertex-degree 14%
+ walk-tree-nodes <bst-node> <t> 13%
+ shared-initialize <standard-object> <t> 6%
+ %shared-initialize 4%
+ other-vertex <graph-container-edge> <graph-container-vertex> 2%
+ member 2%
+%std-slot-value-using-class 2% 2% 2,115,320
+----
+ #<anonymous function #xa7cee86> 59%
+ walk-tree-nodes <bst-node> <t> 12%
+ %vertex-degree 9%
+ %%before-and-after-combined-method-dcode 6%
+ shared-initialize <standard-object> <t> 4%
+ update 4%
+ other-vertex <graph-container-edge> <graph-container-vertex> 4%
+ %shared-initialize 2%
+%%one-arg-dcode 2% 2% 2,478,304
+----
+ make-instance <symbol> 68%
+ %make-instance 23%
+ make-instance <standard-class> 9%
+%make-std-instance 2% 2% 2,283,344
+ %%before-and-after-combined-method-dcode 47%
+ shared-initialize <standard-object> <t> 15%
+ %%standard-combined-method-dcode 12%
+ %maybe-std-slot-value-using-class 3%
+----
+ #<anonymous function #xa7cee86> 78%
+ %vertex-degree 7%
+ uniform-random 5%
+ %make-std-instance 2%
+ shared-initialize <standard-object> <t> 3%
+ view-get <simple-view> <t> 2%
+ walk-tree-nodes <bst-node> <t> 3%
+%maybe-std-slot-value-using-class 2% 2% 2,005,048
+----
+ add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
+ add-vertex <basic-graph> <t> 40%
+ initialize-instance (after) <graph-container-vertex> 7%
+ add-it 6%
+ %%before-and-after-combined-method-dcode 5%
+make-instance <symbol> 2% 2% 1,932,504
+ %make-std-instance 92%
+----
+ #<anonymous function #xaa2070e> 100%
+constantly 2% 2% 1,629,880
+----
+ walk-tree-nodes <bst-node> <t> 97%
+ %%before-and-after-combined-method-dcode 3%
++-2 2% 2% 1,688,392
+ %maybe-std-slot-value-using-class 3%
+----
+ %%check-keywords 100%
+add-vertex <basic-graph> <t> 2% 2% 2,259,304
+ make-instance <symbol> 44%
+ %%standard-combined-method-dcode 30%
+ %%before-and-after-combined-method-dcode 8%
+ %make-std-instance 3%
+----
+generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
+ %%standard-combined-method-dcode 48%
+ %%check-keywords 16%
+ uniform-random 15%
+ make-instance <symbol> 6%
+----
+ generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
+ add-vertex <basic-graph> <t> 25%
+ %make-std-instance 18%
+ make-instance <standard-class> 6%
+ add-it 3%
+ insert-item <weighted-sampler-with-lookup-container> <t> 3%
+%%standard-combined-method-dcode 2% 2% 2,019,832
+ insert-item <container-uses-nodes-mixin> <t> 45%
+ %%before-and-after-combined-method-dcode 25%
+ %%nth-arg-dcode 3%
+ make-instance <symbol> 3%
+----
+#<GRAPH-CONTAINER 1000>
+? 2
+2
+?
+
+(open-plot-in-window
+ (histogram
+ (collect-elements
+ (clnuplot::data->n-buckets
+ (sort (collect-items x :transform #'vertex-degree) #'>)
+ 20
+ #'identity)
+ :filter
+ (lambda (x)
+ (and (plusp (first x))
+ (plusp (second x ))))
+ :transform
+ (lambda (x)
+ (list (log (first x) 10) (log (second x)))))))
+
+
+
+(clasp:linear-regression-brief
+ (mapcar #'first
+ '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
+ (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
+ (3.2961164921697144 1.6094379124341003)
+ (3.3831867994748994 1.9459101490553132)
+ (3.4556821645007902 0.6931471805599453)
+ (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
+ (3.932600584500482 0.0))
+ )
+ (mapcar #'second
+ '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
+ (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
+ (3.2961164921697144 1.6094379124341003)
+ (3.3831867994748994 1.9459101490553132)
+ (3.4556821645007902 0.6931471805599453)
+ (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
+ (3.932600584500482 0.0))
+ ))
+
+|#
+
+;;; ---------------------------------------------------------------------------
+;;; generate-assortative-graph-with-degree-distributions
+;;; ---------------------------------------------------------------------------
+
+#+Ignore
+(define-debugging-class generate-assortative-graph-with-degree-distributions ())
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-assortative-graph-with-degree-distributions
+ (generator (graph-class symbol)
+ edge-count assortativity-matrix
+ average-degrees
+ degree-distributions
+ vertex-creator
+ &key (duplicate-edge-function 'identity))
+ (generate-assortative-graph-with-degree-distributions
+ generator (make-instance graph-class)
+ edge-count assortativity-matrix
+ average-degrees
+ degree-distributions
+ vertex-creator
+ :duplicate-edge-function duplicate-edge-function))
+
+#|
+Split into a function to compute some of the intermediate pieces and one to use them
+|#
+
+(defmethod generate-assortative-graph-with-degree-distributions
+ (generator graph edge-count assortativity-matrix
+ average-degrees
+ degree-distributions
+ vertex-creator
+ &key (duplicate-edge-function 'identity))
+ (setf assortativity-matrix (normalize-matrix assortativity-matrix))
+ (let* ((kind-count (array-dimension assortativity-matrix 0))
+ (vertex->degree-counts (make-array kind-count))
+ (edges (copy-tree
+ (sample-edges-for-assortative-graph
+ generator edge-count assortativity-matrix)))
+ (degree-sums (sort
+ (merge-elements
+ (append (element-counts edges :key #'first)
+ (element-counts edges :key #'second))
+ (lambda (old new)
+ (+ old new))
+ (lambda (new)
+ new) :key #'first :argument #'second)
+ #'<
+ :key #'first))
+ (vertex-counts (collect-elements
+ degree-sums
+ :transform
+ (lambda (kind-and-count)
+ (round (float (/ (second kind-and-count)
+ (elt average-degrees (first kind-and-count))))))))
+ (edge-samplers (make-array kind-count)))
+ (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
+
+ ;; setup bookkeeping
+ (loop for kind from 0 to (1- kind-count) do
+ (setf (aref edge-samplers kind)
+ (make-container 'vector-container)
+ (aref vertex->degree-counts kind)
+ (make-container 'simple-associative-container)))
+ (loop for edge in edges do
+ (insert-item (aref edge-samplers (first edge)) (cons :source edge))
+ (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
+ (iterate-elements
+ edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
+
+ ;(spy edges degree-sums vertex-counts)
+
+ (loop for kind from 0 to (1- kind-count)
+ for count in vertex-counts do
+ (let ((distribution (nth-element degree-distributions kind))
+ (vertexes (make-container 'vector-container))
+ (vertex-degrees (aref vertex->degree-counts kind))
+ (total-degree 0)
+ (desired-sum (second (elt degree-sums kind))))
+
+ ;; for each type, create vertexes
+ (loop for i from 0 to (1- count) do
+ (let ((vertex (funcall vertex-creator kind i))
+ (degree (funcall distribution)))
+ (insert-item vertexes vertex)
+ (setf (item-at-1 vertex-degrees vertex)
+ degree)
+ (incf total-degree degree)))
+
+ ;(spy vertexes total-degree desired-sum)
+
+ ;; ensure proper total degree
+ (loop while (/= total-degree desired-sum) do
+ #+Ignore
+ (when-debugging-format
+ generate-assortative-graph-with-degree-distributions
+ "Current: ~D, Desired: ~D, Difference: ~D"
+ total-degree desired-sum
+ (abs (- total-degree desired-sum)))
+ (let* ((vertex (sample-element vertexes generator))
+ (bigger? (< total-degree desired-sum))
+ (current-degree (item-at-1 vertex-degrees vertex))
+ (new-degree 0)
+ (attempts 100))
+ (when (or bigger?
+ (and (not bigger?)
+ (plusp current-degree)))
+ (decf total-degree current-degree)
+
+ #+Ignore
+ (when-debugging-format
+ generate-assortative-graph-with-degree-distributions
+ " ~D ~D ~:[^~]"
+ total-degree current-degree new-degree (not bigger?))
+
+ ;; increase speed by knowing which direction we need to go...?
+ (loop until (or (zerop (decf attempts))
+ (and bigger?
+ (> (setf new-degree (funcall distribution))
+ current-degree))
+ (and (not bigger?)
+ (< (setf new-degree (funcall distribution))
+ current-degree))) do
+
+ (setf bigger? (< (+ total-degree new-degree) desired-sum)))
+
+ (cond ((plusp attempts)
+ #+Ignore
+ (when-debugging
+ generate-assortative-graph-with-degree-distributions
+ (format *debug-io* " -> ~D" new-degree))
+
+ (setf (item-at-1 vertex-degrees vertex) new-degree)
+ (incf total-degree new-degree)
+
+ #+Ignore
+ (when-debugging-format
+ generate-assortative-graph-with-degree-distributions
+ "~D ~D" total-degree desired-sum))
+ (t
+ ;; couldn't find one, try again
+ (incf total-degree current-degree))))))
+
+ ;; attach edges
+ (let ((edge-sampler (aref edge-samplers kind)))
+ (flet ((sample-edges-for-vertex (vertex)
+ ;(spy vertex)
+ (loop repeat (item-at-1 vertex-degrees vertex) do
+ (bind (((edge-kind . edge) (delete-last edge-sampler)))
+ (ecase edge-kind
+ (:source (setf (first edge) vertex))
+ (:target (setf (second edge) vertex)))))))
+ (iterate-elements
+ vertexes
+ #'sample-edges-for-vertex)))))
+
+ ;; repair self edges
+
+
+ ;; now make the graph [at last]
+ (iterate-elements
+ edges
+ (lambda (edge)
+ (add-edge-between-vertexes graph (first edge) (second edge)
+ :if-duplicate-do duplicate-edge-function))))
+
+ graph)
+
+#+Test
+(generate-assortative-graph-with-degree-distributions
+ *random-generator*
+ 'graph-container
+ 100
+ #2A((0.1111111111111111 0.2222222222222222)
+ (0.2222222222222222 0.4444444444444444))
+ #+No
+ #2A((0.011840772766222637 0.04524421593830334)
+ (0.04524421593830334 0.8976707953571706))
+ '(3 3)
+ (list
+ (make-degree-sampler
+ (lambda (i)
+ (poisson-vertex-degree-distribution 3 i))
+ :generator *random-generator*)
+ (make-degree-sampler
+ (lambda (i)
+ (poisson-vertex-degree-distribution 3 i))
+ :generator *random-generator*))
+
+ (lambda (kind count)
+ (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
+
+#+Test
+(element-counts
+ (copy-tree
+ (sample-edges-for-assortative-graph
+ *random-generator*
+ 100
+ #2A((0.1111111111111111 0.2222222222222222)
+ (0.2222222222222222 0.4444444444444444))))
+ :test #'eq)
+
+;;; ---------------------------------------------------------------------------
+;;; generate-graph-by-resampling-edges
+;;; ---------------------------------------------------------------------------
+
+#|
+doesn't take edge weights into account when sampling
+
+should include pointer back to original graph
+|#
+
+(defclass* basic-edge-sampler ()
+ ((generator nil ir)
+ (graph nil ir)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod next-element ((sampler basic-edge-sampler))
+ (sample-element (graph-edges (graph sampler)) (generator sampler)))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* weighted-edge-sampler (basic-edge-sampler)
+ ((weight-so-far 0 a)
+ (index-iterator nil r)
+ (edge-iterator nil r)
+ (size nil ir)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
+ (bind ((generator (generator object))
+ (weighted-edge-count
+ (let ((result 0))
+ (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
+ result)))
+ (unless (size object)
+ (setf (slot-value object 'size) weighted-edge-count))
+ (setf (slot-value object 'index-iterator)
+ (make-iterator
+ (sort (loop repeat (size object) collect
+ (integer-random generator 1 weighted-edge-count)) #'<))
+ (slot-value object 'edge-iterator)
+ (make-iterator (graph-edges (graph object))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod next-element ((object weighted-edge-sampler))
+ (let ((edge-iterator (edge-iterator object))
+ (index-iterator (index-iterator object)))
+ (move-forward index-iterator)
+ (loop while (< (weight-so-far object) (current-element index-iterator)) do
+ (move-forward edge-iterator)
+ (incf (weight-so-far object) (weight (current-element edge-iterator))))
+ (current-element edge-iterator)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-graph-by-resampling-edges
+ (generator original-graph &key
+ (edge-sampler-class 'basic-edge-sampler)
+ (edge-count (edge-count original-graph)))
+ (let ((graph (copy-template original-graph))
+ (edge-sampler (make-instance edge-sampler-class
+ :generator generator
+ :graph original-graph
+ :size edge-count)))
+ (save-generation-information graph generator 'generate-graph-by-resampling-edges)
+
+ ;; vertexes
+ (iterate-vertexes
+ original-graph
+ (lambda (v)
+ (add-vertex graph (element v))))
+
+ ;; sample edges
+ (loop repeat edge-count do
+ (let ((edge (next-element edge-sampler)))
+ (if (directed-edge-p edge)
+ (add-edge-between-vertexes
+ graph (element (source-vertex edge)) (element (target-vertex edge))
+ :edge-type :directed
+ :if-duplicate-do (lambda (e) (incf (weight e))))
+ (add-edge-between-vertexes
+ graph (element (vertex-1 edge)) (element (vertex-2 edge))
+ :edge-type :undirected
+ :if-duplicate-do (lambda (e) (incf (weight e)))))))
+
+ graph))
+
+#+Test
+(fluid-bind (((random-seed *random-generator*) 1))
+ (let* ((dd-1 (lambda (i)
+ #+Ignore
+ (power-law-vertex-degree-distribution 3 i)
+ (poisson-vertex-degree-distribution 3 i)))
+ (dd-2 (lambda (i)
+ #+Ignore
+ (power-law-vertex-degree-distribution 3 i)
+ (poisson-vertex-degree-distribution 3 i)))
+ (g (generate-assortative-graph-with-degree-distributions
+ *random-generator*
+ (make-instance 'graph-container
+ :default-edge-type :undirected
+ :undirected-edge-class 'weighted-edge)
+ 100
+ #2A((0.011840772766222637 0.04524421593830334)
+ (0.04524421593830334 0.8976707953571706))
+ '(3 3)
+ (list
+ (make-degree-sampler
+ dd-1
+ :generator *random-generator*
+ :max-degree 40
+ :min-probability nil)
+ (make-degree-sampler
+ dd-2
+ :generator *random-generator*
+ :max-degree 40
+ :min-probability nil))
+ #'simple-group-id-generator
+ :duplicate-edge-function (lambda (e) (incf (weight e))))))
+ (flet ((avd (g)
+ (average-vertex-degree
+ g
+ :vertex-filter (lambda (v)
+ (plusp (edge-count v)))
+ :edge-size #'weight)))
+ (print (avd g))
+ (loop for i from 1 to 10
+ do
+ (fluid-bind (((random-seed *random-generator*) i))
+ (print (avd
+ (generate-graph-by-resampling-edges
+ *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
+
+;;; ---------------------------------------------------------------------------
+;;; some preferential attachment algorithms
+;;; ---------------------------------------------------------------------------
+
+#+Ignore
+(define-debugging-class generate-preferential-attachment-graph
+ (graph-generation))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-simple-preferential-attachment-graph
+ (generator graph size minimum-degree)
+ (bind ((m (make-array (list (* 2 size minimum-degree)))))
+ (loop for v from 0 to (1- size) do
+ (loop for i from 0 to (1- minimum-degree) do
+ (bind ((index (* 2 (+ i (* v minimum-degree))))
+ (r (integer-random generator 0 index)))
+ (setf (item-at m index) v
+ (item-at m (1+ index)) (item-at m r)))))
+ (loop for i from 0 to (1- (* size minimum-degree)) do
+ (add-edge-between-vertexes
+ graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
+ graph))
+
+#+Test
+(setf (ds :g-b)
+ (generate-simple-preferential-attachment-graph
+ *random-generator*
+ (make-container 'graph-container :default-edge-type :undirected)
+ 10000
+ 10))
+
+#+Test
+(element-counts
+ (collect-nodes (ds :g-b)
+ :transform (lambda (v) (list (element v) (vertex-degree v))))
+ :key #'second
+ :sort #'>
+ :sort-on :values)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-preferential-attachment-graph
+ (generator (graph-class symbol) size kind-matrix minimum-degree
+ assortativity-matrix
+ &key (vertex-labeler 'simple-group-id-generator)
+ (duplicate-edge-function :ignore))
+ (generate-preferential-attachment-graph
+ generator (make-instance graph-class)
+ size kind-matrix minimum-degree assortativity-matrix
+ :vertex-labeler vertex-labeler
+ :duplicate-edge-function duplicate-edge-function))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-preferential-attachment-graph
+ (generator (graph basic-graph) size kind-matrix minimum-degree
+ assortativity-matrix
+ &key (vertex-labeler 'simple-group-id-generator)
+ (duplicate-edge-function :ignore))
+ (bind ((kind-count (array-dimension kind-matrix 0))
+ (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
+ (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
+ (edge-recorders (make-array (list kind-count)))
+ (count-recorders (make-array (list kind-count) :initial-element 0))
+ (edge-samplers (make-array (list kind-count))))
+
+ ;; set up record keeping
+ (dotimes (i kind-count)
+ (setf (aref edge-recorders i)
+ (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
+ :initial-element nil))
+ (setf (aref edge-samplers i)
+ (make-edge-sampler-for-preferential-attachment-graph
+ generator (array-row assortativity-matrix i))))
+
+ ;; add vertexes (to ensure that we have something at which to point)
+ (loop for v from 0 to (1- size)
+ for kind in vertex-kinds do
+ (bind ((edge-recorder (aref edge-recorders kind)))
+ (loop for i from 0 to (1- minimum-degree) do
+ (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
+ (setf (item-at edge-recorder index)
+ (funcall vertex-labeler kind v)))))
+ (incf (aref count-recorders kind)))
+
+ ;; determine edges
+ (dotimes (i kind-count)
+ (setf (aref count-recorders i) 0))
+ (loop for v from 0 to (1- size)
+ for kind in vertex-kinds do
+ (bind ((edge-recorder (aref edge-recorders kind))
+ (edge-sampler (aref edge-samplers kind)))
+ (loop for i from 0 to (1- minimum-degree) do
+ (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
+ (other-kind (funcall edge-sampler))
+ (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
+ (aref count-recorders other-kind))
+ minimum-degree))))
+ (other-edge-recorder (aref edge-recorders other-kind))
+ (r (integer-random generator 0 (1- other-index))))
+ #+Ignore
+ (when-debugging-format
+ generate-preferential-attachment-graph
+ "[~2D ~6D] [~2D ~6D] (max: ~6D)"
+ kind (1+ index) other-kind r other-index)
+ (setf (item-at edge-recorder (1+ index))
+ (cond ((item-at other-edge-recorder r)
+ (item-at other-edge-recorder r))
+ ((and (= kind other-kind)
+ (= (1+ index) r))
+ ;; it's me!
+ (item-at edge-recorder index))
+ (t
+ ;; haven't done the other one yet... save it for later fixing
+ (list other-kind r))))))
+ (incf (aref count-recorders kind))))
+
+ ;; record fixups
+ (let ((corrections 0)
+ (last-corrections nil)
+ (again? t))
+ (loop while again? do
+ (setf corrections 0
+ again? nil)
+ (dotimes (kind kind-count)
+ (loop for vertex across (aref edge-recorders kind)
+ for index = 0 then (1+ index)
+ when (consp vertex) do
+ (bind (((other-kind other-index) vertex))
+ #+Ignore
+ (when-debugging-format
+ generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
+ kind index vertex
+ (aref (aref edge-recorders other-kind) other-index))
+ (incf corrections)
+ (if (and (= kind other-kind) (= index other-index))
+ ;; pointing at myself
+ (setf (aref (aref edge-recorders kind) index)
+ (aref (aref edge-recorders kind) (1- index)))
+ (let ((new (aref (aref edge-recorders other-kind) other-index)))
+ (when (consp new)
+ (setf again? t))
+ (setf (aref (aref edge-recorders kind) index) new))))))
+ (when (and last-corrections
+ (>= corrections last-corrections))
+ (error "It's not getting any better old boy"))
+ (setf last-corrections corrections)))
+
+ ;; make sure we got 'em all
+ (dotimes (i kind-count)
+ (loop for vertex across (aref edge-recorders i)
+ when (not (symbolp vertex)) do (error "bad function, down boy")))
+
+ (dotimes (i kind-count)
+ (let ((edge-recorder (aref edge-recorders i)))
+ (loop for index from 0 to (1- (size edge-recorder)) by 2 do
+ (add-edge-between-vertexes
+ graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
+ :if-duplicate-do duplicate-edge-function))))
+
+ #|
+;; record properties
+ (record-graph-properties graph)
+ (setf (get-value graph :initial-seed) (random-seed generator))
+ (setf (get-value graph :size) size
+ (get-value graph :minimum-degree) minimum-degree
+ (get-value graph :assortativity-matrix) assortativity-matrix
+ (get-value graph :duplicate-edge-function) duplicate-edge-function)
+|#
+
+ graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
+ (let ((c (make-container 'weighted-sampling-container
+ :random-number-generator generator
+ :key (lambda (item)
+ (aref assortativities item)))))
+ (dotimes (i (array-dimension assortativities 0))
+ (insert-item c i))
+ (lambda () (next-element c))))
+
+
+#+Test
+(let ((s
+ (make-edge-sampler-for-preferential-attachment-graph
+ *random-generator* #(0.02 0.25 0.25))))
+ (loop repeat 100 collect (funcall s)))
+
+#+Test
+(progn
+ (setf (random-seed *random-generator*) 2)
+ (generate-preferential-attachment-graph
+ *random-generator*
+ (make-graph 'graph-container :edge-type :undirected)
+ 100
+ #(90 5 5)
+ 3
+ #2A((0.96 0.02 0.02)
+ (0.02 0.25 0.25)
+ (0.02 0.25 0.25))))
+
+#+Test
+(generate-preferential-attachment-graph
+ *random-generator*
+ (make-graph 'graph-container :edge-type :undirected)
+ 1100
+ #(1000 50 50)
+ 3
+ #2A((0.96 0.02 0.02)
+ (0.02 0.25 0.25)
+ (0.02 0.25 0.25)))
+
+#+Test
+(pro:with-profiling
+ (generate-preferential-attachment-graph
+ *random-generator*
+ (make-graph 'graph-container :edge-type :undirected)
+ 11000
+ #(10000 500 500)
+ 3
+ #2A((0.96 0.02 0.02)
+ (0.02 0.25 0.25)
+ (0.02 0.25 0.25))))
+
+;;; ---------------------------------------------------------------------------
+
+(Defmethod generate-acquaintance-network
+ (generator graph size death-probability iterations vertex-labeler
+ &key (duplicate-edge-function :ignore))
+ ;; bring the graph up to size
+ (loop for i from (size graph) to (1- size) do
+ (add-vertex graph (funcall vertex-labeler 0 i)))
+
+ (loop repeat iterations do
+ (add-acquaintance-and-maybe-kill-something
+ generator graph death-probability duplicate-edge-function))
+ (values graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-acquaintance-network-until-stable
+ (generator graph size death-probability step-count
+ stability-fn vertex-labeler
+ &key (duplicate-edge-function :ignore))
+ ;; bring the graph up to size
+ (loop for i from (size graph) to (1- size) do
+ (add-vertex graph (funcall vertex-labeler 0 i)))
+
+ (loop do
+ (loop repeat step-count do
+ (add-acquaintance-and-maybe-kill-something
+ generator graph death-probability duplicate-edge-function))
+ (when (funcall stability-fn graph)
+ (return)))
+
+ (values graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defun add-acquaintance-and-maybe-kill-something
+ (generator graph death-probability duplicate-edge-function)
+ ;; add edges step
+ (bind ((vertex (sample-element (graph-vertexes graph) generator))
+ (neighbors (when (>= (size (vertex-edges vertex)) 2)
+ (sample-unique-elements
+ (vertex-edges vertex) generator 2))))
+ (flet ((sample-other-vertex ()
+ (loop for result = (sample-element (graph-vertexes graph) generator)
+ until (not (eq vertex result))
+ finally (return result)))) ;; CTM: 'finally do' not legal in openMCL
+ (if neighbors
+ (add-edge-between-vertexes
+ graph
+ (other-vertex (first neighbors) vertex)
+ (other-vertex (second neighbors) vertex)
+ :if-duplicate-do duplicate-edge-function)
+ (add-edge-between-vertexes
+ graph vertex (sample-other-vertex)
+ :if-duplicate-do duplicate-edge-function))))
+
+ ;; remove vertexes step
+ (when (random-boolean generator death-probability)
+ (let ((vertex (sample-element (graph-vertexes graph) generator)))
+ (delete-vertex graph vertex)
+ (add-vertex graph (element vertex)))))
+
+#+Test
+(generate-acquaintance-network
+ *random-generator*
+ (make-graph 'graph-container :edge-type :undirected)
+ 1000
+ 0.001
+ 10000
+ 'simple-group-id-generator)
\ No newline at end of file
--- /dev/null
+
+;;; ---------------------------------------------------------------------------
+;;; vertex-iterator
+;;; ---------------------------------------------------------------------------
+
+(u:defclass* vertex-iterator (containers::forward-iterator)
+ ())
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object vertex-iterator) &key)
+ (reset object))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod reset ((iterator vertex-iterator))
+ (let ((vertex (containers::initial-container iterator)))
+ (setf (slot-value iterator 'containers::iterating-container)
+ (make-iterator (edges vertex)
+ :transform (lambda (e) (other-vertex e vertex)))))
+ iterator)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod containers::base-class-for-iteratee ((container basic-vertex))
+ 'vertex-iterator)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod containers::base-class-for-iteratee ((container basic-vertex))
+ (containers::base-class-for-iteratee (vertex-edges container)))
+
+(u:add-parameter->dynamic-class :iterator :children nil )
+
+(collect-elements
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#| simple-header
+
+$Id: graph-matrix.lisp,v 1.1 2005/05/01 21:40:26 gwking Exp $
+
+Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
+University of Massachusetts Amherst MA, 01003-4610
+Professor Paul Cohen, Director
+
+Author: Gary King
+
+DISCUSSION
+
+CtF uses an adj list (vector of edges with lists) or adj matrix (vector with vectors)
+
+I think I'd like a numeric class and then a object one... maybe someday
+|#
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-matrix (basic-graph)
+ ((adjencency-matrix nil r))
+ (:default-initargs
+ :vertex-class 'graph-matrix-vertex
+ :undirected-edge-class 'graph-matrix-edge)
+ (:export-p t)
+ (:documentation "Stub for matrix based graph. Not implemented."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object graph-matrix) &key)
+ (setf (slot-value object 'adjencency-matrix)
+ nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-vertex-container ((graph graph-matrix) initial-size)
+ (make-container 'vector-container :initial-size initial-size
+ :fill-pointer 0))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-edge-container ((graph graph-matrix) initial-size)
+ (make-container 'vector-container :initial-size initial-size
+ :fill-pointer 0))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-matrix-edge (basic-edge)
+ ()
+ #+COPYING :copy-slots
+ (:export-p t)
+ (:documentation "Stub for matrix based graph. Not implemented."))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* graph-matrix-vertex (basic-vertex)
+ ()
+ (:export-p t)
+ (:documentation "Stub for matrix based graph. Not implemented."))
+
+;;; ---------------------------------------------------------------------------
+
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#| simple-header
+
+$Id: graph-metrics.lisp,v 1.9 2005/08/09 01:56:47 gwking Exp $
+
+Author: Gary King
+
+DISCUSSION
+
+|#
+(in-package metabang.graph)
+
+
+(defun vertex-degree-counts (g)
+ "Returns an associative-container mapping edge-counts to the number of vertexes with that edge-count."
+ (let ((c (make-container 'associative-container :initial-element 0)))
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (incf (item-at c (edge-count v)))))
+ c))
+
+;;; ---------------------------------------------------------------------------
+
+(defun average-vertex-degree (graph &key
+ (vertex-filter (constantly t))
+ (edge-filter (constantly t))
+ (edge-size (constantly 1)))
+ "Returns the average degree of the all of the vertexes in `graph` that pass the `vertex-filter`. Both `vertex-filter` and `edge-filter` are predicates; `edge-size` is a function that maps edges to their weight. Compare with `vertex-degree`."
+ (let ((total 0)
+ (size 0))
+ (iterate-container
+ graph
+ (lambda (v)
+ (when (funcall vertex-filter v)
+ (incf size)
+ (incf total (%vertex-degree v edge-filter edge-size)))))
+ (if size
+ (values (float (/ total size)))
+ nil)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun vertex-degree (vertex &key
+ (edge-filter (constantly t))
+ (edge-size (constantly 1)))
+ "Returns the degree of `vertex`. The degree is computed by totaling the `edge-size` \(e.g., the `weight`\) of each edge attached to vertex that passes `edge-filter`. `Edge-filter is a predicate and `edge-size` should map edges to their weights."
+ (declare (inline %vertex-degree))
+ (%vertex-degree vertex edge-filter edge-size))
+
+;;; ---------------------------------------------------------------------------
+
+(defun %vertex-degree (vertex edge-filter edge-size)
+ "Called internally by `vertex-degree` and `average-vertex-degree`."
+ (let ((degree 0))
+ (iterate-edges
+ vertex
+ (lambda (e)
+ (when (funcall edge-filter e (other-vertex e vertex))
+ (incf degree (funcall edge-size e)))))
+ degree))
+
+;;; ---------------------------------------------------------------------------
+
+(defun vertex-degree-summary (graph vertex-classifier
+ &key (edge-size (constantly 1)))
+ "Prints a summary of vertex degrees in `graph` to standard-out. Both the average degree of all vertexes and the average degree between all pairs of vertex classes \(as determined by the vertex-classifier\) will be printed. The `edge-size` parameter is passed on to `vertex-degree` to allow for weighted edges."
+
+ (bind ((counts (node-counts graph :key vertex-classifier))
+ (kinds (collect-elements counts :transform #'first)))
+ (format t "~%Vertex counts: ")
+ (loop for (kind count) in counts do
+ (format t "~A = ~A; " kind count))
+ (flet ((show-avd (vertex-filter edge-filter message &rest args)
+ (terpri)
+ (apply #'format t message args)
+ (format t "~7,2F"
+ (average-vertex-degree
+ graph
+ :vertex-filter (or vertex-filter (constantly t))
+ :edge-filter (or edge-filter (constantly t))
+ :edge-size edge-size))))
+ (show-avd nil nil "Average vertex degree:")
+ (loop for kind in kinds do
+ (show-avd (lambda (v) (equal kind (funcall vertex-classifier v))) nil
+ "Average vertex degree for ~A:" kind))
+ (dolist (k-1 kinds)
+ (dolist (k-2 kinds)
+ (show-avd
+ (lambda (v) (equal (funcall vertex-classifier v) k-1))
+ (lambda (e v)
+ (declare (ignore e))
+ (equal (funcall vertex-classifier v) k-2))
+ "Average vertex degree between ~A and ~A:"
+ k-1 k-2))))))
+
+;;; ---------------------------------------------------------------------------
+
+#|
+Transitivity or Clustering.
+the friend of your friend is likely also to be your friend.
+
+C = 3 x number of triangles in the network /
+ number of connected triples of vertices
+
+or
+
+C = 6 x number of triangles in the network /
+ number of paths of length two
+
+C measures the fraction of triples that have their third edge *filled in
+to complete the triangle.
+
+The definition of C given here has been widely used in the sociology literature,
+where it is referred to as the fraction of transitive triples.
+
+An alternative definition of the clustering coefficient, also widely used, has been given by Watts and Strogatz [415], who proposed de*ning a local value
+
+Ci = number of triangles connected to vertex i /
+ number of triples centered on vertex i
+
+For vertices with degree 0 or 1, for which both numerator and denominator are zero,
+we put Ci = 0.
+
+C = Sum( Ci ) / n
+
+It tends to weight the contributions of
+low-degree vertices more heavily, because such vertices have a small denominator in (3.5) and hence can give quite di*erent results from (3.3).
+
+The local clustering Ci above has been used quite widely in its own right in
+the sociological literature, where it is referred to as the network density
+|#
+
+(defun average-vertex-clustering-coefficient (graph)
+ "Returns the average `vertex-clustering-coefficient` of all the vertexes in the graph."
+ (/
+ (let ((total 0.0))
+ (iterate-vertexes
+ graph (lambda (v) (incf total (vertex-clustering-coefficient v))))
+ total)
+ (size graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun vertex-clustering-coefficient (vertex)
+ "The vertex-clustering-coefficient is, informally, a measure of the number of triangles in which a vertex participates as compared to the maximum possible number of triangles in which it could participate. It measures how likely it is that any two neighbors of the vertex are also joined by an edge."
+ (if (< (edge-count vertex) 2)
+ 0.0
+ (float (/ (vertex-triangle-count vertex)
+ (combination-count (edge-count vertex) 2)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun vertex-triangle-count (vertex)
+ (let ((neighbors (neighbor-vertexes vertex)))
+ (loop for neighbor in neighbors sum
+ (/ (count-if (lambda (v)
+ (member v neighbors))
+ (neighbor-vertexes neighbor)) 2))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun row-sums (matrix)
+ (let* ((row-count (array-dimension matrix 1))
+ (result (make-array row-count :initial-element 0d0)))
+ (dotimes (row row-count)
+ (dotimes (column (array-dimension matrix 0))
+ (incf (aref result row) (aref matrix column row))))
+ result))
+
+;;; ---------------------------------------------------------------------------
+
+(defun column-sums (matrix)
+ (let* ((column-count (array-dimension matrix 0))
+ (result (make-array column-count :initial-element 0d0)))
+ (dotimes (column column-count)
+ (dotimes (row (array-dimension matrix 1))
+ (incf (aref result column) (aref matrix column row))))
+ result))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod assortativity-coefficient ((matrix array))
+
+ (let* ((matrix (normalize-matrix matrix))
+ (sum-squared (sum-of-array-elements (matrix-multiply matrix matrix)))
+ (trace (matrix-trace matrix)))
+ (if (= trace 1d0)
+ (values 1)
+ (values (/ (- trace sum-squared) (- 1 sum-squared))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph-edge-mixture-matrix ((graph basic-graph) vertex-classifier &key
+ (edge-weight (constantly 1)))
+ (let* ((vertex-types (remove-duplicates
+ (collect-items graph :transform vertex-classifier)))
+ (size (size vertex-types))
+ (matrix (make-array (list size size) :initial-element 0d0)))
+ (iterate-edges
+ graph
+ (lambda (e)
+ (let* ((vertex-class-1 (funcall vertex-classifier (vertex-1 e)))
+ (vertex-class-2 (funcall vertex-classifier (vertex-2 e)))
+ (index-1 (position vertex-class-1 vertex-types))
+ (index-2 (position vertex-class-2 vertex-types))
+ (weight (funcall edge-weight e)))
+ (incf (aref matrix index-1 index-2) weight)
+ (incf (aref matrix index-2 index-1) weight))))
+ (values
+ (matrix-multiply matrix (/ (sum-of-array-elements matrix)))
+ vertex-types)))
+
+#+Test
+(assortativity-coefficient
+ #2A((0.258 0.016 0.035 0.013)
+ (0.012 0.157 0.058 0.019)
+ (0.013 0.023 0.306 0.035)
+ (0.005 0.007 0.024 0.016)))
+
+;;; ---------------------------------------------------------------------------
+
+;;OPT we call the classifier a lot, probably better to make a new ht for that
+
+(defmethod graph-mixing-matrix ((graph basic-graph) vertex-classifier &key
+ (edge-weight (constantly 1)))
+ (declare (ignore edge-weight))
+ (let* ((vertex-types (remove-duplicates
+ (collect-items graph :transform vertex-classifier)))
+ (size (size vertex-types))
+ (matrix (make-array (list size size) :initial-element 0d0))
+ (class-sizes (make-container 'simple-associative-container
+ :initial-element 0
+ :test #'eq))
+ (class-indexes (make-container 'simple-associative-container
+ :initial-element nil
+ :test #'eq)))
+ (block determine-class-indexes
+ (let ((n -1))
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (let ((vertex-class (funcall vertex-classifier v)))
+ (unless (item-at-1 class-indexes vertex-class)
+ (setf (item-at-1 class-indexes vertex-class) (incf n))
+ (when (= n (1- size))
+ (return-from determine-class-indexes nil))))))))
+
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (incf (item-at-1 class-sizes (funcall vertex-classifier v)))))
+
+ (iterate-vertexes
+ graph
+ (lambda (v-1)
+ (let ((index-1 (item-at-1 class-indexes (funcall vertex-classifier v-1))))
+ (iterate-neighbors
+ v-1
+ (lambda (v-2)
+ (let ((index-2 (item-at-1 class-indexes (funcall vertex-classifier v-2))))
+ (incf (item-at matrix index-1 index-2))))))))
+
+ #+Ignore
+ (iterate-key-value
+ class-indexes
+ (lambda (class-1 index-1)
+ (iterate-key-value
+ class-indexes
+ (lambda (class-2 index-2)
+ (setf (item-at matrix index-1 index-2)
+ (/ (item-at matrix index-1 index-2)
+ (if (= index-1 index-2)
+ (* 2 (combination-count (item-at-1 class-sizes class-1) 2))
+ (combination-count (+ (item-at-1 class-sizes class-1)
+ (item-at-1 class-sizes class-2))
+ 2))))))))
+
+ (values matrix (collect-key-value class-indexes)
+ (collect-key-value class-sizes))))
+
+#+Test
+;; this computes the same matrix but is probably slower and more consy
+(time
+ (let ((vertex-classes
+ (merge-nodes
+ (adma::ds :g-5000)
+ (lambda (old new)
+ (push new old))
+ (lambda (first)
+ (list first))
+ :key (lambda (v) (aref (symbol-name (element v)) 0)))))
+ (loop for (class vertexes) in vertex-classes collect
+ (list class
+ (element-counts
+ (loop for vertex in vertexes append
+ (neighbor-vertexes vertex))
+ :key (lambda (v) (aref (symbol-name (element v)) 0)))))))
+
+#+Old
+(defmethod graph-mixing-matrix ((graph basic-graph) vertex-classifier &key
+ (edge-weight (constantly 1)))
+ (let* ((vertex-types (remove-duplicates
+ (collect-items graph :transform vertex-classifier)))
+ (size (size vertex-types))
+ (matrix (make-array (list size size) :initial-element 0d0))
+ (class-sizes (make-container 'simple-associative-container
+ :initial-element 0
+ :test #'eq))
+ (class-indexes (make-container 'simple-associative-container
+ :initial-element nil
+ :test #'eq)))
+ (block determine-class-indexes
+ (let ((n -1))
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (let ((vertex-class (funcall vertex-classifier v)))
+ (unless (item-at-1 class-indexes vertex-class)
+ (setf (item-at-1 class-indexes vertex-class) (incf n))
+ (when (= n (1- size))
+ (return-from determine-class-indexes nil))))))))
+
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (incf (item-at-1 class-sizes
+ (item-at-1 class-indexes (funcall vertex-classifier v))))))
+
+ (iterate-vertexes
+ graph
+ (lambda (v-1)
+ (let ((index-1 (item-at-1 class-indexes (funcall vertex-classifier v-1))))
+ (iterate-neighbors
+ v-1
+ (lambda (v-2)
+ (let ((index-2 (item-at-1 class-indexes (funcall vertex-classifier v-2))))
+ ; (when (= index-1 1 index-2)
+ ; (break))
+ ; (when (< index-2 index-1)
+ ; (rotatef index-1 index-2))
+ (unless (< index-2 index-1)
+ (incf (item-at matrix index-1 index-2)))))))))
+
+ (iterate-key-value
+ class-indexes
+ (lambda (class-1 index-1)
+ (iterate-key-value
+ class-indexes
+ (lambda (class-2 index-2)
+ (when (<= index-1 index-2)
+ (setf (item-at matrix index-1 index-2)
+ (/ (item-at matrix index-1 index-2)
+ (if (= index-1 index-2)
+ (* 2 (combination-count (item-at-1 class-sizes class-1) 2))
+ (/ (combination-count (+ (item-at-1 class-sizes class-1)
+ (item-at-1 class-sizes class-2))
+ 2) 2)))))))))
+
+ (values matrix (collect-key-value class-indexes))))
+
+
+
+
+
+
+
\ No newline at end of file
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#|
+$Id: graph.lisp,v 1.30 2005/09/07 16:17:06 gwking Exp $
+
+Author: Gary W. King, et. al.
+
+|#
+
+#| NOTES
+
+something is putting something on the vertexes plist's
+
+|#
+
+
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;;; classes
+;;; ---------------------------------------------------------------------------
+
+(defcondition graph-error (error)
+ ((graph nil ir))
+ (:export-p t)
+ (:export-slots-p t)
+ (:documentation "This is the root condition for errors that occur while running code in CL-Graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defcondition edge-error (graph-error)
+ ((edge nil ir "The `edge` that is implicated in the condition."))
+ (:export-p t)
+ (:export-slots-p t)
+ (:documentation "This is the root condition for graph errors that have to do with edges."))
+
+;;; ---------------------------------------------------------------------------
+
+(defcondition graph-vertex-not-found-error (graph-error)
+ ((vertex nil ir "The vertex or value that could not be found in the graph."))
+ (:report (lambda (c s)
+ (format s "Vertex ~S not found in ~A" (vertex c) (graph c))))
+ (:export-p t)
+ (:export-slots-p t)
+ (:documentation "This condition is signaled when a vertex can not be found in a graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defcondition graph-vertex-not-found-in-edge-error (edge-error)
+ ((vertex nil ir))
+ (:report (lambda (c s)
+ (format s "Vertex ~S not found in ~A" (vertex c) (edge c))))
+ (:export-p t)
+ (:documentation "This condition is signaled when a vertex can not be found in an edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defcondition graph-edge-not-found-error (graph-error)
+ ((vertex-1 nil ir "One of the vertexes for which no connecting edge could be found.")
+ (vertex-2 nil ir "One of the vertexes for which no connecting edge could be found."))
+ (:report (lambda (c s)
+ (format s "Edge between ~S and ~S not found in ~A"
+ (vertex-1 c) (vertex-2 c) (graph c))))
+ (:export-p t)
+ (:export-slots-p t)
+ (:documentation "This condition is signaled when an edge cannot be found in a graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* basic-vertex (container-node-mixin)
+ ((depth-level 0 ia :type number "`Depth-level` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
+ (vertex-id 0 ir "`Vertex-id` is used internally to keep track of vertexes.")
+ (element :unbound ia :accessor value "The `element` is the value that this vertex represents.")
+ (tag nil ia "The `tag` slot is used by some algorithms to keep track of which vertexes have been visited.")
+ (graph nil ia "The graph in which this vertex is contained.")
+ (color nil ia "The `color` slot is used by some algorithms for bookkeeping.")
+ (rank nil ia "The `rank` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
+ (previous-node nil ia "`Previous-node` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
+ (next-node nil ia "`Next-node` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
+ (discovery-time -1 ia "`Discovery-time` is used by some algorithms for bookkeeping. [?? Should be in a mixin]")
+ (finish-time -1 ia "`Finish-time` is used by some algorithms for bookkeeping. [?? Should be in a mixin]"))
+ (:export-p t)
+ (:export-slots vertex-id tag rank color previous-node next-node
+ discovery-time finish-time)
+ (:make-load-form-p t)
+ (:documentation "This is the root class for all vertexes in CL-Graph."))
+
+;;; ---------------------------------------------------------------------------
+
+#+COPYING
+(defcopy-methods basic-vertex :copy-all t)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id)
+ (when (and graph (not vertex-id))
+ (setf (slot-value object 'vertex-id)
+ (largest-vertex-id graph))
+ (incf (slot-value graph 'largest-vertex-id))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod print-object ((vertex basic-vertex) stream)
+ (print-unreadable-object (vertex stream :identity nil)
+ (format stream "~A"
+ (if (and (slot-exists-p vertex 'element) (slot-boundp vertex 'element))
+ (element vertex) "#unbound#"))))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* basic-edge ()
+ ((edge-id 0 ia "The `edge-id` is used internally by CL-Graph for bookkeeping.")
+ (element nil ia :accessor value :initarg :value)
+ (tag nil ia "The `tag` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]")
+ (graph nil ir "The `graph` of which this edge is a part.")
+ (color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]"))
+ (:export-p t)
+ (:export-slots edge-id element tag color)
+ #+COPYING :copy-slots
+ (:make-load-form-p t)
+ (:documentation "This is the root class for all edges in CL-Graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object basic-edge) &key graph edge-id)
+ (when (and graph (not edge-id))
+ (setf (slot-value object 'edge-id)
+ (largest-edge-id graph))
+ (incf (slot-value graph 'largest-edge-id))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod print-object ((object basic-edge) stream)
+ (print-unreadable-object (object stream :type t)
+ (format stream "<~A ~A>" (vertex-1 object) (vertex-2 object))))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* directed-edge-mixin (#+COPYING copyable-mixin) ()
+ (:export-p t)
+ (:documentation "This mixin class is used to indicate that an edge is directed."))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* weighted-edge-mixin (#+COPYING copyable-mixin)
+ ((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
+ #+COPYING :copy-slots
+ :export-slots
+ (:export-p t)
+ (:documentation "This mixin class adds a `weight` slot to an edge."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod weight ((edge basic-edge)) (values 1.0))
+
+;;; ---------------------------------------------------------------------------
+
+(defclass* basic-graph (#+COPYING copyable-mixin)
+ ((graph-vertexes :unbound ir)
+ (graph-edges :unbound ir)
+ (largest-vertex-id 0 r)
+ (largest-edge-id 0 r)
+ (vertex-class 'basic-vertex ir
+ "The class of the vertexes in the graph.")
+ (directed-edge-class 'basic-directed-edge ir
+ "The class used to create directed edges in the graph.")
+ (undirected-edge-class 'basic-edge ir
+ "The class used to create undirected edges in the graph.")
+ (contains-directed-edge-p nil ar
+ "Returns true if graph contains at least one directed edge. [?? Not sure if this is really keep up-to-date.]")
+ (contains-undirected-edge-p nil ar
+ "Returns true if graph contains at least one undirected edge. [?? Not sure if this is really keep up-to-date.]")
+ (vertex-test #'eq ir)
+ (vertex-key #'identity ir)
+ (edge-test #'eq ir)
+ (edge-key #'identity ir)
+ (default-edge-type nil ir
+ "The default edge type for the graph. This should be one of :undirected or :directed.")
+ (default-edge-class nil ir
+ "The default edge class for the graph."))
+ (:make-load-form-p t)
+ (:export-slots vertex-class directed-edge-class undirected-edge-class
+ default-edge-type default-edge-class)
+ (:default-initargs
+ :initial-size 25)
+ (:documentation "This is the root class for all graphs in CL-Graph."))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-instance :after ((object basic-graph) &key initial-size
+ &allow-other-keys)
+ (setf (slot-value object 'graph-vertexes)
+ (make-vertex-container object initial-size))
+ (setf (slot-value object 'graph-edges)
+ (make-edge-container object initial-size)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod print-object ((graph basic-graph) stream)
+ (print-unreadable-object (graph stream :type t :identity t)
+ (format stream "~A" (size graph))))
+
+
+;;; ---------------------------------------------------------------------------
+;;; internals
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-vertex ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
+ (declare (ignore if-duplicate-do))
+ (values value))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-vertex-for-graph ((graph basic-graph) &rest args &key
+ (vertex-class (vertex-class graph))
+ &allow-other-keys)
+ (remf args :vertex-class)
+ (assert (subtypep vertex-class (vertex-class graph)) nil
+ "Vertex class '~A' must be a subtype of ~A" vertex-class (vertex-class graph))
+ (apply #'make-instance vertex-class :graph graph args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-edge-for-graph ((graph basic-graph)
+ (vertex-1 basic-vertex) (vertex-2 basic-vertex)
+ &rest args &key
+ (edge-type (default-edge-type graph))
+ (edge-class (default-edge-class graph))
+ &allow-other-keys)
+ (remf args :edge-class)
+ (remf args :edge-type)
+
+ #| I removed 'em, gwk
+
+ ;;; I added these - jjm
+ (remf args :vertex-test)
+ (remf args :vertex-key)
+ (remf args :edge-key)
+ (remf args :edge-test)
+ (remf args :force-new?)
+
+|#
+
+ (assert (or (null edge-type)
+ (eq edge-type :directed)
+ (eq edge-type :undirected)) nil
+ "Edge-type must be nil, :directed or :undirected.")
+
+ (assert (or (null edge-class)
+ (subtypep edge-class (directed-edge-class graph))
+ (subtypep edge-class (undirected-edge-class graph))) nil
+ "Edge-class must be nil or a subtype of ~A or ~A"
+ (undirected-edge-class graph)
+ (directed-edge-class graph))
+
+ (apply #'make-instance
+ (or edge-class
+ (ecase edge-type
+ (:directed (directed-edge-class graph))
+ (:undirected (undirected-edge-class graph))
+ ((nil) nil))
+ (undirected-edge-class graph))
+ :graph graph
+ :vertex-1 vertex-1 :vertex-2 vertex-2 args))
+
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
+ (apply #'make-instance graph-type args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-graph ((classes list) &rest args)
+ (let ((name (find-or-create-class 'basic-graph classes)))
+ (apply #'make-instance name args)))
+
+;;; ---------------------------------------------------------------------------
+;;; generic implementation
+;;; ---------------------------------------------------------------------------
+
+(defmethod undirected-edge-p ((edge basic-edge))
+ (not (directed-edge-p edge)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod directed-edge-p ((edge basic-edge))
+ (typep edge 'directed-edge-mixin))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod tagged-edge-p ((edge basic-edge))
+ (tag edge))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod untagged-edge-p ((edge basic-edge))
+ (null (tag edge)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod tag-all-edges ((graph basic-graph))
+ (iterate-edges
+ graph
+ (lambda (e)
+ (setf (tag e) t))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod tag-all-edges ((vertex basic-vertex))
+ (iterate-edges
+ vertex
+ (lambda (e)
+ (setf (tag e) t))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod untag-all-edges ((graph basic-graph))
+ (iterate-edges
+ graph
+ (lambda (e)
+ (setf (tag e) nil))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod untag-all-edges ((vertex basic-vertex))
+ (iterate-edges
+ vertex
+ (lambda (e)
+ (setf (tag e) nil))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod untag-edges ((edges list))
+ (iterate-nodes
+ edges
+ (lambda (e)
+ (setf (tag e) nil))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod tag-edges ((edges list))
+ (iterate-nodes
+ edges
+ (lambda (e)
+ (setf (tag e) t))))
+
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod (setf element) :around ((value t) (vertex basic-vertex))
+ (with-changing-vertex (vertex)
+ (call-next-method)))
+
+;;; ---------------------------------------------------------------------------
+
+;; :ignore, :force, :replace, <function>
+
+(defmethod add-vertex ((graph basic-graph) (value t) &rest args &key
+ (if-duplicate-do :ignore) &allow-other-keys)
+ (remf args :if-duplicate-do)
+ (let ((existing-vertex (find-vertex graph value nil)))
+ (labels ((make-it ()
+ (apply #'make-vertex-for-graph graph :element value args))
+ (add-it (why)
+ (values (add-vertex graph (make-it)) why)))
+ (if existing-vertex
+ (cond ((eq if-duplicate-do :ignore)
+ (values existing-vertex :ignore))
+
+ ((eq if-duplicate-do :force)
+ (add-it :force))
+
+ ((eq if-duplicate-do :replace)
+ (replace-vertex graph existing-vertex (make-it)))
+
+ ((eq if-duplicate-do :replace-value)
+ (setf (element existing-vertex) value)
+ (values existing-vertex :replace-value))
+
+ (t
+ (values (funcall if-duplicate-do existing-vertex)
+ :duplicate)))
+
+ ;; not found, add
+ (add-it :new)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod replace-vertex ((graph basic-graph) (old basic-vertex) (new basic-vertex))
+ ;; we need the graph and the new vertex to reference each other
+ ;; we need every edge of the old vertex to use the new-vertex
+ ;; we need to remove the old vertex
+ ;;
+ ;; since I'm tired today, let's ignore trying to make this elegant
+
+ ;; first, we connect the edges to the new vertex so that they don't get deleted
+ ;; when we delete the old vertex
+ (iterate-edges
+ old
+ (lambda (e)
+ (if (eq (vertex-1 e) old)
+ (setf (slot-value e 'vertex-1) new) (setf (slot-value e 'vertex-2) new))
+ (add-edge-to-vertex e new)))
+
+ (delete-vertex graph old)
+ (add-vertex graph new))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
+ &rest args &key (if-duplicate-do :ignore)
+ &allow-other-keys)
+ (declare (ignore if-duplicate-do)
+ (dynamic-extent args))
+ (let ((v1 (or (find-vertex graph value-1 nil)
+ (add-vertex graph value-1 :if-duplicate-do :ignore)))
+ (v2 (or (find-vertex graph value-2 nil)
+ (add-vertex graph value-2 :if-duplicate-do :replace))))
+ (apply #'add-edge-between-vertexes graph v1 v2 args)))
+
+;;; ---------------------------------------------------------------------------
+;;; to-do - add-edge-between-vertexes needs to be able to grab the weight and
+;;; color from edges that inherit from weight and color mixins
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge-between-vertexes ((graph basic-graph)
+ (v-1 basic-vertex) (v-2 basic-vertex)
+ &rest args &key
+ (value nil) (if-duplicate-do :ignore)
+ &allow-other-keys)
+ (declare (dynamic-extent args))
+ (remf args :if-duplicate-do)
+
+ (let ((edge (find-edge-between-vertexes graph v-1 v-2 :error-if-not-found? nil)))
+ (flet ((add-it (why)
+ (values (add-edge
+ graph
+ (apply #'make-edge-for-graph graph v-1 v-2 args))
+ why)))
+ (if edge
+ (cond
+ ((eq if-duplicate-do :ignore)
+ (values edge :ignore))
+
+ ((eq if-duplicate-do :force)
+ (add-it :force))
+
+ ((eq if-duplicate-do :force-if-different-value)
+ (if (equal (value edge) value)
+ (values :ignore)
+ (add-it :force)))
+
+
+ ((eq if-duplicate-do :replace)
+ (warn "replace edges isn't really implemented, maybe you can use :replace-value")
+ (delete-edge graph edge)
+ (add-it :replace))
+
+ ((eq if-duplicate-do :replace-value)
+ (setf (element edge) value)
+ (values edge :replace-value))
+
+ (t
+ (setf edge (funcall if-duplicate-do edge))
+ (values edge :duplicate)))
+
+ ;; not found, add
+ (add-it :new)))))
+
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge-to-vertex ((edge basic-edge) (vertex basic-vertex))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
+ &key (error-if-not-found? t))
+ (let ((v1 (find-vertex graph value-1 error-if-not-found?))
+ (v2 (find-vertex graph value-2 error-if-not-found?)))
+ (aif (and v1 v2 (find-edge-between-vertexes graph v1 v2))
+ it
+ (when error-if-not-found?
+ (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-edge-between-vertexes ((graph basic-graph)
+ (value-or-vertex-1 t)
+ (value-or-vertex-2 t) &rest args)
+ (let ((edge (apply #'find-edge-between-vertexes
+ graph value-or-vertex-1 value-or-vertex-2 args)))
+ (when edge
+ (delete-edge graph edge))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-edge :after ((graph basic-graph) (edge basic-edge))
+ (delete-item (graph-edges graph) edge)
+ edge)
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-vertex ((graph basic-graph) value-or-vertex)
+ (delete-vertex graph (find-vertex graph value-or-vertex)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-vertex ((graph basic-graph) (vertex basic-vertex))
+ (unless (eq graph (graph vertex))
+ (error 'graph-vertex-not-found-error
+ :graph graph :vertex vertex))
+
+ (iterate-edges
+ vertex
+ (lambda (edge)
+ (delete-edge graph edge)))
+
+ (empty! (vertex-edges vertex))
+ (values vertex graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod delete-vertex :after ((graph basic-graph)
+ (vertex basic-vertex))
+ (setf (slot-value vertex 'graph) nil)
+ (delete-item-at (graph-vertexes graph)
+ (funcall (vertex-key graph) (element vertex))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod insert-item ((graph basic-graph) value)
+ (add-vertex graph value))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod source-edges ((vertex basic-vertex) &optional filter)
+ (collect-using #'iterate-source-edges filter vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod target-edges ((vertex basic-vertex) &optional filter)
+ (collect-using #'iterate-target-edges filter vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod child-vertexes (vertex &optional filter)
+ (collect-using #'iterate-children filter vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod parent-vertexes (vertex &optional filter)
+ (collect-using #'iterate-parents filter vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod neighbor-vertexes (vertex &optional filter)
+ (collect-using #'iterate-neighbors filter vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod adjacentp ((graph basic-graph) vertex-1 vertex-2)
+ (adjacentp graph (find-vertex graph vertex-1) (find-vertex graph vertex-2)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod adjacentp ((graph basic-graph) (vertex-1 basic-vertex) (vertex-2 basic-vertex))
+ (iterate-neighbors
+ vertex-1
+ (lambda (vertex)
+ (when (eq vertex vertex-2)
+ (return-from adjacentp t))))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod number-of-neighbors (vertex)
+ (count-using #'iterate-neighbors nil vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod in-cycle-p ((graph basic-graph) (vertex t))
+ (in-cycle-p graph (find-vertex graph vertex)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod renumber-vertexes ((graph basic-graph))
+ (let ((count 0))
+ (iterate-vertexes graph (lambda (vertex)
+ (setf (slot-value vertex 'vertex-id) count)
+ (incf count)))
+ (setf (slot-value graph 'largest-vertex-id) count)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod renumber-edges ((graph basic-graph))
+ (let ((count 0))
+ (iterate-edges graph (lambda (vertex)
+ (setf (slot-value vertex 'edge-id) count)
+ (incf count)))
+ (setf (slot-value graph 'largest-edge-id) count)))
+
+;;; ---------------------------------------------------------------------------
+
+(deprecated
+ (defmethod container->list ((graph basic-graph))
+ (collect-elements (graph-vertexes graph))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-vertex :before ((graph basic-graph) (vertex basic-vertex)
+ &key &allow-other-keys)
+
+ (assert (typep vertex (vertex-class graph)))
+ (setf (item-at (graph-vertexes graph)
+ (funcall (vertex-key graph) (element vertex))) vertex
+ (slot-value vertex 'graph) graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod add-edge :before ((graph basic-graph) (edge basic-edge) &key force-new?)
+ (declare (ignore force-new?))
+ (insert-item (graph-edges graph) edge)
+ (setf (slot-value edge 'graph) graph)
+ (if (subtypep (class-name (class-of edge)) 'directed-edge-mixin)
+ (progn (setf (contains-directed-edge-p graph) t))
+ (progn (setf (contains-undirected-edge-p graph) t))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-vertex ((graph basic-graph) (value t)
+ &optional (error-if-not-found? t))
+ (aif (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
+ it
+ (when error-if-not-found?
+ (error 'graph-vertex-not-found-error :vertex value :graph graph))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-vertex ((edge basic-edge) (value t)
+ &optional (error-if-not-found? t))
+ (iterate-vertexes
+ edge
+ (lambda (vertex)
+ (when (funcall (vertex-test (graph edge))
+ (funcall (vertex-key (graph edge)) (element vertex)) value)
+ (return-from find-vertex vertex))))
+ (when error-if-not-found?
+ (error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod search-for-vertex ((graph basic-graph) (value t)
+ &key (key (vertex-key graph)) (test 'equal)
+ (error-if-not-found? t))
+ (aif (search-for-node graph value :test test :key key)
+ it
+ (when error-if-not-found?
+ (error "~S not found in ~A using key ~S and test ~S" value graph key
+ test))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
+ &key (key (vertex-key graph)) (test 'equal)
+ (error-if-not-found? t))
+ (aif (search-for-node (graph-vertexes graph) vertex :test test :key key)
+ it
+ (when error-if-not-found?
+ (error "~A not found in ~A" vertex graph))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod search-for-vertex ((graph basic-graph) (vertex t)
+ &key (key (vertex-key graph)) (test 'equal)
+ (error-if-not-found? t))
+ (aif (search-for-element (graph-vertexes graph) vertex :test test :key key)
+ it
+ (when error-if-not-found?
+ (error "~A not found in ~A" vertex graph))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-elements ((graph basic-graph) fn)
+ (iterate-elements (graph-vertexes graph)
+ (lambda (vertex) (funcall fn (element vertex)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-nodes ((graph basic-graph) fn)
+ (iterate-nodes (graph-vertexes graph) fn))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-vertexes ((graph basic-graph) fn)
+ (iterate-nodes (graph-vertexes graph) fn))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod iterate-vertexes ((edge basic-edge) fn)
+ (funcall fn (vertex-1 edge))
+ (funcall fn (vertex-2 edge)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod size ((graph basic-graph))
+ (size (graph-vertexes graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edges ((graph basic-graph))
+ (collect-using #'iterate-edges nil graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edges ((vertex basic-vertex))
+ (collect-using #'iterate-edges nil vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(deprecated
+ "Use size instead"
+ (defmethod vertex-count ((graph basic-graph))
+ (size graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod vertexes ((graph basic-graph))
+ (collect-elements (graph-vertexes graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod source-edge-count ((vertex basic-vertex))
+ (count-using 'iterate-source-edges nil vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod target-edge-count ((vertex basic-vertex))
+ (count-using 'iterate-target-edges nil vertex))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph-roots ((graph basic-graph))
+ (collect-elements (graph-vertexes graph) :filter #'rootp))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod rootp ((vertex basic-vertex))
+ ;;?? this is inefficient in the same way that (zerop (length <list>)) is...
+ (zerop (source-edge-count vertex)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-vertex-if ((graph basic-graph) fn &key key)
+ (iterate-vertexes graph
+ (lambda (v)
+ (when (funcall fn (if key (funcall key v) v))
+ (return-from find-vertex-if v))))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-vertex-if ((edge basic-edge) fn &key key)
+ (iterate-vertexes edge
+ (lambda (v)
+ (when (funcall fn (if key (funcall key v) v))
+ (return-from find-vertex-if v))))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edge-if ((graph basic-graph) fn &key key)
+ (iterate-edges graph
+ (lambda (e)
+ (when (funcall fn (if key (funcall key e) e))
+ (return-from find-edge-if e))))
+ (values nil))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-edges-if ((graph basic-graph) fn)
+ (collect-using 'iterate-edges fn graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod find-vertexes-if ((graph basic-graph) fn)
+ (collect-using 'iterate-vertexes fn graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod empty! ((graph basic-graph))
+ (empty! (graph-edges graph))
+ (empty! (graph-vertexes graph))
+ (renumber-edges graph)
+ (renumber-vertexes graph)
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defun neighbors-to-children (new-graph root &optional visited-list)
+ (pushnew root visited-list)
+ (iterate-neighbors
+ root
+ (lambda (c)
+ (when (not (member c visited-list))
+ (add-edge-between-vertexes
+ new-graph (value root) (value c) :edge-type :directed)
+ (neighbors-to-children new-graph c visited-list)))))
+
+;;; ---------------------------------------------------------------------------
+
+#+COPYING
+(defmethod generate-directed-free-tree ((graph basic-graph) (root basic-vertex))
+ (let ((new-graph (copy-top-level graph)))
+ (empty! new-graph)
+ (nilf (contains-undirected-edge-p new-graph))
+ (neighbors-to-children new-graph root)
+ (values new-graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod generate-directed-free-tree ((graph basic-graph) root)
+ (generate-directed-free-tree graph (find-vertex graph root)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod force-undirected ((graph basic-graph))
+ (iterate-edges
+ graph
+ (lambda (edge)
+ (change-class edge (undirected-edge-class graph)))))
+
+
+
+;;; ---------------------------------------------------------------------------
+;;; traversal
+;;; ---------------------------------------------------------------------------
+
+(defmethod traverse-elements ((thing basic-graph) (style symbol) fn)
+ (let ((marker (gensym)))
+ (iterate-vertexes
+ thing
+ (lambda (vertex)
+ (setf (tag vertex) marker)))
+
+ (iterate-elements
+ (graph-roots thing)
+ (lambda (vertex)
+ (traverse-elements-helper vertex style marker fn)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
+ (when (eq (tag thing) marker)
+ (nilf (tag thing))
+ (iterate-children
+ thing
+ (lambda (vertex)
+ (traverse-elements-helper vertex style marker fn)))
+
+ (funcall fn thing)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
+ (when (eq (tag thing) marker)
+ (nilf (tag thing))
+ (funcall fn thing))
+
+ (iterate-neighbors
+ thing
+ (lambda (vertex)
+ (when (eq (tag vertex) marker)
+ (funcall fn vertex))))
+
+ (iterate-neighbors
+ thing
+ (lambda (vertex)
+ (when (eq (tag vertex) marker)
+ (nilf (tag vertex))
+ (traverse-elements-helper vertex style marker fn)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
+ (let ((first-time? t))
+ (not (null
+ (graph-search
+ (list start-vertex)
+ (lambda (v)
+ (if first-time?
+ (nilf first-time?)
+ (eq (find-vertex graph v) start-vertex)))
+ (lambda (v)
+ (child-vertexes v))
+ #'append
+ :new-state-fn
+ (lambda (states successors state= old-states)
+ ;; Generate successor states that have not been seen before but
+ ;; don't remove the start state.
+ (remove-if
+ #'(lambda (state)
+ (and (not (eq start-vertex state))
+ (or (member state states :test state=)
+ (member state old-states :test state=))))
+ (funcall successors (first states)))))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod in-undirected-cycle-p
+ ((graph basic-graph) (current basic-vertex)
+ &optional (marked (make-container 'simple-associative-container))
+ (previous nil))
+ (block do-it
+ (tf (item-at-1 marked current))
+ (iterate-children current
+ (lambda (child)
+ (cond
+ ((eq child previous) nil)
+ ((item-at-1 marked child) (return-from do-it t))
+ (t
+ (in-undirected-cycle-p graph child marked current)))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod any-undirected-cycle-p ((graph basic-graph))
+ (let ((marked (make-container 'simple-associative-container)))
+ (iterate-vertexes graph (lambda (v)
+ (unless (item-at-1 marked v)
+ (when (in-undirected-cycle-p graph v marked)
+ (return-from any-undirected-cycle-p v)))))
+ (values nil)))
+
+;;; ---------------------------------------------------------------------------
+
+(defun remove-list (original target)
+ "Removes all elements in original from target."
+ (remove-if (lambda (target-element)
+ (member target-element original))
+ target))
+
+;;; ---------------------------------------------------------------------------
+
+(defun get-nodelist-relatives (node-list)
+ "Collects set of unique relatives of nodes in node-list."
+ (let ((unique-relatives nil))
+ (dolist (node node-list)
+ (setf unique-relatives
+ (append-unique (neighbor-vertexes node) unique-relatives)))
+ unique-relatives))
+
+;;; ---------------------------------------------------------------------------
+
+(defun get-transitive-closure (vertex-list &optional (depth nil))
+ "Given a list of vertices, returns a combined list of all of the nodes
+in the transitive closure(s) of each of the vertices in the list
+(without duplicates). Optional DEPTH limits the depth (in _both_ the
+child and parent directions) to which the closure is gathered; default
+nil gathers the entire closure(s)."
+ (labels ((collect-transitive-closure (remaining visited depth)
+ (if (and remaining
+ (typecase depth
+ (null t)
+ (fixnum (>= (decf depth) 0))))
+
+ (let* ((non-visited-relatives ;; list of relatives not yet visited
+ (remove-list visited
+ (get-nodelist-relatives remaining)))
+ (visited-nodes ;; list of nodes visited so far
+ (append-unique non-visited-relatives visited)))
+ (collect-transitive-closure non-visited-relatives
+ visited-nodes
+ depth))
+ (values visited))))
+ (collect-transitive-closure vertex-list vertex-list depth)))
+
+;;; ---------------------------------------------------------------------------
+;;; make-filtered-graph
+;;; ---------------------------------------------------------------------------
+
+(defmethod complete-links ((new-graph basic-graph)
+ (old-graph basic-graph))
+ ;; Copy links from old-graph ONLY for nodes already in new-graph
+ (iterate-vertexes
+ new-graph
+ (lambda (vertex)
+ (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
+ (iterate-edges
+ old-graph-vertex
+ (lambda (old-edge)
+ (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
+ (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
+ (when (and new-other-vertex
+ (< (vertex-id vertex) (vertex-id new-other-vertex)))
+ (let* ((new-edge (copy-template old-edge)))
+ (if (eq old-graph-vertex (vertex-1 old-edge))
+ (setf (slot-value new-edge 'vertex-1) vertex
+ (slot-value new-edge 'vertex-2) new-other-vertex)
+ (setf (slot-value new-edge 'vertex-2) vertex
+ (slot-value new-edge 'vertex-1) new-other-vertex))
+ (add-edge new-graph new-edge))))))))))
+
+#+Old
+(defmethod complete-links ((new-graph basic-graph)
+ (old-graph basic-graph))
+ ;; Copy links from old-graph ONLY for nodes already in new-graph
+ (iterate-vertexes
+ new-graph
+ (lambda (vertex)
+ (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
+ (iterate-edges
+ old-graph-vertex
+ (lambda (edge)
+ (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
+ (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
+ (edge-type (if (directed-edge-p edge)
+ :directed :undirected)))
+ (when new-other-vertex
+ (if (and (directed-edge-p edge)
+ (eq old-graph-vertex (target-vertex edge)))
+ (add-edge-between-vertexes new-graph new-other-vertex vertex
+ :value (value edge)
+ :edge-type edge-type)
+ (add-edge-between-vertexes new-graph vertex new-other-vertex
+ :value (value edge)
+ :edge-type edge-type))))))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod make-filtered-graph ((old-graph basic-graph)
+ test-fn
+ &optional
+ (graph-completion-method nil)
+ (depth nil))
+ (let ((new-graph
+ (copy-template old-graph)))
+ (ecase graph-completion-method
+ ((nil
+ :complete-links)
+ (iterate-vertexes old-graph
+ (lambda (vertex)
+ (when (funcall test-fn vertex)
+ (add-vertex new-graph (value vertex))))))
+ ((:complete-closure-nodes-only
+ :complete-closure-with-links)
+ (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
+ (closure-vertexes
+ (get-transitive-closure old-graph-vertexes depth)))
+ (dolist (vertex closure-vertexes)
+ (add-vertex new-graph (copy-template vertex))))))
+
+ (ecase graph-completion-method
+ ((nil :complete-closure-nodes-only) nil)
+ ((:complete-links
+ :complete-closure-with-links)
+ (complete-links new-graph old-graph)))
+
+ new-graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
+ &optional (depth nil))
+ (make-filtered-graph graph
+ #'(lambda (v)
+ (equal v vertex))
+ :complete-closure-with-links
+ depth))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edge-count ((graph basic-graph))
+ (length (edges graph)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edge-count ((vertex basic-vertex))
+ (size (vertex-edges vertex)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod topological-sort ((graph basic-graph))
+ (assign-level graph 0)
+ (sort (collect-elements (graph-vertexes graph)) #'<
+ :key (lambda (x) (depth-level x))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod assign-level ((graph basic-graph) (level number))
+ (loop for node in (graph-roots graph)
+ do (assign-level node 0)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod assign-level ((node basic-vertex) (level number))
+ (if (or (not (depth-level node))
+ (> level (depth-level node)))
+ (setf (depth-level node) level))
+ (iterate-children node (lambda (x) (assign-level x (1+ level)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod depth ((graph basic-graph))
+ (assign-level graph 0)
+ (let ((depth 0))
+ (iterate-vertexes graph (lambda (vertex)
+ (maxf depth (depth-level vertex))))
+ depth))
+
+;;; ---------------------------------------------------------------------------
+;;; mapping
+;;; ---------------------------------------------------------------------------
+
+(defun map-paths (graph start-vertex length fn &key (filter (constantly t)))
+ "Apply fn to each path that starts at start-vertex and is of exactly length
+length"
+ ;; a sort of depth first search
+ (labels ((follow-path (next-vertex current-path length)
+ (when (zerop length)
+ (funcall fn (reverse current-path)))
+ ; (format t "~%~A ~A ~A" current-path next-vertex length)
+ (when (plusp length)
+ (iterate-neighbors
+ next-vertex
+ (lambda (v)
+ (when (funcall filter v)
+ ;; no repeats
+ (unless (find-item current-path v)
+ (let ((new-path (copy-list current-path)))
+ (follow-path v (push v new-path) (1- length))))))))))
+ (iterate-neighbors
+ start-vertex
+ (lambda (v)
+ (when (funcall filter v)
+ (follow-path v (list v start-vertex) (1- length))))))
+ (values graph))
+
+;;; ---------------------------------------------------------------------------
+
+(defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
+ "Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
+ (bind ((visited (make-container 'simple-associative-container
+ :test #'equal)))
+ (labels ((visit (p)
+ (setf (item-at-1 visited p) t))
+ (visited-p (p)
+ (item-at-1 visited p))
+ )
+ (loop for n from 1 to (1- depth) do
+ (map-paths graph start-vertex n
+ (lambda (p)
+ (visit (first (last p))))
+ :filter filter))
+ ;(break)
+ (visit start-vertex)
+ (map-paths graph start-vertex depth
+ (lambda (p)
+ (unless (visited-p (first (last p)))
+ (funcall fn p)))
+ :filter filter))))
+
+
+;;; ---------------------------------------------------------------------------
+;;; utilities
+;;; ---------------------------------------------------------------------------
+
+(defun append-unique (list1 list2)
+ (remove-duplicates (append list1 list2)))
+
+;;; ---------------------------------------------------------------------------
+;;; project-bipartite-graph
+;;; ---------------------------------------------------------------------------
+
+(defmethod project-bipartite-graph
+ ((new-graph symbol) graph vertex-class vertex-classifier)
+ (project-bipartite-graph
+ (make-instance new-graph) graph vertex-class vertex-classifier))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod project-bipartite-graph
+ ((new-graph basic-graph) graph vertex-class vertex-classifier)
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (when (eq (funcall vertex-classifier v) vertex-class)
+ (add-vertex new-graph (element v)))))
+
+ (iterate-vertexes
+ graph
+ (lambda (v)
+ (when (eq (funcall vertex-classifier v) vertex-class)
+ (iterate-neighbors
+ v
+ (lambda (other-class-vertex)
+ (iterate-neighbors
+ other-class-vertex
+ (lambda (this-class-vertex)
+ (when (< (vertex-id v) (vertex-id this-class-vertex))
+ (add-edge-between-vertexes
+ new-graph (element v) (element this-class-vertex)
+ :if-duplicate-do (lambda (e) (incf (weight e))))))))))))
+
+ new-graph)
+
+#+Test
+(pro:with-profiling
+ (setf (ds :g-5000-m-projection)
+ (project-bipartite-graph
+ 'undirected-graph-container
+ (ds :g-5000)
+ :m
+ (lambda (v)
+ (let ((vertex-class (aref (symbol-name (element v)) 0)))
+ (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
+ :m)
+ ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
+ :h)))))))
+
+#+Test
+(pro:with-profiling
+ (setf (ds :g-5000-h-projection)
+ (project-bipartite-graph
+ 'undirected-graph-container
+ (ds :g-5000)
+ :h
+ (lambda (v)
+ (let ((vertex-class (aref (symbol-name (element v)) 0)))
+ (cond ((member vertex-class '(#\a #\b) :test #'char-equal)
+ :m)
+ ((member vertex-class '(#\x #\y #\z) :test #'char-equal)
+ :h)))))))
+
+#+Test
+(pro:with-profiling
+ (project-bipartite-graph
+ 'undirected-graph-container
+ (ds :g-1000)
+ :m
+ (lambda (v)
+ (let ((vertex-class (aref (symbol-name (element v)) 0)))
+ (cond ((member vertex-class '(#\x #\y) :test #'char-equal)
+ :m)
+ ((member vertex-class '(#\a #\b #\c) :test #'char-equal)
+ :h))))))
+
+
+
+
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+#| simple-header
+
+$Id: graphviz-support.lisp,v 1.7 2005/06/21 20:51:51 moody Exp $
+
+Copyright 1992 - 2005 Experimental Knowledge Systems Lab,
+University of Massachusetts Amherst MA, 01003-4610
+Professor Paul Cohen, Director
+
+Author: Gary King
+
+DISCUSSION
+
+A color value can be a huesaturation-
+brightness triple (three floating point numbers between 0 and 1, separated
+by commas); one of the colors names listed in Appendix G (borrowed from
+some version of the X window system); or a red-green-blue (RGB) triple4 (three
+hexadecimal number between 00 and FF, preceded by the character Õ#Õ). Thus,
+the values "orchid", "0.8396,0.4862,0.8549" and #DA70D6 are three
+ways to specify the same color.
+
+|#
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;
+; This outputs the graph to string in accordance with the DOT file format.
+; For more information about DOT file format, search the web for "DOTTY" and
+; "GRAPHVIZ".
+;
+(defmethod graph->dot ((g basic-graph) (stream stream)
+ &key
+ (graph-formatter 'graph->dot-properties)
+ (vertex-key 'vertex-id)
+ (vertex-labeler nil)
+ (vertex-formatter 'vertex->dot)
+ (edge-key nil)
+ (edge-labeler 'princ)
+ (edge-formatter 'edge->dot))
+ (format stream "~A G {~%graph " (if (contains-undirected-edge-p g) "graph" "digraph"))
+ (format stream "[")
+ (funcall graph-formatter g stream)
+ (format stream "];")
+ (terpri stream)
+
+ ;; vertex formatting
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (terpri stream)
+ (let ((key (if vertex-key (funcall vertex-key v) v)))
+ (princ key stream)
+ (princ " [" stream)
+ (when vertex-labeler
+ (princ "label=\"" stream)
+ (funcall vertex-labeler v stream)
+ (princ "\", " stream))
+ (funcall vertex-formatter v stream)
+ (princ "]" stream))))
+
+ (let ((directed-edge-connector (if (contains-undirected-edge-p g) "--" "->"))
+ (directed-edge-tag (when (and (contains-undirected-edge-p g)
+ (contains-directed-edge-p g))
+ "dir=forward, ")))
+ (flet ((format-edge (e connector from to directed?)
+ (terpri stream)
+ (princ (funcall vertex-key from) stream)
+ (princ connector stream)
+ (princ (funcall vertex-key to) stream)
+ (princ " [" stream)
+ (when (and directed? directed-edge-tag)
+ (princ directed-edge-tag stream))
+ (when edge-key
+ (princ "label=\"" stream)
+ (funcall edge-labeler e stream)
+ (princ "\"," stream))
+ (funcall edge-formatter e stream)
+ (princ "]" stream)))
+ ;; directed edges
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (iterate-target-edges
+ v
+ (lambda (e)
+ (when (directed-edge-p e)
+ (format-edge e directed-edge-connector
+ (source-vertex e) (target-vertex e) t))))))
+
+ ;; undirected edges
+ (let ((edges (make-container 'simple-associative-container)))
+ (iterate-vertexes
+ g
+ (lambda (v)
+ (iterate-edges
+ v
+ (lambda (e)
+ (when (and (undirected-edge-p e)
+ (not (item-at-1 edges e)))
+ (setf (item-at-1 edges e) t)
+ (format-edge e "--" (vertex-1 e) (vertex-2 e) nil)))))))))
+
+ (terpri stream)
+ (princ "}" stream)
+
+ (values g))
+
+
+#+Test
+(let ((g (make-container 'graph-container :default-edge-type :undirected)))
+ (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b))
+ (graph->dot g nil))
+
+#+Test
+"graph G {
+E []
+C []
+B []
+A []
+D []
+F []
+D--E []
+E--F []
+B--C []
+A--B []
+B--D []
+D--F []
+}"
+
+#+Test
+(let ((g (make-container 'graph-container :default-edge-type :directed)))
+ (loop for (a b) in '((a b) (b c) (b d) (d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b))
+ (graph->dot g nil))
+
+#+Test
+"digraph G {
+E []
+C []
+B []
+A []
+D []
+F []
+E->F []
+B->C []
+B->D []
+A->B []
+D->E []
+D->F []
+}"
+
+#+Test
+(let ((g (make-container 'graph-container)))
+ (loop for (a b) in '((d e) (e f) (d f)) do
+ (add-edge-between-vertexes g a b :edge-type :directed))
+ (loop for (a b) in '((a b) (b c) (b d)) do
+ (add-edge-between-vertexes g a b :edge-type :undirected))
+ (graph->dot g nil))
+
+#+Test
+"graph G {
+E []
+C []
+B []
+A []
+D []
+F []
+E--F [dir=forward, ]
+D--E [dir=forward, ]
+D--F [dir=forward, ]
+B--C []
+A--B []
+B--D []
+}"
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream (eql nil))
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (let ((out (make-string-output-stream)))
+ (apply #'graph->dot g out args)
+ (get-output-stream-string out)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream (eql t))
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (apply #'graph->dot g *standard-output* args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream string)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'graph->dot g out args)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot ((g basic-graph) (stream pathname)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (apply #'graph->dot g (namestring stream) args))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod graph->dot-properties ((g t) (stream t))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod vertex->dot ((v basic-vertex) (stream stream))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod edge->dot ((v basic-edge) (stream stream))
+ (values))
+
+;;; ---------------------------------------------------------------------------
+;;; dot->graph
+;;; ---------------------------------------------------------------------------
+
+#|
+(defmethod dot->graph ((dot-stream stream)
+ &key)
+ )
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dot->graph ((dot-stream string)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'dot->graph g out args)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod dot->graph ((dot-stream pathname)
+ &rest args &key &allow-other-keys)
+ (declare (dynamic-extent args))
+ (with-open-file (out stream :direction :output :if-exists :supersede)
+ (apply #'dot->graph g out args))
+ (apply #'dot->graph g (namestring stream) args))
+
+|#
\ No newline at end of file
--- /dev/null
+(in-package :COMMON-LISP-USER)
+
+;;; ---------------------------------------------------------------------------
+
+#-EKSL-GENERIC-LOAD-UTILS
+(let (#+MCL (*warn-if-redefine* nil))
+ (defun current-load-pathname ()
+ #+lucid lcl:*source-pathname*
+ #+allegro excl:*source-pathname*
+ #+(or Genera Explorer) sys:fdefine-file-pathname
+ #+MCL (if *load-truename*
+ *load-truename*
+ ;; This makes it work in a fred buffer...
+ *loading-file-source-file*)
+ #-(or lucid allegro Genera Explorer MCL)
+ *load-truename*)
+
+ ;;; ---------------------------------------------------------------------------
+
+ (setf (logical-pathname-translations "GLU")
+ (list (list "GLU:ROOT;**;*.*.*"
+ (directory-namestring
+ (make-pathname
+ :directory (append
+ (pathname-directory (current-load-pathname))
+ (list :wild-inferiors)))))))
+
+ ;;; ---------------------------------------------------------------------------
+
+ (defun eksl-load-if-exists (filespec &rest args &key (verbose t) &allow-other-keys)
+ (when (and filespec (probe-file filespec))
+ (apply #'load filespec :verbose verbose args)
+ (values t)))
+
+ ;;; ---------------------------------------------------------------------------
+
+ (defun load-sibling (name &rest args &key (verbose t) &allow-other-keys)
+ "Load the file named 'name' that lives in the same folder as THIS file."
+ (apply #'eksl-load-if-exists
+ (merge-pathnames name (current-load-pathname))
+ :verbose verbose
+ args))
+
+ ;;; ---------------------------------------------------------------------------
+
+ (defun canonical-glu-file ()
+ (let ((current-directory (and (current-load-pathname)
+ (pathname-directory (current-load-pathname)))))
+ (when current-directory
+ (make-pathname
+ :directory (append
+ (butlast current-directory 2)
+ (list "GENERIC-LOAD-UTILITIES" "DEV"))
+ :name "generic-load-utils"
+ :type "lisp"))))
+
+ ;;; ---------------------------------------------------------------------------
+
+ (defun load-in-canonical-place ()
+ (eksl-load-if-exists (canonical-glu-file)))
+
+
+ ;;; ---------------------------------------------------------------------------
+
+ (defun load-glu ()
+ "Attempt to load generic-load-utilities.lisp"
+ (or
+ ;; Try the 'canonical' one
+ (load-in-canonical-place)
+ ;; try right here
+ (load-sibling "generic-load-utils")
+ ;; give up
+ (warn "Unable to load generic-load-utilities. Please load it by hand before attempting to load or compile an EKSL load system.")))
+
+
+ ;;; ---------------------------------------------------------------------------
+ ;;; try to load generic utilities
+ ;;; ---------------------------------------------------------------------------
+
+ (load-glu))
+
+;;; ***************************************************************************
+;;; * End of File *
+;;; ***************************************************************************
\ No newline at end of file
--- /dev/null
+;;;-*- Mode: Lisp; Package: metabang.graph -*-
+
+(in-package metabang.graph)
+
+;;?? Gary King 2006-01-30:
+;;?? Face it, I have no idea why we need this anymore... but i'm sure we do
+(defmacro with-changing-vertex ((vertex) &body body)
+ "This is used to maintain consistency when changing the value of vertex elements while iterating over the vertexes..."
+ (with-variables (v g)
+ `(let* ((,v ,vertex)
+ (,g (graph ,v)))
+ (delete-item-at (graph-vertexes ,g)
+ (funcall (vertex-key ,g) (element ,v)))
+ ,@body
+ (setf (item-at (graph-vertexes ,g)
+ (funcall (vertex-key ,g) (element ,v))) ,v))))
--- /dev/null
+(in-package metabang.graph)
+
+(in-package cl-graph)
+(defun is-connected-p (g)
+ (let ((count 0))
+ (cl-graph::breadth-first-visitor g (first-item g) (lambda (v)
+ (declare (ignore v))
+ (incf count)))
+ (= count (size g))))
+
+(let ((g (make-container 'graph-container))
+ )
+ (loop for v in '(a b c d e) do
+ (add-vertex g v))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
+ (add-edge-between-vertexes g v1 v2))
+ g
+ (is-connected-p g))
+
+(let ((g (make-container 'graph-container))
+ )
+ (loop for v in '(a b c d e) do
+ (add-vertex g v))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d)) do
+ (add-edge-between-vertexes g v1 v2))
+ g
+ (is-connected-p g))
+
+
+
+#|
+searching functions
+|#
+
+#|
+nearest-common-descendent
+adjacentp
+adjacentp*
+all-next-vertexes
+all-next-vertexes*
+all-previous-vertexes
+all-previous-vertexes*
+|#
+
+add-edge doesn't use force-new? or other args
+
+I'd like to be able to (setf (edges g a b) c) or something
+
+pull id-pools from AFS to use for graph and edge id's
+
+
+;;; ---------------------------------------------------------------------------
+
+ok - do vertexes know their graph? edges their vertexes?
+ok - edges can be defined 'generically'
+ok - in-undirected-cycle-p uses loop instead of iterate-vertexes
+
--- /dev/null
+;;;-*- Mode: Lisp; Package: COMMON-LISP-USER -*-
+
+#| simple-header
+
+Author: Gary King, et. al.
+
+DISCUSSION
+
+|#
+(in-package common-lisp-user)
+
+(defpackage "CL-GRAPH"
+ (:use "COMMON-LISP" "METATILITIES" "CL-CONTAINERS"
+ "METABANG.BIND" "METABANG.MATH")
+ (:nicknames "METABANG.GRAPH")
+ (:documentation "CL-Graph is a Common Lisp library for manipulating graphs and running graph algorithms.")
+
+ (:export
+ #:with-changing-vertex
+
+ #:make-graph
+ #:basic-graph
+
+ #:add-edge-between-vertexes ; graph { value | vertex } { value | vertex }
+ #:delete-edge-between-vertexes ; graph { value | vertex } { value | vertex }
+ #:add-vertex ; graph { value | vertex }
+ #:find-vertex ; graph { value | vertex }
+ #:find-edge ; graph edge
+ #:find-edge-between-vertexes ; graph { vertex | value } { vertex | value }
+ #:find-vertex-if
+ #:find-vertexes-if
+ #:search-for-vertex
+
+ #:iterate-container ; graph fn
+ #:iterate-vertexes
+ #:vertexes
+ #:source-edges
+ #:target-edges
+ #:child-vertexes
+ #:parent-vertexes
+ #:neighbor-vertexes
+ #:other-vertex
+
+ #:edge-count ; graph
+ #:vertex-count ; graph
+ #:source-edge-count ; vertex
+ #:target-edge-count ; vertex
+
+ #:rootp ; vertex
+ #:graph-roots ; graph
+
+ #:topological-sort ; graph
+ #:depth ; graph | vertex
+ #:depth-level
+
+ #:get-transitive-closure ;; CTM
+ #:make-filtered-graph ;; CTM
+
+ #:adjacentp
+ #:in-cycle-p ; graph vertex
+ #:force-undirected
+
+ #:renumber-vertexes
+ #:renumber-edges
+
+ #:generate-directed-free-tree
+
+ #:contains-undirected-edge-p
+ #:contains-directed-edge-p
+
+ #:undirected-edge-p
+ #:directed-edge-p
+ #:tagged-edge-p
+ #:untagged-edge-p
+ #:tag-all-edges
+ #:untag-all-edges
+ #:graph->dot
+ #:vertex->dot
+ #:edge->dot
+ #:graph->dot-properties
+ #:subgraph-containing
+
+ #:connected-graph-p
+ #:find-connected-components
+ #:connected-component-count
+
+ #:target-vertex
+ #:source-vertex
+
+ #:add-edge ; graph edge
+ #:delete-edge ; graph edge
+
+ #:add-vertex ; graph { value | vertex }
+ #:delete-vertex ; graph { value | vertex }
+ #:find-vertex ; graph { value | vertex }
+ #:find-edge ; graph edge
+ #:find-edge-between-vertexes ; graph { vertex | value } { vertex | value }
+ #:find-edge-between-vertexes-if ; graph { vertex | value } { vertex | value } fn
+ #:find-edge-if ; graph
+ #:find-edges-if ; graph
+
+ #:edges ; graph | vertex
+ #:iterate-edges ; graph fn
+ #:iterate-source-edges ; vertex fn
+ #:iterate-target-edges ; vertex fn
+ #:iterate-children ; vertex (nodes) fn
+ #:iterate-parents ; vertex (nodes) fn
+ #:iterate-neighbors ; vertex (all neighbors) fn
+ #:has-children-p
+ #:has-parent-p
+ #:number-of-neighbors
+
+ #:edge-count ; graph
+ #:vertex-count ; graph
+
+ #:topological-sort ; graph
+ #:depth ; graph | vertex
+ #:depth-level
+
+ #:get-transitive-closure ;; CTM
+ #:make-filtered-graph ;; CTM
+
+ #:adjacentp
+ #:in-cycle-p ; graph vertex
+ #:in-undirected-cycle-p ; graph vertex
+ #:any-undirected-cycle-p ; graph
+ #:force-undirected
+ #:vertices-share-edge-p
+
+ #:map-paths
+ #:map-shortest-paths
+
+ ;;; depth first search
+ #:dfs-edge-type
+ #:dfs-back-edge-p
+ #:dfs-tree-edge-p
+ #:edge-lessp-by-direction
+ #:out-edge-for-vertex-p
+ #:dfs
+
+ ;;; minimum-spanning-tree
+ #+Ignore #:add-edges-to-graph
+
+ #:make-graph-from-vertexes
+ #:edge-lessp-by-weight
+ #:minimum-spanning-tree
+
+ ;;; mapping
+ #+Ignore #:map-over-all-combinations-of-k-vertexes
+ #+Ignore #:map-over-all-combinations-of-k-edges
+
+ #:project-bipartite-graph
+
+ #:make-vertex-edges-container
+
+ #:vertex-degree-counts
+ #:vertex-degree
+ #:average-vertex-degree
+ #:vertex-clustering-coefficient
+ #:average-vertex-clustering-coefficient
+
+ #:graph-mixing-matrix
+ #:graph-edge-mixture-matrix
+ #:assortativity-coefficient
+ #:vertex-degree-summary))
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+(deftestsuite test-connected-component ()
+ ())
+
+;;; ---------------------------------------------------------------------------
+
+(defun make-connected-component-graph-1 ()
+ (let ((g (make-container 'graph-container)))
+ (loop for label in '(wk-6-0 wp-5-1 wp-1-2 wp-2-3 wb-1-1
+ wp-4-4 bp-5-6 bk-6-5 bb-5-7 bp-2-4
+ bp-2-6 bp-1-5) do
+ (add-vertex g label))
+ (loop for (source target) in '((wk-6-0 wp-5-1)
+ (wp-1-2 wp-2-3)
+ (wb-1-1 wp-4-4)
+ (bp-5-6 bk-6-5)
+ (bk-6-5 bb-5-7)
+ (bb-5-7 bp-2-4)
+ (bp-2-6 bp-1-5)
+ (bp-1-5 bp-2-4)) do
+ (add-edge-between-vertexes g source target :edge-type :directed
+ :value :defend))
+ (loop for (source target) in '((bk-6-5 wp-4-4)) do
+ (add-edge-between-vertexes g source target :edge-type :directed
+ :value :attack))
+ (loop for (source target) in '((wp-2-3 bp-2-4)) do
+ (add-edge-between-vertexes g source target :edge-type :undirected))
+ g))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-connected-component)
+ test-1
+ (let ((g (make-connected-component-graph-1)))
+ (ensure-same
+ (mapcar #'size (find-connected-components g)) '(2 10) :test 'set-equal)))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-connected-component)
+ test-connected-component-count-1
+ (let ((g (make-connected-component-graph-1)))
+ (ensure-same (connected-component-count g) 2 :test '=)))
--- /dev/null
+(in-package cl-graph)
+
+(deftestsuite test-connected-components ()
+ ())
+
+(addtest (test-connected-components)
+ test-1
+ (let ((g (make-container 'graph-container :default-edge-type :undirected)))
+ (loop for v in '(a b c d e f g h i j) do (add-vertex g v))
+ (loop for (v1 v2) in '((a b) (a c) ( b c) (b d) (e f) (e g) (h i)) do
+ (add-edge-between-vertexes g v1 v2))
+
+ (let ((cc (connected-components g)))
+ (flet ((test (a b result)
+ (ensure-same (eq (representative-node cc (find-vertex g a))
+ (representative-node cc (find-vertex g b)))
+ result)))
+ (loop for (v1 v2 result) in '((a b t) (a e nil) (f g t)
+ (j c nil) (b a t) (d c t)) do
+ (test v1 v2 result))))))
+
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-minimum-spanning-tree ()
+ ())
+
+(deftestsuite test-mst-kruskal (test-minimum-spanning-tree)
+ ())
+
+(addtest (test-mst-kruskal)
+ test-1
+ (let ((g (make-container 'graph-container
+ :default-edge-type :undirected
+ :undirected-edge-class 'weighted-edge))
+ (m nil))
+ (loop for (v1 v2 w) in '((a b 4) (a h 9)
+ (b c 8) (b h 11)
+ (c i 2) (c d 7) (c f 4)
+ (d e 9) (d f 14)
+ (e f 10)
+ (f g 2)
+ (g h 1) (g i 6)
+ (h i 7)) do
+ (add-edge-between-vertexes g v1 v2 :weight w))
+ (setf m (minimum-spanning-tree-kruskal g))
+ (ensure (set-equal
+ '(a b c d e f g h i)
+ (flatten (mapcar (lambda (e)
+ (list (element (vertex-1 e)) (element (vertex-2 e))))
+ m))))
+ (ensure-same (reduce #'+ m :key 'weight) 37 :test '=)
+ (ensure-same (size m) 8)))
+
+#+Test
+(defclass* directed-weighted-edge (weighted-edge-mixin graph-container-directed-edge)
+ ())
+
+#+Test
+(let ((g (make-container 'graph-container
+ :default-edge-type :undirected
+ :undirected-edge-class 'weighted-edge
+ :directed-edge-class 'directed-weighted-edge)))
+ (loop for (v1 v2 w) in '((a b 4) (a h 9)
+ (b c 8) (b h 11)
+ (c i 2) (c d 7) (c f 4)
+ (d e 9) (d f 14)
+ (e f 10)
+ (f g 2)
+ (g h 1) (g i 6)
+ (h i 7)
+
+ (a h 3)) do
+ (add-edge-between-vertexes g v1 v2 :weight w
+ :edge-type (if (random-boolean *random-generator* 0.3)
+ :directed :undirected)))
+ (minimum-spanning-tree-kruskal g))
+
+#+Test
+(graph->dot
+ (let ((g (make-container 'graph-container
+ :default-edge-type :undirected
+ :undirected-edge-class 'weighted-edge))
+ (m nil))
+ (loop for (v1 v2 w) in '((a b 10) (a b 1) (a d 3)
+ (b c 1) (b d 3)
+ (c d 1)) do
+ (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force))
+ (setf m (minimum-spanning-tree-kruskal g))
+ g)
+ "p2dis:data;x.dot")
+
+#+Test
+(let ((g (make-container 'graph-container
+ :default-edge-type :undirected
+ :undirected-edge-class 'weighted-edge))
+ (m nil))
+ (loop for (v1 v2 w) in '((a b 1) (a d 3)
+ (b c 5) (b d 2)
+ (c d 1)) do
+ (add-edge-between-vertexes g v1 v2 :weight w :if-duplicate-do :force))
+ (setf m (minimum-spanning-tree-kruskal g))
+ m)
+
+;;; ---------------------------------------------------------------------------
+
+#+test
+(let ((graph (make-container 'graph-container)))
+ (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x)
+ (u y) (w x) (x y)) do
+ (add-edge-between-vertexes graph a b))
+
+ (breadth-first-search-graph graph 's))
+
+;;; ---------------------------------------------------------------------------
+
+(let ((graph (make-container 'graph-container)))
+ (loop for (a b) in '((r s) (r v) (s w) (t u) (t w) (t x)
+ (u y) (w x) (x y)) do
+ (add-edge-between-vertexes graph a b))
+
+ (breadth-first-visitor graph 's #'print))
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+;;; utilities
+;;; ---------------------------------------------------------------------------
+
+(defun make-simple-test-graph ()
+ (let ((g (make-container 'graph-container)))
+ (loop for v in '(a b c d e) do
+ (add-vertex g v))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
+ (add-edge-between-vertexes g v1 v2))
+ g))
+
+;;; ---------------------------------------------------------------------------
+;;; tests
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-graph-container () ())
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-graph-container)
+ test-simple-copying
+ (let ((g1 (make-simple-test-graph))
+ (g2 nil))
+ (setf g2 (copy-top-level g1))
+ (ensure-same (size g1) (size g2))
+ (iterate-vertexes
+ g1 (lambda (v)
+ (ensure (find-vertex g2 (value v)))))
+ (iterate-edges
+ g1 (lambda (e)
+ (ensure (find-edge-between-vertexes
+ g2 (value (source-vertex e))
+ (value (target-vertex e))))))))
+
+;;; ---------------------------------------------------------------------------
+
+;; fails because find-edge-between-vertexes for graph containers doesn't
+;; care about the graph...
+(addtest (test-graph-container)
+ test-find-edge-between-vertexes
+ (let ((g1 (make-simple-test-graph))
+ (g2 nil))
+ (setf g2 (copy-top-level g1))
+
+ (ensure (not
+ (find-edge-between-vertexes g2 (find-vertex g1 'a) (find-vertex g1 'b))))))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-graph-container)
+ test-empty!
+ (let ((g1 (make-simple-test-graph)))
+ (empty! g1)
+ (ensure-same (size g1) 0)))
+
+;;; ---------------------------------------------------------------------------
+;;; vertex test
+;;; ---------------------------------------------------------------------------
+
+;;?? should be in test-graph and work for every graph container type
+
+(addtest (test-graph-container)
+ no-vertex-test
+ (let ((g (make-container 'graph-container)))
+ (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
+ (add-edge-between-vertexes g (list src) (list dst)))
+ (ensure-same (size g) 14 :test '=)))
+
+(addtest (test-graph-container)
+ vertex-test
+ (let ((g (make-container 'graph-container :vertex-test #'equal)))
+ (loop for (src dst) in '((a b) (a c) (c d) (a d) (d e) (e f) (b f)) do
+ (add-edge-between-vertexes g (list src) (list dst)))
+ (ensure-same (size g) 6 :test '=)))
--- /dev/null
+(in-package metabang.graph)
+
+;;; ---------------------------------------------------------------------------
+
+(lift:deftestsuite test-vertex-triangle-count ()
+ ((g (make-container 'graph-container))))
+
+(lift:deftestsuite test-vertex-triangle-count-1 (test-vertex-triangle-count)
+ ()
+ (:setup
+ (loop for v in '(a b c d e f g h) do (add-vertex g v))
+ (loop for (s d) in '((a b) (b c) (a c) (b d) (d e) (d f) (d g) (e f) (f g) (g h)) do
+ (add-edge-between-vertexes g s d))))
+
+(lift:addtest (test-vertex-triangle-count-1)
+ (lift:ensure-same (vertex-triangle-count (find-vertex g 'a)) 1 :test '=))
+
+
+(lift:addtest (test-vertex-triangle-count-1)
+ (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 2 :test '=))
+
+(lift:addtest (test-vertex-triangle-count-1)
+ (lift:ensure-same (vertex-triangle-count (find-vertex g 'h)) 0 :test '=))
+
+(lift:deftestsuite test-vertex-triangle-count-2 (test-vertex-triangle-count)
+ ()
+ (:setup
+ (loop for v in '(a b c d e) do (add-vertex g v))
+ (loop for (s d) in '((a b) (b c) (a c) (c d) (c e)) do
+ (add-edge-between-vertexes g s d))))
+
+(lift:addtest (test-vertex-triangle-count-2)
+ (lift:ensure-same (vertex-triangle-count (find-vertex g 'c)) 1 :test '=)
+ (lift:ensure-same (vertex-triangle-count (find-vertex g 'd)) 0 :test '=))
+
+(lift:addtest (test-vertex-triangle-count-2)
+ (lift:ensure-same (average-local-clustering-coefficient g)
+ (float (/ 13 30)) :test 'samep))
\ No newline at end of file
--- /dev/null
+(in-package metabang.graph)
+
+#|
+(let ((g (make-container 'graph-container)))
+ (add-edge-between-vertexes g 'a 'b)
+ (let ((v-a (find-vertex g 'a))
+ (v-b (find-vertex g 'b)))
+ (print (compute-applicable-methods #'(SETF ELEMENT) (list :NEW-A V-A)))
+ (setf (element v-a) :new-a)
+ (inspect g)))
+|#
+
+(deftestsuite test-graph () ())
+
+
+(deftestsuite test-test-vertex () ())
+
+(addtest (test-test-vertex)
+ test-1
+ (bind ((x (float 2.1d0))
+ (y (float 2.1d0))
+ (g (make-container 'graph-container)))
+ (add-vertex g (+ x y))
+ (add-vertex g (+ x y))
+
+ (ensure-same (size g) 2)))
+
+(addtest (test-test-vertex)
+ test-1
+ (bind ((x (float 2.1d0))
+ (y (float 2.1d0))
+ (g (make-container 'graph-container :vertex-test #'=)))
+ (add-vertex g (+ x y))
+ (add-vertex g (+ x y))
+
+ (ensure-same (size g) 1)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; should do this for each _kind_ of graph
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-basic-graph-properties (test-graph)
+ ((graph-undirected (make-container 'graph-container :default-edge-type :undirected))
+ (graph-directed (make-container 'graph-container :default-edge-type :directed)))
+ :setup ((loop for v in '(a b c d e) do
+ (add-vertex graph-undirected v)
+ (add-vertex graph-directed v))
+ (loop for (v1 . v2) in '((a . b) (a . c) (b . d) (c . e)) do
+ (add-edge-between-vertexes graph-undirected v1 v2)
+ (add-edge-between-vertexes graph-directed v1 v2))))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-basic-graph-properties)
+ (ensure-same (size (graph-vertexes graph-directed)) 5 :test #'=)
+ (ensure-same (size (graph-edges graph-directed)) 4 :test #'=))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-basic-graph-properties)
+ (delete-edge-between-vertexes graph-directed 'a 'b)
+ (ensure (null (find-edge-between-vertexes graph-directed 'a 'b
+ :error-if-not-found? nil))))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-basic-graph-properties)
+ (delete-edge-between-vertexes graph-directed 'a 'b)
+ (ensure-same (size (graph-edges graph-directed)) 3))
+
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-graph-traversal (test-graph)
+ ((g (make-container 'graph-container)))
+ :setup (loop for (src dst) in '((a b) (a c) (a d) (b e)
+ (b f) (d g) (d h) (h i)
+ (h j)) do
+ (add-edge-between-vertexes g src dst :edge-type :directed)))
+
+;;; ---------------------------------------------------------------------------
+
+#|
+
+a - b - e
+ - f
+ - c
+ - d - g
+ - h - i
+ - j
+
+|#
+
+(addtest (test-graph-traversal)
+ (let ((result nil))
+ (traverse-elements
+ g :depth (lambda (v) (push (element v) result)))
+ (ensure-same (reverse result)
+ '(e f b c g i j h d a) :test #'equal)))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-graph-traversal)
+ (let ((result nil))
+ (traverse-elements
+ g :breadth (lambda (v) (push (element v) result)))
+ ;(print (reverse result))
+ (ensure-same (reverse result)
+ '(a b c d e f g h i j) :test #'equal)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; test-replace-vertex
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-replace-vertex (test-basic-graph-properties) ())
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-replace-vertex)
+ test-directed
+ (let ((b (find-vertex graph-directed 'b))
+ (x (make-vertex-for-graph graph-directed :element 'x)))
+ (replace-vertex graph-directed b x)
+ (ensure (find-vertex graph-directed 'x))
+ (ensure (not (find-vertex graph-directed 'b nil)))
+ (ensure-same (edge-count (find-vertex graph-directed 'x)) 2 :test =)
+ (ensure (find-edge-between-vertexes graph-directed 'a 'x))
+ (ensure (find-edge-between-vertexes graph-directed 'x 'd))))
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-replace-vertex)
+ test-undirected
+ (let ((b (find-vertex graph-undirected 'b))
+ (x (make-vertex-for-graph graph-undirected :element 'x)))
+ (replace-vertex graph-undirected b x)
+ (ensure (find-vertex graph-undirected 'x))
+ (ensure (not (find-vertex graph-undirected 'b nil)))
+ (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =)
+ (ensure (find-edge-between-vertexes graph-undirected 'a 'x))
+ (ensure (find-edge-between-vertexes graph-undirected 'x 'd))))
+
+;;; ---------------------------------------------------------------------------
+;;; change vertex value
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-change-vertex-value (test-basic-graph-properties) ())
+
+;;; ---------------------------------------------------------------------------
+
+(addtest (test-change-vertex-value)
+ test-undirected
+ (let ((b (find-vertex graph-undirected 'b)))
+ (setf (element b) 'x)
+ (ensure (find-vertex graph-undirected 'x))
+ (ensure (not (find-vertex graph-undirected 'b nil)))
+ (ensure-same (edge-count (find-vertex graph-undirected 'x)) 2 :test =)
+ (ensure (find-edge-between-vertexes graph-undirected 'a 'x))
+ (ensure (find-edge-between-vertexes graph-undirected 'x 'd))))
+
+
+
+;;; ---------------------------------------------------------------------------
+;;; test-replace-edge
+;;; ---------------------------------------------------------------------------
+
--- /dev/null
+;;; -*- Mode: Lisp -*-
+
+(in-package #:rw)
+
+(html-file-page ("index")
+ (html
+ (:HEAD (:TITLE "CL-Graph")
+ (generate-shared-headers))
+ (:BODY
+ (generate-two-line-header
+ "CL-Graph" "Better than sliced mangoes!")
+
+ ((:DIV :CLASS "contents")
+ (generate-system-sidebar)
+
+ ((:DIV :CLASS "system-description")
+ (:H3 "What it is")
+ (:P "CL-Graph is a Common Lisp library for manipulating graphs and running
+graph algorithms. " (rw:link :tinaa) " documentation for CL-Graph is "
+ (rw:link :cl-graph-tinaa :title "available") ".")
+
+ ((:A :NAME "mailing-lists"))
+ (:h3 "Mailing Lists")
+ (:ul
+ (:li ((:a :href "http://common-lisp.net/cgi-bin/mailman/listinfo/cl-graph-announce") "cl-graph-announce")
+ ": A low volume, read only list for announcements.")
+
+ (:li ((:a :href "http://common-lisp.net/cgi-bin/mailman/listinfo/cl-graph-devel") "cl-graph-devel")
+ ": A list for questions, patches, bug reports, and so on; It's for everything
+other than announcements."))
+
+ ((:A :NAME "downloads"))
+ (:H3 "Where is it")
+ (:P "A " (rw:link :darcs) " repository is available (note that you'll also need to get several other bits and pieces to get CL-Graph to work). The commands are listed below:")
+ (:PRE
+ "darcs get http://common-lisp.net/project/cl-graph/darcs/cl-graph
+darcs get http://common-lisp.net/project/cl-mathstats/darcs/cl-mathstats
+darcs get http://common-lisp.net/project/cl-containers/metabang.bind/darcs/metabang.bind
+darcs get http://common-lisp.net/project/cl-containers/metatilities/darcs/metatilities
+darcs get http://common-lisp.net/project/cl-containers/moptilities/darcs/moptilities")
+ (:P "CL-Graph (and friends) should also be " (rw:link :asdf-install :title "ASDF installable") ". Its CLiki home is right " (rw:link :cl-graph-cliki :title "where") " you'd expect.")
+
+ (:P "There's also a handy " (rw:link :cl-graph-package :title "gzipped tar file") ".")
+
+ ((:A :NAME "news"))
+ (:H3 "What is happening")
+ ((:TABLE :CLASS "system-news")
+ (:TR
+ (:TH "2 Feb 2006")
+ (:TD "Lots of new " (link :cl-graph-tinaa) " documentation."))
+ (:TR
+ (:TH "25 Nov 2005")
+ (:TD "Wrote a mini tutorial and published it on "
+ ((:a :href "http://www.metabang.com/unclog/publisha/atinybit.html") "unCLog") "."))
+ ((:TR :ALIGN "left" :VALIGN "top")
+ (:TH "10 Nov 2005")
+ (:TD "Initial setup.")))))
+
+
+ ((:DIV :CLASS "footer")
+ (generate-button-row
+ (format nil "Last updated: ~A"
+ (format-date "%A, %e %B %Y" (get-universal-time))))))))
\ No newline at end of file
projects / cl-graph.git / commitdiff