Commit 119d10c8 by Johannes Kanig

### ma proposition

parent 2a6ee4aa
src/main.ml 0 → 100644
 open Term open Typing let alpha = Name.from_string "alpha" let talpha = Ty.var alpha let aa = Ty.arrow talpha talpha let a = Name.from_string "a" let b = Name.from_string "b" let t1 = lam a talpha (app (var a) (var b)) let t2 = lam a talpha (app (var a) (var b)) let ta = app (var a) (var b) let tb = app (var a) (var b) let g = Name.from_string "g" let f = Name.from_string "f" let h = Name.from_string "h" let tk = lam g aa (lam f aa (app (var g) (var f))) let termfun t = match t.node with | App ({ node = Var v}, t2) when Name.equal v g -> app (var h) t2 | _ -> t let tl = map termfun tk let _ = Format.printf "%a = %a = %b@." print t1 print t2 (equal t1 t2); Format.printf "%a = %a = %b@." print ta print tb (equal ta tb); Format.printf "%a -> %a : %b@." print tk print tl (alpha_equal tk tl) let x = Name.from_string "x" let y = Name.from_string "y" let pat = ptuple (pvar x) (pvar y) let ap = app (var x) (var y) let t = app (case tk pat [x;y] ap) (tuple ap ap) let _ = Format.printf "%a@." print t; Typing.theory [ Formula (close_polyterm [] t) ]
src/misc.ml 0 → 100644
 let combine n acc = let r = acc * 65599 + n in if r < 0 then if r = min_int then max_int else 0 - r else r let combine2 n acc1 acc2 = combine n (combine acc1 acc2) let combine3 n acc1 acc2 acc3 = combine n (combine acc1 (combine acc2 acc3)) let hash_int : int -> int = Hashtbl.hash let hash_string : string -> int = Hashtbl.hash module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) open Format let id x = x let ksprintf k s = ignore(flush_str_formatter ()); kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter s let sprintf s = ksprintf id s let rec print_list sep prf fmt = function | [] -> () | [x] -> prf fmt x | (x::xs) -> prf fmt x; sep fmt (); print_list sep prf fmt xs let comma fmt () = pp_print_string fmt ","
src/name.ml 0 → 100644
 type t = { tag : int ; name : string } let fresh = let cnt = ref 0 in fun t -> let tag = !cnt in incr cnt; { t with tag = tag } let from_string s = fresh { name = s; tag = 0} let equal a b = a.tag = b.tag let compare a b = Pervasives.compare a.tag b.tag let hash n = Hashtbl.hash n.tag let unsafe_to_string n = n.name let name_map = Hashtbl.create 47 let default_string = "anon" let strip_numbers s = let rec aux n = if n <= 0 then 0 else match s.[n-1] with | '0'..'9' -> aux (n-1) | _ -> n in let n = aux (String.length s) in if n = 0 then default_string else String.sub s 0 n let fresh_string name = let s = strip_numbers name in try let i = Hashtbl.find name_map s in let s' = s ^ (string_of_int !i) in incr i; s' with Not_found -> let x = ref 1 in Hashtbl.add name_map s x; s let to_string n = fresh_string (unsafe_to_string n) module HT = struct type t' = t type t = t' let equal = equal let hash = hash let compare = compare end module H = Hashtbl.Make (HT) module M = Map.Make (HT) module S = Set.Make (HT) let get_cur_name, reset = let current_name_map = H.create 47 in let reset () = H.clear current_name_map; Hashtbl.clear name_map in let get_name x = try H.find current_name_map x with Not_found -> let s = to_string x in H.add current_name_map x s; s in get_name, reset let to_string = get_cur_name let print fmt x = Format.fprintf fmt "%s" (get_cur_name x) let build_map nl = let m,_ = List.fold_left (fun (m, i) n -> M.add n i m, i + 1) (M.empty, 0) nl in m
src/name.mli 0 → 100644
 type t (** the type of Names *) val from_string : string -> t (** create a new name from a string *) val fresh : t -> t (** generate a new name from an old one *) val equal : t -> t -> bool (** efficient equality test on names *) val compare : t -> t -> int (** efficient comparison on names *) val hash : t -> int (** compute a hash for this name *) val unsafe_to_string : t -> string (** convert a name to a string; does not guarantee uniqueness. *) val to_string : t -> string (** get a unique string for a name. This name is memoized between calls, so that [to_string n] always returns the same string for the same name. Call [reset] to reset the memoization information. *) val print : Format.formatter -> t -> unit (** pretty printing names, using [to_string] to obtain a unique string. *) val reset : unit -> unit (* Reset the memoization information. Strings obtained using [to_string] or [print] after resetting are not guaranteed to be different from strings obtained before. *) module M : Map.S with type key = t module S : Set.S with type elt = t val build_map : t list -> int M.t (** from the list [ [n_1; ... ; n_m] ] of names build the map * [ n_1 |-> 0 ; ... n_m |-> m -1 ] *)
