1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
module type S = sig
type graph
type vertex
val divisors : int -> graph
val de_bruijn : int -> graph
val vertex_only : int -> graph
val full : ?self:bool -> int -> graph
val cycle : int -> graph * vertex array
val grid : n:int -> m:int -> graph * vertex array array
val kneser : n:int -> k:int -> graph
val petersen : unit -> graph
end
module Generic(B : Builder.INT) = struct
type graph = B.G.t
type vertex = B.G.V.t
let divisors n =
if n < 2 then invalid_arg "divisors";
let v = Array.init (n + 1) (fun i -> B.G.V.create i) in
let rec loop g i =
let sqrt_i = truncate (sqrt (float i)) in
let rec loop_i g d =
if d > sqrt_i then
g
else if i mod d == 0 then
loop_i (B.add_edge (B.add_edge g v.(i / d) v.(i)) v.(d) v.(i)) (d+1)
else
loop_i g (succ d)
in
if i > n then g else loop (loop_i (B.add_vertex g v.(i)) 2) (i+1)
in
loop (B.empty ()) 2
let fold_for i0 i1 f =
let rec loop i v = if i > i1 then v else loop (i + 1) (f v i) in
loop i0
let de_bruijn n =
if n < 1 || n > Sys.word_size - 1 then invalid_arg "de_bruijn";
let v = Array.init (1 lsl n) (fun i -> B.G.V.create i) in
let all_1 = 1 lsl n - 1 in
let g = fold_for 0 all_1 (fun g i -> B.add_vertex g v.(i)) (B.empty ()) in
let rec loop g i =
if i > all_1 then
g
else
let si = (i lsl 1) land all_1 in
let g = B.add_edge g v.(i) v.(si) in
let g = B.add_edge g v.(i) v.(si lor 1) in
loop g (i + 1)
in
loop g 0
let vertex_only n =
fold_for 1 n (fun g i -> B.add_vertex g (B.G.V.create i)) (B.empty ())
let full ?(self=true) n =
let v = Array.init (n + 1) (fun i -> B.G.V.create i) in
fold_for 1 n
(fun g i ->
fold_for 1 n
(fun g j -> if self || i <> j then B.add_edge g v.(i) v.(j) else g)
g)
(fold_for 1 n (fun g i -> B.add_vertex g v.(i)) (B.empty ()))
let cycle n =
if n < 0 then invalid_arg "cycle";
let v = Array.init n (fun i -> B.G.V.create i) in
let g = Array.fold_left B.add_vertex (B.empty ()) v in
let rec loop g i =
if i = n then g
else let g = B.add_edge g v.(i) v.((i+1) mod n) in loop g (i+1) in
loop g 0, v
let grid ~n ~m =
if n < 0 || m < 0 then invalid_arg "grid";
let create i j = B.G.V.create (m * i + j) in
let v = Array.init n (fun i -> Array.init m (fun j -> create i j)) in
let g = Array.fold_left (Array.fold_left B.add_vertex) (B.empty ()) v in
let rec loop g i j =
if i = n then g
else if j = m then loop g (i+1) 0
else let g = if j < m-1 then B.add_edge g v.(i).(j) v.(i).(j+1) else g in
let g = if i < n-1 then B.add_edge g v.(i).(j) v.(i+1).(j) else g in
loop g i (j+1) in
loop g 0 0, v
let kneser ~n ~k =
if n < 0 || n > Sys.int_size || k < 0 || k > n then invalid_arg "kneser";
let vert = Hashtbl.create (1 lsl n) in
let add x = Hashtbl.add vert x (B.G.V.create x) in
let rec visit mask n k =
assert (0 <= k && k <= n);
if k = 0 then add mask else
if k = n then add (mask lor (1 lsl n - 1)) else (
let n = n - 1 in
visit mask n k ;
visit (mask lor (1 lsl n)) n (k - 1);
) in
visit 0 n k;
let g = Hashtbl.fold (fun _ v g -> B.add_vertex g v) vert (B.empty ()) in
let g = Hashtbl.fold (fun i vi g ->
Hashtbl.fold (fun j vj g ->
if i <> j && i land j = 0 then B.add_edge g vi vj else g)
vert g) vert g in
g
let petersen () =
kneser ~n:5 ~k:2
end
module P (G : Sig.P with type V.label = int) = Generic(Builder.P(G))
module I (G : Sig.I with type V.label = int) = Generic(Builder.I(G))