module Tas = struct
type tas = {
mutable elems : (int * float) option array ;
mutable where : (int option) array;
mutable size : int;
}
let pp_opt p fmt opt =
match opt with
| None -> Format.fprintf fmt "None"
| Some(x) -> Format.fprintf fmt "Some(%a)" p x
let print_tas (t: tas) =
Format.printf "@[<v>@[<v 2>{@,elems: %a@,where: %a@, size: %d@]@,}@]@."
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") (pp_opt
(fun fmt (i, f) -> Format.fprintf fmt "%d, %f" i f))) (t.elems |> Array.to_list)
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") (pp_opt
Format.pp_print_int)) (t.where |> Array.to_list)
t.size
let resize_where_for_i (i: int) (t: tas) =
let n = Array.length t.where in
if i >= n then
let rec aux n = if i < n then n else aux (2 * n) in
let new_alloc = aux n in
let new_where = Array.make (new_alloc) None in
Array.blit t.where 0 new_where 0 n ;
t.where <- new_where
let resize_elems_if_needed (t: tas) =
let n = Array.length t.elems in
if t.size = n then
let new_elems = Array.make (2 * t.size) None in
Array.blit t.elems 0 new_elems 0 t.size ;
t.elems <- new_elems;
else if t.size < n / 2 then
let new_elems = Array.make (n/2) None in
Array.blit t.elems 0 new_elems 0 t.size ;
t.elems <- new_elems
let mem_tas (t: tas) (elem: int) : bool =
elem < (Array.length t.where) && t.where.(elem) != None
let is_empty (t: tas) : bool =
t.size = 0
let get tab i =
match tab.(i) with
| Some (x) -> x
| None -> raise (Invalid_argument "get")
let set tab i x =
tab.(i) <- Some(x)
let get_prio tab i =
snd (get tab i)
let prio_assoc (t: tas) (x: int) : float =
let w = get t.where x in
let _, f = get t.elems w in
f
let swap elems where i j =
let who_is_in_i, i_prio = get elems i in
let who_is_in_j, j_prio = get elems j in
set elems i (who_is_in_j, j_prio);
set elems j (who_is_in_i, i_prio);
where.(who_is_in_i) <- Some (j);
where.(who_is_in_j) <- Some (i)
let cree_tas_vide () = {elems = Array.make 1 None; where = Array.make 1 None;
size = 0}
let elem_min (t: tas) : int = get t.elems 0 |> fst
let prio_min (t: tas) : float = get t.elems 0 |> snd
let elem_prio_min (t: tas) : int * float = get t.elems 0
let has_left_son (t: tas) (i: int) = 2 * i + 1 < t.size
let has_right_son (t: tas) (i: int) = 2 * i + 2 < t.size
let is_root (t: tas) (i: int): bool = i = 0
let left_son (i: int) = 2 * i + 1
let right_son (i: int) = 2 * i + 2
let father (i: int) = (i-1) / 2
exception NotValide
let est_valide (t: tas): bool =
try
for i = 1 to t.size-1 do
if (get t.elems (father i) |> snd) > (get t.elems i |> snd) then raise
NotValide
done;
true
with NotValide -> false
let insere_tas (t: tas) (elem: int) (prio: float) : unit =
resize_where_for_i elem t;
resize_elems_if_needed t;
let elemprio = (elem, prio) in
set t.elems t.size elemprio ;
set t.where (fst elemprio) t.size;
let curs = ref t.size in
t.size <- t.size + 1 ;
while (not (is_root t (!curs)) && (get_prio t.elems (!curs)) < (get_prio
t.elems (father !curs))) do
swap t.elems t.where (!curs) (father !curs);
curs := father (!curs);
done
let decrease_prio (t: tas) (elem : int) (prio : float) : unit =
let w = get t.where elem in
set t.elems w (elem, prio);
let curs = ref w in
while (not (is_root t (!curs)) && (get_prio t.elems (!curs)) < (get_prio
t.elems (father !curs))) do
swap t.elems t.where (!curs) (father !curs);
curs := father (!curs);
done
let supprime_min (t: tas): unit =
let e = elem_min t in
swap t.elems t.where 0 (t.size-1);
t.elems.(t.size-1) <- None;
t.size <- t.size-1;
let curs = ref 0 in
while ((has_left_son t !curs
&& get_prio t.elems (!curs) > get_prio t.elems (left_son !curs))
||(has_right_son t !curs
&& get_prio t.elems (!curs) > get_prio t.elems (right_son !curs))) do
let next = if ((has_right_son t !curs)
&& get_prio t.elems (right_son !curs) < get_prio t.elems
(left_son !curs))
then right_son !curs
else left_son !curs
in
swap t.elems t.where (!curs) next;
curs := next
done;
t.where.(e) <- None;
resize_elems_if_needed t
end
(* par listes d'adjacences *)
type graph = (int * float) list array
let g_ex =
[|
[(1, 3.); (2, 1.); (3, 1.); (6, 2.);];
[(6, 2.); (2, 1.); (4, 2.);];
[(5, 3.); (4, 3.); (7, 4.);];
[(2, 1.); (6, 2.); (8, 5.);];
[(8, 1.); (7, 1.);];
[(4, 3.); (8, 1.); (9, 2.);];
[(5, 2.); (9, 5.);];
[(8, 2.);];
[(6, 1.);];
[(8, 1.);]
|]