src/term.ml 0 → 100644
 include Termbase let map f t = let rec aux t = let t = match t.node with | BVar _ -> assert false | Var _ -> t | App (t1,t2) -> app (aux t1) (aux t2) | Tuple (t1,t2) -> tuple (aux t1) (aux t2) | Case (t,c) -> let p,nl,t = open_case c in case t p nl (aux t) | Lam (ty,b) -> let n,t = open_lam b in lam n ty (aux t) in f t in aux t
src/term.mli 0 → 100644
 type node = Termbase.node = private | BVar of int * int | Var of Name.t | Tuple of t * t | App of t * t | Lam of Ty.t * varbind | Case of t * case and t = Termbase.t = private { tag : int ; node : node } and varbind = Termbase.varbind and pattern = Termbase.pattern = private | PBVar of int | PVar of Name.t | PTuple of pattern * pattern | Wildcard and case = Termbase.case type decl = Termbase.decl = | Logic of Name.t * Ty.scheme | Formula of poly_term and poly_term = Termbase.poly_term val lam : Name.t -> Ty.t -> t -> t val app : t -> t -> t val var : Name.t -> t val equal : t -> t -> bool val alpha_equal : t -> t -> bool val case : t -> pattern -> Name.t list -> t -> t val tuple : t -> t -> t val map : (t -> t) -> t -> t val print : Format.formatter -> t -> unit val wildcard : pattern val pvar : Name.t -> pattern val ptuple : pattern -> pattern -> pattern val open_lam : varbind -> Name.t * t val open_polyterm : poly_term -> Name.t list * t val close_polyterm : Name.t list -> t -> poly_term val open_case : case -> pattern * Name.t list * t val close_case : pattern -> Name.t list -> t -> case
