-(in-package metabang.graph)
-
-(export '(generate-Gnp
- generate-Gnm
- generate-undirected-graph-via-assortativity-matrix
- generate-undirected-graph-via-vertex-probabilities
- generate-multi-group-graph-fixed
- #+Ignore generate-girvan-newman-graph
- generate-scale-free-graph
- generate-assortative-graph-with-degree-distributions
-
- generate-simple-preferential-attachment-graph
- generate-preferential-attachment-graph
-
- generate-acquaintance-network
- generate-acquaintance-network-until-stable
-
- generate-graph-by-resampling-edges
-
- sample-edge
- basic-edge-sampler
- weighted-edge-sampler
- simple-group-id-generator
- simple-group-id-parser
-
- make-degree-sampler
- poisson-vertex-degree-distribution
- power-law-vertex-degree-distribution))
+(in-package #:metabang.graph)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(generate-gnp
+ generate-gnm
+ generate-undirected-graph-via-assortativity-matrix
+ generate-undirected-graph-via-vertex-probabilities
+ generate-multi-group-graph-fixed
+ #+Ignore generate-girvan-newman-graph
+ generate-scale-free-graph
+ generate-assortative-graph-with-degree-distributions
+
+ generate-simple-preferential-attachment-graph
+ generate-preferential-attachment-graph
+
+ generate-acquaintance-network
+ generate-acquaintance-network-until-stable
+
+ generate-graph-by-resampling-edges
+
+ sample-edge
+ basic-edge-sampler
+ weighted-edge-sampler
+ simple-group-id-generator
+ simple-group-id-parser
+
+ make-degree-sampler
+ poisson-vertex-degree-distribution
+ power-law-vertex-degree-distribution)))
;;; ---------------------------------------------------------------------------
;;; classes
;;; ---------------------------------------------------------------------------
-;;; generate-Gnp
+;;; generate-gnp
;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnp (generator (graph-class symbol) n p &key (label 'identity))
- (generate-Gnp
+(defmethod generate-gnp (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-gnp
generator (make-instance graph-class) n p :label label))
;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnp (generator (graph basic-graph) n p &key (label 'identity))
+(defmethod generate-gnp (generator (graph basic-graph) n p &key (label 'identity))
(let ((v 1)
(w -1)
(log-1-p (log (- 1 p))))
graph))
;;; ---------------------------------------------------------------------------
-;;; generate-Gnm
+;;; generate-gnm
;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnm (generator (graph-class symbol) n p &key (label 'identity))
- (generate-Gnm
+(defmethod generate-gnm (generator (graph-class symbol) n p &key (label 'identity))
+ (generate-gnm
generator (make-instance graph-class) n p :label label))
;;; ---------------------------------------------------------------------------
-(defmethod generate-Gnm (generator (graph basic-graph) n m &key (label 'identity))
+(defmethod generate-gnm (generator (graph basic-graph) n m &key (label 'identity))
(let ((max-edge-index (1- (combination-count n 2))))
+ (assert (<= m max-edge-index))
#+Ignore
(save-generation-information graph generator 'generate-gnm)
(loop for i from 0 to (1- n) do
;;; ---------------------------------------------------------------------------
(defun poisson-vertex-degree-distribution (z k)
- (/ (* (expt z k) (expt +e+ (- z)))
+ (/ (* (expt z k) (expt cl-mathstats:+e+ (- z)))
(factorial k)))
#|
;;; ---------------------------------------------------------------------------
(defun power-law-vertex-degree-distribution (kappa k)
- (* (- 1 (expt +e+ (- (/ kappa)))) (expt +e+ (- (/ k kappa)))))
+ (* (- 1 (expt cl-mathstats:+e+ (- (/ kappa))))
+ (expt cl-mathstats:+e+ (- (/ k kappa)))))
;;; ---------------------------------------------------------------------------
(defun generate-girvan-newman-graph (generator graph-class z-in)
(warn "This is broken!")
- (bind ((g (make-instance graph-class))
+ (let ((g (make-instance graph-class))
(group-count 4)
(group-size 32)
(edge-count 16)
(check-type from-group fixnum)
(loop
- (bind ((other-group (integer-random generator 0 (- group-count 2)))
+ (let ((other-group (integer-random generator 0 (- group-count 2)))
(other (sample-element
(item-at groups (if (= from-group other-group)
(1+ other-group)
(iterate-edges
g
(lambda (e)
- (bind ((v1 (vertex-1 e))
+ (let ((v1 (vertex-1 e))
(v2 (vertex-2 e))
(id1 (element v1))
(id2 (element v2)))
(list vertex other-kind))))
(update (kind thing)
;; handle bookkeeping for changed vertex degree
- (bind ((sampler (aref vertex-sampler kind))
+ (let ((sampler (aref vertex-sampler kind))
(node (find-node sampler thing)))
(delete-node sampler node)
(insert-item sampler thing))))
(flet ((sample-edges-for-vertex (vertex)
;(spy vertex)
(loop repeat (item-at-1 vertex-degrees vertex) do
- (bind (((edge-kind . edge) (delete-last edge-sampler)))
+ (let (((edge-kind . edge) (delete-last edge-sampler)))
(ecase edge-kind
(:source (setf (first edge) vertex))
(:target (setf (second edge) vertex)))))))
;;; ---------------------------------------------------------------------------
(defmethod initialize-instance :after ((object weighted-edge-sampler) &key)
- (bind ((generator (generator object))
+ (let ((generator (generator object))
(weighted-edge-count
(let ((result 0))
(iterate-edges (graph object) (lambda (e) (incf result (weight e))))
(defmethod generate-simple-preferential-attachment-graph
(generator graph size minimum-degree)
- (bind ((m (make-array (list (* 2 size minimum-degree)))))
+ (let ((m (make-array (list (* 2 size minimum-degree)))))
(loop for v from 0 to (1- size) do
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* v minimum-degree))))
+ (let ((index (* 2 (+ i (* v minimum-degree))))
(r (integer-random generator 0 index)))
(setf (item-at m index) v
(item-at m (1+ index)) (item-at m r)))))
assortativity-matrix
&key (vertex-labeler 'simple-group-id-generator)
(duplicate-edge-function :ignore))
- (bind ((kind-count (array-dimension kind-matrix 0))
+ (let ((kind-count (array-dimension kind-matrix 0))
(vertex-kinds (sample-vertexes-for-mixed-graph generator size kind-matrix))
(vertex-kind-counts (element-counts vertex-kinds :sort #'< :sort-on :values))
(edge-recorders (make-array (list kind-count)))
;; add vertexes (to ensure that we have something at which to point)
(loop for v from 0 to (1- size)
for kind in vertex-kinds do
- (bind ((edge-recorder (aref edge-recorders kind)))
+ (let ((edge-recorder (aref edge-recorders kind)))
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
+ (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree)))))
(setf (item-at edge-recorder index)
(funcall vertex-labeler kind v)))))
(incf (aref count-recorders kind)))
(setf (aref count-recorders i) 0))
(loop for v from 0 to (1- size)
for kind in vertex-kinds do
- (bind ((edge-recorder (aref edge-recorders kind))
+ (let ((edge-recorder (aref edge-recorders kind))
(edge-sampler (aref edge-samplers kind)))
(loop for i from 0 to (1- minimum-degree) do
- (bind ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
+ (let ((index (* 2 (+ i (* (aref count-recorders kind) minimum-degree))))
(other-kind (funcall edge-sampler))
(other-index (* 2 (+ i (* (min (1- (item-at vertex-kind-counts other-kind))
(aref count-recorders other-kind))
(loop for vertex across (aref edge-recorders kind)
for index = 0 then (1+ index)
when (consp vertex) do
- (bind (((other-kind other-index) vertex))
+ (let (((other-kind other-index) vertex))
#+Ignore
(when-debugging-format
generate-preferential-attachment-graph "~2D ~10D, ~A -> ~A"
;;; ---------------------------------------------------------------------------
+
+(defmethod generate-acquaintance-network
+ (generator (class-name symbol) size death-probability iterations vertex-labeler
+ &key (duplicate-edge-function :ignore))
+ (generate-acquaintance-network
+ generator (make-instance class-name)
+ size death-probability iterations vertex-labeler
+ :duplicate-edge-function duplicate-edge-function))
+
(defmethod generate-acquaintance-network
(generator graph size death-probability iterations vertex-labeler
&key (duplicate-edge-function :ignore))
(defun add-acquaintance-and-maybe-kill-something
(generator graph death-probability duplicate-edge-function)
;; add edges step
- (bind ((vertex (sample-element (graph-vertexes graph) generator))
+ (let ((vertex (sample-element (graph-vertexes graph) generator))
(neighbors (when (>= (size (vertex-edges vertex)) 2)
(sample-unique-elements
(vertex-edges vertex) generator 2))))
(flet ((sample-other-vertex ()
(loop for result = (sample-element (graph-vertexes graph) generator)
until (not (eq vertex result))
- finally (return result)))) ;; CTM: 'finally do' not legal in openMCL
+ finally (return result))))
(if neighbors
(add-edge-between-vertexes
graph
(let ((vertex (sample-element (graph-vertexes graph) generator)))
(delete-vertex graph vertex)
(add-vertex graph (element vertex)))))
+
+#+Ignore
+(defun sv (v)
+ (format t "~%~A ~A"
+ v
+ (adjustable-array-p (contents (vertex-edges v)))))
#+Test
(generate-acquaintance-network
projects / cl-graph.git / blobdiff