X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph-generation.lisp;h=1f53b14edbdaff99ff249660f7f7ece9a6d71d8b;hb=80af22e39e0787769c4c9f455bb1d2c95e2343b5;hp=36bcbb7fdab00a1a9238508f180d4010a1f05ea7;hpb=438d1e0593dc62fe7b975a5865ec27955afcb7a1;p=cl-graph.git diff --git a/dev/graph-generation.lisp b/dev/graph-generation.lisp index 36bcbb7..1f53b14 100644 --- a/dev/graph-generation.lisp +++ b/dev/graph-generation.lisp @@ -1,41 +1,39 @@ -(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)) - -;;; --------------------------------------------------------------------------- +(in-package #:metabang.graph) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (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 @@ -47,28 +45,23 @@ (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 -;;; --------------------------------------------------------------------------- +;;; generate-gnp -(defmethod generate-Gnp (generator (graph-class symbol) n p &key (label 'identity)) - (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)) +(defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity)) (let ((v 1) (w -1) (log-1-p (log (- 1 p)))) @@ -87,18 +80,16 @@ graph)) -;;; --------------------------------------------------------------------------- -;;; generate-Gnm -;;; --------------------------------------------------------------------------- +;;; generate-gnm -(defmethod generate-Gnm (generator (graph-class symbol) n p &key (label 'identity)) - (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)) +(defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity)) (let ((max-edge-index (1- (combination-count n 2)))) + (assert (<= m max-edge-index)) #+Ignore (save-generation-information graph generator 'generate-gnm) (loop for i from 0 to (1- n) do @@ -123,12 +114,10 @@ '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 @@ -136,12 +125,10 @@ (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 @@ -149,9 +136,7 @@ (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 @@ -162,7 +147,6 @@ kind-matrix assortativity-matrix vertex-creator :duplicate-edge-function duplicate-edge-function)) -;;; --------------------------------------------------------------------------- (defmethod generate-undirected-graph-via-assortativity-matrix (generator graph size edge-count @@ -215,9 +199,7 @@ (values graph))) -;;; --------------------------------------------------------------------------- ;;; generate-undirected-graph-via-verex-probabilities -;;; --------------------------------------------------------------------------- (defmethod generate-undirected-graph-via-vertex-probabilities (generator (graph-class symbol) size @@ -226,7 +208,6 @@ generator (make-instance graph-class) size kind-matrix probability-matrix vertex-creator)) -;;; --------------------------------------------------------------------------- (defmethod generate-undirected-graph-via-vertex-probabilities (generator graph size @@ -358,7 +339,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) @@ -377,7 +357,6 @@ #+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) @@ -393,10 +372,9 @@ (when (< v rows) (funcall fn v w))))))) -;;; --------------------------------------------------------------------------- (defun poisson-vertex-degree-distribution (z k) - (/ (* (expt z k) (expt +e+ (- z))) + (/ (* (expt z k) (expt cl-mathstats:+e+ (- z))) (factorial k))) #| @@ -404,19 +382,17 @@ We know the probability of finding a vertex of degree k is p_k. We want to sampl from this distribution |# -;;; --------------------------------------------------------------------------- (defun power-law-vertex-degree-distribution (kappa k) - (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa))))) + (* (- 1 (expt cl-mathstats:+e+ (- (/ kappa)))) + (expt cl-mathstats:+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) @@ -438,7 +414,6 @@ from this distribution (lambda () (first (next-element wsc))))) -;;; --------------------------------------------------------------------------- #+Old (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix) @@ -452,14 +427,12 @@ from this distribution (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 @@ -471,7 +444,6 @@ from this distribution (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))) @@ -551,13 +523,11 @@ from this distribution 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)) + (let ((g (make-instance graph-class)) (group-count 4) (group-size 32) (edge-count 16) @@ -586,7 +556,7 @@ from this distribution (check-type from-group fixnum) (loop - (bind ((other-group (integer-random generator 0 (- group-count 2))) + (let ((other-group (integer-random generator 0 (- group-count 2))) (other (sample-element (item-at groups (if (= from-group other-group) (1+ other-group) @@ -646,12 +616,10 @@ from this distribution (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 @@ -659,7 +627,7 @@ from this distribution (iterate-edges g (lambda (e) - (bind ((v1 (vertex-1 e)) + (let ((v1 (vertex-1 e)) (v2 (vertex-2 e)) (id1 (element v1)) (id2 (element v2))) @@ -676,13 +644,11 @@ from this distribution #'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) @@ -693,7 +659,6 @@ from this distribution (slot-value object 'lookup) (make-container 'simple-associative-container))) -;;; --------------------------------------------------------------------------- (defmethod insert-item ((container weighted-sampler-with-lookup-container) (item t)) @@ -702,25 +667,21 @@ from this distribution (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 @@ -749,7 +710,7 @@ from this distribution (list vertex other-kind)))) (update (kind thing) ;; handle bookkeeping for changed vertex degree - (bind ((sampler (aref vertex-sampler kind)) + (let ((sampler (aref vertex-sampler kind)) (node (find-node sampler thing))) (delete-node sampler node) (insert-item sampler thing)))) @@ -781,7 +742,6 @@ from this distribution graph))) -;;; --------------------------------------------------------------------------- #+Test (defun poisson-connector (count generator) @@ -1079,14 +1039,11 @@ generate-scale-free-graph 2% 2% 1,700 |# -;;; --------------------------------------------------------------------------- ;;; 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) @@ -1228,7 +1185,7 @@ Split into a function to compute some of the intermediate pieces and one to use (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))) + (let (((edge-kind . edge) (delete-last edge-sampler))) (ecase edge-kind (:source (setf (first edge) vertex)) (:target (setf (second edge) vertex))))))) @@ -1282,9 +1239,7 @@ Split into a function to compute some of the intermediate pieces and one to use (0.2222222222222222 0.4444444444444444)))) :test #'eq) -;;; --------------------------------------------------------------------------- ;;; generate-graph-by-resampling-edges -;;; --------------------------------------------------------------------------- #| doesn't take edge weights into account when sampling @@ -1296,12 +1251,10 @@ should include pointer back to original graph ((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) @@ -1309,10 +1262,9 @@ should include pointer back to original graph (edge-iterator nil r) (size nil ir))) -;;; --------------------------------------------------------------------------- (defmethod initialize-instance :after ((object weighted-edge-sampler) &key) - (bind ((generator (generator object)) + (let ((generator (generator object)) (weighted-edge-count (let ((result 0)) (iterate-edges (graph object) (lambda (e) (incf result (weight e)))) @@ -1326,7 +1278,6 @@ should include pointer back to original graph (slot-value object 'edge-iterator) (make-iterator (graph-edges (graph object)))))) -;;; --------------------------------------------------------------------------- (defmethod next-element ((object weighted-edge-sampler)) (let ((edge-iterator (edge-iterator object)) @@ -1417,22 +1368,25 @@ should include pointer back to original graph (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-class symbol) size minimum-degree) + (generate-simple-preferential-attachment-graph + generator (make-instance graph-class) size minimum-degree)) + (defmethod generate-simple-preferential-attachment-graph (generator graph size minimum-degree) - (bind ((m (make-array (list (* 2 size minimum-degree))))) + (let ((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)))) + (let ((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))))) @@ -1457,7 +1411,6 @@ should include pointer back to original graph :sort #'> :sort-on :values) -;;; --------------------------------------------------------------------------- (defmethod generate-preferential-attachment-graph (generator (graph-class symbol) size kind-matrix minimum-degree @@ -1470,14 +1423,13 @@ should include pointer back to original graph :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)) + (let ((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))) @@ -1496,9 +1448,9 @@ should include pointer back to original graph ;; 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))) + (let ((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))))) + (let ((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))) @@ -1508,10 +1460,10 @@ should include pointer back to original graph (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)) + (let ((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)))) + (let ((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)) @@ -1546,7 +1498,7 @@ should include pointer back to original graph (loop for vertex across (aref edge-recorders kind) for index = 0 then (1+ index) when (consp vertex) do - (bind (((other-kind other-index) vertex)) + (let (((other-kind other-index) vertex)) #+Ignore (when-debugging-format generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A" @@ -1590,7 +1542,6 @@ should include pointer back to original graph graph)) -;;; --------------------------------------------------------------------------- (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities) (let ((c (make-container 'weighted-sampling-container @@ -1644,9 +1595,17 @@ should include pointer back to original graph (0.02 0.25 0.25) (0.02 0.25 0.25)))) -;;; --------------------------------------------------------------------------- -(Defmethod generate-acquaintance-network + +(defmethod generate-acquaintance-network + (generator (class-name symbol) size death-probability iterations vertex-labeler + &key (duplicate-edge-function :ignore)) + (generate-acquaintance-network + generator (make-instance class-name) + size death-probability iterations vertex-labeler + :duplicate-edge-function duplicate-edge-function)) + +(defmethod generate-acquaintance-network (generator graph size death-probability iterations vertex-labeler &key (duplicate-edge-function :ignore)) ;; bring the graph up to size @@ -1658,7 +1617,6 @@ should include pointer back to original graph generator graph death-probability duplicate-edge-function)) (values graph)) -;;; --------------------------------------------------------------------------- (defmethod generate-acquaintance-network-until-stable (generator graph size death-probability step-count @@ -1677,19 +1635,18 @@ should include pointer back to original graph (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)) + (let ((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 + finally (return result)))) (if neighbors (add-edge-between-vertexes graph @@ -1705,6 +1662,12 @@ should include pointer back to original graph (let ((vertex (sample-element (graph-vertexes graph) generator))) (delete-vertex graph vertex) (add-vertex graph (element vertex))))) + +#+Ignore +(defun sv (v) + (format t "~%~A ~A" + v + (adjustable-array-p (contents (vertex-edges v))))) #+Test (generate-acquaintance-network