/src/utils/utils.ml - Diff - LustreC

« Previous | Next »

Revision ca7ff3f7

Added by Lélio Brun over 1 year ago

ID ca7ff3f7d0683919e7a2950ab977708d58aa208d
Parent 3ee26303
Child d0f26f04

reformatting

     open Graph
     type rat = int*int
     type rat = int * int
     type ident = string
     type tag = int
     type longident = (string * tag) list
     exception TransposeError of int*int
     exception TransposeError of int * int
     (** General utility functions. *)
     let create_hashtable size init =
-...
       List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
       tbl
     module IdentModule =
     struct (* Node module *)
     module IdentModule = struct
       (* Node module *)
       type t = ident
       let compare = compare
       let hash n = Hashtbl.hash n
       let equal n1 n2 = n1 = n2
     end
     module IMap = struct
       include Map.Make(IdentModule)
       include Map.Make (IdentModule)
       let union_l m1 m2 =
         merge (fun _ o1 o2 -> match o1, o2 with
             | None, None -> None
             | Some _, _ -> o1
             | _, Some _ -> o2) m1 m2
         merge
           (fun _ o1 o2 ->
             match o1, o2 with
             | None, None ->
               None
             | Some _, _ ->
               o1
             | _, Some _ ->
               o2)
           m1 m2
     end
     module ISet = Set.Make(IdentModule)
     module ISet = Set.Make (IdentModule)
     module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
     module TopologicalDepGraph = Topological.Make(IdentDepGraph)
     module ComponentsDepGraph = Components.Make(IdentDepGraph)
     module TopologicalDepGraph = Topological.Make (IdentDepGraph)
     module ComponentsDepGraph = Components.Make (IdentDepGraph)
     (*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
     module Bfs = Traverse.Bfs (IdentDepGraph)
     exception DeSome
     let desome x = match x with Some x -> x | None -> raise DeSome
     let option_map f o =
       match o with
       | None   -> None
       | Some e -> Some (f e)
     let option_map f o = match o with None -> None | Some e -> Some (f e)
     let add_cons x l =
      if List.mem x l then l else x::l
     let add_cons x l = if List.mem x l then l else x :: l
     let rec remove_duplicates l =
      match l with
      | [] -> []
      | t::q -> add_cons t (remove_duplicates q)
       match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q)
     let position pred l =
       let rec pos p l =
         match l with
         | [] -> assert false
         | t::q -> if pred t then p else pos (p+1) q
       in pos 0 l
         | [] ->
           assert false
         | t :: q ->
           if pred t then p else pos (p + 1) q
       in
       pos 0 l
     (* TODO: Lélio: why n+1? cf former def below *)
     (* if n < 0 then [] else x :: duplicate x (n - 1) *)
     let duplicate x n = List.init (n+1) (fun _ -> x)
     let duplicate x n = List.init (n + 1) (fun _ -> x)
     let enumerate n = List.init n (fun i -> i)
     let rec repeat n f x =
      if n <= 0 then x else repeat (n-1) f (f x)
     let rec repeat n f x = if n <= 0 then x else repeat (n - 1) f (f x)
     let transpose_list ll =
       let rec transpose ll =
         match ll with
         | []   -> []
         | [l]  -> List.map (fun el -> [el]) l
         | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
       in match ll with
       | []   -> []
       | l::q -> let length_l = List.length l in
         List.iter (fun l' -> let length_l' = List.length l'
                     in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
         | [] ->
           []
         | [ l ] ->
           List.map (fun el -> [ el ]) l
         | l :: q ->
           List.map2 (fun el eq -> el :: eq) l (transpose q)
       in
       match ll with
       | [] ->
         []
       | l :: q ->
         let length_l = List.length l in
         List.iter
           (fun l' ->
             let length_l' = List.length l' in
             if length_l <> length_l' then
               raise (TransposeError (length_l, length_l')))
           q;
         transpose ll
     let rec filter_upto p n l =
      if n = 0 then [] else
      match l with
      | [] -> []
      | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
       if n = 0 then []
       else
         match l with
         | [] ->
           []
         | t :: q ->
           if p t then t :: filter_upto p (n - 1) q else filter_upto p n q
     (* Warning: bad complexity *)
     let list_of_imap imap =
       IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
       IMap.fold (fun i v (il, vl) -> i :: il, v :: vl) imap ([], [])
     (** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
     let rec gcd a b =
       if b = 0 then a
       else gcd b (a mod b)
     let rec gcd a b = if b = 0 then a else gcd b (a mod b)
     (** [lcm a b] returns the least common multiple of [a] and [b]. *)
     let lcm a b =
       if a = 0 && b = 0 then
       else a*b/(gcd a b)
     (** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
         [(a',b')] *)
     let sum_rat (a,b) (a',b') =
       if a = 0 && b = 0 then
         (a',b')
       else if a'=0 && b'=0 then
         (a,b)
     let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b
     (** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *)
     let sum_rat (a, b) (a', b') =
       if a = 0 && b = 0 then a', b'
       else if a' = 0 && b' = 0 then a, b
       else
         let lcm_bb' = lcm b b' in
         (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
         (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
     let simplify_rat (a,b) =
     let simplify_rat (a, b) =
       let gcd = gcd a b in
       if (gcd =0) then
         (a,b)
       else (a/gcd,b/gcd)
     let max_rat (a,b) (a',b') =
       let ratio_ab = (float_of_int a)/.(float_of_int b) in
       let ratio_ab' = (float_of_int a')/.(float_of_int b') in
       if ratio_ab > ratio_ab' then
         (a,b)
       else
         (a',b')
       if gcd = 0 then a, b else a / gcd, b / gcd
     (** [list_union l1 l2] returns the union of list [l1] and [l2]. The
         result contains no duplicates. *)
     let max_rat (a, b) (a', b') =
       let ratio_ab = float_of_int a /. float_of_int b in
       let ratio_ab' = float_of_int a' /. float_of_int b' in
       if ratio_ab > ratio_ab' then a, b else a', b'
     (** [list_union l1 l2] returns the union of list [l1] and [l2]. The result
         contains no duplicates. *)
     let list_union l1 l2 =
       let rec aux l acc =
         match l with
         | [] -> acc
         | x::tl ->
             if List.mem x acc then
               aux tl acc
             else
               aux tl (x::acc)
         | [] ->
           acc
         | x :: tl ->
           if List.mem x acc then aux tl acc else aux tl (x :: acc)
       in
       let l1' = aux l1 [] in
       aux l2 l1'
-...
     let hashtbl_iterlast h f1 f2 =
       let l = Hashtbl.length h in
       ignore(
       Hashtbl.fold
         (fun k v cpt ->
           if cpt = l then
             begin f2 k v; cpt+1 end
           else
             begin f1 k v; cpt+1 end)
         h 1)
     (** Match types variables to 'a, 'b, ..., for pretty-printing. Type
         variables are identified by integers. *)
     let tnames = ref ([]: (int * string) list)
       ignore
         (Hashtbl.fold
            (fun k v cpt ->
              if cpt = l then (
                f2 k v;
                cpt + 1)
              else (
                f1 k v;
                cpt + 1))
            h 1)
     (** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables
         are identified by integers. *)
     let tnames = ref ([] : (int * string) list)
     let tname_counter = ref 0
     (* Same for carriers *)
     let crnames = ref ([]: (int * string) list)
     let crnames = ref ([] : (int * string) list)
     let crname_counter = ref 0
     (* Same for dimension *)
     let dnames = ref ([]: (int * string) list)
     let dnames = ref ([] : (int * string) list)
     let dname_counter = ref 0
     (* Same for delays *)
     let inames = ref ([]: (int * string) list)
     let inames = ref ([] : (int * string) list)
     let iname_counter = ref 0
     let reset_names () =
-...
     (* From OCaml compiler *)
     let new_tname () =
       let tname =
         if !tname_counter < 26
         then String.make 1 (Char.chr(97 + !tname_counter))
         else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
           string_of_int(!tname_counter / 26) in
         if !tname_counter < 26 then String.make 1 (Char.chr (97 + !tname_counter))
         else
           String.make 1 (Char.chr (97 + (!tname_counter mod 26)))
           ^ string_of_int (!tname_counter / 26)
       in
       incr tname_counter;
       tname
     let new_crname () =
       incr crname_counter;
       Format.sprintf "c%i" (!crname_counter-1)
       Format.sprintf "c%i" (!crname_counter - 1)
     let name_of_type id =
       try List.assoc id !tnames with Not_found ->
       try List.assoc id !tnames
       with Not_found ->
         let name = new_tname () in
         tnames := (id, name) :: !tnames;
         name
     let name_of_carrier id =
       let pp_id =
         try List.assoc id !crnames with Not_found ->
         try List.assoc id !crnames
         with Not_found ->
           let name = new_crname () in
           crnames := (id,name) :: !crnames;
           crnames := (id, name) :: !crnames;
           name
       in
       pp_id
     let new_dname () =
       incr dname_counter;
       Format.sprintf "d%i" (!dname_counter-1)
       Format.sprintf "d%i" (!dname_counter - 1)
     let name_of_dimension id =
       try List.assoc id !dnames with Not_found ->
       try List.assoc id !dnames
       with Not_found ->
         let name = new_dname () in
         dnames := (id, name) :: !dnames;
         name
     let new_iname () =
       incr iname_counter;
       Format.sprintf "t%i" (!iname_counter-1)
       Format.sprintf "t%i" (!iname_counter - 1)
     let name_of_delay id =
       try List.assoc id !inames with Not_found ->
       try List.assoc id !inames
       with Not_found ->
         let name = new_iname () in
         inames := (id, name) :: !inames;
         name
     open Format
     let print_rat fmt (a,b) =
       if b=1 then
         Format.fprintf fmt "%i" a
       else
         if b < 0 then
           Format.fprintf fmt "%i/%i" (-a) (-b)
         else
           Format.fprintf fmt "%i/%i" a b
     let print_rat fmt (a, b) =
       if b = 1 then Format.fprintf fmt "%i" a
       else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
       else Format.fprintf fmt "%i/%i" a b
     (* Generic pretty printing *)
     let pp_final_char_if_non_empty c l fmt =
       match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c
     let pp_final_char_if_non_empty c l =
       (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
     let pp_newline_if_non_empty l =
       (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
     let pp_newline_if_non_empty l fmt =
       match l with [] -> () | _ -> Format.fprintf fmt "@,"
     module Format = struct
       include Format
-...
       let pp_print_endcut s fmt () = fprintf fmt "%s@," s
       let pp_print_opar fmt () = pp_print_string fmt "("
       let pp_print_cpar fmt () = pp_print_string fmt ")"
       let pp_print_obracket fmt () = pp_print_string fmt "["
       let pp_print_cbracket fmt () = pp_print_string fmt "]"
       let pp_print_obrace fmt () = pp_print_string fmt "{"
       let pp_print_cbrace fmt () = pp_print_string fmt "}"
       let pp_print_opar' fmt () = pp_print_string fmt "( "
       let pp_print_cpar' fmt () = pp_print_string fmt " )"
       let pp_print_obrace' fmt () = pp_print_string fmt "{ "
       let pp_print_cbrace' fmt () = pp_print_string fmt " }"
       let pp_print_comma fmt () = fprintf fmt ",@ "
       let pp_print_semicolon fmt () = fprintf fmt ";@ "
       let pp_print_comma' fmt () = fprintf fmt ","
       let pp_print_semicolon' fmt () = fprintf fmt ";"
       let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
       let pp_print_list
           ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
           ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
           ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
           ?(pp_eol=pp_print_nothing)
           ?(pp_nil=pp_print_nothing)
           ?pp_sep pp_v fmt l =
       let pp_print_list ?(pp_prologue = pp_print_nothing)
           ?(pp_epilogue = pp_print_nothing) ?(pp_op = pp_print_nothing)
           ?(pp_cl = pp_print_nothing)
           ?(pp_open_box = fun fmt () -> pp_open_box fmt 0)
           ?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt
           l =
         fprintf fmt "%a%a%a%a%a@]%a%a"
           (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
           pp_op ()
           pp_open_box ()
           (fun fmt l -> if l <> [] then pp_prologue fmt ())
           l pp_op () pp_open_box ()
           (fun fmt () ->
              if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) ()
           (fun fmt l -> if l <> [] then pp_eol fmt ()) l
           pp_cl ()
           (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
             if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l)
           ()
           (fun fmt l -> if l <> [] then pp_eol fmt ())
           l pp_cl ()
           (fun fmt l -> if l <> [] then pp_epilogue fmt ())
+          l
       let pp_comma_list = pp_print_list ~pp_sep:pp_print_comma
       let pp_print_list_i
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           pp_v =
       let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
           ?pp_eol ?pp_sep pp_v =
         let i = ref 0 in
         pp_print_list
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           (fun fmt x -> pp_v fmt !i x; incr i)
       let pp_print_list2
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           pp_v fmt (l1, l2) =
         pp_print_list
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           pp_v fmt (List.combine l1 l2)
       let pp_print_list_i2
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           pp_v fmt (l1, l2) =
         pp_print_list_i
           ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
           (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
       let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
         pp_print_list
           ~pp_op:pp_print_opar
           ~pp_cl:pp_print_cpar
           ~pp_sep
       let pp_print_bracketed ?(pp_sep=pp_print_comma) =
         pp_print_list
           ~pp_op:pp_print_obracket
           ~pp_cl:pp_print_cbracket
           ~pp_sep
       let pp_print_braced ?(pp_sep=pp_print_comma) =
         pp_print_list
           ~pp_op:pp_print_obrace
           ~pp_cl:pp_print_cbrace
           ~pp_sep
       let pp_print_braced' ?(pp_sep=pp_print_comma) =
         pp_print_list
           ~pp_op:pp_print_obrace'
           ~pp_cl:pp_print_cbrace'
           ~pp_sep
         pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
           ?pp_sep (fun fmt x ->
             pp_v fmt !i x;
             incr i)
       let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
           ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
         pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
           ?pp_sep pp_v fmt (List.combine l1 l2)
       let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
           ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
         pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
           ?pp_sep
           (fun fmt i (x1, x2) -> pp_v fmt i x1 x2)
           fmt (List.combine l1 l2)
       let pp_print_parenthesized ?(pp_sep = pp_print_comma) =
         pp_print_list ~pp_op:pp_print_opar ~pp_cl:pp_print_cpar ~pp_sep
       let pp_print_bracketed ?(pp_sep = pp_print_comma) =
         pp_print_list ~pp_op:pp_print_obracket ~pp_cl:pp_print_cbracket ~pp_sep
       let pp_print_braced ?(pp_sep = pp_print_comma) =
         pp_print_list ~pp_op:pp_print_obrace ~pp_cl:pp_print_cbrace ~pp_sep
       let pp_print_braced' ?(pp_sep = pp_print_comma) =
         pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep
     end
     let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
     let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
       Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
       if l <> [] then Format.fprintf fmt "%(%)" eol
     let pp_list l pp_fun beg_str end_str sep_str =
       if (beg_str="\n") then
         print_newline ()
       else
         print_string beg_str;
       if beg_str = "\n" then print_newline () else print_string beg_str;
       let rec pp_l l =
         match l with
         | [] -> ()
         | [hd] ->
             pp_fun hd
         | hd::tl ->
             pp_fun hd;
             if (sep_str="\n") then
               print_newline ()
             else
               print_string sep_str;
             pp_l tl
         | [] ->
           ()
         | [ hd ] ->
           pp_fun hd
         | hd :: tl ->
           pp_fun hd;
           if sep_str = "\n" then print_newline () else print_string sep_str;
           pp_l tl
       in
       pp_l l;
       if (end_str="\n") then
         print_newline ()
       else
         print_string end_str
       if end_str = "\n" then print_newline () else print_string end_str
     let pp_array a pp_fun beg_str end_str sep_str =
       if (beg_str="\n") then
         print_newline ()
       else
         print_string beg_str;
       if beg_str = "\n" then print_newline () else print_string beg_str;
       let n = Array.length a in
       if n > 0 then
         begin
           Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
           pp_fun a.(n-1)
         end;
       if (end_str="\n") then
         print_newline ()
       else
         print_string end_str
       if n > 0 then (
         Array.iter
           (fun x ->
             pp_fun x;
             print_string sep_str)
           (Array.sub a 0 (n - 1));
         pp_fun a.(n - 1));
       if end_str = "\n" then print_newline () else print_string end_str
     let pp_iset fmt t =
       Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
       ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
       Format.fprintf fmt "@]@ }@]"
     let pp_imap ?(comment="") pp_val fmt m =
     let pp_imap ?(comment = "") pp_val fmt m =
       Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
       IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
       Format.fprintf fmt "@]@ }@]"
     let pp_hashtbl t pp_fun beg_str end_str sep_str =
       if (beg_str="\n") then
         print_newline ()
       else
         print_string beg_str;
       if beg_str = "\n" then print_newline () else print_string beg_str;
       let pp_fun1 k v =
         pp_fun k v;
         if (sep_str="\n") then
           print_newline ()
         else
           print_string sep_str
         if sep_str = "\n" then print_newline () else print_string sep_str
       in
       hashtbl_iterlast t pp_fun1 pp_fun;
       if (end_str="\n") then
         print_newline ()
       else
         print_string end_str
       if end_str = "\n" then print_newline () else print_string end_str
     let pp_longident lid =
       let pp_fun (nid, tag) =
-...
         print_int tag;
         print_string ")"
       in
       pp_list lid pp_fun "" "." "."
       pp_list lid pp_fun "" "." "."
     let pp_date fmt tm =
       let open Unix in
       Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
         (tm.tm_year + 1900)
         tm.tm_mon
         tm.tm_mday
         tm.tm_hour
         tm.tm_min
         tm.tm_sec
       Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon
         tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
     (* Used for uid in variables *)
     let get_new_id =
       let var_id_cpt = ref 0 in
       fun () -> incr var_id_cpt; !var_id_cpt
       fun () ->
         incr var_id_cpt;
         !var_id_cpt
     let new_tag =
       let last_tag = ref (-1) in
       fun () -> incr last_tag; !last_tag
       fun () ->
         incr last_tag;
         !last_tag
     module List = struct
       include List
       include List
       let iteri2 f l1 l2 =
         if List.length l1 <> List.length l2 then
           raise (Invalid_argument "iteri2: lists have different lengths")
         else
           let rec run idx l1 l2 =
             match l1, l2 with
             | [], [] -> ()
             | hd1::tl1, hd2::tl2 ->
             | [], [] ->
               ()
             | hd1 :: tl1, hd2 :: tl2 ->
               f idx hd1 hd2;
               run (idx+1) tl1 tl2
             | _ -> assert false
               run (idx + 1) tl1 tl2
             | _ ->
               assert false
           in
           run 0 l1 l2
       let rec extract l fst last =
         if last < fst then assert false else
         if last < fst then assert false
         else
           match l, fst with
           | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
           | _::tl, _ -> extract tl (fst-1) (last-1)
           | [], 0 -> if last=0 then [] else assert false (* List too short *)
           | _ -> assert false
           | hd :: tl, 0 ->
             if last = 0 then [] else hd :: extract tl 0 (last - 1)
           | _ :: tl, _ ->
             extract tl (fst - 1) (last - 1)
           | [], 0 ->
             if last = 0 then [] else assert false (* List too short *)
           | _ ->
             assert false
     end
     let get_date () =
       let tm = Unix.localtime (Unix.time ()) in
       let tm = Unix.localtime (Unix.time ()) in
       let fmt = Format.str_formatter in
       pp_date fmt tm;
       Format.flush_str_formatter ()

Also available in: Unified diff

Project

General

Profile

CristalCaveGem » LustreC

Revision ca7ff3f7

Added by Lélio Brun over 1 year ago