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 cl-mathstats:+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 cl-mathstats:+e+ (- (/ kappa))))
413 (expt cl-mathstats:+e+ (- (/ k kappa)))))
415 ;;; ---------------------------------------------------------------------------
417 (defun create-specified-vertex-degree-distribution (degrees)
419 (declare (ignore z k))
422 ;;; ---------------------------------------------------------------------------
424 (defun make-degree-sampler (p_k &key (generator *random-generator*)
426 (min-probability 0.0001))
427 (let ((wsc (make-container 'containers:weighted-sampling-container
428 :random-number-generator generator
432 (loop for k = 0 then (1+ k)
433 for p = (funcall p_k k)
434 until (or (and max-degree (> k max-degree))
435 (and min-probability (< (- 1.0 total) min-probability))) do
438 (insert-item wsc (list k p)))
439 (when (plusp (- 1.0 total))
440 (insert-item wsc (list (1+ max-k) (- 1.0 total))))
442 (first (next-element wsc)))))
444 ;;; ---------------------------------------------------------------------------
447 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
448 (let ((c (make-container 'weighted-sampling-container
449 :random-number-generator generator
451 (aref assortativity-matrix (first item) (second item))))))
452 (dotimes (i (array-dimension assortativity-matrix 0))
453 (dotimes (j (array-dimension assortativity-matrix 1))
454 (insert-item c (list i j))))
455 (loop repeat edge-count collect
458 ;;; ---------------------------------------------------------------------------
460 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
461 (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
462 (loop repeat edge-count collect
465 ;;; ---------------------------------------------------------------------------
467 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
468 (let ((c (make-container 'weighted-sampling-container
469 :random-number-generator generator
471 (aref assortativity-matrix (first item) (second item))))))
472 (dotimes (i (array-dimension assortativity-matrix 0))
473 (dotimes (j (array-dimension assortativity-matrix 1))
474 (insert-item c (list i j))))
475 (lambda () (next-element c))))
477 ;;; ---------------------------------------------------------------------------
479 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
480 (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
481 ;; use kind-matrix as counts
482 (assert (= size (sum-of-array-elements kind-matrix)))
483 (coerce (shuffle-elements!
486 (loop for i = 0 then (1+ i)
487 for count across kind-matrix nconc
488 (make-list count :initial-element i)))
489 :generator generator)
493 ;; use kind-matrix as ratios to sample
494 (let* ((c (make-container 'weighted-sampling-container
495 :random-number-generator generator
497 (aref kind-matrix item)))))
498 (dotimes (i (array-dimension kind-matrix 0))
500 (loop repeat size collect
501 (next-element c))))))
504 (sample-vertexes-for-mixed-graph
506 50 #2A((0.258 0.016 0.035 0.013)
507 (0.012 0.157 0.058 0.019)
508 (0.013 0.023 0.306 0.035)
509 (0.005 0.007 0.024 0.016)))
512 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
513 (0.012 0.157 0.058 0.019)
514 (0.013 0.023 0.306 0.035)
515 (0.005 0.007 0.024 0.016)))
517 (let ((a #2A((0.258 0.016 0.035 0.013)
518 (0.012 0.157 0.058 0.019)
519 (0.013 0.023 0.306 0.035)
520 (0.005 0.007 0.024 0.016)))
521 (c (make-container 'weighted-sampling-container :key #'second)))
524 (insert-item c (list (list i j) (aref a i j)))))
526 (loop repeat 1000 collect
532 (let ((a #2A((0.258 0.016 0.035 0.013)
533 (0.012 0.157 0.058 0.019)
534 (0.013 0.023 0.306 0.035)
535 (0.005 0.007 0.024 0.016)))
536 (c (make-container 'weighted-sampling-container :key #'second)))
538 (loop repeat 100000 do
542 (defun foo (percent-bad percent-mixing)
543 (let ((kind-matrix (make-array 2 :initial-element 0d0))
544 (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
545 (setf (aref kind-matrix 0) (- 1d0 percent-bad)
546 (aref kind-matrix 1) percent-bad
547 (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
548 (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
549 (aref mixing-matrix 1 0) percent-mixing
550 (aref mixing-matrix 0 1) percent-mixing)
551 (normalize-matrix kind-matrix)
552 (setf mixing-matrix (normalize-matrix mixing-matrix))
557 ;;; ---------------------------------------------------------------------------
558 ;;; girvan-newman-test-graphs
559 ;;; ---------------------------------------------------------------------------
561 (defun generate-girvan-newman-graph (generator graph-class z-in)
562 (warn "This is broken!")
563 (bind ((g (make-instance graph-class))
567 (z-out (- edge-count z-in))
568 (vertexes (make-container 'simple-associative-container))
569 (groups (make-container 'alist-container)))
570 (save-generation-information g generator
571 'generate-girvan-newman-graph)
572 (labels ((make-id (group index)
573 (form-keyword "A" group "0" index))
575 (choose-inner-id (group id)
576 (check-type group fixnum)
577 (check-type id symbol)
579 (let ((other (sample-element (item-at groups group :needs-in) generator)))
583 (not (find-edge-between-vertexes
584 g id other :error-if-not-found? nil)))
585 (return-from choose-inner-id other)))))
587 (choose-outer-id (from-group id)
588 (declare (ignore id))
590 (check-type from-group fixnum)
592 (bind ((other-group (integer-random generator 0 (- group-count 2)))
593 (other (sample-element
594 (item-at groups (if (= from-group other-group)
596 other-group) :needs-out)
600 (not (find-edge-between-vertexes
601 g id other :error-if-not-found? nil)))
602 (return-from choose-outer-id other)))))
604 (make-in-edge (from to)
605 (let ((group (gn-id->group from)))
606 (when (zerop (decf (first (item-at vertexes from))))
607 (setf (item-at groups group :needs-in)
608 (remove from (item-at groups group :needs-in))))
609 (when (zerop (decf (first (item-at vertexes to))))
610 (setf (item-at groups group :needs-in)
611 (remove to (item-at groups group :needs-in))))
612 (add-edge-between-vertexes
613 g from to :edge-type :undirected
614 :if-duplicate-do (lambda (e) (incf (weight e))))))
616 (make-out-edge (from to)
617 (let ((group-from (gn-id->group from))
618 (group-to (gn-id->group to)))
619 (when (zerop (decf (second (item-at vertexes from))))
620 (setf (item-at groups group-from :needs-out)
621 (remove from (item-at groups group-from :needs-out))))
622 (when (zerop (decf (second (item-at vertexes to))))
623 (setf (item-at groups group-to :needs-out)
624 (remove to (item-at groups group-to :needs-out))))
626 (add-edge-between-vertexes
627 g from to :edge-type :undirected
628 :if-duplicate-do (lambda (e) (incf (weight e)))))))
631 (loop for group from 0 to (1- group-count) do
632 (loop for index from 0 to (1- group-size) do
633 (let ((id (make-id group index)))
634 (setf (item-at vertexes id) (list z-in z-out))
636 (push id (item-at groups group :needs-in)))
638 (push id (item-at groups group :needs-out))))))
641 (loop for group from 0 to (1- group-count) do
642 (loop for index from 0 to (1- group-size) do
643 (let ((from (make-id group index)))
645 (loop while (plusp (first (item-at vertexes from))) do
646 (make-in-edge from (choose-inner-id group from)))
647 (loop while (plusp (second (item-at vertexes from))) do
648 (make-out-edge from (choose-outer-id group from)))))))
652 ;;; ---------------------------------------------------------------------------
654 (defun gn-id->group (id)
655 (parse-integer (subseq (symbol-name id) 1 2)))
657 ;;; ---------------------------------------------------------------------------
659 (defun collect-edge-counts (g)
660 (let ((vertexes (make-container 'simple-associative-container
661 :initial-element-fn (lambda () (list 0 0)))))
665 (bind ((v1 (vertex-1 e))
669 (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
670 (incf (first (item-at vertexes id1)) (weight e))
671 (incf (first (item-at vertexes id2)) (weight e)))
673 (incf (second (item-at vertexes id1)) (weight e))
674 (incf (second (item-at vertexes id2)) (weight e)))))))
678 :transform (lambda (k v) (list k (first v) (second v))))
682 ;;; ---------------------------------------------------------------------------
684 (defclass* weighted-sampler-with-lookup-container ()
688 ;;; ---------------------------------------------------------------------------
690 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
691 &key random-number-generator key)
692 (setf (slot-value object 'sampler)
693 (make-container 'weighted-sampling-container
694 :random-number-generator random-number-generator
696 (slot-value object 'lookup)
697 (make-container 'simple-associative-container)))
699 ;;; ---------------------------------------------------------------------------
701 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
703 (let ((node (nth-value 1 (insert-item (sampler container) item))))
705 (assert (not (null node)))
706 (setf (item-at-1 (lookup container) item) node)))
708 ;;; ---------------------------------------------------------------------------
710 (defmethod find-node ((container weighted-sampler-with-lookup-container)
712 (item-at-1 (lookup container) item))
714 ;;; ---------------------------------------------------------------------------
716 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
718 ;; not going to worry about the hash table
719 (delete-node (sampler container) node))
721 ;;; ---------------------------------------------------------------------------
723 (defmethod next-element ((container weighted-sampler-with-lookup-container))
724 (next-element (sampler container)))
726 ;;; ---------------------------------------------------------------------------
728 (defmethod generate-scale-free-graph
729 (generator graph size kind-matrix add-edge-count
730 other-vertex-kind-samplers
732 &key (duplicate-edge-function 'identity))
733 (let* ((kind-count (array-dimension kind-matrix 0))
734 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
735 (vertex-sampler (make-array kind-count)))
736 (save-generation-information graph generator 'generate-scale-free-graph)
737 (flet ((sample-existing-vertexes (for-kind)
738 ;; return list of vertexes to attach based on preferential attachment
739 (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
740 add-edge-count generator) collect
741 (let ((vertex (next-element (aref vertex-sampler other-kind))))
744 for nil across vertex-sampler
746 (setf vertex (next-element (aref vertex-sampler i))
749 ;;?? remove. this should never happen
750 (unless vertex (break))
752 (list vertex other-kind))))
754 ;; handle bookkeeping for changed vertex degree
755 (bind ((sampler (aref vertex-sampler kind))
756 (node (find-node sampler thing)))
757 (delete-node sampler node)
758 (insert-item sampler thing))))
762 for nil across vertex-sampler do
763 (setf (aref vertex-sampler i)
764 (make-container 'weighted-sampler-with-lookup-container
765 :random-number-generator generator
766 :key (lambda (vertex)
767 (1+ (vertex-degree vertex))))))
769 ;; add vertexes and edges
770 (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
772 (let* ((element (funcall vertex-creator kind i))
773 (vertex (add-vertex graph element)))
774 (when (> i add-edge-count)
775 (loop for (other other-kind) in (sample-existing-vertexes kind) do
776 (update other-kind other)
778 (if (or (null kind) (null other)) (break))
779 (add-edge-between-vertexes
782 (lambda (e) (funcall duplicate-edge-function e)))))
783 (insert-item (aref vertex-sampler kind) vertex)))
787 ;;; ---------------------------------------------------------------------------
790 (defun poisson-connector (count generator)
791 (let* ((ts (poisson-random generator 2))
792 (cs (poisson-random generator 2))
793 (rest (- count ts cs)))
794 (loop for tick = t then (not tick) while (minusp rest) do
796 (if tick (decf ts) (decf cs)))
798 (append (make-list (truncate rest) :initial-element 0)
799 (make-list (truncate ts) :initial-element 1)
800 (make-list (truncate cs) :initial-element 2))
801 :generator generator)))
805 (generate-scale-free-graph
807 (make-container 'graph-container :default-edge-type :undirected)
812 (lambda (count generator)
813 (declare (ignore generator))
814 (make-list count :initial-element 0))
818 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
822 (generate-scale-free-graph
824 (make-container 'graph-container :default-edge-type :undirected)
829 (lambda (count generator)
830 (declare (ignore generator))
831 (make-list count :initial-element 0)))
833 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
837 (generate-scale-free-graph
839 (make-container 'graph-container :default-edge-type :undirected)
844 (lambda (count generator)
845 (declare (ignore generator))
846 (make-list count :initial-element 0)))
848 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
851 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
852 ;;; 102,959,032 words consed
853 Execution time profile from 2078 samples
856 Children Relative Absolute Consing Conses
858 %%check-keywords 99% 99% 100,970,656
859 sample-existing-vertexes 62%
860 insert-item <weighted-sampler-with-lookup-container> <t> 32%
861 add-vertex <basic-graph> <t> 2%
863 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
865 iterate-container <contents-as-array-mixin> <t> 1%
867 %%check-keywords 100%
868 sample-existing-vertexes 62% 61% 62,577,336
869 walk-tree-nodes <bst-node> <t> 99%
872 sample-existing-vertexes 100%
873 walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
874 #<anonymous function #xaa2070e> 77%
876 element-weight <weighted-sampling-container> <t> 2%
881 walk-tree-nodes <bst-node> <t> 98%
882 %%before-and-after-combined-method-dcode 2%
883 #<anonymous function #xaa2070e> 48% 47% 48,156,256
884 iterate-container <contents-as-array-mixin> <t> 73%
885 %%1st-two-arg-dcode 9%
886 iterate-edges <graph-container-vertex> <t> 6%
888 iterate-elements <abstract-container> <t> 2%
890 #<anonymous function #xaa2070e> 99%
892 iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
893 other-vertex <graph-container-edge> <graph-container-vertex> 43%
895 #<anonymous function #x271d31e> 10%
897 insert-item <weighted-sampler-with-lookup-container> <t> 92%
898 %make-std-instance 3%
900 %%standard-combined-method-dcode 1%
902 %%before-and-after-combined-method-dcode 34% 34% 34,400,720
903 insert-item <binary-search-tree> <bst-node> 90%
904 #<anonymous function #xaa2070e> 2%
905 shared-initialize <standard-object> <t> 2%
910 %%check-keywords 100%
911 insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
912 %%before-and-after-combined-method-dcode 100%
914 %%before-and-after-combined-method-dcode 100%
915 insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
919 insert-item <binary-search-tree> <bst-node> 99%
920 #<anonymous function #xaa2070e> 1%
921 %vertex-degree 26% 25% 25,870,312
922 #<anonymous function #xa7cee86> 68%
924 %std-slot-value-using-class 1%
927 iterate-container <contents-as-array-mixin> <t> 1%
930 iterate-container <contents-as-array-mixin> <t> 1%
931 #<anonymous function #xa7cee86> 18% 17% 17,420,592
932 %maybe-std-slot-value-using-class 8%
934 %std-slot-value-using-class 8%
936 vertex-1 <graph-container-edge> 5%
937 #<anonymous function #x271d31e> 1%
939 iterate-container <contents-as-array-mixin> <t> 99%
940 #<anonymous function #xa7cee86> 1%
941 other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
944 iterate-container <contents-as-array-mixin> <t> 95%
946 %%before-and-after-combined-method-dcode 1%
947 initialize-instance (around) <basic-initial-contents-mixin> 1%
948 %%nth-arg-dcode 7% 9% 9,238,560
950 #<anonymous function #xaa2070e> 93%
951 walk-tree-nodes <bst-node> <t> 5%
952 %%before-and-after-combined-method-dcode 2%
953 %%1st-two-arg-dcode 5% 5% 4,802,264
955 iterate-container <contents-as-array-mixin> <t> 96%
956 #<anonymous function #xa7cee86> 3%
957 shared-initialize <standard-object> <t> 1%
958 #<anonymous function #x271d31e> 4% 4% 4,012,368
960 #<anonymous function #xaa2070e> 100%
961 iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
963 #<anonymous function #xa7cee86> 59%
965 walk-tree-nodes <bst-node> <t> 13%
966 shared-initialize <standard-object> <t> 6%
967 %shared-initialize 4%
968 other-vertex <graph-container-edge> <graph-container-vertex> 2%
970 %std-slot-value-using-class 2% 2% 2,115,320
972 #<anonymous function #xa7cee86> 59%
973 walk-tree-nodes <bst-node> <t> 12%
975 %%before-and-after-combined-method-dcode 6%
976 shared-initialize <standard-object> <t> 4%
978 other-vertex <graph-container-edge> <graph-container-vertex> 4%
979 %shared-initialize 2%
980 %%one-arg-dcode 2% 2% 2,478,304
982 make-instance <symbol> 68%
984 make-instance <standard-class> 9%
985 %make-std-instance 2% 2% 2,283,344
986 %%before-and-after-combined-method-dcode 47%
987 shared-initialize <standard-object> <t> 15%
988 %%standard-combined-method-dcode 12%
989 %maybe-std-slot-value-using-class 3%
991 #<anonymous function #xa7cee86> 78%
994 %make-std-instance 2%
995 shared-initialize <standard-object> <t> 3%
996 view-get <simple-view> <t> 2%
997 walk-tree-nodes <bst-node> <t> 3%
998 %maybe-std-slot-value-using-class 2% 2% 2,005,048
1000 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
1001 add-vertex <basic-graph> <t> 40%
1002 initialize-instance (after) <graph-container-vertex> 7%
1004 %%before-and-after-combined-method-dcode 5%
1005 make-instance <symbol> 2% 2% 1,932,504
1006 %make-std-instance 92%
1008 #<anonymous function #xaa2070e> 100%
1009 constantly 2% 2% 1,629,880
1011 walk-tree-nodes <bst-node> <t> 97%
1012 %%before-and-after-combined-method-dcode 3%
1014 %maybe-std-slot-value-using-class 3%
1016 %%check-keywords 100%
1017 add-vertex <basic-graph> <t> 2% 2% 2,259,304
1018 make-instance <symbol> 44%
1019 %%standard-combined-method-dcode 30%
1020 %%before-and-after-combined-method-dcode 8%
1021 %make-std-instance 3%
1023 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
1024 %%standard-combined-method-dcode 48%
1025 %%check-keywords 16%
1027 make-instance <symbol> 6%
1029 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
1030 add-vertex <basic-graph> <t> 25%
1031 %make-std-instance 18%
1032 make-instance <standard-class> 6%
1034 insert-item <weighted-sampler-with-lookup-container> <t> 3%
1035 %%standard-combined-method-dcode 2% 2% 2,019,832
1036 insert-item <container-uses-nodes-mixin> <t> 45%
1037 %%before-and-after-combined-method-dcode 25%
1039 make-instance <symbol> 3%
1041 #<GRAPH-CONTAINER 1000>
1046 (open-plot-in-window
1049 (clnuplot::data->n-buckets
1050 (sort (collect-items x :transform #'vertex-degree) #'>)
1055 (and (plusp (first x))
1056 (plusp (second x ))))
1059 (list (log (first x) 10) (log (second x)))))))
1063 (clasp:linear-regression-brief
1065 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1066 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1067 (3.2961164921697144 1.6094379124341003)
1068 (3.3831867994748994 1.9459101490553132)
1069 (3.4556821645007902 0.6931471805599453)
1070 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1071 (3.932600584500482 0.0))
1074 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1075 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1076 (3.2961164921697144 1.6094379124341003)
1077 (3.3831867994748994 1.9459101490553132)
1078 (3.4556821645007902 0.6931471805599453)
1079 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1080 (3.932600584500482 0.0))
1085 ;;; ---------------------------------------------------------------------------
1086 ;;; generate-assortative-graph-with-degree-distributions
1087 ;;; ---------------------------------------------------------------------------
1090 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1092 ;;; ---------------------------------------------------------------------------
1094 (defmethod generate-assortative-graph-with-degree-distributions
1095 (generator (graph-class symbol)
1096 edge-count assortativity-matrix
1098 degree-distributions
1100 &key (duplicate-edge-function 'identity))
1101 (generate-assortative-graph-with-degree-distributions
1102 generator (make-instance graph-class)
1103 edge-count assortativity-matrix
1105 degree-distributions
1107 :duplicate-edge-function duplicate-edge-function))
1110 Split into a function to compute some of the intermediate pieces and one to use them
1113 (defmethod generate-assortative-graph-with-degree-distributions
1114 (generator graph edge-count assortativity-matrix
1116 degree-distributions
1118 &key (duplicate-edge-function 'identity))
1119 (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1120 (let* ((kind-count (array-dimension assortativity-matrix 0))
1121 (vertex->degree-counts (make-array kind-count))
1123 (sample-edges-for-assortative-graph
1124 generator edge-count assortativity-matrix)))
1127 (append (element-counts edges :key #'first)
1128 (element-counts edges :key #'second))
1132 new) :key #'first :argument #'second)
1135 (vertex-counts (collect-elements
1138 (lambda (kind-and-count)
1139 (round (float (/ (second kind-and-count)
1140 (elt average-degrees (first kind-and-count))))))))
1141 (edge-samplers (make-array kind-count)))
1142 (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1144 ;; setup bookkeeping
1145 (loop for kind from 0 to (1- kind-count) do
1146 (setf (aref edge-samplers kind)
1147 (make-container 'vector-container)
1148 (aref vertex->degree-counts kind)
1149 (make-container 'simple-associative-container)))
1150 (loop for edge in edges do
1151 (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1152 (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1154 edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1156 ;(spy edges degree-sums vertex-counts)
1158 (loop for kind from 0 to (1- kind-count)
1159 for count in vertex-counts do
1160 (let ((distribution (nth-element degree-distributions kind))
1161 (vertexes (make-container 'vector-container))
1162 (vertex-degrees (aref vertex->degree-counts kind))
1164 (desired-sum (second (elt degree-sums kind))))
1166 ;; for each type, create vertexes
1167 (loop for i from 0 to (1- count) do
1168 (let ((vertex (funcall vertex-creator kind i))
1169 (degree (funcall distribution)))
1170 (insert-item vertexes vertex)
1171 (setf (item-at-1 vertex-degrees vertex)
1173 (incf total-degree degree)))
1175 ;(spy vertexes total-degree desired-sum)
1177 ;; ensure proper total degree
1178 (loop while (/= total-degree desired-sum) do
1180 (when-debugging-format
1181 generate-assortative-graph-with-degree-distributions
1182 "Current: ~D, Desired: ~D, Difference: ~D"
1183 total-degree desired-sum
1184 (abs (- total-degree desired-sum)))
1185 (let* ((vertex (sample-element vertexes generator))
1186 (bigger? (< total-degree desired-sum))
1187 (current-degree (item-at-1 vertex-degrees vertex))
1192 (plusp current-degree)))
1193 (decf total-degree current-degree)
1196 (when-debugging-format
1197 generate-assortative-graph-with-degree-distributions
1199 total-degree current-degree new-degree (not bigger?))
1201 ;; increase speed by knowing which direction we need to go...?
1202 (loop until (or (zerop (decf attempts))
1204 (> (setf new-degree (funcall distribution))
1207 (< (setf new-degree (funcall distribution))
1208 current-degree))) do
1210 (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1212 (cond ((plusp attempts)
1215 generate-assortative-graph-with-degree-distributions
1216 (format *debug-io* " -> ~D" new-degree))
1218 (setf (item-at-1 vertex-degrees vertex) new-degree)
1219 (incf total-degree new-degree)
1222 (when-debugging-format
1223 generate-assortative-graph-with-degree-distributions
1224 "~D ~D" total-degree desired-sum))
1226 ;; couldn't find one, try again
1227 (incf total-degree current-degree))))))
1230 (let ((edge-sampler (aref edge-samplers kind)))
1231 (flet ((sample-edges-for-vertex (vertex)
1233 (loop repeat (item-at-1 vertex-degrees vertex) do
1234 (bind (((edge-kind . edge) (delete-last edge-sampler)))
1236 (:source (setf (first edge) vertex))
1237 (:target (setf (second edge) vertex)))))))
1240 #'sample-edges-for-vertex)))))
1242 ;; repair self edges
1245 ;; now make the graph [at last]
1249 (add-edge-between-vertexes graph (first edge) (second edge)
1250 :if-duplicate-do duplicate-edge-function))))
1255 (generate-assortative-graph-with-degree-distributions
1259 #2A((0.1111111111111111 0.2222222222222222)
1260 (0.2222222222222222 0.4444444444444444))
1262 #2A((0.011840772766222637 0.04524421593830334)
1263 (0.04524421593830334 0.8976707953571706))
1266 (make-degree-sampler
1268 (poisson-vertex-degree-distribution 3 i))
1269 :generator *random-generator*)
1270 (make-degree-sampler
1272 (poisson-vertex-degree-distribution 3 i))
1273 :generator *random-generator*))
1275 (lambda (kind count)
1276 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1281 (sample-edges-for-assortative-graph
1284 #2A((0.1111111111111111 0.2222222222222222)
1285 (0.2222222222222222 0.4444444444444444))))
1288 ;;; ---------------------------------------------------------------------------
1289 ;;; generate-graph-by-resampling-edges
1290 ;;; ---------------------------------------------------------------------------
1293 doesn't take edge weights into account when sampling
1295 should include pointer back to original graph
1298 (defclass* basic-edge-sampler ()
1302 ;;; ---------------------------------------------------------------------------
1304 (defmethod next-element ((sampler basic-edge-sampler))
1305 (sample-element (graph-edges (graph sampler)) (generator sampler)))
1307 ;;; ---------------------------------------------------------------------------
1309 (defclass* weighted-edge-sampler (basic-edge-sampler)
1310 ((weight-so-far 0 a)
1311 (index-iterator nil r)
1312 (edge-iterator nil r)
1315 ;;; ---------------------------------------------------------------------------
1317 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1318 (bind ((generator (generator object))
1319 (weighted-edge-count
1321 (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1323 (unless (size object)
1324 (setf (slot-value object 'size) weighted-edge-count))
1325 (setf (slot-value object 'index-iterator)
1327 (sort (loop repeat (size object) collect
1328 (integer-random generator 1 weighted-edge-count)) #'<))
1329 (slot-value object 'edge-iterator)
1330 (make-iterator (graph-edges (graph object))))))
1332 ;;; ---------------------------------------------------------------------------
1334 (defmethod next-element ((object weighted-edge-sampler))
1335 (let ((edge-iterator (edge-iterator object))
1336 (index-iterator (index-iterator object)))
1337 (move-forward index-iterator)
1338 (loop while (< (weight-so-far object) (current-element index-iterator)) do
1339 (move-forward edge-iterator)
1340 (incf (weight-so-far object) (weight (current-element edge-iterator))))
1341 (current-element edge-iterator)))
1343 ;;; ---------------------------------------------------------------------------
1345 (defmethod generate-graph-by-resampling-edges
1346 (generator original-graph &key
1347 (edge-sampler-class 'basic-edge-sampler)
1348 (edge-count (edge-count original-graph)))
1349 (let ((graph (copy-template original-graph))
1350 (edge-sampler (make-instance edge-sampler-class
1351 :generator generator
1352 :graph original-graph
1354 (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1360 (add-vertex graph (element v))))
1363 (loop repeat edge-count do
1364 (let ((edge (next-element edge-sampler)))
1365 (if (directed-edge-p edge)
1366 (add-edge-between-vertexes
1367 graph (element (source-vertex edge)) (element (target-vertex edge))
1368 :edge-type :directed
1369 :if-duplicate-do (lambda (e) (incf (weight e))))
1370 (add-edge-between-vertexes
1371 graph (element (vertex-1 edge)) (element (vertex-2 edge))
1372 :edge-type :undirected
1373 :if-duplicate-do (lambda (e) (incf (weight e)))))))
1378 (fluid-bind (((random-seed *random-generator*) 1))
1379 (let* ((dd-1 (lambda (i)
1381 (power-law-vertex-degree-distribution 3 i)
1382 (poisson-vertex-degree-distribution 3 i)))
1385 (power-law-vertex-degree-distribution 3 i)
1386 (poisson-vertex-degree-distribution 3 i)))
1387 (g (generate-assortative-graph-with-degree-distributions
1389 (make-instance 'graph-container
1390 :default-edge-type :undirected
1391 :undirected-edge-class 'weighted-edge)
1393 #2A((0.011840772766222637 0.04524421593830334)
1394 (0.04524421593830334 0.8976707953571706))
1397 (make-degree-sampler
1399 :generator *random-generator*
1401 :min-probability nil)
1402 (make-degree-sampler
1404 :generator *random-generator*
1406 :min-probability nil))
1407 #'simple-group-id-generator
1408 :duplicate-edge-function (lambda (e) (incf (weight e))))))
1410 (average-vertex-degree
1412 :vertex-filter (lambda (v)
1413 (plusp (edge-count v)))
1414 :edge-size #'weight)))
1416 (loop for i from 1 to 10
1418 (fluid-bind (((random-seed *random-generator*) i))
1420 (generate-graph-by-resampling-edges
1421 *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1423 ;;; ---------------------------------------------------------------------------
1424 ;;; some preferential attachment algorithms
1425 ;;; ---------------------------------------------------------------------------
1428 (define-debugging-class generate-preferential-attachment-graph
1431 ;;; ---------------------------------------------------------------------------
1433 (defmethod generate-simple-preferential-attachment-graph
1434 (generator (graph-class symbol) size minimum-degree)
1435 (generate-simple-preferential-attachment-graph
1436 generator (make-instance graph-class) size minimum-degree))
1438 ;;; ---------------------------------------------------------------------------
1440 (defmethod generate-simple-preferential-attachment-graph
1441 (generator graph size minimum-degree)
1442 (bind ((m (make-array (list (* 2 size minimum-degree)))))
1443 (loop for v from 0 to (1- size) do
1444 (loop for i from 0 to (1- minimum-degree) do
1445 (bind ((index (* 2 (+ i (* v minimum-degree))))
1446 (r (integer-random generator 0 index)))
1447 (setf (item-at m index) v
1448 (item-at m (1+ index)) (item-at m r)))))
1449 (loop for i from 0 to (1- (* size minimum-degree)) do
1450 (add-edge-between-vertexes
1451 graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1456 (generate-simple-preferential-attachment-graph
1458 (make-container 'graph-container :default-edge-type :undirected)
1464 (collect-nodes (ds :g-b)
1465 :transform (lambda (v) (list (element v) (vertex-degree v))))
1470 ;;; ---------------------------------------------------------------------------
1472 (defmethod generate-preferential-attachment-graph
1473 (generator (graph-class symbol) size kind-matrix minimum-degree
1474 assortativity-matrix
1475 &key (vertex-labeler 'simple-group-id-generator)
1476 (duplicate-edge-function :ignore))
1477 (generate-preferential-attachment-graph
1478 generator (make-instance graph-class)
1479 size kind-matrix minimum-degree assortativity-matrix
1480 :vertex-labeler vertex-labeler
1481 :duplicate-edge-function duplicate-edge-function))
1483 ;;; ---------------------------------------------------------------------------
1485 (defmethod generate-preferential-attachment-graph
1486 (generator (graph basic-graph) size kind-matrix minimum-degree
1487 assortativity-matrix
1488 &key (vertex-labeler 'simple-group-id-generator)
1489 (duplicate-edge-function :ignore))
1490 (bind ((kind-count (array-dimension kind-matrix 0))
1491 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1492 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1493 (edge-recorders (make-array (list kind-count)))
1494 (count-recorders (make-array (list kind-count) :initial-element 0))
1495 (edge-samplers (make-array (list kind-count))))
1497 ;; set up record keeping
1498 (dotimes (i kind-count)
1499 (setf (aref edge-recorders i)
1500 (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1501 :initial-element nil))
1502 (setf (aref edge-samplers i)
1503 (make-edge-sampler-for-preferential-attachment-graph
1504 generator (array-row assortativity-matrix i))))
1506 ;; add vertexes (to ensure that we have something at which to point)
1507 (loop for v from 0 to (1- size)
1508 for kind in vertex-kinds do
1509 (bind ((edge-recorder (aref edge-recorders kind)))
1510 (loop for i from 0 to (1- minimum-degree) do
1511 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1512 (setf (item-at edge-recorder index)
1513 (funcall vertex-labeler kind v)))))
1514 (incf (aref count-recorders kind)))
1517 (dotimes (i kind-count)
1518 (setf (aref count-recorders i) 0))
1519 (loop for v from 0 to (1- size)
1520 for kind in vertex-kinds do
1521 (bind ((edge-recorder (aref edge-recorders kind))
1522 (edge-sampler (aref edge-samplers kind)))
1523 (loop for i from 0 to (1- minimum-degree) do
1524 (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1525 (other-kind (funcall edge-sampler))
1526 (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1527 (aref count-recorders other-kind))
1529 (other-edge-recorder (aref edge-recorders other-kind))
1530 (r (integer-random generator 0 (1- other-index))))
1532 (when-debugging-format
1533 generate-preferential-attachment-graph
1534 "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1535 kind (1+ index) other-kind r other-index)
1536 (setf (item-at edge-recorder (1+ index))
1537 (cond ((item-at other-edge-recorder r)
1538 (item-at other-edge-recorder r))
1539 ((and (= kind other-kind)
1542 (item-at edge-recorder index))
1544 ;; haven't done the other one yet... save it for later fixing
1545 (list other-kind r))))))
1546 (incf (aref count-recorders kind))))
1549 (let ((corrections 0)
1550 (last-corrections nil)
1552 (loop while again? do
1555 (dotimes (kind kind-count)
1556 (loop for vertex across (aref edge-recorders kind)
1557 for index = 0 then (1+ index)
1558 when (consp vertex) do
1559 (bind (((other-kind other-index) vertex))
1561 (when-debugging-format
1562 generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1564 (aref (aref edge-recorders other-kind) other-index))
1566 (if (and (= kind other-kind) (= index other-index))
1567 ;; pointing at myself
1568 (setf (aref (aref edge-recorders kind) index)
1569 (aref (aref edge-recorders kind) (1- index)))
1570 (let ((new (aref (aref edge-recorders other-kind) other-index)))
1573 (setf (aref (aref edge-recorders kind) index) new))))))
1574 (when (and last-corrections
1575 (>= corrections last-corrections))
1576 (error "It's not getting any better old boy"))
1577 (setf last-corrections corrections)))
1579 ;; make sure we got 'em all
1580 (dotimes (i kind-count)
1581 (loop for vertex across (aref edge-recorders i)
1582 when (not (symbolp vertex)) do (error "bad function, down boy")))
1584 (dotimes (i kind-count)
1585 (let ((edge-recorder (aref edge-recorders i)))
1586 (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1587 (add-edge-between-vertexes
1588 graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1589 :if-duplicate-do duplicate-edge-function))))
1592 ;; record properties
1593 (record-graph-properties graph)
1594 (setf (get-value graph :initial-seed) (random-seed generator))
1595 (setf (get-value graph :size) size
1596 (get-value graph :minimum-degree) minimum-degree
1597 (get-value graph :assortativity-matrix) assortativity-matrix
1598 (get-value graph :duplicate-edge-function) duplicate-edge-function)
1603 ;;; ---------------------------------------------------------------------------
1605 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1606 (let ((c (make-container 'weighted-sampling-container
1607 :random-number-generator generator
1609 (aref assortativities item)))))
1610 (dotimes (i (array-dimension assortativities 0))
1612 (lambda () (next-element c))))
1617 (make-edge-sampler-for-preferential-attachment-graph
1618 *random-generator* #(0.02 0.25 0.25))))
1619 (loop repeat 100 collect (funcall s)))
1623 (setf (random-seed *random-generator*) 2)
1624 (generate-preferential-attachment-graph
1626 (make-graph 'graph-container :edge-type :undirected)
1630 #2A((0.96 0.02 0.02)
1635 (generate-preferential-attachment-graph
1637 (make-graph 'graph-container :edge-type :undirected)
1641 #2A((0.96 0.02 0.02)
1647 (generate-preferential-attachment-graph
1649 (make-graph 'graph-container :edge-type :undirected)
1653 #2A((0.96 0.02 0.02)
1657 ;;; ---------------------------------------------------------------------------
1660 (defmethod generate-acquaintance-network
1661 (generator (class-name symbol) size death-probability iterations vertex-labeler
1662 &key (duplicate-edge-function :ignore))
1663 (generate-acquaintance-network
1664 generator (make-instance class-name)
1665 size death-probability iterations vertex-labeler
1666 :duplicate-edge-function duplicate-edge-function))
1668 (defmethod generate-acquaintance-network
1669 (generator graph size death-probability iterations vertex-labeler
1670 &key (duplicate-edge-function :ignore))
1671 ;; bring the graph up to size
1672 (loop for i from (size graph) to (1- size) do
1673 (add-vertex graph (funcall vertex-labeler 0 i)))
1675 (loop repeat iterations do
1676 (add-acquaintance-and-maybe-kill-something
1677 generator graph death-probability duplicate-edge-function))
1680 ;;; ---------------------------------------------------------------------------
1682 (defmethod generate-acquaintance-network-until-stable
1683 (generator graph size death-probability step-count
1684 stability-fn vertex-labeler
1685 &key (duplicate-edge-function :ignore))
1686 ;; bring the graph up to size
1687 (loop for i from (size graph) to (1- size) do
1688 (add-vertex graph (funcall vertex-labeler 0 i)))
1691 (loop repeat step-count do
1692 (add-acquaintance-and-maybe-kill-something
1693 generator graph death-probability duplicate-edge-function))
1694 (when (funcall stability-fn graph)
1699 ;;; ---------------------------------------------------------------------------
1701 (defun add-acquaintance-and-maybe-kill-something
1702 (generator graph death-probability duplicate-edge-function)
1704 (bind ((vertex (sample-element (graph-vertexes graph) generator))
1705 (neighbors (when (>= (size (vertex-edges vertex)) 2)
1706 (sample-unique-elements
1707 (vertex-edges vertex) generator 2))))
1708 (flet ((sample-other-vertex ()
1709 (loop for result = (sample-element (graph-vertexes graph) generator)
1710 until (not (eq vertex result))
1711 finally (return result))))
1713 (add-edge-between-vertexes
1715 (other-vertex (first neighbors) vertex)
1716 (other-vertex (second neighbors) vertex)
1717 :if-duplicate-do duplicate-edge-function)
1718 (add-edge-between-vertexes
1719 graph vertex (sample-other-vertex)
1720 :if-duplicate-do duplicate-edge-function))))
1722 ;; remove vertexes step
1723 (when (random-boolean generator death-probability)
1724 (let ((vertex (sample-element (graph-vertexes graph) generator)))
1725 (delete-vertex graph vertex)
1726 (add-vertex graph (element vertex)))))
1732 (adjustable-array-p (contents (vertex-edges v)))))
1735 (generate-acquaintance-network
1737 (make-graph 'graph-container :edge-type :undirected)
1741 'simple-group-id-generator)