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))))
102 (assert (<= m max-edge-index))
104 (save-generation-information graph generator 'generate-gnm)
105 (loop for i from 0 to (1- n) do
106 (add-vertex graph (funcall label i)))
107 (loop for i from 0 to (1- m) do
109 until (let* ((i (integer-random generator 0 max-edge-index))
110 (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
111 (w (- i (/ (* v (1- v)) 2)))
112 (label-v (funcall label v))
113 (label-w (funcall label w)))
114 (unless (find-edge-between-vertexes
115 graph label-v label-w :error-if-not-found? nil)
116 (add-edge-between-vertexes graph label-v label-w)))))
122 (setf g (generate-gnm
124 'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
127 ;;; ---------------------------------------------------------------------------
129 (defun vertex-group (v)
130 (aref (symbol-name (element v)) 1))
132 ;;; ---------------------------------------------------------------------------
134 (defun in-group-degree (v &key (key 'vertex-group))
136 v :edge-filter (lambda (e ov)
138 (in-same-group-p v ov key))))
140 ;;; ---------------------------------------------------------------------------
142 (defun in-same-group-p (v1 v2 key)
143 (eq (funcall key v1) (funcall key v2)))
145 ;;; ---------------------------------------------------------------------------
147 (defun out-group-degree (v &key (key 'vertex-group))
149 v :edge-filter (lambda (e ov)
151 (not (in-same-group-p v ov key)))))
153 ;;; ---------------------------------------------------------------------------
154 ;;; generate-undirected-graph-via-assortativity-matrix
155 ;;; ---------------------------------------------------------------------------
157 (defmethod generate-undirected-graph-via-assortativity-matrix
158 (generator (graph-class symbol) size edge-count
159 kind-matrix assortativity-matrix vertex-creator
160 &key (duplicate-edge-function 'identity))
161 (generate-undirected-graph-via-assortativity-matrix
162 generator (make-instance graph-class) size edge-count
163 kind-matrix assortativity-matrix vertex-creator
164 :duplicate-edge-function duplicate-edge-function))
166 ;;; ---------------------------------------------------------------------------
168 (defmethod generate-undirected-graph-via-assortativity-matrix
169 (generator graph size edge-count
170 kind-matrix assortativity-matrix vertex-creator
171 &key (duplicate-edge-function 'identity))
172 (let* ((kind-count (array-dimension assortativity-matrix 0))
173 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
175 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
176 (vertex-sampler (make-array kind-count))
177 (edge-kinds (sample-edges-for-assortative-graph
178 generator edge-count assortativity-matrix))
180 (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
182 (loop for vertex-kind from 0 to (1- kind-count)
183 for count in vertex-kind-counts do
184 (setf (aref vertex-sampler vertex-kind)
185 (make-array (second count))))
187 (let ((current-kind 0)
189 (current-vertexes (aref vertex-sampler 0)))
191 (loop for kind in vertex-kinds
193 (when (not (eq current-kind kind))
194 (setf current-count 0
196 current-vertexes (aref vertex-sampler current-kind)))
197 (let ((vertex (funcall vertex-creator kind i)))
198 (setf (aref current-vertexes current-count) vertex)
199 (add-vertex graph vertex)
200 (incf current-count)))
202 (loop for (from-kind to-kind) in edge-kinds do
205 (if (= from-kind to-kind)
206 (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
208 (setf v1 (first sample) v2 (second sample)))
209 (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
210 v2 (sample-element (aref vertex-sampler to-kind) generator)))
211 (add-edge-between-vertexes
215 :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
219 ;;; ---------------------------------------------------------------------------
220 ;;; generate-undirected-graph-via-verex-probabilities
221 ;;; ---------------------------------------------------------------------------
223 (defmethod generate-undirected-graph-via-vertex-probabilities
224 (generator (graph-class symbol) size
225 kind-matrix probability-matrix vertex-creator)
226 (generate-undirected-graph-via-vertex-probabilities
227 generator (make-instance graph-class) size
228 kind-matrix probability-matrix vertex-creator))
230 ;;; ---------------------------------------------------------------------------
232 (defmethod generate-undirected-graph-via-vertex-probabilities
233 (generator graph size
234 kind-matrix probability-matrix vertex-creator)
235 (let* ((kind-count (array-dimension probability-matrix 0))
236 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
238 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
239 (vertex-sampler (make-array kind-count)))
240 (save-generation-information graph generator
241 'generate-undirected-graph-via-vertex-probabilities)
243 ;; initialize vertex bookkeeping
244 (loop for vertex-kind from 0 to (1- kind-count)
245 for count in vertex-kind-counts do
246 (setf (aref vertex-sampler vertex-kind)
247 (make-array (second count))))
250 (let ((current-kind 0)
252 (current-vertexes (aref vertex-sampler 0)))
253 (loop for kind in vertex-kinds
255 (when (not (eq current-kind kind))
256 (setf current-count 0
258 current-vertexes (aref vertex-sampler current-kind)))
259 (let ((vertex (funcall vertex-creator kind i)))
260 (setf (aref current-vertexes current-count) vertex)
261 (add-vertex graph vertex)
262 (incf current-count))))
265 ;; adjust probabilities
266 (loop for (kind-1 count-1) in vertex-kind-counts do
267 (loop for (kind-2 count-2) in vertex-kind-counts
268 when (<= kind-1 kind-2) do
269 (format t "~%~6,6F ~6,6F"
270 (aref probability-matrix kind-1 kind-2)
271 (float (/ (aref probability-matrix kind-1 kind-2)
272 (* count-1 count-2))))
273 (setf (aref probability-matrix kind-1 kind-2)
274 (float (/ (aref probability-matrix kind-1 kind-2)
275 (* count-1 count-2))))))
278 (flet ((add-one-edge (k1 k2 a b)
279 (add-edge-between-vertexes
281 (aref (aref vertex-sampler k1) a)
282 (aref (aref vertex-sampler k2) b))))
283 (loop for (kind-1 count-1) in vertex-kind-counts do
284 (loop for (kind-2 count-2) in vertex-kind-counts
285 when (<= kind-1 kind-2) do
286 (if (eq kind-1 kind-2)
287 (sample-edges-of-same-kind
288 generator count-1 (aref probability-matrix kind-1 kind-2)
290 (add-one-edge kind-1 kind-2 a b)))
291 (sample-edges-of-different-kinds
292 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
294 (add-one-edge kind-1 kind-2 a b)))))))
299 (defmethod generate-undirected-graph-via-vertex-probabilities
300 (generator graph size
301 kind-matrix probability-matrix vertex-creator)
302 (let* ((kind-count (array-dimension probability-matrix 0))
303 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
305 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
306 (vertex-sampler (make-array kind-count)))
308 (loop for vertex-kind from 0 to (1- kind-count)
309 for count in vertex-kind-counts do
310 (setf (aref vertex-sampler vertex-kind)
311 (make-array (second count))))
313 (let ((current-kind 0)
315 (current-vertexes (aref vertex-sampler 0)))
317 (loop for kind in vertex-kinds
319 (when (not (eq current-kind kind))
320 (setf current-count 0
322 current-vertexes (aref vertex-sampler current-kind)))
323 (let ((vertex (funcall vertex-creator kind i)))
324 (setf (aref current-vertexes current-count) vertex)
325 (add-vertex graph vertex)
326 (incf current-count))))
329 (flet ((add-one-edge (k1 k2 a b)
331 (add-edge-between-vertexes
333 (aref (aref vertex-sampler k1) a)
334 (aref (aref vertex-sampler k2) b))))
335 (loop for (kind-1 count-1) in vertex-kind-counts do
336 (loop for (kind-2 count-2) in vertex-kind-counts
337 when (<= kind-1 kind-2) do
339 (if (eq kind-1 kind-2)
340 (sample-edges-of-same-kind
341 generator count-1 (aref probability-matrix kind-1 kind-2)
343 (add-one-edge kind-1 kind-2 a b)))
344 (sample-edges-of-different-kinds
345 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
347 (add-one-edge kind-1 kind-2 a b))))
348 (format t "~%~A ~A ~A ~A -> ~A"
349 count-1 count-2 kind-1 kind-2 xxx)))))
354 (generate-undirected-graph-via-vertex-probabilities
355 *random-generator* 'graph-container
358 #2A((0.1 0.02) (0.02 0.6))
360 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
362 ;;; ---------------------------------------------------------------------------
364 (defun sample-edges-of-same-kind (generator n p fn)
368 (log-1-p (log (- 1 p))))
369 (loop while (< v n) do
370 (let ((r (uniform-random generator 0d0 1d0)))
371 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
372 (loop while (and (>= w v) (< v n)) do
376 (funcall fn v w)))))))
379 (sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
381 ;;; ---------------------------------------------------------------------------
383 (defun sample-edges-of-different-kinds (generator rows cols p fn)
387 (log-1-p (log (- 1 p))))
388 (loop while (< v rows) do
389 (let ((r (uniform-random generator 0d0 1d0)))
390 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
391 (loop while (and (>= w cols) (< v rows)) do
395 (funcall fn v w)))))))
397 ;;; ---------------------------------------------------------------------------
399 (defun poisson-vertex-degree-distribution (z k)
400 (/ (* (expt z k) (expt +e+ (- z)))
404 We know the probability of finding a vertex of degree k is p_k. We want to sample
405 from this distribution
408 ;;; ---------------------------------------------------------------------------
410 (defun power-law-vertex-degree-distribution (kappa k)
411 (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
413 ;;; ---------------------------------------------------------------------------
415 (defun create-specified-vertex-degree-distribution (degrees)
417 (declare (ignore z k))
420 ;;; ---------------------------------------------------------------------------
422 (defun make-degree-sampler (p_k &key (generator *random-generator*)
424 (min-probability 0.0001))
425 (let ((wsc (make-container 'containers:weighted-sampling-container
426 :random-number-generator generator
430 (loop for k = 0 then (1+ k)
431 for p = (funcall p_k k)
432 until (or (and max-degree (> k max-degree))
433 (and min-probability (< (- 1.0 total) min-probability))) do
436 (insert-item wsc (list k p)))
437 (when (plusp (- 1.0 total))
438 (insert-item wsc (list (1+ max-k) (- 1.0 total))))
440 (first (next-element wsc)))))
442 ;;; ---------------------------------------------------------------------------
445 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
446 (let ((c (make-container 'weighted-sampling-container
447 :random-number-generator generator
449 (aref assortativity-matrix (first item) (second item))))))
450 (dotimes (i (array-dimension assortativity-matrix 0))
451 (dotimes (j (array-dimension assortativity-matrix 1))
452 (insert-item c (list i j))))
453 (loop repeat edge-count collect
456 ;;; ---------------------------------------------------------------------------
458 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
459 (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
460 (loop repeat edge-count collect
463 ;;; ---------------------------------------------------------------------------
465 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
466 (let ((c (make-container 'weighted-sampling-container
467 :random-number-generator generator
469 (aref assortativity-matrix (first item) (second item))))))
470 (dotimes (i (array-dimension assortativity-matrix 0))
471 (dotimes (j (array-dimension assortativity-matrix 1))
472 (insert-item c (list i j))))
473 (lambda () (next-element c))))
475 ;;; ---------------------------------------------------------------------------
477 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
478 (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
479 ;; use kind-matrix as counts
480 (assert (= size (sum-of-array-elements kind-matrix)))
481 (coerce (shuffle-elements!
484 (loop for i = 0 then (1+ i)
485 for count across kind-matrix nconc
486 (make-list count :initial-element i)))
487 :generator generator)
491 ;; use kind-matrix as ratios to sample
492 (let* ((c (make-container 'weighted-sampling-container
493 :random-number-generator generator
495 (aref kind-matrix item)))))
496 (dotimes (i (array-dimension kind-matrix 0))
498 (loop repeat size collect
499 (next-element c))))))
502 (sample-vertexes-for-mixed-graph
504 50 #2A((0.258 0.016 0.035 0.013)
505 (0.012 0.157 0.058 0.019)
506 (0.013 0.023 0.306 0.035)
507 (0.005 0.007 0.024 0.016)))
510 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
511 (0.012 0.157 0.058 0.019)
512 (0.013 0.023 0.306 0.035)
513 (0.005 0.007 0.024 0.016)))
515 (let ((a #2A((0.258 0.016 0.035 0.013)
516 (0.012 0.157 0.058 0.019)
517 (0.013 0.023 0.306 0.035)
518 (0.005 0.007 0.024 0.016)))
519 (c (make-container 'weighted-sampling-container :key #'second)))
522 (insert-item c (list (list i j) (aref a i j)))))
524 (loop repeat 1000 collect
530 (let ((a #2A((0.258 0.016 0.035 0.013)
531 (0.012 0.157 0.058 0.019)
532 (0.013 0.023 0.306 0.035)
533 (0.005 0.007 0.024 0.016)))
534 (c (make-container 'weighted-sampling-container :key #'second)))
536 (loop repeat 100000 do
540 (defun foo (percent-bad percent-mixing)
541 (let ((kind-matrix (make-array 2 :initial-element 0d0))
542 (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
543 (setf (aref kind-matrix 0) (- 1d0 percent-bad)
544 (aref kind-matrix 1) percent-bad
545 (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
546 (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
547 (aref mixing-matrix 1 0) percent-mixing
548 (aref mixing-matrix 0 1) percent-mixing)
549 (normalize-matrix kind-matrix)
550 (setf mixing-matrix (normalize-matrix mixing-matrix))
555 ;;; ---------------------------------------------------------------------------
556 ;;; girvan-newman-test-graphs
557 ;;; ---------------------------------------------------------------------------
559 (defun generate-girvan-newman-graph (generator graph-class z-in)
560 (warn "This is broken!")
561 (bind ((g (make-instance graph-class))
565 (z-out (- edge-count z-in))
566 (vertexes (make-container 'simple-associative-container))
567 (groups (make-container 'alist-container)))
568 (save-generation-information g generator
569 'generate-girvan-newman-graph)
570 (labels ((make-id (group index)
571 (form-keyword "A" group "0" index))
573 (choose-inner-id (group id)
574 (check-type group fixnum)
575 (check-type id symbol)
577 (let ((other (sample-element (item-at groups group :needs-in) generator)))
581 (not (find-edge-between-vertexes
582 g id other :error-if-not-found? nil)))
583 (return-from choose-inner-id other)))))
585 (choose-outer-id (from-group id)
586 (declare (ignore id))
588 (check-type from-group fixnum)
590 (bind ((other-group (integer-random generator 0 (- group-count 2)))
591 (other (sample-element
592 (item-at groups (if (= from-group other-group)
594 other-group) :needs-out)
598 (not (find-edge-between-vertexes
599 g id other :error-if-not-found? nil)))
600 (return-from choose-outer-id other)))))
602 (make-in-edge (from to)
603 (let ((group (gn-id->group from)))
604 (when (zerop (decf (first (item-at vertexes from))))
605 (setf (item-at groups group :needs-in)
606 (remove from (item-at groups group :needs-in))))
607 (when (zerop (decf (first (item-at vertexes to))))
608 (setf (item-at groups group :needs-in)
609 (remove to (item-at groups group :needs-in))))
610 (add-edge-between-vertexes
611 g from to :edge-type :undirected
612 :if-duplicate-do (lambda (e) (incf (weight e))))))
614 (make-out-edge (from to)
615 (let ((group-from (gn-id->group from))
616 (group-to (gn-id->group to)))
617 (when (zerop (decf (second (item-at vertexes from))))
618 (setf (item-at groups group-from :needs-out)
619 (remove from (item-at groups group-from :needs-out))))
620 (when (zerop (decf (second (item-at vertexes to))))
621 (setf (item-at groups group-to :needs-out)
622 (remove to (item-at groups group-to :needs-out))))
624 (add-edge-between-vertexes
625 g from to :edge-type :undirected
626 :if-duplicate-do (lambda (e) (incf (weight e)))))))
629 (loop for group from 0 to (1- group-count) do
630 (loop for index from 0 to (1- group-size) do
631 (let ((id (make-id group index)))
632 (setf (item-at vertexes id) (list z-in z-out))
634 (push id (item-at groups group :needs-in)))
636 (push id (item-at groups group :needs-out))))))
639 (loop for group from 0 to (1- group-count) do
640 (loop for index from 0 to (1- group-size) do
641 (let ((from (make-id group index)))
643 (loop while (plusp (first (item-at vertexes from))) do
644 (make-in-edge from (choose-inner-id group from)))
645 (loop while (plusp (second (item-at vertexes from))) do
646 (make-out-edge from (choose-outer-id group from)))))))
650 ;;; ---------------------------------------------------------------------------
652 (defun gn-id->group (id)
653 (parse-integer (subseq (symbol-name id) 1 2)))
655 ;;; ---------------------------------------------------------------------------
657 (defun collect-edge-counts (g)
658 (let ((vertexes (make-container 'simple-associative-container
659 :initial-element-fn (lambda () (list 0 0)))))
663 (bind ((v1 (vertex-1 e))
667 (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
668 (incf (first (item-at vertexes id1)) (weight e))
669 (incf (first (item-at vertexes id2)) (weight e)))
671 (incf (second (item-at vertexes id1)) (weight e))
672 (incf (second (item-at vertexes id2)) (weight e)))))))
676 :transform (lambda (k v) (list k (first v) (second v))))
680 ;;; ---------------------------------------------------------------------------
682 (defclass* weighted-sampler-with-lookup-container ()
686 ;;; ---------------------------------------------------------------------------
688 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
689 &key random-number-generator key)
690 (setf (slot-value object 'sampler)
691 (make-container 'weighted-sampling-container
692 :random-number-generator random-number-generator
694 (slot-value object 'lookup)
695 (make-container 'simple-associative-container)))
697 ;;; ---------------------------------------------------------------------------
699 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
701 (let ((node (nth-value 1 (insert-item (sampler container) item))))
703 (assert (not (null node)))
704 (setf (item-at-1 (lookup container) item) node)))
706 ;;; ---------------------------------------------------------------------------
708 (defmethod find-node ((container weighted-sampler-with-lookup-container)
710 (item-at-1 (lookup container) item))
712 ;;; ---------------------------------------------------------------------------
714 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
716 ;; not going to worry about the hash table
717 (delete-node (sampler container) node))
719 ;;; ---------------------------------------------------------------------------
721 (defmethod next-element ((container weighted-sampler-with-lookup-container))
722 (next-element (sampler container)))
724 ;;; ---------------------------------------------------------------------------
726 (defmethod generate-scale-free-graph
727 (generator graph size kind-matrix add-edge-count
728 other-vertex-kind-samplers
730 &key (duplicate-edge-function 'identity))
731 (let* ((kind-count (array-dimension kind-matrix 0))
732 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
733 (vertex-sampler (make-array kind-count)))
734 (save-generation-information graph generator 'generate-scale-free-graph)
735 (flet ((sample-existing-vertexes (for-kind)
736 ;; return list of vertexes to attach based on preferential attachment
737 (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
738 add-edge-count generator) collect
739 (let ((vertex (next-element (aref vertex-sampler other-kind))))
742 for nil across vertex-sampler
744 (setf vertex (next-element (aref vertex-sampler i))
747 ;;?? remove. this should never happen
748 (unless vertex (break))
750 (list vertex other-kind))))
752 ;; handle bookkeeping for changed vertex degree
753 (bind ((sampler (aref vertex-sampler kind))
754 (node (find-node sampler thing)))
755 (delete-node sampler node)
756 (insert-item sampler thing))))
760 for nil across vertex-sampler do
761 (setf (aref vertex-sampler i)
762 (make-container 'weighted-sampler-with-lookup-container
763 :random-number-generator generator
764 :key (lambda (vertex)
765 (1+ (vertex-degree vertex))))))
767 ;; add vertexes and edges
768 (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
770 (let* ((element (funcall vertex-creator kind i))
771 (vertex (add-vertex graph element)))
772 (when (> i add-edge-count)
773 (loop for (other other-kind) in (sample-existing-vertexes kind) do
774 (update other-kind other)
776 (if (or (null kind) (null other)) (break))
777 (add-edge-between-vertexes
780 (lambda (e) (funcall duplicate-edge-function e)))))
781 (insert-item (aref vertex-sampler kind) vertex)))
785 ;;; ---------------------------------------------------------------------------
788 (defun poisson-connector (count generator)
789 (let* ((ts (poisson-random generator 2))
790 (cs (poisson-random generator 2))
791 (rest (- count ts cs)))
792 (loop for tick = t then (not tick) while (minusp rest) do
794 (if tick (decf ts) (decf cs)))
796 (append (make-list (truncate rest) :initial-element 0)
797 (make-list (truncate ts) :initial-element 1)
798 (make-list (truncate cs) :initial-element 2))
799 :generator generator)))
803 (generate-scale-free-graph
805 (make-container 'graph-container :default-edge-type :undirected)
810 (lambda (count generator)
811 (declare (ignore generator))
812 (make-list count :initial-element 0))
816 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
820 (generate-scale-free-graph
822 (make-container 'graph-container :default-edge-type :undirected)
827 (lambda (count generator)
828 (declare (ignore generator))
829 (make-list count :initial-element 0)))
831 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
835 (generate-scale-free-graph
837 (make-container 'graph-container :default-edge-type :undirected)
842 (lambda (count generator)
843 (declare (ignore generator))
844 (make-list count :initial-element 0)))
846 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
849 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
850 ;;; 102,959,032 words consed
851 Execution time profile from 2078 samples
854 Children Relative Absolute Consing Conses
856 %%check-keywords 99% 99% 100,970,656
857 sample-existing-vertexes 62%
858 insert-item <weighted-sampler-with-lookup-container> <t> 32%
859 add-vertex <basic-graph> <t> 2%
861 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
863 iterate-container <contents-as-array-mixin> <t> 1%
865 %%check-keywords 100%
866 sample-existing-vertexes 62% 61% 62,577,336
867 walk-tree-nodes <bst-node> <t> 99%
870 sample-existing-vertexes 100%
871 walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
872 #<anonymous function #xaa2070e> 77%
874 element-weight <weighted-sampling-container> <t> 2%
879 walk-tree-nodes <bst-node> <t> 98%
880 %%before-and-after-combined-method-dcode 2%
881 #<anonymous function #xaa2070e> 48% 47% 48,156,256
882 iterate-container <contents-as-array-mixin> <t> 73%
883 %%1st-two-arg-dcode 9%
884 iterate-edges <graph-container-vertex> <t> 6%
886 iterate-elements <abstract-container> <t> 2%
888 #<anonymous function #xaa2070e> 99%
890 iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
891 other-vertex <graph-container-edge> <graph-container-vertex> 43%
893 #<anonymous function #x271d31e> 10%
895 insert-item <weighted-sampler-with-lookup-container> <t> 92%
896 %make-std-instance 3%
898 %%standard-combined-method-dcode 1%
900 %%before-and-after-combined-method-dcode 34% 34% 34,400,720
901 insert-item <binary-search-tree> <bst-node> 90%
902 #<anonymous function #xaa2070e> 2%
903 shared-initialize <standard-object> <t> 2%
908 %%check-keywords 100%
909 insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
910 %%before-and-after-combined-method-dcode 100%
912 %%before-and-after-combined-method-dcode 100%
913 insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
917 insert-item <binary-search-tree> <bst-node> 99%
918 #<anonymous function #xaa2070e> 1%
919 %vertex-degree 26% 25% 25,870,312
920 #<anonymous function #xa7cee86> 68%
922 %std-slot-value-using-class 1%
925 iterate-container <contents-as-array-mixin> <t> 1%
928 iterate-container <contents-as-array-mixin> <t> 1%
929 #<anonymous function #xa7cee86> 18% 17% 17,420,592
930 %maybe-std-slot-value-using-class 8%
932 %std-slot-value-using-class 8%
934 vertex-1 <graph-container-edge> 5%
935 #<anonymous function #x271d31e> 1%
937 iterate-container <contents-as-array-mixin> <t> 99%
938 #<anonymous function #xa7cee86> 1%
939 other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
942 iterate-container <contents-as-array-mixin> <t> 95%
944 %%before-and-after-combined-method-dcode 1%
945 initialize-instance (around) <basic-initial-contents-mixin> 1%
946 %%nth-arg-dcode 7% 9% 9,238,560
948 #<anonymous function #xaa2070e> 93%
949 walk-tree-nodes <bst-node> <t> 5%
950 %%before-and-after-combined-method-dcode 2%
951 %%1st-two-arg-dcode 5% 5% 4,802,264
953 iterate-container <contents-as-array-mixin> <t> 96%
954 #<anonymous function #xa7cee86> 3%
955 shared-initialize <standard-object> <t> 1%
956 #<anonymous function #x271d31e> 4% 4% 4,012,368
958 #<anonymous function #xaa2070e> 100%
959 iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
961 #<anonymous function #xa7cee86> 59%
963 walk-tree-nodes <bst-node> <t> 13%
964 shared-initialize <standard-object> <t> 6%
965 %shared-initialize 4%
966 other-vertex <graph-container-edge> <graph-container-vertex> 2%
968 %std-slot-value-using-class 2% 2% 2,115,320
970 #<anonymous function #xa7cee86> 59%
971 walk-tree-nodes <bst-node> <t> 12%
973 %%before-and-after-combined-method-dcode 6%
974 shared-initialize <standard-object> <t> 4%
976 other-vertex <graph-container-edge> <graph-container-vertex> 4%
977 %shared-initialize 2%
978 %%one-arg-dcode 2% 2% 2,478,304
980 make-instance <symbol> 68%
982 make-instance <standard-class> 9%
983 %make-std-instance 2% 2% 2,283,344
984 %%before-and-after-combined-method-dcode 47%
985 shared-initialize <standard-object> <t> 15%
986 %%standard-combined-method-dcode 12%
987 %maybe-std-slot-value-using-class 3%
989 #<anonymous function #xa7cee86> 78%
992 %make-std-instance 2%
993 shared-initialize <standard-object> <t> 3%
994 view-get <simple-view> <t> 2%
995 walk-tree-nodes <bst-node> <t> 3%
996 %maybe-std-slot-value-using-class 2% 2% 2,005,048
998 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
999 add-vertex <basic-graph> <t> 40%
1000 initialize-instance (after) <graph-container-vertex> 7%
1002 %%before-and-after-combined-method-dcode 5%
1003 make-instance <symbol> 2% 2% 1,932,504
1004 %make-std-instance 92%
1006 #<anonymous function #xaa2070e> 100%
1007 constantly 2% 2% 1,629,880
1009 walk-tree-nodes <bst-node> <t> 97%
1010 %%before-and-after-combined-method-dcode 3%
1012 %maybe-std-slot-value-using-class 3%
1014 %%check-keywords 100%
1015 add-vertex <basic-graph> <t> 2% 2% 2,259,304
1016 make-instance <symbol> 44%
1017 %%standard-combined-method-dcode 30%
1018 %%before-and-after-combined-method-dcode 8%
1019 %make-std-instance 3%
1021 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
1022 %%standard-combined-method-dcode 48%
1023 %%check-keywords 16%
1025 make-instance <symbol> 6%
1027 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
1028 add-vertex <basic-graph> <t> 25%
1029 %make-std-instance 18%
1030 make-instance <standard-class> 6%
1032 insert-item <weighted-sampler-with-lookup-container> <t> 3%
1033 %%standard-combined-method-dcode 2% 2% 2,019,832
1034 insert-item <container-uses-nodes-mixin> <t> 45%
1035 %%before-and-after-combined-method-dcode 25%
1037 make-instance <symbol> 3%
1039 #<GRAPH-CONTAINER 1000>
1044 (open-plot-in-window
1047 (clnuplot::data->n-buckets
1048 (sort (collect-items x :transform #'vertex-degree) #'>)
1053 (and (plusp (first x))
1054 (plusp (second x ))))
1057 (list (log (first x) 10) (log (second x)))))))
1061 (clasp:linear-regression-brief
1063 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1064 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1065 (3.2961164921697144 1.6094379124341003)
1066 (3.3831867994748994 1.9459101490553132)
1067 (3.4556821645007902 0.6931471805599453)
1068 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1069 (3.932600584500482 0.0))
1072 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1073 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1074 (3.2961164921697144 1.6094379124341003)
1075 (3.3831867994748994 1.9459101490553132)
1076 (3.4556821645007902 0.6931471805599453)
1077 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1078 (3.932600584500482 0.0))
1083 ;;; ---------------------------------------------------------------------------
1084 ;;; generate-assortative-graph-with-degree-distributions
1085 ;;; ---------------------------------------------------------------------------
1088 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1090 ;;; ---------------------------------------------------------------------------
1092 (defmethod generate-assortative-graph-with-degree-distributions
1093 (generator (graph-class symbol)
1094 edge-count assortativity-matrix
1096 degree-distributions
1098 &key (duplicate-edge-function 'identity))
1099 (generate-assortative-graph-with-degree-distributions
1100 generator (make-instance graph-class)
1101 edge-count assortativity-matrix
1103 degree-distributions
1105 :duplicate-edge-function duplicate-edge-function))
1108 Split into a function to compute some of the intermediate pieces and one to use them
1111 (defmethod generate-assortative-graph-with-degree-distributions
1112 (generator graph edge-count assortativity-matrix
1114 degree-distributions
1116 &key (duplicate-edge-function 'identity))
1117 (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1118 (let* ((kind-count (array-dimension assortativity-matrix 0))
1119 (vertex->degree-counts (make-array kind-count))
1121 (sample-edges-for-assortative-graph
1122 generator edge-count assortativity-matrix)))
1125 (append (element-counts edges :key #'first)
1126 (element-counts edges :key #'second))
1130 new) :key #'first :argument #'second)
1133 (vertex-counts (collect-elements
1136 (lambda (kind-and-count)
1137 (round (float (/ (second kind-and-count)
1138 (elt average-degrees (first kind-and-count))))))))
1139 (edge-samplers (make-array kind-count)))
1140 (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1142 ;; setup bookkeeping
1143 (loop for kind from 0 to (1- kind-count) do
1144 (setf (aref edge-samplers kind)
1145 (make-container 'vector-container)
1146 (aref vertex->degree-counts kind)
1147 (make-container 'simple-associative-container)))
1148 (loop for edge in edges do
1149 (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1150 (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1152 edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1154 ;(spy edges degree-sums vertex-counts)
1156 (loop for kind from 0 to (1- kind-count)
1157 for count in vertex-counts do
1158 (let ((distribution (nth-element degree-distributions kind))
1159 (vertexes (make-container 'vector-container))
1160 (vertex-degrees (aref vertex->degree-counts kind))
1162 (desired-sum (second (elt degree-sums kind))))
1164 ;; for each type, create vertexes
1165 (loop for i from 0 to (1- count) do
1166 (let ((vertex (funcall vertex-creator kind i))
1167 (degree (funcall distribution)))
1168 (insert-item vertexes vertex)
1169 (setf (item-at-1 vertex-degrees vertex)
1171 (incf total-degree degree)))
1173 ;(spy vertexes total-degree desired-sum)
1175 ;; ensure proper total degree
1176 (loop while (/= total-degree desired-sum) do
1178 (when-debugging-format
1179 generate-assortative-graph-with-degree-distributions
1180 "Current: ~D, Desired: ~D, Difference: ~D"
1181 total-degree desired-sum
1182 (abs (- total-degree desired-sum)))
1183 (let* ((vertex (sample-element vertexes generator))
1184 (bigger? (< total-degree desired-sum))
1185 (current-degree (item-at-1 vertex-degrees vertex))
1190 (plusp current-degree)))
1191 (decf total-degree current-degree)
1194 (when-debugging-format
1195 generate-assortative-graph-with-degree-distributions
1197 total-degree current-degree new-degree (not bigger?))
1199 ;; increase speed by knowing which direction we need to go...?
1200 (loop until (or (zerop (decf attempts))
1202 (> (setf new-degree (funcall distribution))
1205 (< (setf new-degree (funcall distribution))
1206 current-degree))) do
1208 (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1210 (cond ((plusp attempts)
1213 generate-assortative-graph-with-degree-distributions
1214 (format *debug-io* " -> ~D" new-degree))
1216 (setf (item-at-1 vertex-degrees vertex) new-degree)
1217 (incf total-degree new-degree)
1220 (when-debugging-format
1221 generate-assortative-graph-with-degree-distributions
1222 "~D ~D" total-degree desired-sum))
1224 ;; couldn't find one, try again
1225 (incf total-degree current-degree))))))
1228 (let ((edge-sampler (aref edge-samplers kind)))
1229 (flet ((sample-edges-for-vertex (vertex)
1231 (loop repeat (item-at-1 vertex-degrees vertex) do
1232 (bind (((edge-kind . edge) (delete-last edge-sampler)))
1234 (:source (setf (first edge) vertex))
1235 (:target (setf (second edge) vertex)))))))
1238 #'sample-edges-for-vertex)))))
1240 ;; repair self edges
1243 ;; now make the graph [at last]
1247 (add-edge-between-vertexes graph (first edge) (second edge)
1248 :if-duplicate-do duplicate-edge-function))))
1253 (generate-assortative-graph-with-degree-distributions
1257 #2A((0.1111111111111111 0.2222222222222222)
1258 (0.2222222222222222 0.4444444444444444))
1260 #2A((0.011840772766222637 0.04524421593830334)
1261 (0.04524421593830334 0.8976707953571706))
1264 (make-degree-sampler
1266 (poisson-vertex-degree-distribution 3 i))
1267 :generator *random-generator*)
1268 (make-degree-sampler
1270 (poisson-vertex-degree-distribution 3 i))
1271 :generator *random-generator*))
1273 (lambda (kind count)
1274 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1279 (sample-edges-for-assortative-graph
1282 #2A((0.1111111111111111 0.2222222222222222)
1283 (0.2222222222222222 0.4444444444444444))))
1286 ;;; ---------------------------------------------------------------------------
1287 ;;; generate-graph-by-resampling-edges
1288 ;;; ---------------------------------------------------------------------------
1291 doesn't take edge weights into account when sampling
1293 should include pointer back to original graph
1296 (defclass* basic-edge-sampler ()
1300 ;;; ---------------------------------------------------------------------------
1302 (defmethod next-element ((sampler basic-edge-sampler))
1303 (sample-element (graph-edges (graph sampler)) (generator sampler)))
1305 ;;; ---------------------------------------------------------------------------
1307 (defclass* weighted-edge-sampler (basic-edge-sampler)
1308 ((weight-so-far 0 a)
1309 (index-iterator nil r)
1310 (edge-iterator nil r)
1313 ;;; ---------------------------------------------------------------------------
1315 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1316 (bind ((generator (generator object))
1317 (weighted-edge-count
1319 (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1321 (unless (size object)
1322 (setf (slot-value object 'size) weighted-edge-count))
1323 (setf (slot-value object 'index-iterator)
1325 (sort (loop repeat (size object) collect
1326 (integer-random generator 1 weighted-edge-count)) #'<))
1327 (slot-value object 'edge-iterator)
1328 (make-iterator (graph-edges (graph object))))))
1330 ;;; ---------------------------------------------------------------------------
1332 (defmethod next-element ((object weighted-edge-sampler))
1333 (let ((edge-iterator (edge-iterator object))
1334 (index-iterator (index-iterator object)))
1335 (move-forward index-iterator)
1336 (loop while (< (weight-so-far object) (current-element index-iterator)) do
1337 (move-forward edge-iterator)
1338 (incf (weight-so-far object) (weight (current-element edge-iterator))))
1339 (current-element edge-iterator)))
1341 ;;; ---------------------------------------------------------------------------
1343 (defmethod generate-graph-by-resampling-edges
1344 (generator original-graph &key
1345 (edge-sampler-class 'basic-edge-sampler)
1346 (edge-count (edge-count original-graph)))
1347 (let ((graph (copy-template original-graph))
1348 (edge-sampler (make-instance edge-sampler-class
1349 :generator generator
1350 :graph original-graph
1352 (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1358 (add-vertex graph (element v))))
1361 (loop repeat edge-count do
1362 (let ((edge (next-element edge-sampler)))
1363 (if (directed-edge-p edge)
1364 (add-edge-between-vertexes
1365 graph (element (source-vertex edge)) (element (target-vertex edge))
1366 :edge-type :directed
1367 :if-duplicate-do (lambda (e) (incf (weight e))))
1368 (add-edge-between-vertexes
1369 graph (element (vertex-1 edge)) (element (vertex-2 edge))
1370 :edge-type :undirected
1371 :if-duplicate-do (lambda (e) (incf (weight e)))))))
1376 (fluid-bind (((random-seed *random-generator*) 1))
1377 (let* ((dd-1 (lambda (i)
1379 (power-law-vertex-degree-distribution 3 i)
1380 (poisson-vertex-degree-distribution 3 i)))
1383 (power-law-vertex-degree-distribution 3 i)
1384 (poisson-vertex-degree-distribution 3 i)))
1385 (g (generate-assortative-graph-with-degree-distributions
1387 (make-instance 'graph-container
1388 :default-edge-type :undirected
1389 :undirected-edge-class 'weighted-edge)
1391 #2A((0.011840772766222637 0.04524421593830334)
1392 (0.04524421593830334 0.8976707953571706))
1395 (make-degree-sampler
1397 :generator *random-generator*
1399 :min-probability nil)
1400 (make-degree-sampler
1402 :generator *random-generator*
1404 :min-probability nil))
1405 #'simple-group-id-generator
1406 :duplicate-edge-function (lambda (e) (incf (weight e))))))
1408 (average-vertex-degree
1410 :vertex-filter (lambda (v)
1411 (plusp (edge-count v)))
1412 :edge-size #'weight)))
1414 (loop for i from 1 to 10
1416 (fluid-bind (((random-seed *random-generator*) i))
1418 (generate-graph-by-resampling-edges
1419 *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1421 ;;; ---------------------------------------------------------------------------
1422 ;;; some preferential attachment algorithms
1423 ;;; ---------------------------------------------------------------------------
1426 (define-debugging-class generate-preferential-attachment-graph
1429 ;;; ---------------------------------------------------------------------------
1431 (defmethod generate-simple-preferential-attachment-graph
1432 (generator (graph-class symbol) size minimum-degree)
1433 (generate-simple-preferential-attachment-graph
1434 generator (make-instance graph-class) size minimum-degree))
1436 ;;; ---------------------------------------------------------------------------
1438 (defmethod generate-simple-preferential-attachment-graph
1439 (generator graph size minimum-degree)
1440 (bind ((m (make-array (list (* 2 size minimum-degree)))))
1441 (loop for v from 0 to (1- size) do
1442 (loop for i from 0 to (1- minimum-degree) do
1443 (bind ((index (* 2 (+ i (* v minimum-degree))))
1444 (r (integer-random generator 0 index)))
1445 (setf (item-at m index) v
1446 (item-at m (1+ index)) (item-at m r)))))
1447 (loop for i from 0 to (1- (* size minimum-degree)) do
1448 (add-edge-between-vertexes
1449 graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1454 (generate-simple-preferential-attachment-graph
1456 (make-container 'graph-container :default-edge-type :undirected)
1462 (collect-nodes (ds :g-b)
1463 :transform (lambda (v) (list (element v) (vertex-degree v))))
1468 ;;; ---------------------------------------------------------------------------
1470 (defmethod generate-preferential-attachment-graph
1471 (generator (graph-class symbol) size kind-matrix minimum-degree
1472 assortativity-matrix
1473 &key (vertex-labeler 'simple-group-id-generator)
1474 (duplicate-edge-function :ignore))
1475 (generate-preferential-attachment-graph
1476 generator (make-instance graph-class)
1477 size kind-matrix minimum-degree assortativity-matrix
1478 :vertex-labeler vertex-labeler
1479 :duplicate-edge-function duplicate-edge-function))
1481 ;;; ---------------------------------------------------------------------------
1483 (defmethod generate-preferential-attachment-graph
1484 (generator (graph basic-graph) size kind-matrix minimum-degree
1485 assortativity-matrix
1486 &key (vertex-labeler 'simple-group-id-generator)
1487 (duplicate-edge-function :ignore))
1488 (bind ((kind-count (array-dimension kind-matrix 0))
1489 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1490 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1491 (edge-recorders (make-array (list kind-count)))
1492 (count-recorders (make-array (list kind-count) :initial-element 0))
1493 (edge-samplers (make-array (list kind-count))))
1495 ;; set up record keeping
1496 (dotimes (i kind-count)
1497 (setf (aref edge-recorders i)
1498 (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1499 :initial-element nil))
1500 (setf (aref edge-samplers i)
1501 (make-edge-sampler-for-preferential-attachment-graph
1502 generator (array-row assortativity-matrix i))))
1504 ;; add vertexes (to ensure that we have something at which to point)
1505 (loop for v from 0 to (1- size)
1506 for kind in vertex-kinds do
1507 (bind ((edge-recorder (aref edge-recorders kind)))
1508 (loop for i from 0 to (1- minimum-degree) do
1509 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1510 (setf (item-at edge-recorder index)
1511 (funcall vertex-labeler kind v)))))
1512 (incf (aref count-recorders kind)))
1515 (dotimes (i kind-count)
1516 (setf (aref count-recorders i) 0))
1517 (loop for v from 0 to (1- size)
1518 for kind in vertex-kinds do
1519 (bind ((edge-recorder (aref edge-recorders kind))
1520 (edge-sampler (aref edge-samplers kind)))
1521 (loop for i from 0 to (1- minimum-degree) do
1522 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1523 (other-kind (funcall edge-sampler))
1524 (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1525 (aref count-recorders other-kind))
1527 (other-edge-recorder (aref edge-recorders other-kind))
1528 (r (integer-random generator 0 (1- other-index))))
1530 (when-debugging-format
1531 generate-preferential-attachment-graph
1532 "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1533 kind (1+ index) other-kind r other-index)
1534 (setf (item-at edge-recorder (1+ index))
1535 (cond ((item-at other-edge-recorder r)
1536 (item-at other-edge-recorder r))
1537 ((and (= kind other-kind)
1540 (item-at edge-recorder index))
1542 ;; haven't done the other one yet... save it for later fixing
1543 (list other-kind r))))))
1544 (incf (aref count-recorders kind))))
1547 (let ((corrections 0)
1548 (last-corrections nil)
1550 (loop while again? do
1553 (dotimes (kind kind-count)
1554 (loop for vertex across (aref edge-recorders kind)
1555 for index = 0 then (1+ index)
1556 when (consp vertex) do
1557 (bind (((other-kind other-index) vertex))
1559 (when-debugging-format
1560 generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1562 (aref (aref edge-recorders other-kind) other-index))
1564 (if (and (= kind other-kind) (= index other-index))
1565 ;; pointing at myself
1566 (setf (aref (aref edge-recorders kind) index)
1567 (aref (aref edge-recorders kind) (1- index)))
1568 (let ((new (aref (aref edge-recorders other-kind) other-index)))
1571 (setf (aref (aref edge-recorders kind) index) new))))))
1572 (when (and last-corrections
1573 (>= corrections last-corrections))
1574 (error "It's not getting any better old boy"))
1575 (setf last-corrections corrections)))
1577 ;; make sure we got 'em all
1578 (dotimes (i kind-count)
1579 (loop for vertex across (aref edge-recorders i)
1580 when (not (symbolp vertex)) do (error "bad function, down boy")))
1582 (dotimes (i kind-count)
1583 (let ((edge-recorder (aref edge-recorders i)))
1584 (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1585 (add-edge-between-vertexes
1586 graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1587 :if-duplicate-do duplicate-edge-function))))
1590 ;; record properties
1591 (record-graph-properties graph)
1592 (setf (get-value graph :initial-seed) (random-seed generator))
1593 (setf (get-value graph :size) size
1594 (get-value graph :minimum-degree) minimum-degree
1595 (get-value graph :assortativity-matrix) assortativity-matrix
1596 (get-value graph :duplicate-edge-function) duplicate-edge-function)
1601 ;;; ---------------------------------------------------------------------------
1603 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1604 (let ((c (make-container 'weighted-sampling-container
1605 :random-number-generator generator
1607 (aref assortativities item)))))
1608 (dotimes (i (array-dimension assortativities 0))
1610 (lambda () (next-element c))))
1615 (make-edge-sampler-for-preferential-attachment-graph
1616 *random-generator* #(0.02 0.25 0.25))))
1617 (loop repeat 100 collect (funcall s)))
1621 (setf (random-seed *random-generator*) 2)
1622 (generate-preferential-attachment-graph
1624 (make-graph 'graph-container :edge-type :undirected)
1628 #2A((0.96 0.02 0.02)
1633 (generate-preferential-attachment-graph
1635 (make-graph 'graph-container :edge-type :undirected)
1639 #2A((0.96 0.02 0.02)
1645 (generate-preferential-attachment-graph
1647 (make-graph 'graph-container :edge-type :undirected)
1651 #2A((0.96 0.02 0.02)
1655 ;;; ---------------------------------------------------------------------------
1658 (defmethod generate-acquaintance-network
1659 (generator (class-name symbol) size death-probability iterations vertex-labeler
1660 &key (duplicate-edge-function :ignore))
1661 (generate-acquaintance-network
1662 generator (make-instance class-name)
1663 size death-probability iterations vertex-labeler
1664 :duplicate-edge-function duplicate-edge-function))
1666 (defmethod generate-acquaintance-network
1667 (generator graph size death-probability iterations vertex-labeler
1668 &key (duplicate-edge-function :ignore))
1669 ;; bring the graph up to size
1670 (loop for i from (size graph) to (1- size) do
1671 (add-vertex graph (funcall vertex-labeler 0 i)))
1673 (loop repeat iterations do
1674 (add-acquaintance-and-maybe-kill-something
1675 generator graph death-probability duplicate-edge-function))
1678 ;;; ---------------------------------------------------------------------------
1680 (defmethod generate-acquaintance-network-until-stable
1681 (generator graph size death-probability step-count
1682 stability-fn vertex-labeler
1683 &key (duplicate-edge-function :ignore))
1684 ;; bring the graph up to size
1685 (loop for i from (size graph) to (1- size) do
1686 (add-vertex graph (funcall vertex-labeler 0 i)))
1689 (loop repeat step-count do
1690 (add-acquaintance-and-maybe-kill-something
1691 generator graph death-probability duplicate-edge-function))
1692 (when (funcall stability-fn graph)
1697 ;;; ---------------------------------------------------------------------------
1699 (defun add-acquaintance-and-maybe-kill-something
1700 (generator graph death-probability duplicate-edge-function)
1702 (bind ((vertex (sample-element (graph-vertexes graph) generator))
1703 (neighbors (when (>= (size (vertex-edges vertex)) 2)
1704 (sample-unique-elements
1705 (vertex-edges vertex) generator 2))))
1706 (flet ((sample-other-vertex ()
1707 (loop for result = (sample-element (graph-vertexes graph) generator)
1708 until (not (eq vertex result))
1709 finally (return result))))
1711 (add-edge-between-vertexes
1713 (other-vertex (first neighbors) vertex)
1714 (other-vertex (second neighbors) vertex)
1715 :if-duplicate-do duplicate-edge-function)
1716 (add-edge-between-vertexes
1717 graph vertex (sample-other-vertex)
1718 :if-duplicate-do duplicate-edge-function))))
1720 ;; remove vertexes step
1721 (when (random-boolean generator death-probability)
1722 (let ((vertex (sample-element (graph-vertexes graph) generator)))
1723 (delete-vertex graph vertex)
1724 (add-vertex graph (element vertex)))))
1730 (adjustable-array-p (contents (vertex-edges v)))))
1733 (generate-acquaintance-network
1735 (make-graph 'graph-container :edge-type :undirected)
1739 'simple-group-id-generator)