src/termbase.ml 0 → 100644
 type node = | BVar of int * int | Var of Name.t | Tuple of t * t | App of t * t | Lam of Ty.t * varbind | Case of t * case and t = { tag : int ; node : node } and varbind = Name.t list * t and pattern = | PBVar of int | PVar of Name.t | PTuple of pattern * pattern | Wildcard and case = pattern * varbind type decl = | Logic of Name.t * Ty.scheme | Formula of poly_term and poly_term = Name.t list * t module TBase = struct type node' = node type node = node' type t' = t type t = t' let rec equal n1 n2 = match n1, n2 with | BVar (i1,j1), BVar (i2,j2) -> i1 = i2 && j1 = j2 | App (ta1, ta2), App (tb1, tb2) | Tuple (ta1, ta2), Tuple (tb1, tb2) -> equal_t ta1 tb1 && equal_t ta2 tb2 | Lam (ty1, (n1,t1)), Lam (ty2, (n2,t2)) -> equal_names n1 n2 && equal_t t1 t2 && Ty.hc_equal ty1 ty2 | Var n1, Var n2 -> Name.equal n1 n2 | Case (ta,(p1,(n1,t1))), Case (tb,(p2,(n2,t2))) -> equal_t ta tb && equal_pattern p1 p2 && equal_names n1 n2 && equal_t t1 t2 | BVar _, _ | _, BVar _ -> false | Var _, _ | _, Var _ -> false | App _, _ | _, App _ -> false | Tuple _, _ | _, Tuple _ -> false | Lam _, _ | _, Lam _ -> false and equal_t t1 t2 = t1 == t2 and equal_names l1 l2 = List.for_all2 Name.equal l1 l2 and equal_pattern p1 p2 = match p1, p2 with | Wildcard, Wildcard -> true | PBVar i1, PBVar i2 -> i1 = i2 | PVar n1, PVar n2 -> Name.equal n1 n2 | PTuple (ta1, ta2), PTuple (tb1, tb2) -> equal_pattern ta1 tb1 && equal_pattern ta2 tb2 | Wildcard, _ | _, Wildcard -> false | PVar _, _ | _ , PVar _ -> false | PBVar _, _| _ , PBVar _ -> false let node t = t.node open Misc let rec hash_pattern p = match p with | PBVar i -> combine 7 (hash_int i) | PVar n -> combine 8 (Name.hash n) | PTuple (p1,p2) -> combine2 9 (hash_pattern p1) (hash_pattern p2) | Wildcard -> combine 10 11 let hash_name_list = List.fold_left (fun acc n -> combine2 4 (Name.hash n) acc) let hash n = match n with | BVar (i,j) -> combine2 1 (hash_int i) (hash_int j) | Var n -> combine 2 (Name.hash n) | App (t1,t2) -> combine2 3 t1.tag t2.tag | Lam (ty,(n,t)) -> combine2 12 (hash_name_list t.tag n) (Ty.hash ty) | Tuple (t1,t2) -> combine2 5 t1.tag t2.tag | Case (t,(p,(nl,t2))) -> combine3 6 t.tag (hash_pattern p) (hash_name_list t2.tag nl) end module HTerms = Hashcons.Make(TBase) let equal a b = a.tag = b.tag let mk_t n t = { tag = t; node = n } let var n = HTerms.hashcons (Var n) mk_t let bvar i j = HTerms.hashcons (BVar (i,j)) mk_t let app t1 t2 = HTerms.hashcons (App (t1,t2)) mk_t let tuple t1 t2 = HTerms.hashcons (Tuple (t1,t2)) mk_t let raw_lam t b = HTerms.hashcons (Lam (t,b)) mk_t let raw_case t p b = HTerms.hashcons (Case (t, (p, b))) mk_t let build_map nl = let m,_ = List.fold_left (fun (m, i) n -> Name.M.add n i m, i + 1) (Name.M.empty, 0) nl in m let abstract nl t = let m = build_map nl in let rec aux i t = match t.node with | Var n' -> begin try let j = Name.M.find n' m in bvar i j with Not_found -> t end | BVar _ -> t | App (t1,t2) -> app (aux i t1) (aux i t2) | Tuple (t1,t2) -> tuple (aux i t1) (aux i t2) | Lam (ty, (nl,t)) -> raw_lam ty (nl, aux (i+1) t) | Case (ta,(p,(nl,t))) -> raw_case (aux i ta) p (nl, aux (i+1) t) in aux 0 t let abstract_pattern nl p = let m = build_map nl in let rec aux p = match p with | PVar n -> begin try let i = Name.M.find n m in PBVar i with Not_found -> p end | PBVar _ | Wildcard -> p | PTuple (p1,p2) -> PTuple (aux p1, aux p2) in aux p let instantiate tl t = let rec aux i t = match t.node with | BVar (i',j) when i = i' -> List.nth tl j | BVar _ | Var _ -> t | App (t1,t2) -> app (aux i t1) (aux i t2) | Tuple (t1,t2) -> tuple (aux i t1) (aux i t2) | Lam (ty, (n,t)) -> raw_lam ty (n, aux (i+1) t) | Case (t1, (p,(nl,t2))) -> raw_case (aux i t1) p (nl, aux (i+1) t) in aux 0 t let instantiate_pattern pl p = let rec aux p = match p with | PBVar i -> List.nth pl i | PVar _ | Wildcard -> p | PTuple (p1,p2) -> PTuple (aux p1, aux p2) in aux p open Format let rec print env fmt t = match t.node with | BVar (i,j) -> begin try Name.print fmt (List.nth (List.nth env i) j) with Invalid_argument "List.nth" -> fprintf fmt "{{%d,%d}}" i j end | Var n -> Name.print fmt n | App (t1,t2) -> fprintf fmt "%a %a" (print env) t1 (paren env) t2 | Tuple (t1,t2) -> fprintf fmt "(%a, %a)" (print env) t1 (print env) t2 | Lam (ty, (n,t)) -> fprintf fmt "(λ%a : %a . %a)" (Misc.print_list Misc.comma Name.print) n (Ty.print []) ty (print (n::env)) t | Case (t1, (p,(n,t2))) -> fprintf fmt "case %a of %a -> %a" (print env) t1 (print_pattern n) p (print (n::env)) t2 and paren env fmt t = if is_compound t then fprintf fmt "(%a)" (print env) t else print env fmt t and is_compound t = (* decide if this term has to be printed with parens in some contexts *) match t.node with | BVar _ | Var _ | Lam _ | Tuple _ -> false | App _ | Case _ -> true and print_pattern l fmt p = match p with | PBVar i -> begin try Name.print fmt (List.nth l i) with Invalid_argument "List.nth" -> fprintf fmt "{{%d}}" i end | PVar v -> Name.print fmt v | PTuple (t1,t2) -> fprintf fmt "(%a, %a)" (print_pattern l) t1 (print_pattern l) t2 | Wildcard -> fprintf fmt "_" let print = print [] let rec alpha_equal a b = if equal a b then true else match a.node, b.node with | BVar (i1,j1), BVar (i2,j2) -> i1 = i2 && j1 = j2 | Var n1, Var n2 -> Name.equal n1 n2 | App (ta1, ta2), App (tb1, tb2) | Tuple (ta1, ta2), Tuple (tb1, tb2) -> alpha_equal ta1 tb1 && alpha_equal ta2 tb2 | Lam (ty1, (_,t1)), Lam (ty2, (_,t2)) -> Ty.equal ty1 ty2 && alpha_equal t1 t2 | Case (ta,(p1,(_,t1))), (Case (tb, (p2,(_,t2)))) -> alpha_equal ta tb && TBase.equal_pattern p1 p2 && alpha_equal t1 t2 | BVar _, _ | _, BVar _ -> false | Var _, _ | _, Var _ -> false | App _, _ | _, App _ -> false | Tuple _, _ | _, Tuple _ -> false | Lam _, _ | _, Lam _ -> false let unsafe_map ~tyfun ~termfun t = let rec aux t = let t = match t.node with | BVar _ | Var _ -> t | App (t1,t2) -> app (aux t1) (aux t2) | Tuple (t1,t2) -> tuple (aux t1) (aux t2) | Case (t1, (p,(n,t2))) -> raw_case (aux t1) p (n,aux t2) | Lam (ty, (n,t)) -> raw_lam (tyfun ty) (n, aux t) in termfun t in aux t let open_ (n,t) = n, instantiate (List.map var n) t let close n t = let n' = List.map Name.fresh n in n', abstract n t let lam n ty t = raw_lam ty (close [n] t) let open_case (p,(nl,t)) = let pl = List.map (fun n -> PVar n) nl in let tl = List.map var nl in instantiate_pattern pl p, nl, instantiate tl t let close_case p nl t = let nl' = List.map Name.fresh nl in abstract_pattern nl p, (nl', abstract nl t) let case t1 p nl t2 = let p, b = close_case p nl t2 in raw_case t1 p b let wildcard = Wildcard let pvar x = PVar x let ptuple p1 p2 = PTuple (p1,p2) let open_polyterm (nl,t) = let tl = List.map Ty.var nl in nl, unsafe_map ~tyfun:(Ty.instantiate tl) ~termfun:(fun x -> x) t let close_polyterm nl t = let nl' = List.map Name.fresh nl in nl', unsafe_map ~tyfun:(Ty.abstract nl) ~termfun:(fun x -> x) t let open_lam b = let nl, t = open_ b in List.hd nl, t
