1 (in-package metabang.graph)
3 (eval-when (:compile-toplevel :load-toplevel :execute)
6 generate-undirected-graph-via-assortativity-matrix
7 generate-undirected-graph-via-vertex-probabilities
8 generate-multi-group-graph-fixed
9 #+Ignore generate-girvan-newman-graph
10 generate-scale-free-graph
11 generate-assortative-graph-with-degree-distributions
13 generate-simple-preferential-attachment-graph
14 generate-preferential-attachment-graph
16 generate-acquaintance-network
17 generate-acquaintance-network-until-stable
19 generate-graph-by-resampling-edges
24 simple-group-id-generator
25 simple-group-id-parser
28 poisson-vertex-degree-distribution
29 power-law-vertex-degree-distribution)))
31 ;;; ---------------------------------------------------------------------------
33 ;;; ---------------------------------------------------------------------------
35 (defclass* generated-graph-mixin ()
36 ((generation-method nil ir)
37 (random-seed nil ir)))
39 ;;; ---------------------------------------------------------------------------
41 (defun save-generation-information (graph generator method)
43 ;; (setf (random-seed generator) (random-seed generator))
44 (unless (typep graph 'generated-graph-mixin)
45 (change-class graph (find-or-create-class
46 'basic-graph (list 'generated-graph-mixin
47 (class-name (class-of graph))))))
48 (setf (slot-value graph 'generation-method) method
49 (slot-value graph 'random-seed) (random-seed generator)))
51 ;;; ---------------------------------------------------------------------------
53 (defun simple-group-id-generator (kind count)
54 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
56 ;;; ---------------------------------------------------------------------------
58 (defun simple-group-id-parser (vertex)
59 (parse-integer (subseq (symbol-name (element vertex)) 1 3)))
62 ;;; ---------------------------------------------------------------------------
64 ;;; ---------------------------------------------------------------------------
66 (defmethod generate-gnp (generator (graph-class symbol) n p &key (label 'identity))
68 generator (make-instance graph-class) n p :label label))
70 ;;; ---------------------------------------------------------------------------
72 (defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity))
75 (log-1-p (log (- 1 p))))
76 (save-generation-information graph generator 'generate-gnp)
77 (loop for i from 0 to (1- n) do
78 (add-vertex graph (funcall label i)))
79 (loop while (< v n) do
80 (let ((r (uniform-random generator 0d0 1d0)))
81 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
82 (loop while (and (>= w v) (< v n)) do
86 (add-edge-between-vertexes
87 graph (funcall label v) (funcall label w)))))
91 ;;; ---------------------------------------------------------------------------
93 ;;; ---------------------------------------------------------------------------
95 (defmethod generate-gnm (generator (graph-class symbol) n p &key (label 'identity))
97 generator (make-instance graph-class) n p :label label))
99 ;;; ---------------------------------------------------------------------------
101 (defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity))
102 (let ((max-edge-index (1- (combination-count n 2))))
103 (assert (<= m max-edge-index))
105 (save-generation-information graph generator 'generate-gnm)
106 (loop for i from 0 to (1- n) do
107 (add-vertex graph (funcall label i)))
108 (loop for i from 0 to (1- m) do
110 until (let* ((i (integer-random generator 0 max-edge-index))
111 (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
112 (w (- i (/ (* v (1- v)) 2)))
113 (label-v (funcall label v))
114 (label-w (funcall label w)))
115 (unless (find-edge-between-vertexes
116 graph label-v label-w :error-if-not-found? nil)
117 (add-edge-between-vertexes graph label-v label-w)))))
123 (setf g (generate-gnm
125 'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
128 ;;; ---------------------------------------------------------------------------
130 (defun vertex-group (v)
131 (aref (symbol-name (element v)) 1))
133 ;;; ---------------------------------------------------------------------------
135 (defun in-group-degree (v &key (key 'vertex-group))
137 v :edge-filter (lambda (e ov)
139 (in-same-group-p v ov key))))
141 ;;; ---------------------------------------------------------------------------
143 (defun in-same-group-p (v1 v2 key)
144 (eq (funcall key v1) (funcall key v2)))
146 ;;; ---------------------------------------------------------------------------
148 (defun out-group-degree (v &key (key 'vertex-group))
150 v :edge-filter (lambda (e ov)
152 (not (in-same-group-p v ov key)))))
154 ;;; ---------------------------------------------------------------------------
155 ;;; generate-undirected-graph-via-assortativity-matrix
156 ;;; ---------------------------------------------------------------------------
158 (defmethod generate-undirected-graph-via-assortativity-matrix
159 (generator (graph-class symbol) size edge-count
160 kind-matrix assortativity-matrix vertex-creator
161 &key (duplicate-edge-function 'identity))
162 (generate-undirected-graph-via-assortativity-matrix
163 generator (make-instance graph-class) size edge-count
164 kind-matrix assortativity-matrix vertex-creator
165 :duplicate-edge-function duplicate-edge-function))
167 ;;; ---------------------------------------------------------------------------
169 (defmethod generate-undirected-graph-via-assortativity-matrix
170 (generator graph size edge-count
171 kind-matrix assortativity-matrix vertex-creator
172 &key (duplicate-edge-function 'identity))
173 (let* ((kind-count (array-dimension assortativity-matrix 0))
174 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
176 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
177 (vertex-sampler (make-array kind-count))
178 (edge-kinds (sample-edges-for-assortative-graph
179 generator edge-count assortativity-matrix))
181 (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
183 (loop for vertex-kind from 0 to (1- kind-count)
184 for count in vertex-kind-counts do
185 (setf (aref vertex-sampler vertex-kind)
186 (make-array (second count))))
188 (let ((current-kind 0)
190 (current-vertexes (aref vertex-sampler 0)))
192 (loop for kind in vertex-kinds
194 (when (not (eq current-kind kind))
195 (setf current-count 0
197 current-vertexes (aref vertex-sampler current-kind)))
198 (let ((vertex (funcall vertex-creator kind i)))
199 (setf (aref current-vertexes current-count) vertex)
200 (add-vertex graph vertex)
201 (incf current-count)))
203 (loop for (from-kind to-kind) in edge-kinds do
206 (if (= from-kind to-kind)
207 (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
209 (setf v1 (first sample) v2 (second sample)))
210 (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
211 v2 (sample-element (aref vertex-sampler to-kind) generator)))
212 (add-edge-between-vertexes
216 :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
220 ;;; ---------------------------------------------------------------------------
221 ;;; generate-undirected-graph-via-verex-probabilities
222 ;;; ---------------------------------------------------------------------------
224 (defmethod generate-undirected-graph-via-vertex-probabilities
225 (generator (graph-class symbol) size
226 kind-matrix probability-matrix vertex-creator)
227 (generate-undirected-graph-via-vertex-probabilities
228 generator (make-instance graph-class) size
229 kind-matrix probability-matrix vertex-creator))
231 ;;; ---------------------------------------------------------------------------
233 (defmethod generate-undirected-graph-via-vertex-probabilities
234 (generator graph size
235 kind-matrix probability-matrix vertex-creator)
236 (let* ((kind-count (array-dimension probability-matrix 0))
237 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
239 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
240 (vertex-sampler (make-array kind-count)))
241 (save-generation-information graph generator
242 'generate-undirected-graph-via-vertex-probabilities)
244 ;; initialize vertex bookkeeping
245 (loop for vertex-kind from 0 to (1- kind-count)
246 for count in vertex-kind-counts do
247 (setf (aref vertex-sampler vertex-kind)
248 (make-array (second count))))
251 (let ((current-kind 0)
253 (current-vertexes (aref vertex-sampler 0)))
254 (loop for kind in vertex-kinds
256 (when (not (eq current-kind kind))
257 (setf current-count 0
259 current-vertexes (aref vertex-sampler current-kind)))
260 (let ((vertex (funcall vertex-creator kind i)))
261 (setf (aref current-vertexes current-count) vertex)
262 (add-vertex graph vertex)
263 (incf current-count))))
266 ;; adjust probabilities
267 (loop for (kind-1 count-1) in vertex-kind-counts do
268 (loop for (kind-2 count-2) in vertex-kind-counts
269 when (<= kind-1 kind-2) do
270 (format t "~%~6,6F ~6,6F"
271 (aref probability-matrix kind-1 kind-2)
272 (float (/ (aref probability-matrix kind-1 kind-2)
273 (* count-1 count-2))))
274 (setf (aref probability-matrix kind-1 kind-2)
275 (float (/ (aref probability-matrix kind-1 kind-2)
276 (* count-1 count-2))))))
279 (flet ((add-one-edge (k1 k2 a b)
280 (add-edge-between-vertexes
282 (aref (aref vertex-sampler k1) a)
283 (aref (aref vertex-sampler k2) b))))
284 (loop for (kind-1 count-1) in vertex-kind-counts do
285 (loop for (kind-2 count-2) in vertex-kind-counts
286 when (<= kind-1 kind-2) do
287 (if (eq kind-1 kind-2)
288 (sample-edges-of-same-kind
289 generator count-1 (aref probability-matrix kind-1 kind-2)
291 (add-one-edge kind-1 kind-2 a b)))
292 (sample-edges-of-different-kinds
293 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
295 (add-one-edge kind-1 kind-2 a b)))))))
300 (defmethod generate-undirected-graph-via-vertex-probabilities
301 (generator graph size
302 kind-matrix probability-matrix vertex-creator)
303 (let* ((kind-count (array-dimension probability-matrix 0))
304 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
306 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
307 (vertex-sampler (make-array kind-count)))
309 (loop for vertex-kind from 0 to (1- kind-count)
310 for count in vertex-kind-counts do
311 (setf (aref vertex-sampler vertex-kind)
312 (make-array (second count))))
314 (let ((current-kind 0)
316 (current-vertexes (aref vertex-sampler 0)))
318 (loop for kind in vertex-kinds
320 (when (not (eq current-kind kind))
321 (setf current-count 0
323 current-vertexes (aref vertex-sampler current-kind)))
324 (let ((vertex (funcall vertex-creator kind i)))
325 (setf (aref current-vertexes current-count) vertex)
326 (add-vertex graph vertex)
327 (incf current-count))))
330 (flet ((add-one-edge (k1 k2 a b)
332 (add-edge-between-vertexes
334 (aref (aref vertex-sampler k1) a)
335 (aref (aref vertex-sampler k2) b))))
336 (loop for (kind-1 count-1) in vertex-kind-counts do
337 (loop for (kind-2 count-2) in vertex-kind-counts
338 when (<= kind-1 kind-2) do
340 (if (eq kind-1 kind-2)
341 (sample-edges-of-same-kind
342 generator count-1 (aref probability-matrix kind-1 kind-2)
344 (add-one-edge kind-1 kind-2 a b)))
345 (sample-edges-of-different-kinds
346 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
348 (add-one-edge kind-1 kind-2 a b))))
349 (format t "~%~A ~A ~A ~A -> ~A"
350 count-1 count-2 kind-1 kind-2 xxx)))))
355 (generate-undirected-graph-via-vertex-probabilities
356 *random-generator* 'graph-container
359 #2A((0.1 0.02) (0.02 0.6))
361 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
363 ;;; ---------------------------------------------------------------------------
365 (defun sample-edges-of-same-kind (generator n p fn)
369 (log-1-p (log (- 1 p))))
370 (loop while (< v n) do
371 (let ((r (uniform-random generator 0d0 1d0)))
372 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
373 (loop while (and (>= w v) (< v n)) do
377 (funcall fn v w)))))))
380 (sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
382 ;;; ---------------------------------------------------------------------------
384 (defun sample-edges-of-different-kinds (generator rows cols p fn)
388 (log-1-p (log (- 1 p))))
389 (loop while (< v rows) do
390 (let ((r (uniform-random generator 0d0 1d0)))
391 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
392 (loop while (and (>= w cols) (< v rows)) do
396 (funcall fn v w)))))))
398 ;;; ---------------------------------------------------------------------------
400 (defun poisson-vertex-degree-distribution (z k)
401 (/ (* (expt z k) (expt +e+ (- z)))
405 We know the probability of finding a vertex of degree k is p_k. We want to sample
406 from this distribution
409 ;;; ---------------------------------------------------------------------------
411 (defun power-law-vertex-degree-distribution (kappa k)
412 (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
414 ;;; ---------------------------------------------------------------------------
416 (defun create-specified-vertex-degree-distribution (degrees)
418 (declare (ignore z k))
421 ;;; ---------------------------------------------------------------------------
423 (defun make-degree-sampler (p_k &key (generator *random-generator*)
425 (min-probability 0.0001))
426 (let ((wsc (make-container 'containers:weighted-sampling-container
427 :random-number-generator generator
431 (loop for k = 0 then (1+ k)
432 for p = (funcall p_k k)
433 until (or (and max-degree (> k max-degree))
434 (and min-probability (< (- 1.0 total) min-probability))) do
437 (insert-item wsc (list k p)))
438 (when (plusp (- 1.0 total))
439 (insert-item wsc (list (1+ max-k) (- 1.0 total))))
441 (first (next-element wsc)))))
443 ;;; ---------------------------------------------------------------------------
446 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
447 (let ((c (make-container 'weighted-sampling-container
448 :random-number-generator generator
450 (aref assortativity-matrix (first item) (second item))))))
451 (dotimes (i (array-dimension assortativity-matrix 0))
452 (dotimes (j (array-dimension assortativity-matrix 1))
453 (insert-item c (list i j))))
454 (loop repeat edge-count collect
457 ;;; ---------------------------------------------------------------------------
459 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
460 (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
461 (loop repeat edge-count collect
464 ;;; ---------------------------------------------------------------------------
466 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
467 (let ((c (make-container 'weighted-sampling-container
468 :random-number-generator generator
470 (aref assortativity-matrix (first item) (second item))))))
471 (dotimes (i (array-dimension assortativity-matrix 0))
472 (dotimes (j (array-dimension assortativity-matrix 1))
473 (insert-item c (list i j))))
474 (lambda () (next-element c))))
476 ;;; ---------------------------------------------------------------------------
478 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
479 (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
480 ;; use kind-matrix as counts
481 (assert (= size (sum-of-array-elements kind-matrix)))
482 (coerce (shuffle-elements!
485 (loop for i = 0 then (1+ i)
486 for count across kind-matrix nconc
487 (make-list count :initial-element i)))
488 :generator generator)
492 ;; use kind-matrix as ratios to sample
493 (let* ((c (make-container 'weighted-sampling-container
494 :random-number-generator generator
496 (aref kind-matrix item)))))
497 (dotimes (i (array-dimension kind-matrix 0))
499 (loop repeat size collect
500 (next-element c))))))
503 (sample-vertexes-for-mixed-graph
505 50 #2A((0.258 0.016 0.035 0.013)
506 (0.012 0.157 0.058 0.019)
507 (0.013 0.023 0.306 0.035)
508 (0.005 0.007 0.024 0.016)))
511 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
512 (0.012 0.157 0.058 0.019)
513 (0.013 0.023 0.306 0.035)
514 (0.005 0.007 0.024 0.016)))
516 (let ((a #2A((0.258 0.016 0.035 0.013)
517 (0.012 0.157 0.058 0.019)
518 (0.013 0.023 0.306 0.035)
519 (0.005 0.007 0.024 0.016)))
520 (c (make-container 'weighted-sampling-container :key #'second)))
523 (insert-item c (list (list i j) (aref a i j)))))
525 (loop repeat 1000 collect
531 (let ((a #2A((0.258 0.016 0.035 0.013)
532 (0.012 0.157 0.058 0.019)
533 (0.013 0.023 0.306 0.035)
534 (0.005 0.007 0.024 0.016)))
535 (c (make-container 'weighted-sampling-container :key #'second)))
537 (loop repeat 100000 do
541 (defun foo (percent-bad percent-mixing)
542 (let ((kind-matrix (make-array 2 :initial-element 0d0))
543 (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
544 (setf (aref kind-matrix 0) (- 1d0 percent-bad)
545 (aref kind-matrix 1) percent-bad
546 (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
547 (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
548 (aref mixing-matrix 1 0) percent-mixing
549 (aref mixing-matrix 0 1) percent-mixing)
550 (normalize-matrix kind-matrix)
551 (setf mixing-matrix (normalize-matrix mixing-matrix))
556 ;;; ---------------------------------------------------------------------------
557 ;;; girvan-newman-test-graphs
558 ;;; ---------------------------------------------------------------------------
560 (defun generate-girvan-newman-graph (generator graph-class z-in)
561 (warn "This is broken!")
562 (bind ((g (make-instance graph-class))
566 (z-out (- edge-count z-in))
567 (vertexes (make-container 'simple-associative-container))
568 (groups (make-container 'alist-container)))
569 (save-generation-information g generator
570 'generate-girvan-newman-graph)
571 (labels ((make-id (group index)
572 (form-keyword "A" group "0" index))
574 (choose-inner-id (group id)
575 (check-type group fixnum)
576 (check-type id symbol)
578 (let ((other (sample-element (item-at groups group :needs-in) generator)))
582 (not (find-edge-between-vertexes
583 g id other :error-if-not-found? nil)))
584 (return-from choose-inner-id other)))))
586 (choose-outer-id (from-group id)
587 (declare (ignore id))
589 (check-type from-group fixnum)
591 (bind ((other-group (integer-random generator 0 (- group-count 2)))
592 (other (sample-element
593 (item-at groups (if (= from-group other-group)
595 other-group) :needs-out)
599 (not (find-edge-between-vertexes
600 g id other :error-if-not-found? nil)))
601 (return-from choose-outer-id other)))))
603 (make-in-edge (from to)
604 (let ((group (gn-id->group from)))
605 (when (zerop (decf (first (item-at vertexes from))))
606 (setf (item-at groups group :needs-in)
607 (remove from (item-at groups group :needs-in))))
608 (when (zerop (decf (first (item-at vertexes to))))
609 (setf (item-at groups group :needs-in)
610 (remove to (item-at groups group :needs-in))))
611 (add-edge-between-vertexes
612 g from to :edge-type :undirected
613 :if-duplicate-do (lambda (e) (incf (weight e))))))
615 (make-out-edge (from to)
616 (let ((group-from (gn-id->group from))
617 (group-to (gn-id->group to)))
618 (when (zerop (decf (second (item-at vertexes from))))
619 (setf (item-at groups group-from :needs-out)
620 (remove from (item-at groups group-from :needs-out))))
621 (when (zerop (decf (second (item-at vertexes to))))
622 (setf (item-at groups group-to :needs-out)
623 (remove to (item-at groups group-to :needs-out))))
625 (add-edge-between-vertexes
626 g from to :edge-type :undirected
627 :if-duplicate-do (lambda (e) (incf (weight e)))))))
630 (loop for group from 0 to (1- group-count) do
631 (loop for index from 0 to (1- group-size) do
632 (let ((id (make-id group index)))
633 (setf (item-at vertexes id) (list z-in z-out))
635 (push id (item-at groups group :needs-in)))
637 (push id (item-at groups group :needs-out))))))
640 (loop for group from 0 to (1- group-count) do
641 (loop for index from 0 to (1- group-size) do
642 (let ((from (make-id group index)))
644 (loop while (plusp (first (item-at vertexes from))) do
645 (make-in-edge from (choose-inner-id group from)))
646 (loop while (plusp (second (item-at vertexes from))) do
647 (make-out-edge from (choose-outer-id group from)))))))
651 ;;; ---------------------------------------------------------------------------
653 (defun gn-id->group (id)
654 (parse-integer (subseq (symbol-name id) 1 2)))
656 ;;; ---------------------------------------------------------------------------
658 (defun collect-edge-counts (g)
659 (let ((vertexes (make-container 'simple-associative-container
660 :initial-element-fn (lambda () (list 0 0)))))
664 (bind ((v1 (vertex-1 e))
668 (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
669 (incf (first (item-at vertexes id1)) (weight e))
670 (incf (first (item-at vertexes id2)) (weight e)))
672 (incf (second (item-at vertexes id1)) (weight e))
673 (incf (second (item-at vertexes id2)) (weight e)))))))
677 :transform (lambda (k v) (list k (first v) (second v))))
681 ;;; ---------------------------------------------------------------------------
683 (defclass* weighted-sampler-with-lookup-container ()
687 ;;; ---------------------------------------------------------------------------
689 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
690 &key random-number-generator key)
691 (setf (slot-value object 'sampler)
692 (make-container 'weighted-sampling-container
693 :random-number-generator random-number-generator
695 (slot-value object 'lookup)
696 (make-container 'simple-associative-container)))
698 ;;; ---------------------------------------------------------------------------
700 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
702 (let ((node (nth-value 1 (insert-item (sampler container) item))))
704 (assert (not (null node)))
705 (setf (item-at-1 (lookup container) item) node)))
707 ;;; ---------------------------------------------------------------------------
709 (defmethod find-node ((container weighted-sampler-with-lookup-container)
711 (item-at-1 (lookup container) item))
713 ;;; ---------------------------------------------------------------------------
715 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
717 ;; not going to worry about the hash table
718 (delete-node (sampler container) node))
720 ;;; ---------------------------------------------------------------------------
722 (defmethod next-element ((container weighted-sampler-with-lookup-container))
723 (next-element (sampler container)))
725 ;;; ---------------------------------------------------------------------------
727 (defmethod generate-scale-free-graph
728 (generator graph size kind-matrix add-edge-count
729 other-vertex-kind-samplers
731 &key (duplicate-edge-function 'identity))
732 (let* ((kind-count (array-dimension kind-matrix 0))
733 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
734 (vertex-sampler (make-array kind-count)))
735 (save-generation-information graph generator 'generate-scale-free-graph)
736 (flet ((sample-existing-vertexes (for-kind)
737 ;; return list of vertexes to attach based on preferential attachment
738 (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
739 add-edge-count generator) collect
740 (let ((vertex (next-element (aref vertex-sampler other-kind))))
743 for nil across vertex-sampler
745 (setf vertex (next-element (aref vertex-sampler i))
748 ;;?? remove. this should never happen
749 (unless vertex (break))
751 (list vertex other-kind))))
753 ;; handle bookkeeping for changed vertex degree
754 (bind ((sampler (aref vertex-sampler kind))
755 (node (find-node sampler thing)))
756 (delete-node sampler node)
757 (insert-item sampler thing))))
761 for nil across vertex-sampler do
762 (setf (aref vertex-sampler i)
763 (make-container 'weighted-sampler-with-lookup-container
764 :random-number-generator generator
765 :key (lambda (vertex)
766 (1+ (vertex-degree vertex))))))
768 ;; add vertexes and edges
769 (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
771 (let* ((element (funcall vertex-creator kind i))
772 (vertex (add-vertex graph element)))
773 (when (> i add-edge-count)
774 (loop for (other other-kind) in (sample-existing-vertexes kind) do
775 (update other-kind other)
777 (if (or (null kind) (null other)) (break))
778 (add-edge-between-vertexes
781 (lambda (e) (funcall duplicate-edge-function e)))))
782 (insert-item (aref vertex-sampler kind) vertex)))
786 ;;; ---------------------------------------------------------------------------
789 (defun poisson-connector (count generator)
790 (let* ((ts (poisson-random generator 2))
791 (cs (poisson-random generator 2))
792 (rest (- count ts cs)))
793 (loop for tick = t then (not tick) while (minusp rest) do
795 (if tick (decf ts) (decf cs)))
797 (append (make-list (truncate rest) :initial-element 0)
798 (make-list (truncate ts) :initial-element 1)
799 (make-list (truncate cs) :initial-element 2))
800 :generator generator)))
804 (generate-scale-free-graph
806 (make-container 'graph-container :default-edge-type :undirected)
811 (lambda (count generator)
812 (declare (ignore generator))
813 (make-list count :initial-element 0))
817 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
821 (generate-scale-free-graph
823 (make-container 'graph-container :default-edge-type :undirected)
828 (lambda (count generator)
829 (declare (ignore generator))
830 (make-list count :initial-element 0)))
832 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
836 (generate-scale-free-graph
838 (make-container 'graph-container :default-edge-type :undirected)
843 (lambda (count generator)
844 (declare (ignore generator))
845 (make-list count :initial-element 0)))
847 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
850 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
851 ;;; 102,959,032 words consed
852 Execution time profile from 2078 samples
855 Children Relative Absolute Consing Conses
857 %%check-keywords 99% 99% 100,970,656
858 sample-existing-vertexes 62%
859 insert-item <weighted-sampler-with-lookup-container> <t> 32%
860 add-vertex <basic-graph> <t> 2%
862 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
864 iterate-container <contents-as-array-mixin> <t> 1%
866 %%check-keywords 100%
867 sample-existing-vertexes 62% 61% 62,577,336
868 walk-tree-nodes <bst-node> <t> 99%
871 sample-existing-vertexes 100%
872 walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
873 #<anonymous function #xaa2070e> 77%
875 element-weight <weighted-sampling-container> <t> 2%
880 walk-tree-nodes <bst-node> <t> 98%
881 %%before-and-after-combined-method-dcode 2%
882 #<anonymous function #xaa2070e> 48% 47% 48,156,256
883 iterate-container <contents-as-array-mixin> <t> 73%
884 %%1st-two-arg-dcode 9%
885 iterate-edges <graph-container-vertex> <t> 6%
887 iterate-elements <abstract-container> <t> 2%
889 #<anonymous function #xaa2070e> 99%
891 iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
892 other-vertex <graph-container-edge> <graph-container-vertex> 43%
894 #<anonymous function #x271d31e> 10%
896 insert-item <weighted-sampler-with-lookup-container> <t> 92%
897 %make-std-instance 3%
899 %%standard-combined-method-dcode 1%
901 %%before-and-after-combined-method-dcode 34% 34% 34,400,720
902 insert-item <binary-search-tree> <bst-node> 90%
903 #<anonymous function #xaa2070e> 2%
904 shared-initialize <standard-object> <t> 2%
909 %%check-keywords 100%
910 insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
911 %%before-and-after-combined-method-dcode 100%
913 %%before-and-after-combined-method-dcode 100%
914 insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
918 insert-item <binary-search-tree> <bst-node> 99%
919 #<anonymous function #xaa2070e> 1%
920 %vertex-degree 26% 25% 25,870,312
921 #<anonymous function #xa7cee86> 68%
923 %std-slot-value-using-class 1%
926 iterate-container <contents-as-array-mixin> <t> 1%
929 iterate-container <contents-as-array-mixin> <t> 1%
930 #<anonymous function #xa7cee86> 18% 17% 17,420,592
931 %maybe-std-slot-value-using-class 8%
933 %std-slot-value-using-class 8%
935 vertex-1 <graph-container-edge> 5%
936 #<anonymous function #x271d31e> 1%
938 iterate-container <contents-as-array-mixin> <t> 99%
939 #<anonymous function #xa7cee86> 1%
940 other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
943 iterate-container <contents-as-array-mixin> <t> 95%
945 %%before-and-after-combined-method-dcode 1%
946 initialize-instance (around) <basic-initial-contents-mixin> 1%
947 %%nth-arg-dcode 7% 9% 9,238,560
949 #<anonymous function #xaa2070e> 93%
950 walk-tree-nodes <bst-node> <t> 5%
951 %%before-and-after-combined-method-dcode 2%
952 %%1st-two-arg-dcode 5% 5% 4,802,264
954 iterate-container <contents-as-array-mixin> <t> 96%
955 #<anonymous function #xa7cee86> 3%
956 shared-initialize <standard-object> <t> 1%
957 #<anonymous function #x271d31e> 4% 4% 4,012,368
959 #<anonymous function #xaa2070e> 100%
960 iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
962 #<anonymous function #xa7cee86> 59%
964 walk-tree-nodes <bst-node> <t> 13%
965 shared-initialize <standard-object> <t> 6%
966 %shared-initialize 4%
967 other-vertex <graph-container-edge> <graph-container-vertex> 2%
969 %std-slot-value-using-class 2% 2% 2,115,320
971 #<anonymous function #xa7cee86> 59%
972 walk-tree-nodes <bst-node> <t> 12%
974 %%before-and-after-combined-method-dcode 6%
975 shared-initialize <standard-object> <t> 4%
977 other-vertex <graph-container-edge> <graph-container-vertex> 4%
978 %shared-initialize 2%
979 %%one-arg-dcode 2% 2% 2,478,304
981 make-instance <symbol> 68%
983 make-instance <standard-class> 9%
984 %make-std-instance 2% 2% 2,283,344
985 %%before-and-after-combined-method-dcode 47%
986 shared-initialize <standard-object> <t> 15%
987 %%standard-combined-method-dcode 12%
988 %maybe-std-slot-value-using-class 3%
990 #<anonymous function #xa7cee86> 78%
993 %make-std-instance 2%
994 shared-initialize <standard-object> <t> 3%
995 view-get <simple-view> <t> 2%
996 walk-tree-nodes <bst-node> <t> 3%
997 %maybe-std-slot-value-using-class 2% 2% 2,005,048
999 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
1000 add-vertex <basic-graph> <t> 40%
1001 initialize-instance (after) <graph-container-vertex> 7%
1003 %%before-and-after-combined-method-dcode 5%
1004 make-instance <symbol> 2% 2% 1,932,504
1005 %make-std-instance 92%
1007 #<anonymous function #xaa2070e> 100%
1008 constantly 2% 2% 1,629,880
1010 walk-tree-nodes <bst-node> <t> 97%
1011 %%before-and-after-combined-method-dcode 3%
1013 %maybe-std-slot-value-using-class 3%
1015 %%check-keywords 100%
1016 add-vertex <basic-graph> <t> 2% 2% 2,259,304
1017 make-instance <symbol> 44%
1018 %%standard-combined-method-dcode 30%
1019 %%before-and-after-combined-method-dcode 8%
1020 %make-std-instance 3%
1022 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
1023 %%standard-combined-method-dcode 48%
1024 %%check-keywords 16%
1026 make-instance <symbol> 6%
1028 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
1029 add-vertex <basic-graph> <t> 25%
1030 %make-std-instance 18%
1031 make-instance <standard-class> 6%
1033 insert-item <weighted-sampler-with-lookup-container> <t> 3%
1034 %%standard-combined-method-dcode 2% 2% 2,019,832
1035 insert-item <container-uses-nodes-mixin> <t> 45%
1036 %%before-and-after-combined-method-dcode 25%
1038 make-instance <symbol> 3%
1040 #<GRAPH-CONTAINER 1000>
1045 (open-plot-in-window
1048 (clnuplot::data->n-buckets
1049 (sort (collect-items x :transform #'vertex-degree) #'>)
1054 (and (plusp (first x))
1055 (plusp (second x ))))
1058 (list (log (first x) 10) (log (second x)))))))
1062 (clasp:linear-regression-brief
1064 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1065 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1066 (3.2961164921697144 1.6094379124341003)
1067 (3.3831867994748994 1.9459101490553132)
1068 (3.4556821645007902 0.6931471805599453)
1069 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1070 (3.932600584500482 0.0))
1073 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1074 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1075 (3.2961164921697144 1.6094379124341003)
1076 (3.3831867994748994 1.9459101490553132)
1077 (3.4556821645007902 0.6931471805599453)
1078 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1079 (3.932600584500482 0.0))
1084 ;;; ---------------------------------------------------------------------------
1085 ;;; generate-assortative-graph-with-degree-distributions
1086 ;;; ---------------------------------------------------------------------------
1089 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1091 ;;; ---------------------------------------------------------------------------
1093 (defmethod generate-assortative-graph-with-degree-distributions
1094 (generator (graph-class symbol)
1095 edge-count assortativity-matrix
1097 degree-distributions
1099 &key (duplicate-edge-function 'identity))
1100 (generate-assortative-graph-with-degree-distributions
1101 generator (make-instance graph-class)
1102 edge-count assortativity-matrix
1104 degree-distributions
1106 :duplicate-edge-function duplicate-edge-function))
1109 Split into a function to compute some of the intermediate pieces and one to use them
1112 (defmethod generate-assortative-graph-with-degree-distributions
1113 (generator graph edge-count assortativity-matrix
1115 degree-distributions
1117 &key (duplicate-edge-function 'identity))
1118 (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1119 (let* ((kind-count (array-dimension assortativity-matrix 0))
1120 (vertex->degree-counts (make-array kind-count))
1122 (sample-edges-for-assortative-graph
1123 generator edge-count assortativity-matrix)))
1126 (append (element-counts edges :key #'first)
1127 (element-counts edges :key #'second))
1131 new) :key #'first :argument #'second)
1134 (vertex-counts (collect-elements
1137 (lambda (kind-and-count)
1138 (round (float (/ (second kind-and-count)
1139 (elt average-degrees (first kind-and-count))))))))
1140 (edge-samplers (make-array kind-count)))
1141 (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1143 ;; setup bookkeeping
1144 (loop for kind from 0 to (1- kind-count) do
1145 (setf (aref edge-samplers kind)
1146 (make-container 'vector-container)
1147 (aref vertex->degree-counts kind)
1148 (make-container 'simple-associative-container)))
1149 (loop for edge in edges do
1150 (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1151 (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1153 edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1155 ;(spy edges degree-sums vertex-counts)
1157 (loop for kind from 0 to (1- kind-count)
1158 for count in vertex-counts do
1159 (let ((distribution (nth-element degree-distributions kind))
1160 (vertexes (make-container 'vector-container))
1161 (vertex-degrees (aref vertex->degree-counts kind))
1163 (desired-sum (second (elt degree-sums kind))))
1165 ;; for each type, create vertexes
1166 (loop for i from 0 to (1- count) do
1167 (let ((vertex (funcall vertex-creator kind i))
1168 (degree (funcall distribution)))
1169 (insert-item vertexes vertex)
1170 (setf (item-at-1 vertex-degrees vertex)
1172 (incf total-degree degree)))
1174 ;(spy vertexes total-degree desired-sum)
1176 ;; ensure proper total degree
1177 (loop while (/= total-degree desired-sum) do
1179 (when-debugging-format
1180 generate-assortative-graph-with-degree-distributions
1181 "Current: ~D, Desired: ~D, Difference: ~D"
1182 total-degree desired-sum
1183 (abs (- total-degree desired-sum)))
1184 (let* ((vertex (sample-element vertexes generator))
1185 (bigger? (< total-degree desired-sum))
1186 (current-degree (item-at-1 vertex-degrees vertex))
1191 (plusp current-degree)))
1192 (decf total-degree current-degree)
1195 (when-debugging-format
1196 generate-assortative-graph-with-degree-distributions
1198 total-degree current-degree new-degree (not bigger?))
1200 ;; increase speed by knowing which direction we need to go...?
1201 (loop until (or (zerop (decf attempts))
1203 (> (setf new-degree (funcall distribution))
1206 (< (setf new-degree (funcall distribution))
1207 current-degree))) do
1209 (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1211 (cond ((plusp attempts)
1214 generate-assortative-graph-with-degree-distributions
1215 (format *debug-io* " -> ~D" new-degree))
1217 (setf (item-at-1 vertex-degrees vertex) new-degree)
1218 (incf total-degree new-degree)
1221 (when-debugging-format
1222 generate-assortative-graph-with-degree-distributions
1223 "~D ~D" total-degree desired-sum))
1225 ;; couldn't find one, try again
1226 (incf total-degree current-degree))))))
1229 (let ((edge-sampler (aref edge-samplers kind)))
1230 (flet ((sample-edges-for-vertex (vertex)
1232 (loop repeat (item-at-1 vertex-degrees vertex) do
1233 (bind (((edge-kind . edge) (delete-last edge-sampler)))
1235 (:source (setf (first edge) vertex))
1236 (:target (setf (second edge) vertex)))))))
1239 #'sample-edges-for-vertex)))))
1241 ;; repair self edges
1244 ;; now make the graph [at last]
1248 (add-edge-between-vertexes graph (first edge) (second edge)
1249 :if-duplicate-do duplicate-edge-function))))
1254 (generate-assortative-graph-with-degree-distributions
1258 #2A((0.1111111111111111 0.2222222222222222)
1259 (0.2222222222222222 0.4444444444444444))
1261 #2A((0.011840772766222637 0.04524421593830334)
1262 (0.04524421593830334 0.8976707953571706))
1265 (make-degree-sampler
1267 (poisson-vertex-degree-distribution 3 i))
1268 :generator *random-generator*)
1269 (make-degree-sampler
1271 (poisson-vertex-degree-distribution 3 i))
1272 :generator *random-generator*))
1274 (lambda (kind count)
1275 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1280 (sample-edges-for-assortative-graph
1283 #2A((0.1111111111111111 0.2222222222222222)
1284 (0.2222222222222222 0.4444444444444444))))
1287 ;;; ---------------------------------------------------------------------------
1288 ;;; generate-graph-by-resampling-edges
1289 ;;; ---------------------------------------------------------------------------
1292 doesn't take edge weights into account when sampling
1294 should include pointer back to original graph
1297 (defclass* basic-edge-sampler ()
1301 ;;; ---------------------------------------------------------------------------
1303 (defmethod next-element ((sampler basic-edge-sampler))
1304 (sample-element (graph-edges (graph sampler)) (generator sampler)))
1306 ;;; ---------------------------------------------------------------------------
1308 (defclass* weighted-edge-sampler (basic-edge-sampler)
1309 ((weight-so-far 0 a)
1310 (index-iterator nil r)
1311 (edge-iterator nil r)
1314 ;;; ---------------------------------------------------------------------------
1316 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1317 (bind ((generator (generator object))
1318 (weighted-edge-count
1320 (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1322 (unless (size object)
1323 (setf (slot-value object 'size) weighted-edge-count))
1324 (setf (slot-value object 'index-iterator)
1326 (sort (loop repeat (size object) collect
1327 (integer-random generator 1 weighted-edge-count)) #'<))
1328 (slot-value object 'edge-iterator)
1329 (make-iterator (graph-edges (graph object))))))
1331 ;;; ---------------------------------------------------------------------------
1333 (defmethod next-element ((object weighted-edge-sampler))
1334 (let ((edge-iterator (edge-iterator object))
1335 (index-iterator (index-iterator object)))
1336 (move-forward index-iterator)
1337 (loop while (< (weight-so-far object) (current-element index-iterator)) do
1338 (move-forward edge-iterator)
1339 (incf (weight-so-far object) (weight (current-element edge-iterator))))
1340 (current-element edge-iterator)))
1342 ;;; ---------------------------------------------------------------------------
1344 (defmethod generate-graph-by-resampling-edges
1345 (generator original-graph &key
1346 (edge-sampler-class 'basic-edge-sampler)
1347 (edge-count (edge-count original-graph)))
1348 (let ((graph (copy-template original-graph))
1349 (edge-sampler (make-instance edge-sampler-class
1350 :generator generator
1351 :graph original-graph
1353 (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1359 (add-vertex graph (element v))))
1362 (loop repeat edge-count do
1363 (let ((edge (next-element edge-sampler)))
1364 (if (directed-edge-p edge)
1365 (add-edge-between-vertexes
1366 graph (element (source-vertex edge)) (element (target-vertex edge))
1367 :edge-type :directed
1368 :if-duplicate-do (lambda (e) (incf (weight e))))
1369 (add-edge-between-vertexes
1370 graph (element (vertex-1 edge)) (element (vertex-2 edge))
1371 :edge-type :undirected
1372 :if-duplicate-do (lambda (e) (incf (weight e)))))))
1377 (fluid-bind (((random-seed *random-generator*) 1))
1378 (let* ((dd-1 (lambda (i)
1380 (power-law-vertex-degree-distribution 3 i)
1381 (poisson-vertex-degree-distribution 3 i)))
1384 (power-law-vertex-degree-distribution 3 i)
1385 (poisson-vertex-degree-distribution 3 i)))
1386 (g (generate-assortative-graph-with-degree-distributions
1388 (make-instance 'graph-container
1389 :default-edge-type :undirected
1390 :undirected-edge-class 'weighted-edge)
1392 #2A((0.011840772766222637 0.04524421593830334)
1393 (0.04524421593830334 0.8976707953571706))
1396 (make-degree-sampler
1398 :generator *random-generator*
1400 :min-probability nil)
1401 (make-degree-sampler
1403 :generator *random-generator*
1405 :min-probability nil))
1406 #'simple-group-id-generator
1407 :duplicate-edge-function (lambda (e) (incf (weight e))))))
1409 (average-vertex-degree
1411 :vertex-filter (lambda (v)
1412 (plusp (edge-count v)))
1413 :edge-size #'weight)))
1415 (loop for i from 1 to 10
1417 (fluid-bind (((random-seed *random-generator*) i))
1419 (generate-graph-by-resampling-edges
1420 *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1422 ;;; ---------------------------------------------------------------------------
1423 ;;; some preferential attachment algorithms
1424 ;;; ---------------------------------------------------------------------------
1427 (define-debugging-class generate-preferential-attachment-graph
1430 ;;; ---------------------------------------------------------------------------
1432 (defmethod generate-simple-preferential-attachment-graph
1433 (generator (graph-class symbol) size minimum-degree)
1434 (generate-simple-preferential-attachment-graph
1435 generator (make-instance graph-class) size minimum-degree))
1437 ;;; ---------------------------------------------------------------------------
1439 (defmethod generate-simple-preferential-attachment-graph
1440 (generator graph size minimum-degree)
1441 (bind ((m (make-array (list (* 2 size minimum-degree)))))
1442 (loop for v from 0 to (1- size) do
1443 (loop for i from 0 to (1- minimum-degree) do
1444 (bind ((index (* 2 (+ i (* v minimum-degree))))
1445 (r (integer-random generator 0 index)))
1446 (setf (item-at m index) v
1447 (item-at m (1+ index)) (item-at m r)))))
1448 (loop for i from 0 to (1- (* size minimum-degree)) do
1449 (add-edge-between-vertexes
1450 graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1455 (generate-simple-preferential-attachment-graph
1457 (make-container 'graph-container :default-edge-type :undirected)
1463 (collect-nodes (ds :g-b)
1464 :transform (lambda (v) (list (element v) (vertex-degree v))))
1469 ;;; ---------------------------------------------------------------------------
1471 (defmethod generate-preferential-attachment-graph
1472 (generator (graph-class symbol) size kind-matrix minimum-degree
1473 assortativity-matrix
1474 &key (vertex-labeler 'simple-group-id-generator)
1475 (duplicate-edge-function :ignore))
1476 (generate-preferential-attachment-graph
1477 generator (make-instance graph-class)
1478 size kind-matrix minimum-degree assortativity-matrix
1479 :vertex-labeler vertex-labeler
1480 :duplicate-edge-function duplicate-edge-function))
1482 ;;; ---------------------------------------------------------------------------
1484 (defmethod generate-preferential-attachment-graph
1485 (generator (graph basic-graph) size kind-matrix minimum-degree
1486 assortativity-matrix
1487 &key (vertex-labeler 'simple-group-id-generator)
1488 (duplicate-edge-function :ignore))
1489 (bind ((kind-count (array-dimension kind-matrix 0))
1490 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1491 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1492 (edge-recorders (make-array (list kind-count)))
1493 (count-recorders (make-array (list kind-count) :initial-element 0))
1494 (edge-samplers (make-array (list kind-count))))
1496 ;; set up record keeping
1497 (dotimes (i kind-count)
1498 (setf (aref edge-recorders i)
1499 (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1500 :initial-element nil))
1501 (setf (aref edge-samplers i)
1502 (make-edge-sampler-for-preferential-attachment-graph
1503 generator (array-row assortativity-matrix i))))
1505 ;; add vertexes (to ensure that we have something at which to point)
1506 (loop for v from 0 to (1- size)
1507 for kind in vertex-kinds do
1508 (bind ((edge-recorder (aref edge-recorders kind)))
1509 (loop for i from 0 to (1- minimum-degree) do
1510 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1511 (setf (item-at edge-recorder index)
1512 (funcall vertex-labeler kind v)))))
1513 (incf (aref count-recorders kind)))
1516 (dotimes (i kind-count)
1517 (setf (aref count-recorders i) 0))
1518 (loop for v from 0 to (1- size)
1519 for kind in vertex-kinds do
1520 (bind ((edge-recorder (aref edge-recorders kind))
1521 (edge-sampler (aref edge-samplers kind)))
1522 (loop for i from 0 to (1- minimum-degree) do
1523 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1524 (other-kind (funcall edge-sampler))
1525 (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1526 (aref count-recorders other-kind))
1528 (other-edge-recorder (aref edge-recorders other-kind))
1529 (r (integer-random generator 0 (1- other-index))))
1531 (when-debugging-format
1532 generate-preferential-attachment-graph
1533 "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1534 kind (1+ index) other-kind r other-index)
1535 (setf (item-at edge-recorder (1+ index))
1536 (cond ((item-at other-edge-recorder r)
1537 (item-at other-edge-recorder r))
1538 ((and (= kind other-kind)
1541 (item-at edge-recorder index))
1543 ;; haven't done the other one yet... save it for later fixing
1544 (list other-kind r))))))
1545 (incf (aref count-recorders kind))))
1548 (let ((corrections 0)
1549 (last-corrections nil)
1551 (loop while again? do
1554 (dotimes (kind kind-count)
1555 (loop for vertex across (aref edge-recorders kind)
1556 for index = 0 then (1+ index)
1557 when (consp vertex) do
1558 (bind (((other-kind other-index) vertex))
1560 (when-debugging-format
1561 generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1563 (aref (aref edge-recorders other-kind) other-index))
1565 (if (and (= kind other-kind) (= index other-index))
1566 ;; pointing at myself
1567 (setf (aref (aref edge-recorders kind) index)
1568 (aref (aref edge-recorders kind) (1- index)))
1569 (let ((new (aref (aref edge-recorders other-kind) other-index)))
1572 (setf (aref (aref edge-recorders kind) index) new))))))
1573 (when (and last-corrections
1574 (>= corrections last-corrections))
1575 (error "It's not getting any better old boy"))
1576 (setf last-corrections corrections)))
1578 ;; make sure we got 'em all
1579 (dotimes (i kind-count)
1580 (loop for vertex across (aref edge-recorders i)
1581 when (not (symbolp vertex)) do (error "bad function, down boy")))
1583 (dotimes (i kind-count)
1584 (let ((edge-recorder (aref edge-recorders i)))
1585 (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1586 (add-edge-between-vertexes
1587 graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1588 :if-duplicate-do duplicate-edge-function))))
1591 ;; record properties
1592 (record-graph-properties graph)
1593 (setf (get-value graph :initial-seed) (random-seed generator))
1594 (setf (get-value graph :size) size
1595 (get-value graph :minimum-degree) minimum-degree
1596 (get-value graph :assortativity-matrix) assortativity-matrix
1597 (get-value graph :duplicate-edge-function) duplicate-edge-function)
1602 ;;; ---------------------------------------------------------------------------
1604 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1605 (let ((c (make-container 'weighted-sampling-container
1606 :random-number-generator generator
1608 (aref assortativities item)))))
1609 (dotimes (i (array-dimension assortativities 0))
1611 (lambda () (next-element c))))
1616 (make-edge-sampler-for-preferential-attachment-graph
1617 *random-generator* #(0.02 0.25 0.25))))
1618 (loop repeat 100 collect (funcall s)))
1622 (setf (random-seed *random-generator*) 2)
1623 (generate-preferential-attachment-graph
1625 (make-graph 'graph-container :edge-type :undirected)
1629 #2A((0.96 0.02 0.02)
1634 (generate-preferential-attachment-graph
1636 (make-graph 'graph-container :edge-type :undirected)
1640 #2A((0.96 0.02 0.02)
1646 (generate-preferential-attachment-graph
1648 (make-graph 'graph-container :edge-type :undirected)
1652 #2A((0.96 0.02 0.02)
1656 ;;; ---------------------------------------------------------------------------
1659 (defmethod generate-acquaintance-network
1660 (generator (class-name symbol) size death-probability iterations vertex-labeler
1661 &key (duplicate-edge-function :ignore))
1662 (generate-acquaintance-network
1663 generator (make-instance class-name)
1664 size death-probability iterations vertex-labeler
1665 :duplicate-edge-function duplicate-edge-function))
1667 (defmethod generate-acquaintance-network
1668 (generator graph size death-probability iterations vertex-labeler
1669 &key (duplicate-edge-function :ignore))
1670 ;; bring the graph up to size
1671 (loop for i from (size graph) to (1- size) do
1672 (add-vertex graph (funcall vertex-labeler 0 i)))
1674 (loop repeat iterations do
1675 (add-acquaintance-and-maybe-kill-something
1676 generator graph death-probability duplicate-edge-function))
1679 ;;; ---------------------------------------------------------------------------
1681 (defmethod generate-acquaintance-network-until-stable
1682 (generator graph size death-probability step-count
1683 stability-fn vertex-labeler
1684 &key (duplicate-edge-function :ignore))
1685 ;; bring the graph up to size
1686 (loop for i from (size graph) to (1- size) do
1687 (add-vertex graph (funcall vertex-labeler 0 i)))
1690 (loop repeat step-count do
1691 (add-acquaintance-and-maybe-kill-something
1692 generator graph death-probability duplicate-edge-function))
1693 (when (funcall stability-fn graph)
1698 ;;; ---------------------------------------------------------------------------
1700 (defun add-acquaintance-and-maybe-kill-something
1701 (generator graph death-probability duplicate-edge-function)
1703 (bind ((vertex (sample-element (graph-vertexes graph) generator))
1704 (neighbors (when (>= (size (vertex-edges vertex)) 2)
1705 (sample-unique-elements
1706 (vertex-edges vertex) generator 2))))
1707 (flet ((sample-other-vertex ()
1708 (loop for result = (sample-element (graph-vertexes graph) generator)
1709 until (not (eq vertex result))
1710 finally (return result))))
1712 (add-edge-between-vertexes
1714 (other-vertex (first neighbors) vertex)
1715 (other-vertex (second neighbors) vertex)
1716 :if-duplicate-do duplicate-edge-function)
1717 (add-edge-between-vertexes
1718 graph vertex (sample-other-vertex)
1719 :if-duplicate-do duplicate-edge-function))))
1721 ;; remove vertexes step
1722 (when (random-boolean generator death-probability)
1723 (let ((vertex (sample-element (graph-vertexes graph) generator)))
1724 (delete-vertex graph vertex)
1725 (add-vertex graph (element vertex)))))
1731 (adjustable-array-p (contents (vertex-edges v)))))
1734 (generate-acquaintance-network
1736 (make-graph 'graph-container :edge-type :undirected)
1740 'simple-group-id-generator)