summaryrefslogtreecommitdiff
path: root/simul/graph.ml
blob: 6c832b339cafcbaee356db341384fe261704fff3 (plain)
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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
open Loggenerator
open Scheme

(************************************************************
               fonctions de graphe generique
************************************************************)

type ('a, 'b) graphe = {sommets : ('a * 'b) list; arretes : (('a * int) * ('a * int)) list}

let gajoutes g s = {sommets = s::(g.sommets); arretes = g.arretes}

let gajoutela g la = {sommets = g.sommets; arretes = la @ g.arretes}

let gVide () = {sommets = []; arretes = []}

let gEstVide g = g.sommets = []

let gunion g h = {sommets = g.sommets @ h.sommets; arretes = g.arretes @ h.arretes} (*peut etre virer les arretes en dble*)

let sprint_graphe_ss g =
  let ret = ref "Sommets (id, kind) :\n" in
  List.iter
    (fun x -> ret := !ret ^ (Printf.sprintf "%s %s\n" (fst x) (snd x)))
    g.sommets;
  ret := !ret ^ "Arretes (id1, n1), (id2, n2) :\n";
  List.iter
    (fun x ->
       ret := !ret ^
	 (Printf.sprintf
	    "(%s, %d), (%s, %d)\n"
	    (fst (fst x))
	    (snd (fst x))
	    (fst (snd x))
	    (snd (snd x)))
    )
    g.arretes;
  !ret ^ "\n"
let print_graphe_ss g =
  Printf.printf "%s" (sprint_graphe_ss g)

(****************************************************************
                        fonctions de graphe (string, int)
****************************************************************)

(*une entrée n'est pas sensée se boucler dessus. idem pour une sortie*)
(* fonction spécifique : pas propre aux graphes *)
let gsubs g idA idN nN = (*FIXME : améliorable grace à des listes de trucs à remplacer*)
  let rec auxA acc = function
    |[] -> acc
    |(((i1, n1), (i2, n2))::t) when (i1 = idA) ->
       print_log_debug
	 (Printf.sprintf
	    "substitution avant   : (%s %d) (%s %d) -> (%s %d) (%s %d)"
	    i1 n1 i2 n2 idN nN i2 n2
	 );
       auxA (((idN, nN), (i2, n2))::acc) t
    |(((i1, n1), (i2, n2))::t) when (i2 = idA) ->
       print_log_debug
	 (Printf.sprintf
	    "substitution arriere : (%s %d) (%s %d) -> (%s %d) (%s %d)"
	    i1 n1 i2 n2 i1 n1 idN nN
	 );
       auxA (((i1, n1), (idN, nN))::acc) t
    |(h::t) -> auxA (h::acc) t
  in
  {sommets = g.sommets; arretes = auxA [] g.arretes}

let gadd g idA idN nN = (*comme gsubs, mais n'enleve pas*)
  let rec auxA acc = function
    |[] -> acc
    |(((i1, n1), (i2, n2))::t) when (i1 = idA) ->
       print_log_debug
	 (Printf.sprintf
	    "add avant : (%s %d) (%s %d) -> (%s %d) (%s %d)"
	    i1 n1 i2 n2 idN nN i2 n2
	 );
       auxA (((idN, nN), (i2, n2))::((i1, n1), (i2, n2))::acc) t
    |(((i1, n1), (i2, n2))::t) when (i2 = idA) ->
       print_log_debug
	 (Printf.sprintf
	    "add arriere : (%s %d) (%s %d) -> (%s %d) (%s %d)"
	    i1 n1 i2 n2 i1 n1 idN nN
	 );
       auxA (((i1, n1), (idN, nN))::((i1, n1), (i2, n2))::acc) t
    |(h::t) -> auxA (h::acc) t
  in
  {sommets = g.sommets; arretes = auxA [] g.arretes}

let gremsom g iadel =
  let rec auxA acc = function
    |[] -> acc
    |((x, _)::t) when x = iadel ->
       print_log_debug (Printf.sprintf "supression du sommet %s" x);
       auxA acc t
    |(h::t) -> auxA (h::acc) t
  in
  {sommets = auxA [] g.sommets; arretes = g.arretes}  

let gdelete g iadel =
  let rec auxS acc = function
    |[] -> acc
    |(((i1, n1), (i2, n2))::t) when i1 = iadel ->
       print_log_debug
	 (Printf.sprintf "suppression par pere : (%s %d) (%s %d)" i1 n1 i2 n2);
       auxS acc t
    |(((i1, n1), (i2, n2))::t) when i2 = iadel ->
       print_log_debug
	 (Printf.sprintf "suppression par fils : (%s %d) (%s %d)" i1 n1 i2 n2);
       auxS acc t
    |(h::t) -> auxS (h::acc) t
  in
  let g = gremsom g iadel in
  {sommets = g.sommets; arretes = auxS [] g.arretes}

let gpremsom g =
  let (s, t) = List.hd g.sommets in
  let rec aux arr acc = function
    |[] ->
       (arr, acc)
    |(((a, b), (c, d))::t) when (a = s) or (c = s)->
       aux (((a, b), (c, d))::arr) acc t
    |(h::t) ->
       aux arr (h::acc) t
  in
  let (arEnlevees, arRestantes) = aux [] [] g.arretes in
  ((s, t), arEnlevees, {sommets = List.tl g.sommets; arretes = arRestantes})

let gparents g p =
  let rec aux acc = function
    |[] -> acc
    |(((a, np), (b, nf))::t) when b = p -> aux (Imap.add nf (a, np) acc) t
    |(_::t) -> aux acc t
  in
  aux Imap.empty g.arretes

let gfils g p =
  let rec aux acc = function
    |[] ->
       acc
    |(((i1, n1), (i2, n2))::t) when (i1 = p) && (Imap.mem n1 acc) ->
       aux (Imap.add n1 ((i2, n2)::(Imap.find n1 acc)) acc) t
    |(((i1, n1), (i2, n2))::t) when i1 = p ->
       aux (Imap.add n1 [(i2, n2)] acc) t
    |(a::t) -> aux acc t
  in
  aux Imap.empty g.arretes

let gfilslist g a =
  let rec aux = function
    |[] -> []
    |(((i1, n1), (i2, n2))::t) when i1 = a -> (n1, (i2, n2))::(aux t)
    |(_::t) -> aux t
  in
  aux g.arretes

let gparentslist g a =
  List.rev (Imap.fold (fun n2 (i1, n1) ret -> (i1, n1)::ret) (gparents g a) [])

let gprefixe g pref =
  let rec auxS acc = function
    |[] -> acc
    |((i, k)::t) -> auxS ((pref^i, k)::acc) t
  in
  let rec auxA acc = function
    |[] -> acc
    |(((a, b), (c, d))::t) -> auxA ((((pref^a), b), ((pref^c), d))::acc) t
  in
  {sommets = auxS [] g.sommets; arretes = auxA [] g.arretes}