(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 ;; (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)))) (assert (<= m max-edge-index)) #+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 32% add-vertex 2% update 1% add-edge-between-vertexes 1% form-keyword 1% iterate-container 1% ---- %%check-keywords 100% sample-existing-vertexes 62% 61% 62,577,336 walk-tree-nodes 99% uniform-random 1% ---- sample-existing-vertexes 100% walk-tree-nodes 61% 60% 61,607,072 # 77% +-2 3% element-weight 2% >=-2 2% %double-float+-2! 1% %%one-arg-dcode 1% ---- walk-tree-nodes 98% %%before-and-after-combined-method-dcode 2% # 48% 47% 48,156,256 iterate-container 73% %%1st-two-arg-dcode 9% iterate-edges 6% constantly 4% iterate-elements 2% ---- # 99% %vertex-degree 1% iterate-container 35% 35% 35,440,856 other-vertex 43% %%nth-arg-dcode 20% # 10% ---- insert-item 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 90% # 2% shared-initialize 2% %%one-arg-dcode 1% %double-float+-2! 1% +-2 1% ---- %%check-keywords 100% insert-item 31% 31% 31,970,488 %%before-and-after-combined-method-dcode 100% ---- %%before-and-after-combined-method-dcode 100% insert-item 30% 31% 31,227,120 %vertex-degree 84% vertex-degree 5% ---- insert-item 99% # 1% %vertex-degree 26% 25% 25,870,312 # 68% %aref1 3% %std-slot-value-using-class 1% slot-id-value 1% %%one-arg-dcode 1% iterate-container 1% ---- %vertex-degree 99% iterate-container 1% # 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 5% # 1% ---- iterate-container 99% # 1% other-vertex 15% 14% 14,029,496 %%one-arg-dcode 1% ---- iterate-container 95% %%check-keywords 3% %%before-and-after-combined-method-dcode 1% initialize-instance (around) 1% %%nth-arg-dcode 7% 9% 9,238,560 ---- # 93% walk-tree-nodes 5% %%before-and-after-combined-method-dcode 2% %%1st-two-arg-dcode 5% 5% 4,802,264 ---- iterate-container 96% # 3% shared-initialize 1% # 4% 4% 4,012,368 ---- # 100% iterate-edges 3% 3% 2,918,352 ---- # 59% %vertex-degree 14% walk-tree-nodes 13% shared-initialize 6% %shared-initialize 4% other-vertex 2% member 2% %std-slot-value-using-class 2% 2% 2,115,320 ---- # 59% walk-tree-nodes 12% %vertex-degree 9% %%before-and-after-combined-method-dcode 6% shared-initialize 4% update 4% other-vertex 4% %shared-initialize 2% %%one-arg-dcode 2% 2% 2,478,304 ---- make-instance 68% %make-instance 23% make-instance 9% %make-std-instance 2% 2% 2,283,344 %%before-and-after-combined-method-dcode 47% shared-initialize 15% %%standard-combined-method-dcode 12% %maybe-std-slot-value-using-class 3% ---- # 78% %vertex-degree 7% uniform-random 5% %make-std-instance 2% shared-initialize 3% view-get 2% walk-tree-nodes 3% %maybe-std-slot-value-using-class 2% 2% 2,005,048 ---- add-edge-between-vertexes 42% add-vertex 40% initialize-instance (after) 7% add-it 6% %%before-and-after-combined-method-dcode 5% make-instance 2% 2% 1,932,504 %make-std-instance 92% ---- # 100% constantly 2% 2% 1,629,880 ---- walk-tree-nodes 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 2% 2% 2,259,304 make-instance 44% %%standard-combined-method-dcode 30% %%before-and-after-combined-method-dcode 8% %make-std-instance 3% ---- generate-scale-free-graph 2% 2% 1,700,920 %%standard-combined-method-dcode 48% %%check-keywords 16% uniform-random 15% make-instance 6% ---- generate-scale-free-graph 45% add-vertex 25% %make-std-instance 18% make-instance 6% add-it 3% insert-item 3% %%standard-combined-method-dcode 2% 2% 2,019,832 insert-item 45% %%before-and-after-combined-method-dcode 25% %%nth-arg-dcode 3% make-instance 3% ---- # ? 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-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))))) (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 (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 (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)))) (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))))) #+Ignore (defun sv (v) (format t "~%~A ~A" v (adjustable-array-p (contents (vertex-edges v))))) #+Test (generate-acquaintance-network *random-generator* (make-graph 'graph-container :edge-type :undirected) 1000 0.001 10000 'simple-group-id-generator)