1 (in-package metabang.graph)
5 generate-undirected-graph-via-assortativity-matrix
6 generate-undirected-graph-via-vertex-probabilities
7 generate-multi-group-graph-fixed
8 #+Ignore generate-girvan-newman-graph
9 generate-scale-free-graph
10 generate-assortative-graph-with-degree-distributions
12 generate-simple-preferential-attachment-graph
13 generate-preferential-attachment-graph
15 generate-acquaintance-network
16 generate-acquaintance-network-until-stable
18 generate-graph-by-resampling-edges
23 simple-group-id-generator
24 simple-group-id-parser
27 poisson-vertex-degree-distribution
28 power-law-vertex-degree-distribution))
30 ;;; ---------------------------------------------------------------------------
32 ;;; ---------------------------------------------------------------------------
34 (defclass* generated-graph-mixin ()
35 ((generation-method nil ir)
36 (random-seed nil ir)))
38 ;;; ---------------------------------------------------------------------------
40 (defun save-generation-information (graph generator method)
42 ;; (setf (random-seed generator) (random-seed generator))
43 (unless (typep graph 'generated-graph-mixin)
44 (change-class graph (find-or-create-class
45 'basic-graph (list 'generated-graph-mixin
46 (class-name (class-of graph))))))
47 (setf (slot-value graph 'generation-method) method
48 (slot-value graph 'random-seed) (random-seed generator)))
50 ;;; ---------------------------------------------------------------------------
52 (defun simple-group-id-generator (kind count)
53 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
55 ;;; ---------------------------------------------------------------------------
57 (defun simple-group-id-parser (vertex)
58 (parse-integer (subseq (symbol-name (element vertex)) 1 3)))
61 ;;; ---------------------------------------------------------------------------
63 ;;; ---------------------------------------------------------------------------
65 (defmethod generate-Gnp (generator (graph-class symbol) n p &key (label 'identity))
67 generator (make-instance graph-class) n p :label label))
69 ;;; ---------------------------------------------------------------------------
71 (defmethod generate-Gnp (generator (graph basic-graph) n p &key (label 'identity))
74 (log-1-p (log (- 1 p))))
75 (save-generation-information graph generator 'generate-gnp)
76 (loop for i from 0 to (1- n) do
77 (add-vertex graph (funcall label i)))
78 (loop while (< v n) do
79 (let ((r (uniform-random generator 0d0 1d0)))
80 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
81 (loop while (and (>= w v) (< v n)) do
85 (add-edge-between-vertexes
86 graph (funcall label v) (funcall label w)))))
90 ;;; ---------------------------------------------------------------------------
92 ;;; ---------------------------------------------------------------------------
94 (defmethod generate-Gnm (generator (graph-class symbol) n p &key (label 'identity))
96 generator (make-instance graph-class) n p :label label))
98 ;;; ---------------------------------------------------------------------------
100 (defmethod generate-Gnm (generator (graph basic-graph) n m &key (label 'identity))
101 (let ((max-edge-index (1- (combination-count n 2))))
103 (save-generation-information graph generator 'generate-gnm)
104 (loop for i from 0 to (1- n) do
105 (add-vertex graph (funcall label i)))
106 (loop for i from 0 to (1- m) do
108 until (let* ((i (integer-random generator 0 max-edge-index))
109 (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
110 (w (- i (/ (* v (1- v)) 2)))
111 (label-v (funcall label v))
112 (label-w (funcall label w)))
113 (unless (find-edge-between-vertexes
114 graph label-v label-w :error-if-not-found? nil)
115 (add-edge-between-vertexes graph label-v label-w)))))
121 (setf g (generate-gnm
123 'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
126 ;;; ---------------------------------------------------------------------------
128 (defun vertex-group (v)
129 (aref (symbol-name (element v)) 1))
131 ;;; ---------------------------------------------------------------------------
133 (defun in-group-degree (v &key (key 'vertex-group))
135 v :edge-filter (lambda (e ov)
137 (in-same-group-p v ov key))))
139 ;;; ---------------------------------------------------------------------------
141 (defun in-same-group-p (v1 v2 key)
142 (eq (funcall key v1) (funcall key v2)))
144 ;;; ---------------------------------------------------------------------------
146 (defun out-group-degree (v &key (key 'vertex-group))
148 v :edge-filter (lambda (e ov)
150 (not (in-same-group-p v ov key)))))
152 ;;; ---------------------------------------------------------------------------
153 ;;; generate-undirected-graph-via-assortativity-matrix
154 ;;; ---------------------------------------------------------------------------
156 (defmethod generate-undirected-graph-via-assortativity-matrix
157 (generator (graph-class symbol) size edge-count
158 kind-matrix assortativity-matrix vertex-creator
159 &key (duplicate-edge-function 'identity))
160 (generate-undirected-graph-via-assortativity-matrix
161 generator (make-instance graph-class) size edge-count
162 kind-matrix assortativity-matrix vertex-creator
163 :duplicate-edge-function duplicate-edge-function))
165 ;;; ---------------------------------------------------------------------------
167 (defmethod generate-undirected-graph-via-assortativity-matrix
168 (generator graph size edge-count
169 kind-matrix assortativity-matrix vertex-creator
170 &key (duplicate-edge-function 'identity))
171 (let* ((kind-count (array-dimension assortativity-matrix 0))
172 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
174 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
175 (vertex-sampler (make-array kind-count))
176 (edge-kinds (sample-edges-for-assortative-graph
177 generator edge-count assortativity-matrix))
179 (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
181 (loop for vertex-kind from 0 to (1- kind-count)
182 for count in vertex-kind-counts do
183 (setf (aref vertex-sampler vertex-kind)
184 (make-array (second count))))
186 (let ((current-kind 0)
188 (current-vertexes (aref vertex-sampler 0)))
190 (loop for kind in vertex-kinds
192 (when (not (eq current-kind kind))
193 (setf current-count 0
195 current-vertexes (aref vertex-sampler current-kind)))
196 (let ((vertex (funcall vertex-creator kind i)))
197 (setf (aref current-vertexes current-count) vertex)
198 (add-vertex graph vertex)
199 (incf current-count)))
201 (loop for (from-kind to-kind) in edge-kinds do
204 (if (= from-kind to-kind)
205 (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
207 (setf v1 (first sample) v2 (second sample)))
208 (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
209 v2 (sample-element (aref vertex-sampler to-kind) generator)))
210 (add-edge-between-vertexes
214 :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
218 ;;; ---------------------------------------------------------------------------
219 ;;; generate-undirected-graph-via-verex-probabilities
220 ;;; ---------------------------------------------------------------------------
222 (defmethod generate-undirected-graph-via-vertex-probabilities
223 (generator (graph-class symbol) size
224 kind-matrix probability-matrix vertex-creator)
225 (generate-undirected-graph-via-vertex-probabilities
226 generator (make-instance graph-class) size
227 kind-matrix probability-matrix vertex-creator))
229 ;;; ---------------------------------------------------------------------------
231 (defmethod generate-undirected-graph-via-vertex-probabilities
232 (generator graph size
233 kind-matrix probability-matrix vertex-creator)
234 (let* ((kind-count (array-dimension probability-matrix 0))
235 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
237 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
238 (vertex-sampler (make-array kind-count)))
239 (save-generation-information graph generator
240 'generate-undirected-graph-via-vertex-probabilities)
242 ;; initialize vertex bookkeeping
243 (loop for vertex-kind from 0 to (1- kind-count)
244 for count in vertex-kind-counts do
245 (setf (aref vertex-sampler vertex-kind)
246 (make-array (second count))))
249 (let ((current-kind 0)
251 (current-vertexes (aref vertex-sampler 0)))
252 (loop for kind in vertex-kinds
254 (when (not (eq current-kind kind))
255 (setf current-count 0
257 current-vertexes (aref vertex-sampler current-kind)))
258 (let ((vertex (funcall vertex-creator kind i)))
259 (setf (aref current-vertexes current-count) vertex)
260 (add-vertex graph vertex)
261 (incf current-count))))
264 ;; adjust probabilities
265 (loop for (kind-1 count-1) in vertex-kind-counts do
266 (loop for (kind-2 count-2) in vertex-kind-counts
267 when (<= kind-1 kind-2) do
268 (format t "~%~6,6F ~6,6F"
269 (aref probability-matrix kind-1 kind-2)
270 (float (/ (aref probability-matrix kind-1 kind-2)
271 (* count-1 count-2))))
272 (setf (aref probability-matrix kind-1 kind-2)
273 (float (/ (aref probability-matrix kind-1 kind-2)
274 (* count-1 count-2))))))
277 (flet ((add-one-edge (k1 k2 a b)
278 (add-edge-between-vertexes
280 (aref (aref vertex-sampler k1) a)
281 (aref (aref vertex-sampler k2) b))))
282 (loop for (kind-1 count-1) in vertex-kind-counts do
283 (loop for (kind-2 count-2) in vertex-kind-counts
284 when (<= kind-1 kind-2) do
285 (if (eq kind-1 kind-2)
286 (sample-edges-of-same-kind
287 generator count-1 (aref probability-matrix kind-1 kind-2)
289 (add-one-edge kind-1 kind-2 a b)))
290 (sample-edges-of-different-kinds
291 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
293 (add-one-edge kind-1 kind-2 a b)))))))
298 (defmethod generate-undirected-graph-via-vertex-probabilities
299 (generator graph size
300 kind-matrix probability-matrix vertex-creator)
301 (let* ((kind-count (array-dimension probability-matrix 0))
302 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
304 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
305 (vertex-sampler (make-array kind-count)))
307 (loop for vertex-kind from 0 to (1- kind-count)
308 for count in vertex-kind-counts do
309 (setf (aref vertex-sampler vertex-kind)
310 (make-array (second count))))
312 (let ((current-kind 0)
314 (current-vertexes (aref vertex-sampler 0)))
316 (loop for kind in vertex-kinds
318 (when (not (eq current-kind kind))
319 (setf current-count 0
321 current-vertexes (aref vertex-sampler current-kind)))
322 (let ((vertex (funcall vertex-creator kind i)))
323 (setf (aref current-vertexes current-count) vertex)
324 (add-vertex graph vertex)
325 (incf current-count))))
328 (flet ((add-one-edge (k1 k2 a b)
330 (add-edge-between-vertexes
332 (aref (aref vertex-sampler k1) a)
333 (aref (aref vertex-sampler k2) b))))
334 (loop for (kind-1 count-1) in vertex-kind-counts do
335 (loop for (kind-2 count-2) in vertex-kind-counts
336 when (<= kind-1 kind-2) do
338 (if (eq kind-1 kind-2)
339 (sample-edges-of-same-kind
340 generator count-1 (aref probability-matrix kind-1 kind-2)
342 (add-one-edge kind-1 kind-2 a b)))
343 (sample-edges-of-different-kinds
344 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
346 (add-one-edge kind-1 kind-2 a b))))
347 (format t "~%~A ~A ~A ~A -> ~A"
348 count-1 count-2 kind-1 kind-2 xxx)))))
353 (generate-undirected-graph-via-vertex-probabilities
354 *random-generator* 'graph-container
357 #2A((0.1 0.02) (0.02 0.6))
359 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
361 ;;; ---------------------------------------------------------------------------
363 (defun sample-edges-of-same-kind (generator n p fn)
367 (log-1-p (log (- 1 p))))
368 (loop while (< v n) do
369 (let ((r (uniform-random generator 0d0 1d0)))
370 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
371 (loop while (and (>= w v) (< v n)) do
375 (funcall fn v w)))))))
378 (sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
380 ;;; ---------------------------------------------------------------------------
382 (defun sample-edges-of-different-kinds (generator rows cols p fn)
386 (log-1-p (log (- 1 p))))
387 (loop while (< v rows) do
388 (let ((r (uniform-random generator 0d0 1d0)))
389 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
390 (loop while (and (>= w cols) (< v rows)) do
394 (funcall fn v w)))))))
396 ;;; ---------------------------------------------------------------------------
398 (defun poisson-vertex-degree-distribution (z k)
399 (/ (* (expt z k) (expt +e+ (- z)))
403 We know the probability of finding a vertex of degree k is p_k. We want to sample
404 from this distribution
407 ;;; ---------------------------------------------------------------------------
409 (defun power-law-vertex-degree-distribution (kappa k)
410 (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
412 ;;; ---------------------------------------------------------------------------
414 (defun create-specified-vertex-degree-distribution (degrees)
416 (declare (ignore z k))
419 ;;; ---------------------------------------------------------------------------
421 (defun make-degree-sampler (p_k &key (generator *random-generator*)
423 (min-probability 0.0001))
424 (let ((wsc (make-container 'containers:weighted-sampling-container
425 :random-number-generator generator
429 (loop for k = 0 then (1+ k)
430 for p = (funcall p_k k)
431 until (or (and max-degree (> k max-degree))
432 (and min-probability (< (- 1.0 total) min-probability))) do
435 (insert-item wsc (list k p)))
436 (when (plusp (- 1.0 total))
437 (insert-item wsc (list (1+ max-k) (- 1.0 total))))
439 (first (next-element wsc)))))
441 ;;; ---------------------------------------------------------------------------
444 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
445 (let ((c (make-container 'weighted-sampling-container
446 :random-number-generator generator
448 (aref assortativity-matrix (first item) (second item))))))
449 (dotimes (i (array-dimension assortativity-matrix 0))
450 (dotimes (j (array-dimension assortativity-matrix 1))
451 (insert-item c (list i j))))
452 (loop repeat edge-count collect
455 ;;; ---------------------------------------------------------------------------
457 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
458 (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
459 (loop repeat edge-count collect
462 ;;; ---------------------------------------------------------------------------
464 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
465 (let ((c (make-container 'weighted-sampling-container
466 :random-number-generator generator
468 (aref assortativity-matrix (first item) (second item))))))
469 (dotimes (i (array-dimension assortativity-matrix 0))
470 (dotimes (j (array-dimension assortativity-matrix 1))
471 (insert-item c (list i j))))
472 (lambda () (next-element c))))
474 ;;; ---------------------------------------------------------------------------
476 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
477 (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
478 ;; use kind-matrix as counts
479 (assert (= size (sum-of-array-elements kind-matrix)))
480 (coerce (shuffle-elements!
483 (loop for i = 0 then (1+ i)
484 for count across kind-matrix nconc
485 (make-list count :initial-element i)))
486 :generator generator)
490 ;; use kind-matrix as ratios to sample
491 (let* ((c (make-container 'weighted-sampling-container
492 :random-number-generator generator
494 (aref kind-matrix item)))))
495 (dotimes (i (array-dimension kind-matrix 0))
497 (loop repeat size collect
498 (next-element c))))))
501 (sample-vertexes-for-mixed-graph
503 50 #2A((0.258 0.016 0.035 0.013)
504 (0.012 0.157 0.058 0.019)
505 (0.013 0.023 0.306 0.035)
506 (0.005 0.007 0.024 0.016)))
509 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
510 (0.012 0.157 0.058 0.019)
511 (0.013 0.023 0.306 0.035)
512 (0.005 0.007 0.024 0.016)))
514 (let ((a #2A((0.258 0.016 0.035 0.013)
515 (0.012 0.157 0.058 0.019)
516 (0.013 0.023 0.306 0.035)
517 (0.005 0.007 0.024 0.016)))
518 (c (make-container 'weighted-sampling-container :key #'second)))
521 (insert-item c (list (list i j) (aref a i j)))))
523 (loop repeat 1000 collect
529 (let ((a #2A((0.258 0.016 0.035 0.013)
530 (0.012 0.157 0.058 0.019)
531 (0.013 0.023 0.306 0.035)
532 (0.005 0.007 0.024 0.016)))
533 (c (make-container 'weighted-sampling-container :key #'second)))
535 (loop repeat 100000 do
539 (defun foo (percent-bad percent-mixing)
540 (let ((kind-matrix (make-array 2 :initial-element 0d0))
541 (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
542 (setf (aref kind-matrix 0) (- 1d0 percent-bad)
543 (aref kind-matrix 1) percent-bad
544 (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
545 (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
546 (aref mixing-matrix 1 0) percent-mixing
547 (aref mixing-matrix 0 1) percent-mixing)
548 (normalize-matrix kind-matrix)
549 (setf mixing-matrix (normalize-matrix mixing-matrix))
554 ;;; ---------------------------------------------------------------------------
555 ;;; girvan-newman-test-graphs
556 ;;; ---------------------------------------------------------------------------
558 (defun generate-girvan-newman-graph (generator graph-class z-in)
559 (warn "This is broken!")
560 (bind ((g (make-instance graph-class))
564 (z-out (- edge-count z-in))
565 (vertexes (make-container 'simple-associative-container))
566 (groups (make-container 'alist-container)))
567 (save-generation-information g generator
568 'generate-girvan-newman-graph)
569 (labels ((make-id (group index)
570 (form-keyword "A" group "0" index))
572 (choose-inner-id (group id)
573 (check-type group fixnum)
574 (check-type id symbol)
576 (let ((other (sample-element (item-at groups group :needs-in) generator)))
580 (not (find-edge-between-vertexes
581 g id other :error-if-not-found? nil)))
582 (return-from choose-inner-id other)))))
584 (choose-outer-id (from-group id)
585 (declare (ignore id))
587 (check-type from-group fixnum)
589 (bind ((other-group (integer-random generator 0 (- group-count 2)))
590 (other (sample-element
591 (item-at groups (if (= from-group other-group)
593 other-group) :needs-out)
597 (not (find-edge-between-vertexes
598 g id other :error-if-not-found? nil)))
599 (return-from choose-outer-id other)))))
601 (make-in-edge (from to)
602 (let ((group (gn-id->group from)))
603 (when (zerop (decf (first (item-at vertexes from))))
604 (setf (item-at groups group :needs-in)
605 (remove from (item-at groups group :needs-in))))
606 (when (zerop (decf (first (item-at vertexes to))))
607 (setf (item-at groups group :needs-in)
608 (remove to (item-at groups group :needs-in))))
609 (add-edge-between-vertexes
610 g from to :edge-type :undirected
611 :if-duplicate-do (lambda (e) (incf (weight e))))))
613 (make-out-edge (from to)
614 (let ((group-from (gn-id->group from))
615 (group-to (gn-id->group to)))
616 (when (zerop (decf (second (item-at vertexes from))))
617 (setf (item-at groups group-from :needs-out)
618 (remove from (item-at groups group-from :needs-out))))
619 (when (zerop (decf (second (item-at vertexes to))))
620 (setf (item-at groups group-to :needs-out)
621 (remove to (item-at groups group-to :needs-out))))
623 (add-edge-between-vertexes
624 g from to :edge-type :undirected
625 :if-duplicate-do (lambda (e) (incf (weight e)))))))
628 (loop for group from 0 to (1- group-count) do
629 (loop for index from 0 to (1- group-size) do
630 (let ((id (make-id group index)))
631 (setf (item-at vertexes id) (list z-in z-out))
633 (push id (item-at groups group :needs-in)))
635 (push id (item-at groups group :needs-out))))))
638 (loop for group from 0 to (1- group-count) do
639 (loop for index from 0 to (1- group-size) do
640 (let ((from (make-id group index)))
642 (loop while (plusp (first (item-at vertexes from))) do
643 (make-in-edge from (choose-inner-id group from)))
644 (loop while (plusp (second (item-at vertexes from))) do
645 (make-out-edge from (choose-outer-id group from)))))))
649 ;;; ---------------------------------------------------------------------------
651 (defun gn-id->group (id)
652 (parse-integer (subseq (symbol-name id) 1 2)))
654 ;;; ---------------------------------------------------------------------------
656 (defun collect-edge-counts (g)
657 (let ((vertexes (make-container 'simple-associative-container
658 :initial-element-fn (lambda () (list 0 0)))))
662 (bind ((v1 (vertex-1 e))
666 (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
667 (incf (first (item-at vertexes id1)) (weight e))
668 (incf (first (item-at vertexes id2)) (weight e)))
670 (incf (second (item-at vertexes id1)) (weight e))
671 (incf (second (item-at vertexes id2)) (weight e)))))))
675 :transform (lambda (k v) (list k (first v) (second v))))
679 ;;; ---------------------------------------------------------------------------
681 (defclass* weighted-sampler-with-lookup-container ()
685 ;;; ---------------------------------------------------------------------------
687 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
688 &key random-number-generator key)
689 (setf (slot-value object 'sampler)
690 (make-container 'weighted-sampling-container
691 :random-number-generator random-number-generator
693 (slot-value object 'lookup)
694 (make-container 'simple-associative-container)))
696 ;;; ---------------------------------------------------------------------------
698 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
700 (let ((node (nth-value 1 (insert-item (sampler container) item))))
702 (assert (not (null node)))
703 (setf (item-at-1 (lookup container) item) node)))
705 ;;; ---------------------------------------------------------------------------
707 (defmethod find-node ((container weighted-sampler-with-lookup-container)
709 (item-at-1 (lookup container) item))
711 ;;; ---------------------------------------------------------------------------
713 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
715 ;; not going to worry about the hash table
716 (delete-node (sampler container) node))
718 ;;; ---------------------------------------------------------------------------
720 (defmethod next-element ((container weighted-sampler-with-lookup-container))
721 (next-element (sampler container)))
723 ;;; ---------------------------------------------------------------------------
725 (defmethod generate-scale-free-graph
726 (generator graph size kind-matrix add-edge-count
727 other-vertex-kind-samplers
729 &key (duplicate-edge-function 'identity))
730 (let* ((kind-count (array-dimension kind-matrix 0))
731 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
732 (vertex-sampler (make-array kind-count)))
733 (save-generation-information graph generator 'generate-scale-free-graph)
734 (flet ((sample-existing-vertexes (for-kind)
735 ;; return list of vertexes to attach based on preferential attachment
736 (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
737 add-edge-count generator) collect
738 (let ((vertex (next-element (aref vertex-sampler other-kind))))
741 for nil across vertex-sampler
743 (setf vertex (next-element (aref vertex-sampler i))
746 ;;?? remove. this should never happen
747 (unless vertex (break))
749 (list vertex other-kind))))
751 ;; handle bookkeeping for changed vertex degree
752 (bind ((sampler (aref vertex-sampler kind))
753 (node (find-node sampler thing)))
754 (delete-node sampler node)
755 (insert-item sampler thing))))
759 for nil across vertex-sampler do
760 (setf (aref vertex-sampler i)
761 (make-container 'weighted-sampler-with-lookup-container
762 :random-number-generator generator
763 :key (lambda (vertex)
764 (1+ (vertex-degree vertex))))))
766 ;; add vertexes and edges
767 (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
769 (let* ((element (funcall vertex-creator kind i))
770 (vertex (add-vertex graph element)))
771 (when (> i add-edge-count)
772 (loop for (other other-kind) in (sample-existing-vertexes kind) do
773 (update other-kind other)
775 (if (or (null kind) (null other)) (break))
776 (add-edge-between-vertexes
779 (lambda (e) (funcall duplicate-edge-function e)))))
780 (insert-item (aref vertex-sampler kind) vertex)))
784 ;;; ---------------------------------------------------------------------------
787 (defun poisson-connector (count generator)
788 (let* ((ts (poisson-random generator 2))
789 (cs (poisson-random generator 2))
790 (rest (- count ts cs)))
791 (loop for tick = t then (not tick) while (minusp rest) do
793 (if tick (decf ts) (decf cs)))
795 (append (make-list (truncate rest) :initial-element 0)
796 (make-list (truncate ts) :initial-element 1)
797 (make-list (truncate cs) :initial-element 2))
798 :generator generator)))
802 (generate-scale-free-graph
804 (make-container 'graph-container :default-edge-type :undirected)
809 (lambda (count generator)
810 (declare (ignore generator))
811 (make-list count :initial-element 0))
815 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
819 (generate-scale-free-graph
821 (make-container 'graph-container :default-edge-type :undirected)
826 (lambda (count generator)
827 (declare (ignore generator))
828 (make-list count :initial-element 0)))
830 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
834 (generate-scale-free-graph
836 (make-container 'graph-container :default-edge-type :undirected)
841 (lambda (count generator)
842 (declare (ignore generator))
843 (make-list count :initial-element 0)))
845 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
848 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
849 ;;; 102,959,032 words consed
850 Execution time profile from 2078 samples
853 Children Relative Absolute Consing Conses
855 %%check-keywords 99% 99% 100,970,656
856 sample-existing-vertexes 62%
857 insert-item <weighted-sampler-with-lookup-container> <t> 32%
858 add-vertex <basic-graph> <t> 2%
860 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
862 iterate-container <contents-as-array-mixin> <t> 1%
864 %%check-keywords 100%
865 sample-existing-vertexes 62% 61% 62,577,336
866 walk-tree-nodes <bst-node> <t> 99%
869 sample-existing-vertexes 100%
870 walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
871 #<anonymous function #xaa2070e> 77%
873 element-weight <weighted-sampling-container> <t> 2%
878 walk-tree-nodes <bst-node> <t> 98%
879 %%before-and-after-combined-method-dcode 2%
880 #<anonymous function #xaa2070e> 48% 47% 48,156,256
881 iterate-container <contents-as-array-mixin> <t> 73%
882 %%1st-two-arg-dcode 9%
883 iterate-edges <graph-container-vertex> <t> 6%
885 iterate-elements <abstract-container> <t> 2%
887 #<anonymous function #xaa2070e> 99%
889 iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
890 other-vertex <graph-container-edge> <graph-container-vertex> 43%
892 #<anonymous function #x271d31e> 10%
894 insert-item <weighted-sampler-with-lookup-container> <t> 92%
895 %make-std-instance 3%
897 %%standard-combined-method-dcode 1%
899 %%before-and-after-combined-method-dcode 34% 34% 34,400,720
900 insert-item <binary-search-tree> <bst-node> 90%
901 #<anonymous function #xaa2070e> 2%
902 shared-initialize <standard-object> <t> 2%
907 %%check-keywords 100%
908 insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
909 %%before-and-after-combined-method-dcode 100%
911 %%before-and-after-combined-method-dcode 100%
912 insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
916 insert-item <binary-search-tree> <bst-node> 99%
917 #<anonymous function #xaa2070e> 1%
918 %vertex-degree 26% 25% 25,870,312
919 #<anonymous function #xa7cee86> 68%
921 %std-slot-value-using-class 1%
924 iterate-container <contents-as-array-mixin> <t> 1%
927 iterate-container <contents-as-array-mixin> <t> 1%
928 #<anonymous function #xa7cee86> 18% 17% 17,420,592
929 %maybe-std-slot-value-using-class 8%
931 %std-slot-value-using-class 8%
933 vertex-1 <graph-container-edge> 5%
934 #<anonymous function #x271d31e> 1%
936 iterate-container <contents-as-array-mixin> <t> 99%
937 #<anonymous function #xa7cee86> 1%
938 other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
941 iterate-container <contents-as-array-mixin> <t> 95%
943 %%before-and-after-combined-method-dcode 1%
944 initialize-instance (around) <basic-initial-contents-mixin> 1%
945 %%nth-arg-dcode 7% 9% 9,238,560
947 #<anonymous function #xaa2070e> 93%
948 walk-tree-nodes <bst-node> <t> 5%
949 %%before-and-after-combined-method-dcode 2%
950 %%1st-two-arg-dcode 5% 5% 4,802,264
952 iterate-container <contents-as-array-mixin> <t> 96%
953 #<anonymous function #xa7cee86> 3%
954 shared-initialize <standard-object> <t> 1%
955 #<anonymous function #x271d31e> 4% 4% 4,012,368
957 #<anonymous function #xaa2070e> 100%
958 iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
960 #<anonymous function #xa7cee86> 59%
962 walk-tree-nodes <bst-node> <t> 13%
963 shared-initialize <standard-object> <t> 6%
964 %shared-initialize 4%
965 other-vertex <graph-container-edge> <graph-container-vertex> 2%
967 %std-slot-value-using-class 2% 2% 2,115,320
969 #<anonymous function #xa7cee86> 59%
970 walk-tree-nodes <bst-node> <t> 12%
972 %%before-and-after-combined-method-dcode 6%
973 shared-initialize <standard-object> <t> 4%
975 other-vertex <graph-container-edge> <graph-container-vertex> 4%
976 %shared-initialize 2%
977 %%one-arg-dcode 2% 2% 2,478,304
979 make-instance <symbol> 68%
981 make-instance <standard-class> 9%
982 %make-std-instance 2% 2% 2,283,344
983 %%before-and-after-combined-method-dcode 47%
984 shared-initialize <standard-object> <t> 15%
985 %%standard-combined-method-dcode 12%
986 %maybe-std-slot-value-using-class 3%
988 #<anonymous function #xa7cee86> 78%
991 %make-std-instance 2%
992 shared-initialize <standard-object> <t> 3%
993 view-get <simple-view> <t> 2%
994 walk-tree-nodes <bst-node> <t> 3%
995 %maybe-std-slot-value-using-class 2% 2% 2,005,048
997 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
998 add-vertex <basic-graph> <t> 40%
999 initialize-instance (after) <graph-container-vertex> 7%
1001 %%before-and-after-combined-method-dcode 5%
1002 make-instance <symbol> 2% 2% 1,932,504
1003 %make-std-instance 92%
1005 #<anonymous function #xaa2070e> 100%
1006 constantly 2% 2% 1,629,880
1008 walk-tree-nodes <bst-node> <t> 97%
1009 %%before-and-after-combined-method-dcode 3%
1011 %maybe-std-slot-value-using-class 3%
1013 %%check-keywords 100%
1014 add-vertex <basic-graph> <t> 2% 2% 2,259,304
1015 make-instance <symbol> 44%
1016 %%standard-combined-method-dcode 30%
1017 %%before-and-after-combined-method-dcode 8%
1018 %make-std-instance 3%
1020 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
1021 %%standard-combined-method-dcode 48%
1022 %%check-keywords 16%
1024 make-instance <symbol> 6%
1026 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
1027 add-vertex <basic-graph> <t> 25%
1028 %make-std-instance 18%
1029 make-instance <standard-class> 6%
1031 insert-item <weighted-sampler-with-lookup-container> <t> 3%
1032 %%standard-combined-method-dcode 2% 2% 2,019,832
1033 insert-item <container-uses-nodes-mixin> <t> 45%
1034 %%before-and-after-combined-method-dcode 25%
1036 make-instance <symbol> 3%
1038 #<GRAPH-CONTAINER 1000>
1043 (open-plot-in-window
1046 (clnuplot::data->n-buckets
1047 (sort (collect-items x :transform #'vertex-degree) #'>)
1052 (and (plusp (first x))
1053 (plusp (second x ))))
1056 (list (log (first x) 10) (log (second x)))))))
1060 (clasp:linear-regression-brief
1062 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1063 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1064 (3.2961164921697144 1.6094379124341003)
1065 (3.3831867994748994 1.9459101490553132)
1066 (3.4556821645007902 0.6931471805599453)
1067 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1068 (3.932600584500482 0.0))
1071 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1072 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1073 (3.2961164921697144 1.6094379124341003)
1074 (3.3831867994748994 1.9459101490553132)
1075 (3.4556821645007902 0.6931471805599453)
1076 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1077 (3.932600584500482 0.0))
1082 ;;; ---------------------------------------------------------------------------
1083 ;;; generate-assortative-graph-with-degree-distributions
1084 ;;; ---------------------------------------------------------------------------
1087 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1089 ;;; ---------------------------------------------------------------------------
1091 (defmethod generate-assortative-graph-with-degree-distributions
1092 (generator (graph-class symbol)
1093 edge-count assortativity-matrix
1095 degree-distributions
1097 &key (duplicate-edge-function 'identity))
1098 (generate-assortative-graph-with-degree-distributions
1099 generator (make-instance graph-class)
1100 edge-count assortativity-matrix
1102 degree-distributions
1104 :duplicate-edge-function duplicate-edge-function))
1107 Split into a function to compute some of the intermediate pieces and one to use them
1110 (defmethod generate-assortative-graph-with-degree-distributions
1111 (generator graph edge-count assortativity-matrix
1113 degree-distributions
1115 &key (duplicate-edge-function 'identity))
1116 (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1117 (let* ((kind-count (array-dimension assortativity-matrix 0))
1118 (vertex->degree-counts (make-array kind-count))
1120 (sample-edges-for-assortative-graph
1121 generator edge-count assortativity-matrix)))
1124 (append (element-counts edges :key #'first)
1125 (element-counts edges :key #'second))
1129 new) :key #'first :argument #'second)
1132 (vertex-counts (collect-elements
1135 (lambda (kind-and-count)
1136 (round (float (/ (second kind-and-count)
1137 (elt average-degrees (first kind-and-count))))))))
1138 (edge-samplers (make-array kind-count)))
1139 (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1141 ;; setup bookkeeping
1142 (loop for kind from 0 to (1- kind-count) do
1143 (setf (aref edge-samplers kind)
1144 (make-container 'vector-container)
1145 (aref vertex->degree-counts kind)
1146 (make-container 'simple-associative-container)))
1147 (loop for edge in edges do
1148 (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1149 (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1151 edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1153 ;(spy edges degree-sums vertex-counts)
1155 (loop for kind from 0 to (1- kind-count)
1156 for count in vertex-counts do
1157 (let ((distribution (nth-element degree-distributions kind))
1158 (vertexes (make-container 'vector-container))
1159 (vertex-degrees (aref vertex->degree-counts kind))
1161 (desired-sum (second (elt degree-sums kind))))
1163 ;; for each type, create vertexes
1164 (loop for i from 0 to (1- count) do
1165 (let ((vertex (funcall vertex-creator kind i))
1166 (degree (funcall distribution)))
1167 (insert-item vertexes vertex)
1168 (setf (item-at-1 vertex-degrees vertex)
1170 (incf total-degree degree)))
1172 ;(spy vertexes total-degree desired-sum)
1174 ;; ensure proper total degree
1175 (loop while (/= total-degree desired-sum) do
1177 (when-debugging-format
1178 generate-assortative-graph-with-degree-distributions
1179 "Current: ~D, Desired: ~D, Difference: ~D"
1180 total-degree desired-sum
1181 (abs (- total-degree desired-sum)))
1182 (let* ((vertex (sample-element vertexes generator))
1183 (bigger? (< total-degree desired-sum))
1184 (current-degree (item-at-1 vertex-degrees vertex))
1189 (plusp current-degree)))
1190 (decf total-degree current-degree)
1193 (when-debugging-format
1194 generate-assortative-graph-with-degree-distributions
1196 total-degree current-degree new-degree (not bigger?))
1198 ;; increase speed by knowing which direction we need to go...?
1199 (loop until (or (zerop (decf attempts))
1201 (> (setf new-degree (funcall distribution))
1204 (< (setf new-degree (funcall distribution))
1205 current-degree))) do
1207 (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1209 (cond ((plusp attempts)
1212 generate-assortative-graph-with-degree-distributions
1213 (format *debug-io* " -> ~D" new-degree))
1215 (setf (item-at-1 vertex-degrees vertex) new-degree)
1216 (incf total-degree new-degree)
1219 (when-debugging-format
1220 generate-assortative-graph-with-degree-distributions
1221 "~D ~D" total-degree desired-sum))
1223 ;; couldn't find one, try again
1224 (incf total-degree current-degree))))))
1227 (let ((edge-sampler (aref edge-samplers kind)))
1228 (flet ((sample-edges-for-vertex (vertex)
1230 (loop repeat (item-at-1 vertex-degrees vertex) do
1231 (bind (((edge-kind . edge) (delete-last edge-sampler)))
1233 (:source (setf (first edge) vertex))
1234 (:target (setf (second edge) vertex)))))))
1237 #'sample-edges-for-vertex)))))
1239 ;; repair self edges
1242 ;; now make the graph [at last]
1246 (add-edge-between-vertexes graph (first edge) (second edge)
1247 :if-duplicate-do duplicate-edge-function))))
1252 (generate-assortative-graph-with-degree-distributions
1256 #2A((0.1111111111111111 0.2222222222222222)
1257 (0.2222222222222222 0.4444444444444444))
1259 #2A((0.011840772766222637 0.04524421593830334)
1260 (0.04524421593830334 0.8976707953571706))
1263 (make-degree-sampler
1265 (poisson-vertex-degree-distribution 3 i))
1266 :generator *random-generator*)
1267 (make-degree-sampler
1269 (poisson-vertex-degree-distribution 3 i))
1270 :generator *random-generator*))
1272 (lambda (kind count)
1273 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1278 (sample-edges-for-assortative-graph
1281 #2A((0.1111111111111111 0.2222222222222222)
1282 (0.2222222222222222 0.4444444444444444))))
1285 ;;; ---------------------------------------------------------------------------
1286 ;;; generate-graph-by-resampling-edges
1287 ;;; ---------------------------------------------------------------------------
1290 doesn't take edge weights into account when sampling
1292 should include pointer back to original graph
1295 (defclass* basic-edge-sampler ()
1299 ;;; ---------------------------------------------------------------------------
1301 (defmethod next-element ((sampler basic-edge-sampler))
1302 (sample-element (graph-edges (graph sampler)) (generator sampler)))
1304 ;;; ---------------------------------------------------------------------------
1306 (defclass* weighted-edge-sampler (basic-edge-sampler)
1307 ((weight-so-far 0 a)
1308 (index-iterator nil r)
1309 (edge-iterator nil r)
1312 ;;; ---------------------------------------------------------------------------
1314 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1315 (bind ((generator (generator object))
1316 (weighted-edge-count
1318 (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1320 (unless (size object)
1321 (setf (slot-value object 'size) weighted-edge-count))
1322 (setf (slot-value object 'index-iterator)
1324 (sort (loop repeat (size object) collect
1325 (integer-random generator 1 weighted-edge-count)) #'<))
1326 (slot-value object 'edge-iterator)
1327 (make-iterator (graph-edges (graph object))))))
1329 ;;; ---------------------------------------------------------------------------
1331 (defmethod next-element ((object weighted-edge-sampler))
1332 (let ((edge-iterator (edge-iterator object))
1333 (index-iterator (index-iterator object)))
1334 (move-forward index-iterator)
1335 (loop while (< (weight-so-far object) (current-element index-iterator)) do
1336 (move-forward edge-iterator)
1337 (incf (weight-so-far object) (weight (current-element edge-iterator))))
1338 (current-element edge-iterator)))
1340 ;;; ---------------------------------------------------------------------------
1342 (defmethod generate-graph-by-resampling-edges
1343 (generator original-graph &key
1344 (edge-sampler-class 'basic-edge-sampler)
1345 (edge-count (edge-count original-graph)))
1346 (let ((graph (copy-template original-graph))
1347 (edge-sampler (make-instance edge-sampler-class
1348 :generator generator
1349 :graph original-graph
1351 (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1357 (add-vertex graph (element v))))
1360 (loop repeat edge-count do
1361 (let ((edge (next-element edge-sampler)))
1362 (if (directed-edge-p edge)
1363 (add-edge-between-vertexes
1364 graph (element (source-vertex edge)) (element (target-vertex edge))
1365 :edge-type :directed
1366 :if-duplicate-do (lambda (e) (incf (weight e))))
1367 (add-edge-between-vertexes
1368 graph (element (vertex-1 edge)) (element (vertex-2 edge))
1369 :edge-type :undirected
1370 :if-duplicate-do (lambda (e) (incf (weight e)))))))
1375 (fluid-bind (((random-seed *random-generator*) 1))
1376 (let* ((dd-1 (lambda (i)
1378 (power-law-vertex-degree-distribution 3 i)
1379 (poisson-vertex-degree-distribution 3 i)))
1382 (power-law-vertex-degree-distribution 3 i)
1383 (poisson-vertex-degree-distribution 3 i)))
1384 (g (generate-assortative-graph-with-degree-distributions
1386 (make-instance 'graph-container
1387 :default-edge-type :undirected
1388 :undirected-edge-class 'weighted-edge)
1390 #2A((0.011840772766222637 0.04524421593830334)
1391 (0.04524421593830334 0.8976707953571706))
1394 (make-degree-sampler
1396 :generator *random-generator*
1398 :min-probability nil)
1399 (make-degree-sampler
1401 :generator *random-generator*
1403 :min-probability nil))
1404 #'simple-group-id-generator
1405 :duplicate-edge-function (lambda (e) (incf (weight e))))))
1407 (average-vertex-degree
1409 :vertex-filter (lambda (v)
1410 (plusp (edge-count v)))
1411 :edge-size #'weight)))
1413 (loop for i from 1 to 10
1415 (fluid-bind (((random-seed *random-generator*) i))
1417 (generate-graph-by-resampling-edges
1418 *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1420 ;;; ---------------------------------------------------------------------------
1421 ;;; some preferential attachment algorithms
1422 ;;; ---------------------------------------------------------------------------
1425 (define-debugging-class generate-preferential-attachment-graph
1428 ;;; ---------------------------------------------------------------------------
1430 (defmethod generate-simple-preferential-attachment-graph
1431 (generator (graph-class symbol) size minimum-degree)
1432 (generate-simple-preferential-attachment-graph
1433 generator (make-instance graph-class) size minimum-degree))
1435 ;;; ---------------------------------------------------------------------------
1437 (defmethod generate-simple-preferential-attachment-graph
1438 (generator graph size minimum-degree)
1439 (bind ((m (make-array (list (* 2 size minimum-degree)))))
1440 (loop for v from 0 to (1- size) do
1441 (loop for i from 0 to (1- minimum-degree) do
1442 (bind ((index (* 2 (+ i (* v minimum-degree))))
1443 (r (integer-random generator 0 index)))
1444 (setf (item-at m index) v
1445 (item-at m (1+ index)) (item-at m r)))))
1446 (loop for i from 0 to (1- (* size minimum-degree)) do
1447 (add-edge-between-vertexes
1448 graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1453 (generate-simple-preferential-attachment-graph
1455 (make-container 'graph-container :default-edge-type :undirected)
1461 (collect-nodes (ds :g-b)
1462 :transform (lambda (v) (list (element v) (vertex-degree v))))
1467 ;;; ---------------------------------------------------------------------------
1469 (defmethod generate-preferential-attachment-graph
1470 (generator (graph-class symbol) size kind-matrix minimum-degree
1471 assortativity-matrix
1472 &key (vertex-labeler 'simple-group-id-generator)
1473 (duplicate-edge-function :ignore))
1474 (generate-preferential-attachment-graph
1475 generator (make-instance graph-class)
1476 size kind-matrix minimum-degree assortativity-matrix
1477 :vertex-labeler vertex-labeler
1478 :duplicate-edge-function duplicate-edge-function))
1480 ;;; ---------------------------------------------------------------------------
1482 (defmethod generate-preferential-attachment-graph
1483 (generator (graph basic-graph) size kind-matrix minimum-degree
1484 assortativity-matrix
1485 &key (vertex-labeler 'simple-group-id-generator)
1486 (duplicate-edge-function :ignore))
1487 (bind ((kind-count (array-dimension kind-matrix 0))
1488 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1489 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1490 (edge-recorders (make-array (list kind-count)))
1491 (count-recorders (make-array (list kind-count) :initial-element 0))
1492 (edge-samplers (make-array (list kind-count))))
1494 ;; set up record keeping
1495 (dotimes (i kind-count)
1496 (setf (aref edge-recorders i)
1497 (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1498 :initial-element nil))
1499 (setf (aref edge-samplers i)
1500 (make-edge-sampler-for-preferential-attachment-graph
1501 generator (array-row assortativity-matrix i))))
1503 ;; add vertexes (to ensure that we have something at which to point)
1504 (loop for v from 0 to (1- size)
1505 for kind in vertex-kinds do
1506 (bind ((edge-recorder (aref edge-recorders kind)))
1507 (loop for i from 0 to (1- minimum-degree) do
1508 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1509 (setf (item-at edge-recorder index)
1510 (funcall vertex-labeler kind v)))))
1511 (incf (aref count-recorders kind)))
1514 (dotimes (i kind-count)
1515 (setf (aref count-recorders i) 0))
1516 (loop for v from 0 to (1- size)
1517 for kind in vertex-kinds do
1518 (bind ((edge-recorder (aref edge-recorders kind))
1519 (edge-sampler (aref edge-samplers kind)))
1520 (loop for i from 0 to (1- minimum-degree) do
1521 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1522 (other-kind (funcall edge-sampler))
1523 (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1524 (aref count-recorders other-kind))
1526 (other-edge-recorder (aref edge-recorders other-kind))
1527 (r (integer-random generator 0 (1- other-index))))
1529 (when-debugging-format
1530 generate-preferential-attachment-graph
1531 "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1532 kind (1+ index) other-kind r other-index)
1533 (setf (item-at edge-recorder (1+ index))
1534 (cond ((item-at other-edge-recorder r)
1535 (item-at other-edge-recorder r))
1536 ((and (= kind other-kind)
1539 (item-at edge-recorder index))
1541 ;; haven't done the other one yet... save it for later fixing
1542 (list other-kind r))))))
1543 (incf (aref count-recorders kind))))
1546 (let ((corrections 0)
1547 (last-corrections nil)
1549 (loop while again? do
1552 (dotimes (kind kind-count)
1553 (loop for vertex across (aref edge-recorders kind)
1554 for index = 0 then (1+ index)
1555 when (consp vertex) do
1556 (bind (((other-kind other-index) vertex))
1558 (when-debugging-format
1559 generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1561 (aref (aref edge-recorders other-kind) other-index))
1563 (if (and (= kind other-kind) (= index other-index))
1564 ;; pointing at myself
1565 (setf (aref (aref edge-recorders kind) index)
1566 (aref (aref edge-recorders kind) (1- index)))
1567 (let ((new (aref (aref edge-recorders other-kind) other-index)))
1570 (setf (aref (aref edge-recorders kind) index) new))))))
1571 (when (and last-corrections
1572 (>= corrections last-corrections))
1573 (error "It's not getting any better old boy"))
1574 (setf last-corrections corrections)))
1576 ;; make sure we got 'em all
1577 (dotimes (i kind-count)
1578 (loop for vertex across (aref edge-recorders i)
1579 when (not (symbolp vertex)) do (error "bad function, down boy")))
1581 (dotimes (i kind-count)
1582 (let ((edge-recorder (aref edge-recorders i)))
1583 (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1584 (add-edge-between-vertexes
1585 graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1586 :if-duplicate-do duplicate-edge-function))))
1589 ;; record properties
1590 (record-graph-properties graph)
1591 (setf (get-value graph :initial-seed) (random-seed generator))
1592 (setf (get-value graph :size) size
1593 (get-value graph :minimum-degree) minimum-degree
1594 (get-value graph :assortativity-matrix) assortativity-matrix
1595 (get-value graph :duplicate-edge-function) duplicate-edge-function)
1600 ;;; ---------------------------------------------------------------------------
1602 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1603 (let ((c (make-container 'weighted-sampling-container
1604 :random-number-generator generator
1606 (aref assortativities item)))))
1607 (dotimes (i (array-dimension assortativities 0))
1609 (lambda () (next-element c))))
1614 (make-edge-sampler-for-preferential-attachment-graph
1615 *random-generator* #(0.02 0.25 0.25))))
1616 (loop repeat 100 collect (funcall s)))
1620 (setf (random-seed *random-generator*) 2)
1621 (generate-preferential-attachment-graph
1623 (make-graph 'graph-container :edge-type :undirected)
1627 #2A((0.96 0.02 0.02)
1632 (generate-preferential-attachment-graph
1634 (make-graph 'graph-container :edge-type :undirected)
1638 #2A((0.96 0.02 0.02)
1644 (generate-preferential-attachment-graph
1646 (make-graph 'graph-container :edge-type :undirected)
1650 #2A((0.96 0.02 0.02)
1654 ;;; ---------------------------------------------------------------------------
1656 (defmethod generate-acquaintance-network
1657 (generator graph size death-probability iterations vertex-labeler
1658 &key (duplicate-edge-function :ignore))
1659 ;; bring the graph up to size
1660 (loop for i from (size graph) to (1- size) do
1661 (add-vertex graph (funcall vertex-labeler 0 i)))
1663 (loop repeat iterations do
1664 (add-acquaintance-and-maybe-kill-something
1665 generator graph death-probability duplicate-edge-function))
1668 ;;; ---------------------------------------------------------------------------
1670 (defmethod generate-acquaintance-network-until-stable
1671 (generator graph size death-probability step-count
1672 stability-fn vertex-labeler
1673 &key (duplicate-edge-function :ignore))
1674 ;; bring the graph up to size
1675 (loop for i from (size graph) to (1- size) do
1676 (add-vertex graph (funcall vertex-labeler 0 i)))
1679 (loop repeat step-count do
1680 (add-acquaintance-and-maybe-kill-something
1681 generator graph death-probability duplicate-edge-function))
1682 (when (funcall stability-fn graph)
1687 ;;; ---------------------------------------------------------------------------
1689 (defun add-acquaintance-and-maybe-kill-something
1690 (generator graph death-probability duplicate-edge-function)
1692 (bind ((vertex (sample-element (graph-vertexes graph) generator))
1693 (neighbors (when (>= (size (vertex-edges vertex)) 2)
1694 (sample-unique-elements
1695 (vertex-edges vertex) generator 2))))
1696 (flet ((sample-other-vertex ()
1697 (loop for result = (sample-element (graph-vertexes graph) generator)
1698 until (not (eq vertex result))
1699 finally (return result)))) ;; CTM: 'finally do' not legal in openMCL
1701 (add-edge-between-vertexes
1703 (other-vertex (first neighbors) vertex)
1704 (other-vertex (second neighbors) vertex)
1705 :if-duplicate-do duplicate-edge-function)
1706 (add-edge-between-vertexes
1707 graph vertex (sample-other-vertex)
1708 :if-duplicate-do duplicate-edge-function))))
1710 ;; remove vertexes step
1711 (when (random-boolean generator death-probability)
1712 (let ((vertex (sample-element (graph-vertexes graph) generator)))
1713 (delete-vertex graph vertex)
1714 (add-vertex graph (element vertex)))))
1717 (generate-acquaintance-network
1719 (make-graph 'graph-container :edge-type :undirected)
1723 'simple-group-id-generator)