(* Copyright (C) 2004, HELM Team.
 * 
 * This file is part of HELM, an Hypertextual, Electronic
 * Library of Mathematics, developed at the Computer Science
 * Department, University of Bologna, Italy.
 * 
 * HELM is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 * 
 * HELM is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with HELM; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 * MA  02111-1307, USA.
 * 
 * For details, see the HELM World-Wide-Web page,
 * http://helm.cs.unibo.it/
 *)

open Printf

exception Meta_not_found of int
exception Subst_not_found of int

let lookup_meta index metasenv =
  try
    List.find (fun (index', _, _) -> index = index') metasenv
  with Not_found -> raise (Meta_not_found index)

let lookup_subst n subst =
  try
    List.assoc n subst
  with Not_found -> raise (Subst_not_found n)

let exists_meta index = List.exists (fun (index', _, _) -> (index = index'))

(* clean_up_meta take a substitution, a metasenv a meta_inex and a local
context l and clean up l with respect to the hidden hipothesis in the 
canonical context *)

let clean_up_local_context subst metasenv n l =
  let cc =
    (try
       let (cc,_,_) = lookup_subst n subst in cc
     with Subst_not_found _ ->
       try
	 let (_,cc,_) = lookup_meta n metasenv in cc
       with Meta_not_found _ -> assert false) in
  (try 
     List.map2
       (fun t1 t2 ->
	  match t1,t2 with 
	      None , _ -> None
	    | _ , t -> t) cc l
   with 
       Invalid_argument _ -> assert false)

let is_closed =
 let module C = Cic in
 let rec is_closed k =
  function
      C.Rel m when m > k -> false
    | C.Rel m -> true
    | C.Meta (_,l) ->
       List.fold_left
        (fun i t -> i && (match t with None -> true | Some t -> is_closed k t)
        ) true l
    | C.Sort _ -> true
    | C.Implicit _ -> assert false
    | C.Cast (te,ty) -> is_closed k te && is_closed k ty
    | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
    | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
    | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
    | C.Appl l ->
       List.fold_right (fun x i -> i && is_closed k x) l true
    | C.Var (_,exp_named_subst)
    | C.Const (_,exp_named_subst)
    | C.MutInd (_,_,exp_named_subst)
    | C.MutConstruct (_,_,_,exp_named_subst) ->
       List.fold_right (fun (_,x) i -> i && is_closed k x)
        exp_named_subst true
    | C.MutCase (_,_,out,te,pl) ->
       is_closed k out && is_closed k te &&
        List.fold_right (fun x i -> i && is_closed k x) pl true
    | C.Fix (_,fl) ->
       let len = List.length fl in
        let k_plus_len = k + len in
         List.fold_right
          (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
          ) fl true
    | C.CoFix (_,fl) ->
       let len = List.length fl in
        let k_plus_len = k + len in
         List.fold_right
          (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
          ) fl true
in 
 is_closed 0
;;

let rec is_meta_closed =
  function
      Cic.Rel _ -> true
    | Cic.Meta _ -> false
    | Cic.Sort _ -> true
    | Cic.Implicit _ -> assert false
    | Cic.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty
    | Cic.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest
    | Cic.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest
    | Cic.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest
    | Cic.Appl l ->
       List.fold_right (fun x i -> i && is_meta_closed x) l true
    | Cic.Var (_,exp_named_subst)
    | Cic.Const (_,exp_named_subst)
    | Cic.MutInd (_,_,exp_named_subst)
    | Cic.MutConstruct (_,_,_,exp_named_subst) ->
       List.fold_right (fun (_,x) i -> i && is_meta_closed x)
        exp_named_subst true
    | Cic.MutCase (_,_,out,te,pl) ->
       is_meta_closed out && is_meta_closed te &&
        List.fold_right (fun x i -> i && is_meta_closed x) pl true
    | Cic.Fix (_,fl) ->
        List.fold_right
          (fun (_,_,ty,bo) i -> i && is_meta_closed ty && is_meta_closed bo
          ) fl true
    | Cic.CoFix (_,fl) ->
         List.fold_right
          (fun (_,ty,bo) i -> i && is_meta_closed ty && is_meta_closed bo
          ) fl true
;;

let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))"
let slash_RE = Str.regexp "/"

let term_of_uri uri =
  let s = UriManager.string_of_uri uri in
  try
    (if UriManager.uri_is_con uri then
      Cic.Const (uri, [])
    else if UriManager.uri_is_var uri then
      Cic.Var (uri, [])
    else if not (Str.string_match xpointer_RE s 0) then
      raise (UriManager.IllFormedUri s)
    else
      let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in
      let baseuri = UriManager.uri_of_string baseuri in
      (match Str.split slash_RE xpointer with
      | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, [])
      | [_; tyno; consno] ->
          Cic.MutConstruct
            (baseuri, int_of_string tyno - 1, int_of_string consno, [])
      | _ -> raise Exit))
  with
  | Exit
  | Failure _
  | Not_found -> raise (UriManager.IllFormedUri s)

let uri_of_term = function
  | Cic.Const (uri, [])
  | Cic.Var (uri, []) -> uri
  | Cic.MutInd (baseuri, tyno, []) ->
     UriManager.uri_of_string
      (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1))
  | Cic.MutConstruct (baseuri, tyno, consno, []) ->
     UriManager.uri_of_string
      (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri)
        (tyno + 1) consno)
  | _ -> raise (Invalid_argument "uri_of_term")


(*
let pack terms =
  List.fold_right
    (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc))
    terms (Cic.Sort (Cic.Type (CicUniv.fresh ())))

let rec unpack = function
  | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term]
  | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt
  | _ -> assert false
*)

let rec strip_prods n = function
  | t when n = 0 -> t
  | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt
  | _ -> failwith "not enough prods"

let params_of_obj = function
  | Cic.Constant (_, _, _, params, _)
  | Cic.Variable (_, _, _, params, _)
  | Cic.CurrentProof (_, _, _, _, params, _)
  | Cic.InductiveDefinition (_, params, _, _) ->
      params

let attributes_of_obj = function
  | Cic.Constant (_, _, _, _, attributes)
  | Cic.Variable (_, _, _, _, attributes)
  | Cic.CurrentProof (_, _, _, _, _, attributes)
  | Cic.InductiveDefinition (_, _, _, attributes) ->
      attributes
let rec mk_rels howmany from =
  match howmany with 
  | 0 -> []
  | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from)

let profile =
 function s ->
  let total = ref 0.0 in
  let profile f x =
   let before = Unix.gettimeofday () in
   let res = f x in
   let after = Unix.gettimeofday () in
    total := !total +. (after -. before);
    res
  in
  at_exit
   (fun () ->
     print_endline
      ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
  profile

  (** WARNING: COMMENT THIS TO ENABLE PROFILING **)
let profile _ = let profile f x = f x in profile