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)))
33 (defclass* generated-graph-mixin ()
34 ((generation-method nil ir)
35 (random-seed nil ir)))
38 (defun save-generation-information (graph generator method)
40 ;; (setf (random-seed generator) (random-seed generator))
41 (unless (typep graph 'generated-graph-mixin)
42 (change-class graph (find-or-create-class
43 'basic-graph (list 'generated-graph-mixin
44 (class-name (class-of graph))))))
45 (setf (slot-value graph 'generation-method) method
46 (slot-value graph 'random-seed) (random-seed generator)))
49 (defun simple-group-id-generator (kind count)
50 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count)))
53 (defun simple-group-id-parser (vertex)
54 (parse-integer (subseq (symbol-name (element vertex)) 1 3)))
59 (defmethod generate-gnp (generator (graph-class symbol) n p &key (label 'identity))
61 generator (make-instance graph-class) n p :label label))
64 (defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity))
67 (log-1-p (log (- 1 p))))
68 (save-generation-information graph generator 'generate-gnp)
69 (loop for i from 0 to (1- n) do
70 (add-vertex graph (funcall label i)))
71 (loop while (< v n) do
72 (let ((r (uniform-random generator 0d0 1d0)))
73 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
74 (loop while (and (>= w v) (< v n)) do
78 (add-edge-between-vertexes
79 graph (funcall label v) (funcall label w)))))
85 (defmethod generate-gnm (generator (graph-class symbol) n p &key (label 'identity))
87 generator (make-instance graph-class) n p :label label))
90 (defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity))
91 (let ((max-edge-index (1- (combination-count n 2))))
92 (assert (<= m max-edge-index))
94 (save-generation-information graph generator 'generate-gnm)
95 (loop for i from 0 to (1- n) do
96 (add-vertex graph (funcall label i)))
97 (loop for i from 0 to (1- m) do
99 until (let* ((i (integer-random generator 0 max-edge-index))
100 (v (1+ (floor (+ -0.5 (sqrt (+ 0.25 (* 2 i)))))))
101 (w (- i (/ (* v (1- v)) 2)))
102 (label-v (funcall label v))
103 (label-w (funcall label w)))
104 (unless (find-edge-between-vertexes
105 graph label-v label-w :error-if-not-found? nil)
106 (add-edge-between-vertexes graph label-v label-w)))))
112 (setf g (generate-gnm
114 'graph-container 10000 (floor (* 0.0001 (combination-count 10000 2)))))
118 (defun vertex-group (v)
119 (aref (symbol-name (element v)) 1))
122 (defun in-group-degree (v &key (key 'vertex-group))
124 v :edge-filter (lambda (e ov)
126 (in-same-group-p v ov key))))
129 (defun in-same-group-p (v1 v2 key)
130 (eq (funcall key v1) (funcall key v2)))
133 (defun out-group-degree (v &key (key 'vertex-group))
135 v :edge-filter (lambda (e ov)
137 (not (in-same-group-p v ov key)))))
139 ;;; generate-undirected-graph-via-assortativity-matrix
141 (defmethod generate-undirected-graph-via-assortativity-matrix
142 (generator (graph-class symbol) size edge-count
143 kind-matrix assortativity-matrix vertex-creator
144 &key (duplicate-edge-function 'identity))
145 (generate-undirected-graph-via-assortativity-matrix
146 generator (make-instance graph-class) size edge-count
147 kind-matrix assortativity-matrix vertex-creator
148 :duplicate-edge-function duplicate-edge-function))
151 (defmethod generate-undirected-graph-via-assortativity-matrix
152 (generator graph size edge-count
153 kind-matrix assortativity-matrix vertex-creator
154 &key (duplicate-edge-function 'identity))
155 (let* ((kind-count (array-dimension assortativity-matrix 0))
156 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
158 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
159 (vertex-sampler (make-array kind-count))
160 (edge-kinds (sample-edges-for-assortative-graph
161 generator edge-count assortativity-matrix))
163 (save-generation-information graph generator 'generate-undirected-graph-via-assortativity-matrix)
165 (loop for vertex-kind from 0 to (1- kind-count)
166 for count in vertex-kind-counts do
167 (setf (aref vertex-sampler vertex-kind)
168 (make-array (second count))))
170 (let ((current-kind 0)
172 (current-vertexes (aref vertex-sampler 0)))
174 (loop for kind in vertex-kinds
176 (when (not (eq current-kind kind))
177 (setf current-count 0
179 current-vertexes (aref vertex-sampler current-kind)))
180 (let ((vertex (funcall vertex-creator kind i)))
181 (setf (aref current-vertexes current-count) vertex)
182 (add-vertex graph vertex)
183 (incf current-count)))
185 (loop for (from-kind to-kind) in edge-kinds do
188 (if (= from-kind to-kind)
189 (let ((sample (sample-unique-elements (aref vertex-sampler from-kind)
191 (setf v1 (first sample) v2 (second sample)))
192 (setf v1 (sample-element (aref vertex-sampler from-kind) generator)
193 v2 (sample-element (aref vertex-sampler to-kind) generator)))
194 (add-edge-between-vertexes
198 :if-duplicate-do (lambda (e) (funcall duplicate-edge-function e))))))
202 ;;; generate-undirected-graph-via-verex-probabilities
204 (defmethod generate-undirected-graph-via-vertex-probabilities
205 (generator (graph-class symbol) size
206 kind-matrix probability-matrix vertex-creator)
207 (generate-undirected-graph-via-vertex-probabilities
208 generator (make-instance graph-class) size
209 kind-matrix probability-matrix vertex-creator))
212 (defmethod generate-undirected-graph-via-vertex-probabilities
213 (generator graph size
214 kind-matrix probability-matrix vertex-creator)
215 (let* ((kind-count (array-dimension probability-matrix 0))
216 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
218 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
219 (vertex-sampler (make-array kind-count)))
220 (save-generation-information graph generator
221 'generate-undirected-graph-via-vertex-probabilities)
223 ;; initialize vertex bookkeeping
224 (loop for vertex-kind from 0 to (1- kind-count)
225 for count in vertex-kind-counts do
226 (setf (aref vertex-sampler vertex-kind)
227 (make-array (second count))))
230 (let ((current-kind 0)
232 (current-vertexes (aref vertex-sampler 0)))
233 (loop for kind in vertex-kinds
235 (when (not (eq current-kind kind))
236 (setf current-count 0
238 current-vertexes (aref vertex-sampler current-kind)))
239 (let ((vertex (funcall vertex-creator kind i)))
240 (setf (aref current-vertexes current-count) vertex)
241 (add-vertex graph vertex)
242 (incf current-count))))
245 ;; adjust probabilities
246 (loop for (kind-1 count-1) in vertex-kind-counts do
247 (loop for (kind-2 count-2) in vertex-kind-counts
248 when (<= kind-1 kind-2) do
249 (format t "~%~6,6F ~6,6F"
250 (aref probability-matrix kind-1 kind-2)
251 (float (/ (aref probability-matrix kind-1 kind-2)
252 (* count-1 count-2))))
253 (setf (aref probability-matrix kind-1 kind-2)
254 (float (/ (aref probability-matrix kind-1 kind-2)
255 (* count-1 count-2))))))
258 (flet ((add-one-edge (k1 k2 a b)
259 (add-edge-between-vertexes
261 (aref (aref vertex-sampler k1) a)
262 (aref (aref vertex-sampler k2) b))))
263 (loop for (kind-1 count-1) in vertex-kind-counts do
264 (loop for (kind-2 count-2) in vertex-kind-counts
265 when (<= kind-1 kind-2) do
266 (if (eq kind-1 kind-2)
267 (sample-edges-of-same-kind
268 generator count-1 (aref probability-matrix kind-1 kind-2)
270 (add-one-edge kind-1 kind-2 a b)))
271 (sample-edges-of-different-kinds
272 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
274 (add-one-edge kind-1 kind-2 a b)))))))
279 (defmethod generate-undirected-graph-via-vertex-probabilities
280 (generator graph size
281 kind-matrix probability-matrix vertex-creator)
282 (let* ((kind-count (array-dimension probability-matrix 0))
283 (vertex-kinds (sort (sample-vertexes-for-mixed-graph generator size kind-matrix)
285 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
286 (vertex-sampler (make-array kind-count)))
288 (loop for vertex-kind from 0 to (1- kind-count)
289 for count in vertex-kind-counts do
290 (setf (aref vertex-sampler vertex-kind)
291 (make-array (second count))))
293 (let ((current-kind 0)
295 (current-vertexes (aref vertex-sampler 0)))
297 (loop for kind in vertex-kinds
299 (when (not (eq current-kind kind))
300 (setf current-count 0
302 current-vertexes (aref vertex-sampler current-kind)))
303 (let ((vertex (funcall vertex-creator kind i)))
304 (setf (aref current-vertexes current-count) vertex)
305 (add-vertex graph vertex)
306 (incf current-count))))
309 (flet ((add-one-edge (k1 k2 a b)
311 (add-edge-between-vertexes
313 (aref (aref vertex-sampler k1) a)
314 (aref (aref vertex-sampler k2) b))))
315 (loop for (kind-1 count-1) in vertex-kind-counts do
316 (loop for (kind-2 count-2) in vertex-kind-counts
317 when (<= kind-1 kind-2) do
319 (if (eq kind-1 kind-2)
320 (sample-edges-of-same-kind
321 generator count-1 (aref probability-matrix kind-1 kind-2)
323 (add-one-edge kind-1 kind-2 a b)))
324 (sample-edges-of-different-kinds
325 generator count-1 count-2 (aref probability-matrix kind-1 kind-2)
327 (add-one-edge kind-1 kind-2 a b))))
328 (format t "~%~A ~A ~A ~A -> ~A"
329 count-1 count-2 kind-1 kind-2 xxx)))))
334 (generate-undirected-graph-via-vertex-probabilities
335 *random-generator* 'graph-container
338 #2A((0.1 0.02) (0.02 0.6))
340 (form-keyword "H" (format nil "~2,'0D~4,'0D" kind count))))
343 (defun sample-edges-of-same-kind (generator n p fn)
347 (log-1-p (log (- 1 p))))
348 (loop while (< v n) do
349 (let ((r (uniform-random generator 0d0 1d0)))
350 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
351 (loop while (and (>= w v) (< v n)) do
355 (funcall fn v w)))))))
358 (sample-edges-of-same-kind *random-generator* 10 0.2 (lambda (a b) (print (list a b))))
361 (defun sample-edges-of-different-kinds (generator rows cols p fn)
365 (log-1-p (log (- 1 p))))
366 (loop while (< v rows) do
367 (let ((r (uniform-random generator 0d0 1d0)))
368 (setf w (+ w 1 (floor (/ (log (- 1 r)) log-1-p))))
369 (loop while (and (>= w cols) (< v rows)) do
373 (funcall fn v w)))))))
376 (defun poisson-vertex-degree-distribution (z k)
377 (/ (* (expt z k) (expt cl-mathstats:+e+ (- z)))
381 We know the probability of finding a vertex of degree k is p_k. We want to sample
382 from this distribution
386 (defun power-law-vertex-degree-distribution (kappa k)
387 (* (- 1 (expt cl-mathstats:+e+ (- (/ kappa))))
388 (expt cl-mathstats:+e+ (- (/ k kappa)))))
391 (defun create-specified-vertex-degree-distribution (degrees)
393 (declare (ignore z k))
397 (defun make-degree-sampler (p_k &key (generator *random-generator*)
399 (min-probability 0.0001))
400 (let ((wsc (make-container 'containers:weighted-sampling-container
401 :random-number-generator generator
405 (loop for k = 0 then (1+ k)
406 for p = (funcall p_k k)
407 until (or (and max-degree (> k max-degree))
408 (and min-probability (< (- 1.0 total) min-probability))) do
411 (insert-item wsc (list k p)))
412 (when (plusp (- 1.0 total))
413 (insert-item wsc (list (1+ max-k) (- 1.0 total))))
415 (first (next-element wsc)))))
419 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
420 (let ((c (make-container 'weighted-sampling-container
421 :random-number-generator generator
423 (aref assortativity-matrix (first item) (second item))))))
424 (dotimes (i (array-dimension assortativity-matrix 0))
425 (dotimes (j (array-dimension assortativity-matrix 1))
426 (insert-item c (list i j))))
427 (loop repeat edge-count collect
431 (defun sample-edges-for-assortative-graph (generator edge-count assortativity-matrix)
432 (let ((s (make-edge-sampler-for-assortative-graph generator assortativity-matrix)))
433 (loop repeat edge-count collect
437 (defun make-edge-sampler-for-assortative-graph (generator assortativity-matrix)
438 (let ((c (make-container 'weighted-sampling-container
439 :random-number-generator generator
441 (aref assortativity-matrix (first item) (second item))))))
442 (dotimes (i (array-dimension assortativity-matrix 0))
443 (dotimes (j (array-dimension assortativity-matrix 1))
444 (insert-item c (list i j))))
445 (lambda () (next-element c))))
448 (defun sample-vertexes-for-mixed-graph (generator size kind-matrix)
449 (cond ((every-element-p kind-matrix (lambda (x) (fixnump x)))
450 ;; use kind-matrix as counts
451 (assert (= size (sum-of-array-elements kind-matrix)))
452 (coerce (shuffle-elements!
455 (loop for i = 0 then (1+ i)
456 for count across kind-matrix nconc
457 (make-list count :initial-element i)))
458 :generator generator)
462 ;; use kind-matrix as ratios to sample
463 (let* ((c (make-container 'weighted-sampling-container
464 :random-number-generator generator
466 (aref kind-matrix item)))))
467 (dotimes (i (array-dimension kind-matrix 0))
469 (loop repeat size collect
470 (next-element c))))))
473 (sample-vertexes-for-mixed-graph
475 50 #2A((0.258 0.016 0.035 0.013)
476 (0.012 0.157 0.058 0.019)
477 (0.013 0.023 0.306 0.035)
478 (0.005 0.007 0.024 0.016)))
481 (sample-edges 50 #2A((0.258 0.016 0.035 0.013)
482 (0.012 0.157 0.058 0.019)
483 (0.013 0.023 0.306 0.035)
484 (0.005 0.007 0.024 0.016)))
486 (let ((a #2A((0.258 0.016 0.035 0.013)
487 (0.012 0.157 0.058 0.019)
488 (0.013 0.023 0.306 0.035)
489 (0.005 0.007 0.024 0.016)))
490 (c (make-container 'weighted-sampling-container :key #'second)))
493 (insert-item c (list (list i j) (aref a i j)))))
495 (loop repeat 1000 collect
501 (let ((a #2A((0.258 0.016 0.035 0.013)
502 (0.012 0.157 0.058 0.019)
503 (0.013 0.023 0.306 0.035)
504 (0.005 0.007 0.024 0.016)))
505 (c (make-container 'weighted-sampling-container :key #'second)))
507 (loop repeat 100000 do
511 (defun foo (percent-bad percent-mixing)
512 (let ((kind-matrix (make-array 2 :initial-element 0d0))
513 (mixing-matrix (make-array (list 2 2) :initial-element 0d0)))
514 (setf (aref kind-matrix 0) (- 1d0 percent-bad)
515 (aref kind-matrix 1) percent-bad
516 (aref mixing-matrix 0 0) (* (aref kind-matrix 0) (- 1d0 (/ percent-mixing 1)))
517 (aref mixing-matrix 1 1) (* (aref kind-matrix 1) (- 1d0 (/ percent-mixing 1)))
518 (aref mixing-matrix 1 0) percent-mixing
519 (aref mixing-matrix 0 1) percent-mixing)
520 (normalize-matrix kind-matrix)
521 (setf mixing-matrix (normalize-matrix mixing-matrix))
526 ;;; girvan-newman-test-graphs
528 (defun generate-girvan-newman-graph (generator graph-class z-in)
529 (warn "This is broken!")
530 (let ((g (make-instance graph-class))
534 (z-out (- edge-count z-in))
535 (vertexes (make-container 'simple-associative-container))
536 (groups (make-container 'alist-container)))
537 (save-generation-information g generator
538 'generate-girvan-newman-graph)
539 (labels ((make-id (group index)
540 (form-keyword "A" group "0" index))
542 (choose-inner-id (group id)
543 (check-type group fixnum)
544 (check-type id symbol)
546 (let ((other (sample-element (item-at groups group :needs-in) generator)))
550 (not (find-edge-between-vertexes
551 g id other :error-if-not-found? nil)))
552 (return-from choose-inner-id other)))))
554 (choose-outer-id (from-group id)
555 (declare (ignore id))
557 (check-type from-group fixnum)
559 (let ((other-group (integer-random generator 0 (- group-count 2)))
560 (other (sample-element
561 (item-at groups (if (= from-group other-group)
563 other-group) :needs-out)
567 (not (find-edge-between-vertexes
568 g id other :error-if-not-found? nil)))
569 (return-from choose-outer-id other)))))
571 (make-in-edge (from to)
572 (let ((group (gn-id->group from)))
573 (when (zerop (decf (first (item-at vertexes from))))
574 (setf (item-at groups group :needs-in)
575 (remove from (item-at groups group :needs-in))))
576 (when (zerop (decf (first (item-at vertexes to))))
577 (setf (item-at groups group :needs-in)
578 (remove to (item-at groups group :needs-in))))
579 (add-edge-between-vertexes
580 g from to :edge-type :undirected
581 :if-duplicate-do (lambda (e) (incf (weight e))))))
583 (make-out-edge (from to)
584 (let ((group-from (gn-id->group from))
585 (group-to (gn-id->group to)))
586 (when (zerop (decf (second (item-at vertexes from))))
587 (setf (item-at groups group-from :needs-out)
588 (remove from (item-at groups group-from :needs-out))))
589 (when (zerop (decf (second (item-at vertexes to))))
590 (setf (item-at groups group-to :needs-out)
591 (remove to (item-at groups group-to :needs-out))))
593 (add-edge-between-vertexes
594 g from to :edge-type :undirected
595 :if-duplicate-do (lambda (e) (incf (weight e)))))))
598 (loop for group from 0 to (1- group-count) do
599 (loop for index from 0 to (1- group-size) do
600 (let ((id (make-id group index)))
601 (setf (item-at vertexes id) (list z-in z-out))
603 (push id (item-at groups group :needs-in)))
605 (push id (item-at groups group :needs-out))))))
608 (loop for group from 0 to (1- group-count) do
609 (loop for index from 0 to (1- group-size) do
610 (let ((from (make-id group index)))
612 (loop while (plusp (first (item-at vertexes from))) do
613 (make-in-edge from (choose-inner-id group from)))
614 (loop while (plusp (second (item-at vertexes from))) do
615 (make-out-edge from (choose-outer-id group from)))))))
620 (defun gn-id->group (id)
621 (parse-integer (subseq (symbol-name id) 1 2)))
624 (defun collect-edge-counts (g)
625 (let ((vertexes (make-container 'simple-associative-container
626 :initial-element-fn (lambda () (list 0 0)))))
630 (let ((v1 (vertex-1 e))
634 (cond ((= (gn-id->group id1) (gn-id->group (element v2)))
635 (incf (first (item-at vertexes id1)) (weight e))
636 (incf (first (item-at vertexes id2)) (weight e)))
638 (incf (second (item-at vertexes id1)) (weight e))
639 (incf (second (item-at vertexes id2)) (weight e)))))))
643 :transform (lambda (k v) (list k (first v) (second v))))
648 (defclass* weighted-sampler-with-lookup-container ()
653 (defmethod initialize-instance :after ((object weighted-sampler-with-lookup-container)
654 &key random-number-generator key)
655 (setf (slot-value object 'sampler)
656 (make-container 'weighted-sampling-container
657 :random-number-generator random-number-generator
659 (slot-value object 'lookup)
660 (make-container 'simple-associative-container)))
663 (defmethod insert-item ((container weighted-sampler-with-lookup-container)
665 (let ((node (nth-value 1 (insert-item (sampler container) item))))
667 (assert (not (null node)))
668 (setf (item-at-1 (lookup container) item) node)))
671 (defmethod find-node ((container weighted-sampler-with-lookup-container)
673 (item-at-1 (lookup container) item))
676 (defmethod delete-node ((container weighted-sampler-with-lookup-container)
678 ;; not going to worry about the hash table
679 (delete-node (sampler container) node))
682 (defmethod next-element ((container weighted-sampler-with-lookup-container))
683 (next-element (sampler container)))
686 (defmethod generate-scale-free-graph
687 (generator graph size kind-matrix add-edge-count
688 other-vertex-kind-samplers
690 &key (duplicate-edge-function 'identity))
691 (let* ((kind-count (array-dimension kind-matrix 0))
692 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
693 (vertex-sampler (make-array kind-count)))
694 (save-generation-information graph generator 'generate-scale-free-graph)
695 (flet ((sample-existing-vertexes (for-kind)
696 ;; return list of vertexes to attach based on preferential attachment
697 (loop for other-kind in (funcall (nth for-kind other-vertex-kind-samplers)
698 add-edge-count generator) collect
699 (let ((vertex (next-element (aref vertex-sampler other-kind))))
702 for nil across vertex-sampler
704 (setf vertex (next-element (aref vertex-sampler i))
707 ;;?? remove. this should never happen
708 (unless vertex (break))
710 (list vertex other-kind))))
712 ;; handle bookkeeping for changed vertex degree
713 (let ((sampler (aref vertex-sampler kind))
714 (node (find-node sampler thing)))
715 (delete-node sampler node)
716 (insert-item sampler thing))))
720 for nil across vertex-sampler do
721 (setf (aref vertex-sampler i)
722 (make-container 'weighted-sampler-with-lookup-container
723 :random-number-generator generator
724 :key (lambda (vertex)
725 (1+ (vertex-degree vertex))))))
727 ;; add vertexes and edges
728 (loop for kind in (shuffle-elements! vertex-kinds :generator generator)
730 (let* ((element (funcall vertex-creator kind i))
731 (vertex (add-vertex graph element)))
732 (when (> i add-edge-count)
733 (loop for (other other-kind) in (sample-existing-vertexes kind) do
734 (update other-kind other)
736 (if (or (null kind) (null other)) (break))
737 (add-edge-between-vertexes
740 (lambda (e) (funcall duplicate-edge-function e)))))
741 (insert-item (aref vertex-sampler kind) vertex)))
747 (defun poisson-connector (count generator)
748 (let* ((ts (poisson-random generator 2))
749 (cs (poisson-random generator 2))
750 (rest (- count ts cs)))
751 (loop for tick = t then (not tick) while (minusp rest) do
753 (if tick (decf ts) (decf cs)))
755 (append (make-list (truncate rest) :initial-element 0)
756 (make-list (truncate ts) :initial-element 1)
757 (make-list (truncate cs) :initial-element 2))
758 :generator generator)))
762 (generate-scale-free-graph
764 (make-container 'graph-container :default-edge-type :undirected)
769 (lambda (count generator)
770 (declare (ignore generator))
771 (make-list count :initial-element 0))
775 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
779 (generate-scale-free-graph
781 (make-container 'graph-container :default-edge-type :undirected)
786 (lambda (count generator)
787 (declare (ignore generator))
788 (make-list count :initial-element 0)))
790 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
794 (generate-scale-free-graph
796 (make-container 'graph-container :default-edge-type :undirected)
801 (lambda (count generator)
802 (declare (ignore generator))
803 (make-list count :initial-element 0)))
805 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count)))))
808 ;;; 61.4640 cpu seconds (61.4640 cpu seconds ignoring GC)
809 ;;; 102,959,032 words consed
810 Execution time profile from 2078 samples
813 Children Relative Absolute Consing Conses
815 %%check-keywords 99% 99% 100,970,656
816 sample-existing-vertexes 62%
817 insert-item <weighted-sampler-with-lookup-container> <t> 32%
818 add-vertex <basic-graph> <t> 2%
820 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 1%
822 iterate-container <contents-as-array-mixin> <t> 1%
824 %%check-keywords 100%
825 sample-existing-vertexes 62% 61% 62,577,336
826 walk-tree-nodes <bst-node> <t> 99%
829 sample-existing-vertexes 100%
830 walk-tree-nodes <bst-node> <t> 61% 60% 61,607,072
831 #<anonymous function #xaa2070e> 77%
833 element-weight <weighted-sampling-container> <t> 2%
838 walk-tree-nodes <bst-node> <t> 98%
839 %%before-and-after-combined-method-dcode 2%
840 #<anonymous function #xaa2070e> 48% 47% 48,156,256
841 iterate-container <contents-as-array-mixin> <t> 73%
842 %%1st-two-arg-dcode 9%
843 iterate-edges <graph-container-vertex> <t> 6%
845 iterate-elements <abstract-container> <t> 2%
847 #<anonymous function #xaa2070e> 99%
849 iterate-container <contents-as-array-mixin> <t> 35% 35% 35,440,856
850 other-vertex <graph-container-edge> <graph-container-vertex> 43%
852 #<anonymous function #x271d31e> 10%
854 insert-item <weighted-sampler-with-lookup-container> <t> 92%
855 %make-std-instance 3%
857 %%standard-combined-method-dcode 1%
859 %%before-and-after-combined-method-dcode 34% 34% 34,400,720
860 insert-item <binary-search-tree> <bst-node> 90%
861 #<anonymous function #xaa2070e> 2%
862 shared-initialize <standard-object> <t> 2%
867 %%check-keywords 100%
868 insert-item <weighted-sampler-with-lookup-container> <t> 31% 31% 31,970,488
869 %%before-and-after-combined-method-dcode 100%
871 %%before-and-after-combined-method-dcode 100%
872 insert-item <binary-search-tree> <bst-node> 30% 31% 31,227,120
876 insert-item <binary-search-tree> <bst-node> 99%
877 #<anonymous function #xaa2070e> 1%
878 %vertex-degree 26% 25% 25,870,312
879 #<anonymous function #xa7cee86> 68%
881 %std-slot-value-using-class 1%
884 iterate-container <contents-as-array-mixin> <t> 1%
887 iterate-container <contents-as-array-mixin> <t> 1%
888 #<anonymous function #xa7cee86> 18% 17% 17,420,592
889 %maybe-std-slot-value-using-class 8%
891 %std-slot-value-using-class 8%
893 vertex-1 <graph-container-edge> 5%
894 #<anonymous function #x271d31e> 1%
896 iterate-container <contents-as-array-mixin> <t> 99%
897 #<anonymous function #xa7cee86> 1%
898 other-vertex <graph-container-edge> <graph-container-vertex> 15% 14% 14,029,496
901 iterate-container <contents-as-array-mixin> <t> 95%
903 %%before-and-after-combined-method-dcode 1%
904 initialize-instance (around) <basic-initial-contents-mixin> 1%
905 %%nth-arg-dcode 7% 9% 9,238,560
907 #<anonymous function #xaa2070e> 93%
908 walk-tree-nodes <bst-node> <t> 5%
909 %%before-and-after-combined-method-dcode 2%
910 %%1st-two-arg-dcode 5% 5% 4,802,264
912 iterate-container <contents-as-array-mixin> <t> 96%
913 #<anonymous function #xa7cee86> 3%
914 shared-initialize <standard-object> <t> 1%
915 #<anonymous function #x271d31e> 4% 4% 4,012,368
917 #<anonymous function #xaa2070e> 100%
918 iterate-edges <graph-container-vertex> <t> 3% 3% 2,918,352
920 #<anonymous function #xa7cee86> 59%
922 walk-tree-nodes <bst-node> <t> 13%
923 shared-initialize <standard-object> <t> 6%
924 %shared-initialize 4%
925 other-vertex <graph-container-edge> <graph-container-vertex> 2%
927 %std-slot-value-using-class 2% 2% 2,115,320
929 #<anonymous function #xa7cee86> 59%
930 walk-tree-nodes <bst-node> <t> 12%
932 %%before-and-after-combined-method-dcode 6%
933 shared-initialize <standard-object> <t> 4%
935 other-vertex <graph-container-edge> <graph-container-vertex> 4%
936 %shared-initialize 2%
937 %%one-arg-dcode 2% 2% 2,478,304
939 make-instance <symbol> 68%
941 make-instance <standard-class> 9%
942 %make-std-instance 2% 2% 2,283,344
943 %%before-and-after-combined-method-dcode 47%
944 shared-initialize <standard-object> <t> 15%
945 %%standard-combined-method-dcode 12%
946 %maybe-std-slot-value-using-class 3%
948 #<anonymous function #xa7cee86> 78%
951 %make-std-instance 2%
952 shared-initialize <standard-object> <t> 3%
953 view-get <simple-view> <t> 2%
954 walk-tree-nodes <bst-node> <t> 3%
955 %maybe-std-slot-value-using-class 2% 2% 2,005,048
957 add-edge-between-vertexes <basic-graph> <basic-vertex> <basic-vertex> 42%
958 add-vertex <basic-graph> <t> 40%
959 initialize-instance (after) <graph-container-vertex> 7%
961 %%before-and-after-combined-method-dcode 5%
962 make-instance <symbol> 2% 2% 1,932,504
963 %make-std-instance 92%
965 #<anonymous function #xaa2070e> 100%
966 constantly 2% 2% 1,629,880
968 walk-tree-nodes <bst-node> <t> 97%
969 %%before-and-after-combined-method-dcode 3%
971 %maybe-std-slot-value-using-class 3%
973 %%check-keywords 100%
974 add-vertex <basic-graph> <t> 2% 2% 2,259,304
975 make-instance <symbol> 44%
976 %%standard-combined-method-dcode 30%
977 %%before-and-after-combined-method-dcode 8%
978 %make-std-instance 3%
980 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 2% 2% 1,700,920
981 %%standard-combined-method-dcode 48%
984 make-instance <symbol> 6%
986 generate-scale-free-graph <t> <t> <t> <t> <t> <t> <t> 45%
987 add-vertex <basic-graph> <t> 25%
988 %make-std-instance 18%
989 make-instance <standard-class> 6%
991 insert-item <weighted-sampler-with-lookup-container> <t> 3%
992 %%standard-combined-method-dcode 2% 2% 2,019,832
993 insert-item <container-uses-nodes-mixin> <t> 45%
994 %%before-and-after-combined-method-dcode 25%
996 make-instance <symbol> 3%
998 #<GRAPH-CONTAINER 1000>
1003 (open-plot-in-window
1006 (clnuplot::data->n-buckets
1007 (sort (collect-items x :transform #'vertex-degree) #'>)
1012 (and (plusp (first x))
1013 (plusp (second x ))))
1016 (list (log (first x) 10) (log (second x)))))))
1020 (clasp:linear-regression-brief
1022 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1023 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1024 (3.2961164921697144 1.6094379124341003)
1025 (3.3831867994748994 1.9459101490553132)
1026 (3.4556821645007902 0.6931471805599453)
1027 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1028 (3.932600584500482 0.0))
1031 '((2.3453737305590883 6.812345094177479) (2.819872821950546 3.871201010907891)
1032 (3.041195233696809 2.6390573296152584) (3.1870975005834774 2.1972245773362196)
1033 (3.2961164921697144 1.6094379124341003)
1034 (3.3831867994748994 1.9459101490553132)
1035 (3.4556821645007902 0.6931471805599453)
1036 (3.5721161556642747 1.3862943611198906) (3.909743184806193 0.0)
1037 (3.932600584500482 0.0))
1042 ;;; generate-assortative-graph-with-degree-distributions
1045 (define-debugging-class generate-assortative-graph-with-degree-distributions ())
1048 (defmethod generate-assortative-graph-with-degree-distributions
1049 (generator (graph-class symbol)
1050 edge-count assortativity-matrix
1052 degree-distributions
1054 &key (duplicate-edge-function 'identity))
1055 (generate-assortative-graph-with-degree-distributions
1056 generator (make-instance graph-class)
1057 edge-count assortativity-matrix
1059 degree-distributions
1061 :duplicate-edge-function duplicate-edge-function))
1064 Split into a function to compute some of the intermediate pieces and one to use them
1067 (defmethod generate-assortative-graph-with-degree-distributions
1068 (generator graph edge-count assortativity-matrix
1070 degree-distributions
1072 &key (duplicate-edge-function 'identity))
1073 (setf assortativity-matrix (normalize-matrix assortativity-matrix))
1074 (let* ((kind-count (array-dimension assortativity-matrix 0))
1075 (vertex->degree-counts (make-array kind-count))
1077 (sample-edges-for-assortative-graph
1078 generator edge-count assortativity-matrix)))
1081 (append (element-counts edges :key #'first)
1082 (element-counts edges :key #'second))
1086 new) :key #'first :argument #'second)
1089 (vertex-counts (collect-elements
1092 (lambda (kind-and-count)
1093 (round (float (/ (second kind-and-count)
1094 (elt average-degrees (first kind-and-count))))))))
1095 (edge-samplers (make-array kind-count)))
1096 (save-generation-information graph generator 'generate-assortative-graph-with-degree-distributions)
1098 ;; setup bookkeeping
1099 (loop for kind from 0 to (1- kind-count) do
1100 (setf (aref edge-samplers kind)
1101 (make-container 'vector-container)
1102 (aref vertex->degree-counts kind)
1103 (make-container 'simple-associative-container)))
1104 (loop for edge in edges do
1105 (insert-item (aref edge-samplers (first edge)) (cons :source edge))
1106 (insert-item (aref edge-samplers (second edge)) (cons :target edge)))
1108 edge-samplers (lambda (sampler) (shuffle-elements! sampler :generator generator)))
1110 ;(spy edges degree-sums vertex-counts)
1112 (loop for kind from 0 to (1- kind-count)
1113 for count in vertex-counts do
1114 (let ((distribution (nth-element degree-distributions kind))
1115 (vertexes (make-container 'vector-container))
1116 (vertex-degrees (aref vertex->degree-counts kind))
1118 (desired-sum (second (elt degree-sums kind))))
1120 ;; for each type, create vertexes
1121 (loop for i from 0 to (1- count) do
1122 (let ((vertex (funcall vertex-creator kind i))
1123 (degree (funcall distribution)))
1124 (insert-item vertexes vertex)
1125 (setf (item-at-1 vertex-degrees vertex)
1127 (incf total-degree degree)))
1129 ;(spy vertexes total-degree desired-sum)
1131 ;; ensure proper total degree
1132 (loop while (/= total-degree desired-sum) do
1134 (when-debugging-format
1135 generate-assortative-graph-with-degree-distributions
1136 "Current: ~D, Desired: ~D, Difference: ~D"
1137 total-degree desired-sum
1138 (abs (- total-degree desired-sum)))
1139 (let* ((vertex (sample-element vertexes generator))
1140 (bigger? (< total-degree desired-sum))
1141 (current-degree (item-at-1 vertex-degrees vertex))
1146 (plusp current-degree)))
1147 (decf total-degree current-degree)
1150 (when-debugging-format
1151 generate-assortative-graph-with-degree-distributions
1153 total-degree current-degree new-degree (not bigger?))
1155 ;; increase speed by knowing which direction we need to go...?
1156 (loop until (or (zerop (decf attempts))
1158 (> (setf new-degree (funcall distribution))
1161 (< (setf new-degree (funcall distribution))
1162 current-degree))) do
1164 (setf bigger? (< (+ total-degree new-degree) desired-sum)))
1166 (cond ((plusp attempts)
1169 generate-assortative-graph-with-degree-distributions
1170 (format *debug-io* " -> ~D" new-degree))
1172 (setf (item-at-1 vertex-degrees vertex) new-degree)
1173 (incf total-degree new-degree)
1176 (when-debugging-format
1177 generate-assortative-graph-with-degree-distributions
1178 "~D ~D" total-degree desired-sum))
1180 ;; couldn't find one, try again
1181 (incf total-degree current-degree))))))
1184 (let ((edge-sampler (aref edge-samplers kind)))
1185 (flet ((sample-edges-for-vertex (vertex)
1187 (loop repeat (item-at-1 vertex-degrees vertex) do
1188 (let (((edge-kind . edge) (delete-last edge-sampler)))
1190 (:source (setf (first edge) vertex))
1191 (:target (setf (second edge) vertex)))))))
1194 #'sample-edges-for-vertex)))))
1196 ;; repair self edges
1199 ;; now make the graph [at last]
1203 (add-edge-between-vertexes graph (first edge) (second edge)
1204 :if-duplicate-do duplicate-edge-function))))
1209 (generate-assortative-graph-with-degree-distributions
1213 #2A((0.1111111111111111 0.2222222222222222)
1214 (0.2222222222222222 0.4444444444444444))
1216 #2A((0.011840772766222637 0.04524421593830334)
1217 (0.04524421593830334 0.8976707953571706))
1220 (make-degree-sampler
1222 (poisson-vertex-degree-distribution 3 i))
1223 :generator *random-generator*)
1224 (make-degree-sampler
1226 (poisson-vertex-degree-distribution 3 i))
1227 :generator *random-generator*))
1229 (lambda (kind count)
1230 (form-keyword (aref "BTC" kind) (format nil "~4,'0D" count))))
1235 (sample-edges-for-assortative-graph
1238 #2A((0.1111111111111111 0.2222222222222222)
1239 (0.2222222222222222 0.4444444444444444))))
1242 ;;; generate-graph-by-resampling-edges
1245 doesn't take edge weights into account when sampling
1247 should include pointer back to original graph
1250 (defclass* basic-edge-sampler ()
1255 (defmethod next-element ((sampler basic-edge-sampler))
1256 (sample-element (graph-edges (graph sampler)) (generator sampler)))
1259 (defclass* weighted-edge-sampler (basic-edge-sampler)
1260 ((weight-so-far 0 a)
1261 (index-iterator nil r)
1262 (edge-iterator nil r)
1266 (defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
1267 (let ((generator (generator object))
1268 (weighted-edge-count
1270 (iterate-edges (graph object) (lambda (e) (incf result (weight e))))
1272 (unless (size object)
1273 (setf (slot-value object 'size) weighted-edge-count))
1274 (setf (slot-value object 'index-iterator)
1276 (sort (loop repeat (size object) collect
1277 (integer-random generator 1 weighted-edge-count)) #'<))
1278 (slot-value object 'edge-iterator)
1279 (make-iterator (graph-edges (graph object))))))
1282 (defmethod next-element ((object weighted-edge-sampler))
1283 (let ((edge-iterator (edge-iterator object))
1284 (index-iterator (index-iterator object)))
1285 (move-forward index-iterator)
1286 (loop while (< (weight-so-far object) (current-element index-iterator)) do
1287 (move-forward edge-iterator)
1288 (incf (weight-so-far object) (weight (current-element edge-iterator))))
1289 (current-element edge-iterator)))
1291 ;;; ---------------------------------------------------------------------------
1293 (defmethod generate-graph-by-resampling-edges
1294 (generator original-graph &key
1295 (edge-sampler-class 'basic-edge-sampler)
1296 (edge-count (edge-count original-graph)))
1297 (let ((graph (copy-template original-graph))
1298 (edge-sampler (make-instance edge-sampler-class
1299 :generator generator
1300 :graph original-graph
1302 (save-generation-information graph generator 'generate-graph-by-resampling-edges)
1308 (add-vertex graph (element v))))
1311 (loop repeat edge-count do
1312 (let ((edge (next-element edge-sampler)))
1313 (if (directed-edge-p edge)
1314 (add-edge-between-vertexes
1315 graph (element (source-vertex edge)) (element (target-vertex edge))
1316 :edge-type :directed
1317 :if-duplicate-do (lambda (e) (incf (weight e))))
1318 (add-edge-between-vertexes
1319 graph (element (vertex-1 edge)) (element (vertex-2 edge))
1320 :edge-type :undirected
1321 :if-duplicate-do (lambda (e) (incf (weight e)))))))
1326 (fluid-bind (((random-seed *random-generator*) 1))
1327 (let* ((dd-1 (lambda (i)
1329 (power-law-vertex-degree-distribution 3 i)
1330 (poisson-vertex-degree-distribution 3 i)))
1333 (power-law-vertex-degree-distribution 3 i)
1334 (poisson-vertex-degree-distribution 3 i)))
1335 (g (generate-assortative-graph-with-degree-distributions
1337 (make-instance 'graph-container
1338 :default-edge-type :undirected
1339 :undirected-edge-class 'weighted-edge)
1341 #2A((0.011840772766222637 0.04524421593830334)
1342 (0.04524421593830334 0.8976707953571706))
1345 (make-degree-sampler
1347 :generator *random-generator*
1349 :min-probability nil)
1350 (make-degree-sampler
1352 :generator *random-generator*
1354 :min-probability nil))
1355 #'simple-group-id-generator
1356 :duplicate-edge-function (lambda (e) (incf (weight e))))))
1358 (average-vertex-degree
1360 :vertex-filter (lambda (v)
1361 (plusp (edge-count v)))
1362 :edge-size #'weight)))
1364 (loop for i from 1 to 10
1366 (fluid-bind (((random-seed *random-generator*) i))
1368 (generate-graph-by-resampling-edges
1369 *random-generator* g 'weighted-edge-sampler (edge-count g)))))))))
1371 ;;; some preferential attachment algorithms
1374 (define-debugging-class generate-preferential-attachment-graph
1378 (defmethod generate-simple-preferential-attachment-graph
1379 (generator (graph-class symbol) size minimum-degree)
1380 (generate-simple-preferential-attachment-graph
1381 generator (make-instance graph-class) size minimum-degree))
1384 (defmethod generate-simple-preferential-attachment-graph
1385 (generator graph size minimum-degree)
1386 (let ((m (make-array (list (* 2 size minimum-degree)))))
1387 (loop for v from 0 to (1- size) do
1388 (loop for i from 0 to (1- minimum-degree) do
1389 (let ((index (* 2 (+ i (* v minimum-degree))))
1390 (r (integer-random generator 0 index)))
1391 (setf (item-at m index) v
1392 (item-at m (1+ index)) (item-at m r)))))
1393 (loop for i from 0 to (1- (* size minimum-degree)) do
1394 (add-edge-between-vertexes
1395 graph (item-at m (* 2 i)) (item-at m (1+ (* 2 i)))))
1400 (generate-simple-preferential-attachment-graph
1402 (make-container 'graph-container :default-edge-type :undirected)
1408 (collect-nodes (ds :g-b)
1409 :transform (lambda (v) (list (element v) (vertex-degree v))))
1415 (defmethod generate-preferential-attachment-graph
1416 (generator (graph-class symbol) size kind-matrix minimum-degree
1417 assortativity-matrix
1418 &key (vertex-labeler 'simple-group-id-generator)
1419 (duplicate-edge-function :ignore))
1420 (generate-preferential-attachment-graph
1421 generator (make-instance graph-class)
1422 size kind-matrix minimum-degree assortativity-matrix
1423 :vertex-labeler vertex-labeler
1424 :duplicate-edge-function duplicate-edge-function))
1427 (defmethod generate-preferential-attachment-graph
1428 (generator (graph basic-graph) size kind-matrix minimum-degree
1429 assortativity-matrix
1430 &key (vertex-labeler 'simple-group-id-generator)
1431 (duplicate-edge-function :ignore))
1432 (let ((kind-count (array-dimension kind-matrix 0))
1433 (vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
1434 (vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
1435 (edge-recorders (make-array (list kind-count)))
1436 (count-recorders (make-array (list kind-count) :initial-element 0))
1437 (edge-samplers (make-array (list kind-count))))
1439 ;; set up record keeping
1440 (dotimes (i kind-count)
1441 (setf (aref edge-recorders i)
1442 (make-array (list (* 2 (item-at vertex-kind-counts i) minimum-degree))
1443 :initial-element nil))
1444 (setf (aref edge-samplers i)
1445 (make-edge-sampler-for-preferential-attachment-graph
1446 generator (array-row assortativity-matrix i))))
1448 ;; add vertexes (to ensure that we have something at which to point)
1449 (loop for v from 0 to (1- size)
1450 for kind in vertex-kinds do
1451 (let ((edge-recorder (aref edge-recorders kind)))
1452 (loop for i from 0 to (1- minimum-degree) do
1453 (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
1454 (setf (item-at edge-recorder index)
1455 (funcall vertex-labeler kind v)))))
1456 (incf (aref count-recorders kind)))
1459 (dotimes (i kind-count)
1460 (setf (aref count-recorders i) 0))
1461 (loop for v from 0 to (1- size)
1462 for kind in vertex-kinds do
1463 (let ((edge-recorder (aref edge-recorders kind))
1464 (edge-sampler (aref edge-samplers kind)))
1465 (loop for i from 0 to (1- minimum-degree) do
1466 (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
1467 (other-kind (funcall edge-sampler))
1468 (other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
1469 (aref count-recorders other-kind))
1471 (other-edge-recorder (aref edge-recorders other-kind))
1472 (r (integer-random generator 0 (1- other-index))))
1474 (when-debugging-format
1475 generate-preferential-attachment-graph
1476 "[~2D ~6D] [~2D ~6D] (max: ~6D)"
1477 kind (1+ index) other-kind r other-index)
1478 (setf (item-at edge-recorder (1+ index))
1479 (cond ((item-at other-edge-recorder r)
1480 (item-at other-edge-recorder r))
1481 ((and (= kind other-kind)
1484 (item-at edge-recorder index))
1486 ;; haven't done the other one yet... save it for later fixing
1487 (list other-kind r))))))
1488 (incf (aref count-recorders kind))))
1491 (let ((corrections 0)
1492 (last-corrections nil)
1494 (loop while again? do
1497 (dotimes (kind kind-count)
1498 (loop for vertex across (aref edge-recorders kind)
1499 for index = 0 then (1+ index)
1500 when (consp vertex) do
1501 (let (((other-kind other-index) vertex))
1503 (when-debugging-format
1504 generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
1506 (aref (aref edge-recorders other-kind) other-index))
1508 (if (and (= kind other-kind) (= index other-index))
1509 ;; pointing at myself
1510 (setf (aref (aref edge-recorders kind) index)
1511 (aref (aref edge-recorders kind) (1- index)))
1512 (let ((new (aref (aref edge-recorders other-kind) other-index)))
1515 (setf (aref (aref edge-recorders kind) index) new))))))
1516 (when (and last-corrections
1517 (>= corrections last-corrections))
1518 (error "It's not getting any better old boy"))
1519 (setf last-corrections corrections)))
1521 ;; make sure we got 'em all
1522 (dotimes (i kind-count)
1523 (loop for vertex across (aref edge-recorders i)
1524 when (not (symbolp vertex)) do (error "bad function, down boy")))
1526 (dotimes (i kind-count)
1527 (let ((edge-recorder (aref edge-recorders i)))
1528 (loop for index from 0 to (1- (size edge-recorder)) by 2 do
1529 (add-edge-between-vertexes
1530 graph (item-at edge-recorder index) (item-at edge-recorder (1+ index))
1531 :if-duplicate-do duplicate-edge-function))))
1534 ;; record properties
1535 (record-graph-properties graph)
1536 (setf (get-value graph :initial-seed) (random-seed generator))
1537 (setf (get-value graph :size) size
1538 (get-value graph :minimum-degree) minimum-degree
1539 (get-value graph :assortativity-matrix) assortativity-matrix
1540 (get-value graph :duplicate-edge-function) duplicate-edge-function)
1546 (defun make-edge-sampler-for-preferential-attachment-graph (generator assortativities)
1547 (let ((c (make-container 'weighted-sampling-container
1548 :random-number-generator generator
1550 (aref assortativities item)))))
1551 (dotimes (i (array-dimension assortativities 0))
1553 (lambda () (next-element c))))
1558 (make-edge-sampler-for-preferential-attachment-graph
1559 *random-generator* #(0.02 0.25 0.25))))
1560 (loop repeat 100 collect (funcall s)))
1564 (setf (random-seed *random-generator*) 2)
1565 (generate-preferential-attachment-graph
1567 (make-graph 'graph-container :edge-type :undirected)
1571 #2A((0.96 0.02 0.02)
1576 (generate-preferential-attachment-graph
1578 (make-graph 'graph-container :edge-type :undirected)
1582 #2A((0.96 0.02 0.02)
1588 (generate-preferential-attachment-graph
1590 (make-graph 'graph-container :edge-type :undirected)
1594 #2A((0.96 0.02 0.02)
1600 (defmethod generate-acquaintance-network
1601 (generator (class-name symbol) size death-probability iterations vertex-labeler
1602 &key (duplicate-edge-function :ignore))
1603 (generate-acquaintance-network
1604 generator (make-instance class-name)
1605 size death-probability iterations vertex-labeler
1606 :duplicate-edge-function duplicate-edge-function))
1608 (defmethod generate-acquaintance-network
1609 (generator graph size death-probability iterations vertex-labeler
1610 &key (duplicate-edge-function :ignore))
1611 ;; bring the graph up to size
1612 (loop for i from (size graph) to (1- size) do
1613 (add-vertex graph (funcall vertex-labeler 0 i)))
1615 (loop repeat iterations do
1616 (add-acquaintance-and-maybe-kill-something
1617 generator graph death-probability duplicate-edge-function))
1621 (defmethod generate-acquaintance-network-until-stable
1622 (generator graph size death-probability step-count
1623 stability-fn vertex-labeler
1624 &key (duplicate-edge-function :ignore))
1625 ;; bring the graph up to size
1626 (loop for i from (size graph) to (1- size) do
1627 (add-vertex graph (funcall vertex-labeler 0 i)))
1630 (loop repeat step-count do
1631 (add-acquaintance-and-maybe-kill-something
1632 generator graph death-probability duplicate-edge-function))
1633 (when (funcall stability-fn graph)
1639 (defun add-acquaintance-and-maybe-kill-something
1640 (generator graph death-probability duplicate-edge-function)
1642 (let ((vertex (sample-element (graph-vertexes graph) generator))
1643 (neighbors (when (>= (size (vertex-edges vertex)) 2)
1644 (sample-unique-elements
1645 (vertex-edges vertex) generator 2))))
1646 (flet ((sample-other-vertex ()
1647 (loop for result = (sample-element (graph-vertexes graph) generator)
1648 until (not (eq vertex result))
1649 finally (return result))))
1651 (add-edge-between-vertexes
1653 (other-vertex (first neighbors) vertex)
1654 (other-vertex (second neighbors) vertex)
1655 :if-duplicate-do duplicate-edge-function)
1656 (add-edge-between-vertexes
1657 graph vertex (sample-other-vertex)
1658 :if-duplicate-do duplicate-edge-function))))
1660 ;; remove vertexes step
1661 (when (random-boolean generator death-probability)
1662 (let ((vertex (sample-element (graph-vertexes graph) generator)))
1663 (delete-vertex graph vertex)
1664 (add-vertex graph (element vertex)))))
1670 (adjustable-array-p (contents (vertex-edges v)))))
1673 (generate-acquaintance-network
1675 (make-graph 'graph-container :edge-type :undirected)
1679 'simple-group-id-generator)