src/termbase.mli 0 → 100644
 type node = private | BVar of int * int | Var of Name.t | Tuple of t * t | App of t * t | Lam of Ty.t * varbind | Case of t * case and t = private { tag : int ; node : node } and varbind and pattern = private | PBVar of int | PVar of Name.t | PTuple of pattern * pattern | Wildcard and case type decl = | Logic of Name.t * Ty.scheme | Formula of poly_term and poly_term (** smart constructors *) val lam : Name.t -> Ty.t -> t -> t val app : t -> t -> t val tuple : t -> t -> t val var : Name.t -> t val equal : t -> t -> bool val alpha_equal : t -> t -> bool val case : t -> pattern -> Name.t list -> t -> t val open_case : case -> pattern * Name.t list * t val close_case : pattern -> Name.t list -> t -> case val unsafe_map : tyfun:(Ty.t -> Ty.t) -> termfun:(t -> t) -> t -> t (** [unsafe_map f t] recursively descends into [t] and then applies [f] everywhere going up; This function is unsafe in the sense that you might encounter [BVar] constructors. Only use it for simple rewriting that does not affect names, or does only affect global variables *) val print : Format.formatter -> t -> unit val wildcard : pattern val pvar : Name.t -> pattern val ptuple : pattern -> pattern -> pattern val open_polyterm : poly_term -> Name.t list * t val close_polyterm : Name.t list -> t -> poly_term val open_lam : varbind -> Name.t * t
src/ty.ml 0 → 100644
 type node = | BVar of int | Var of Name.t | Tuple of t * t | Arrow of t * t and t = {tag : int ; node : node } and scheme = Name.t list * t module Base = struct type node' = node type node = node' type t' = t type t = t' let rec equal t1 t2 = match t1, t2 with | Var n1, Var n2 -> Name.equal n1 n2 | BVar (i1), BVar (i2) -> i1 = i2 | Tuple (ta1, ta2), Tuple (tb1, tb2) | Arrow (ta1, ta2), Arrow (tb1, tb2) -> equal_t ta1 tb1 && equal_t ta2 tb2 | Var _, _ | _, Var _ -> false | BVar _, _ | _, BVar _ -> false | Tuple _, _ | _, Tuple _ -> false and equal_t t1 t2 = t1 == t2 let node t = t.node open Misc let hash n = match n with | BVar (i) -> combine 1 (hash_int i) | Var n -> combine 2 (Name.hash n) | Arrow (t1,t2) -> combine2 3 t1.tag t2.tag | Tuple (t1,t2) -> combine2 5 t1.tag t2.tag end let hc_equal = Base.equal_t let hash t = t.tag