l3-ENSL/pieuvre
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

tests de l'alpha équiv, commentaire de mon code

Browse Source
This commit is contained in:
Marwan 2024-05-19 20:44:07 +02:00
parent 4719e2c836
commit 075aa267a7
12 changed files with 143 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
hlam.ml
View File

@ -8,8 +8,8 @@ type hlam = (* hollow lam *)
| HVar of id | HVar of id
| HExf of hlam * Types.ty | HExf of hlam * Types.ty
| HPair of hlam * hlam | HPair of hlam * hlam
| HLeft of hlam * Types.ty | HLeft of hlam * Types.ty (* l (M : t) *)
| HRight of hlam * Types.ty | HRight of hlam * Types.ty (* r (M : t) *)
| Ref of hlam ref | Ref of hlam ref
| Hole | Hole

70
main.ml
View File

@ -81,6 +81,7 @@ let check_via_coq (e : lam) (t : ty) : unit =
then "" then ""
else "intro. " ^ repeat_intro (n-1) else "intro. " ^ repeat_intro (n-1)
in in
(* build checker.v *)
let m = fill_ty_map StringMap.empty t in let m = fill_ty_map StringMap.empty t in
let (ty_vars, intro_n) = intro_of_ty m in let (ty_vars, intro_n) = intro_of_ty m in
let goal_ty = string_of_ty t in let goal_ty = string_of_ty t in
@ -120,40 +121,45 @@ let rec interactive (get_instr : unit -> instr) (sl : (interactive_state) list)
try try
match get_instr () with match get_instr () with
Cmd c -> begin match c with Cmd c ->
Goal ty -> begin match c with
let rh = Ref (ref Hole) in Goal ty ->
[Some (rh, ty), (Some (rh, ty, []), [])] |> interactive get_instr let rh = Ref (ref Hole) in
| Undo -> interactive get_instr sq [Some (rh, ty), (Some (rh, ty, []), [])] |> interactive get_instr
| Qed -> begin match cg with | Undo -> interactive get_instr sq
None -> | Qed -> begin match cg with
print_error "No current goal" ""; None ->
print_error "No current goal" "";
(cg, (g, gs))::sq |> interactive get_instr
| Some (h, t) ->
let l = lam_of_hlam h
|> beta_reduce in
(* uncaught Could_not_infer but won't happened
because exact only allow typable terms *)
if Typing.typecheck [] l t then begin
print_string "Ok";
(cg, (g, gs))::sq |> interactive get_instr
end else begin
print_error "Typing failed" "";
print_expr l;
print_newline ();
print_ty t;
(cg, (g, gs))::sq |> interactive get_instr (cg, (g, gs))::sq |> interactive get_instr
| Some (h, t) ->
let l = lam_of_hlam h
|> beta_reduce in
if Typing.typecheck [] l t then begin
print_string "Ok";
(cg, (g, gs))::sq |> interactive get_instr
end else begin
print_error "Typing failed" "";
print_expr l;
print_newline ();
print_ty t;
(cg, (g, gs))::sq |> interactive get_instr
end
end end
| Check -> begin match cg with end
None -> | Check -> begin match cg with
print_error "No current goal" ""; (* !! Doesn't work with terms containing exfalso
(cg, (g, gs))::sq |> interactive get_instr and Left / Right !! *)
| Some (h, t) -> None ->
begin try print_error "No current goal" "";
let l = lam_of_hlam h in (cg, (g, gs))::sq |> interactive get_instr
check_via_coq l t | Some (h, t) ->
with _ -> print_error "Proof is not over" ""; begin try
end; let l = lam_of_hlam h in
(cg, (g, gs))::sq |> interactive get_instr; check_via_coq l t
with _ -> print_error "Proof is not over" "";
end;
(cg, (g, gs))::sq |> interactive get_instr;
end end
end end
| Tact t -> | Tact t ->

199
proof.ml
View File

@ -1,6 +1,6 @@
open Hlam open Hlam
open Lam open Lam
open Types open Types
type context = (id * id * hlam * Types.ty) list type context = (id * id * hlam * Types.ty) list
type goal = hlam * Types.ty * context type goal = hlam * Types.ty * context
@ -40,19 +40,16 @@ let clean_proof ((g, gs) : proof) : (hlam ref * hlam ref) list ref * proof =
| None -> None | None -> None
in assoc, (g', List.map (clean_goal assoc) gs) in assoc, (g', List.map (clean_goal assoc) gs)
let goal_is_over ((g, _) : proof) : bool = (* typecheck e t cs types e against t in the typing environment defined
match g with by cs *)
None -> true
| Some _ -> false
let typecheck (e : lam) (expected_t : Types.ty) (cs : context) : bool = let typecheck (e : lam) (expected_t : Types.ty) (cs : context) : bool =
let gam_of_ctx : context -> Types.gam = let gam_of_ctx : context -> Types.gam =
let f = fun (_, var_id, _, ty) -> (var_id, ty) in (fun (_, var_id, _, ty) -> (var_id, ty)) |>
List.map f List.map
in in
let g = gam_of_ctx cs in let g = gam_of_ctx cs in
try Typing.typecheck g e expected_t try Typing.typecheck g e expected_t
with _ -> raise (TacticFailed "unable to type") with Typing.Could_not_infer -> raise (TacticFailed "couldn't not infer all variable types")
let rec get_term_by_id (hyp : id) : context -> hlam option = let rec get_term_by_id (hyp : id) : context -> hlam option =
function function
@ -71,77 +68,78 @@ let next_goal (gs : goal list) : (goal option * goal list) =
[] -> None, [] [] -> None, []
| g :: gs -> Some g, gs | g :: gs -> Some g, gs
let tact_exact_term ((g, gs) : proof) (e : lam) : proof = let get_goal : goal option -> hlam * ty * context =
match g with function
None -> raise (TacticFailed "no current goal") None -> raise (TacticFailed "no current goal")
| Some (h, expected_t, cs) -> | Some g -> g
if typecheck e expected_t cs
let tact_exact_term ((g, gs) : proof) (e : lam) : proof =
let (h, expected_t, cs) = get_goal g in
if typecheck e expected_t cs
then
begin
fill h (hlam_of_lam e);
next_goal gs
end
else raise (TacticFailed "type mismatch")
let tact_exact_proof ((g, gs) : proof) (hyp : id) : proof =
let (h, expected_t, cs) = get_goal g in
match get_term_by_id hyp cs with
Some h' ->
if typecheck (lam_of_hlam h') expected_t cs
then then
begin begin
fill h (hlam_of_lam e); fill h h';
next_goal gs next_goal gs
end end
else raise (TacticFailed "type mismatch") else raise (TacticFailed "type mismatch")
| None -> raise (TacticFailed "")
let tact_exact_proof ((g, gs) : proof) (hyp : id) : proof =
match g with
None -> raise (TacticFailed "no current goal")
| Some (h, expected_t, cs) ->
match get_term_by_id hyp cs with
Some h' ->
if typecheck (lam_of_hlam h') expected_t cs
then
begin
fill h h';
next_goal gs
end
else raise (TacticFailed "type mismatch")
| None -> raise (TacticFailed "")
let tact_assumption ((g, gs) : proof) : proof = let tact_assumption ((g, gs) : proof) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") match get_term_by_type goal_ty cs with
| Some (h, goal_ty, cs) -> None -> raise (TacticFailed "no such hypothesis")
match get_term_by_type goal_ty cs with | Some h' ->
None -> (* failwith "assumption failed" *) (g, gs) fill h h';
| Some h' -> next_goal gs
fill h h';
next_goal gs
let tact_intro ((g, gs) : proof) : proof = let tact_intro ((g, gs) : proof) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") match goal_ty with
| Some (h, goal_ty, cs) -> Arr (t1, t2) ->
match goal_ty with let (hyp_id, var_id) = get_fresh_hyp () in
Arr (t1, t2) -> let cs = (hyp_id, var_id, HVar var_id, t1) :: cs in
let (hyp_id, var_id) = get_fresh_hyp () in let new_h = Ref (ref Hole) in
let cs = (hyp_id, var_id, HVar var_id, t1) :: cs in fill h (HFun ((var_id, t1), new_h));
let new_h = Ref (ref Hole) in Some (new_h, t2, cs), gs
fill h (HFun ((var_id, t1), new_h)); | _ -> raise (TacticFailed "expected an implication")
Some (new_h, t2, cs), gs
| _ -> (* failwith "expected function" *) (* (g, gs) *)
raise (TacticFailed "expected function")
let tact_cut ((g, gs) : proof) (new_t : Types.ty) : proof = let tact_cut ((g, gs) : proof) (new_t : Types.ty) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") (* subgoal 2 : new_t -> goal_ty *)
| Some (h, goal_ty, cs) -> let arrow_h = Ref (ref Hole) in
(* subgoal 2 : new_t -> goal_ty *) let arrow_goal = (arrow_h, Arr (new_t, goal_ty), cs) in
let arrow_h = Ref (ref Hole) in let gs = arrow_goal :: gs in
let arrow_goal = (arrow_h, Arr (new_t, goal_ty), cs) in (* subgoal 1 (main goal) : new_t *)
let gs = arrow_goal :: gs in let new_h = Ref (ref Hole) in
(* subgoal 1 (main goal) : new_t *) fill h (HApp (arrow_h, new_h));
let new_h = Ref (ref Hole) in Some (new_h, new_t, cs), gs
fill h (HApp (arrow_h, new_h));
Some (new_h, new_t, cs), gs
let tact_apply ((g, gs) : proof) (hyp_id : id) : proof = let tact_apply ((g, gs) : proof) (hyp_id : id) : proof =
(* check if hypothesis suits apply *)
let rec is_implied (goal_ty : ty) (t : ty) : bool = let rec is_implied (goal_ty : ty) (t : ty) : bool =
match t with match t with
t when t = goal_ty -> true t when t = goal_ty -> true
| Arr (_, t2) -> is_implied goal_ty t2 | Arr (_, t2) -> is_implied goal_ty t2
| _ -> false | _ -> false
in in
(* supposes is_implied goal_ty impl_ty
goal_ty : conclusion of the implication
impl_ty : type of the implication
impl_h : building the term we will apply to goal_h
goal_h : hole of the current goal
h : current hole of impl_h*)
let rec generate_goals (goal_ty : ty) (impl_ty : ty) (impl_h : hlam) let rec generate_goals (goal_ty : ty) (impl_ty : ty) (impl_h : hlam)
(goal_h : hlam) (h : hlam) (cs : context) (gs : goal list) : proof = (goal_h : hlam) (h : hlam) (cs : context) (gs : goal list) : proof =
match impl_ty with match impl_ty with
@ -151,12 +149,15 @@ let tact_apply ((g, gs) : proof) (hyp_id : id) : proof =
let _ = fill goal_h impl_h in let _ = fill goal_h impl_h in
Some (sub_h, t1, cs), gs Some (sub_h, t1, cs), gs
| Arr (t1, t2) -> | Arr (t1, t2) ->
let sub_h = Ref (ref Hole) in (* transforms impl_h from ((f ?x_0) ?) to (((f ?x_0) ?x_1) ?)
let new_h = Ref (ref Hole) in where ? is h and ?x_i are holes associated with
the proof of x_i*)
let sub_h = Ref (ref Hole) in (* proof of t1 *)
let new_h = Ref (ref Hole) in (* proof of t2 *)
let _ = fill h sub_h in let _ = fill h sub_h in
let impl_h = HApp (impl_h, new_h) in let impl_h = HApp (impl_h, new_h) in
let gs = (sub_h, t1, cs) :: gs in let gs = (sub_h, t1, cs) :: gs in (* add the proof of t1 to goals *)
generate_goals goal_ty t2 impl_h goal_h new_h cs gs generate_goals goal_ty t2 impl_h goal_h new_h cs gs (* generate_goals for the proof of t2 *)
| _ -> failwith "impossible" | _ -> failwith "impossible"
in in
let rec get_hyp : context -> (hlam * ty) = function let rec get_hyp : context -> (hlam * ty) = function
@ -164,15 +165,13 @@ let tact_apply ((g, gs) : proof) (hyp_id : id) : proof =
| (hyp_id', _, h', t') :: _ when hyp_id = hyp_id' -> (h', t') | (hyp_id', _, h', t') :: _ when hyp_id = hyp_id' -> (h', t')
| _ :: cs -> get_hyp cs | _ :: cs -> get_hyp cs
in in
match g with let (goal_h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") let impl_h, impl_ty = get_hyp cs in
| Some (goal_h, goal_ty, cs) -> let new_h = Ref (ref Hole) in
let impl_h, impl_ty = get_hyp cs in let impl_h_2 = HApp (impl_h, new_h) in
let new_h = Ref (ref Hole) in if is_implied goal_ty impl_ty
let impl_h_2 = HApp (impl_h, new_h) in then generate_goals goal_ty impl_ty impl_h_2 goal_h new_h cs gs
if is_implied goal_ty impl_ty else raise (TacticFailed "not an implication")
then generate_goals goal_ty impl_ty impl_h_2 goal_h new_h cs gs
else raise (TacticFailed "not an implication")
let tact_intros : proof -> proof = let tact_intros : proof -> proof =
let rec push (p : proof) = let rec push (p : proof) =
@ -183,39 +182,33 @@ let tact_intros : proof -> proof =
in push in push
let tact_split ((g, gs) : proof) : proof = let tact_split ((g, gs) : proof) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") match goal_ty with
| Some (h, goal_ty, cs) -> | And(t1, t2) ->
match goal_ty with let h1 = Ref (ref Hole) in
| And(t1, t2) -> let h2 = Ref (ref Hole) in
let h1 = Ref (ref Hole) in fill h (HPair (h1, h2));
let h2 = Ref (ref Hole) in Some (h1, t1, cs), (h2, t2, cs)::gs
fill h (HPair (h1, h2)); | _ -> raise (TacticFailed "Not a conjonction")
Some (h1, t1, cs), (h2, t2, cs)::gs
| _ -> raise (TacticFailed "Not a conjonction")
let tact_right ((g, gs) : proof) : proof = let tact_right ((g, gs) : proof) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") match goal_ty with
| Some (h, goal_ty, cs) -> | Or(_, t_r) as t ->
match goal_ty with let new_h = Ref (ref Hole) in
| Or(_, t_r) as t -> fill h (HRight (new_h, t));
let new_h = Ref (ref Hole) in Some (new_h, t_r, cs), gs
fill h (HRight (new_h, t)); | _ -> raise (TacticFailed "Not a disjunction")
Some (new_h, t_r, cs), gs
| _ -> raise (TacticFailed "Not a disjunction")
let tact_left ((g, gs) : proof) : proof = let tact_left ((g, gs) : proof) : proof =
match g with let (h, goal_ty, cs) = get_goal g in
None -> raise (TacticFailed "no current goal") match goal_ty with
| Some (h, goal_ty, cs) -> | Or(t_l, _) as t->
match goal_ty with let new_h = Ref (ref Hole) in
| Or(t_l, _) as t-> fill h (HLeft (new_h, t));
let new_h = Ref (ref Hole) in Some (new_h, t_l, cs), gs
fill h (HLeft (new_h, t)); | _ -> raise (TacticFailed "Not a disjunction")
Some (new_h, t_l, cs), gs
| _ -> raise (TacticFailed "Not a disjunction")
let rec apply_tactic (p : proof) (t : tactic) : proof = let rec apply_tactic (p : proof) (t : tactic) : proof =
match t with match t with
@ -231,7 +224,3 @@ let rec apply_tactic (p : proof) (t : tactic) : proof =
| TLeft -> tact_left p | TLeft -> tact_left p
| TTry t -> try apply_tactic p t with TacticFailed _ -> p | TTry t -> try apply_tactic p t with TacticFailed _ -> p
let tact_try (p : proof) (t : tactic) : proof =
try apply_tactic p t
with TacticFailed _ -> p

1
tests/alpha_equiv/free_var_1.lam Normal file
View File

@ -0,0 +1 @@
x & x

1
tests/alpha_equiv/free_var_2.lam Normal file
View File

@ -0,0 +1 @@
x & y

1
tests/alpha_equiv/free_var_3.lam Normal file
View File

@ -0,0 +1 @@
x (fun (y : A) => y) & x (fun (z : A) => z)

1
tests/alpha_equiv/not_same_but_same_order.lam Normal file
View File

@ -0,0 +1 @@
(fun (x : A) => fun (y : B) => x y) & (fun (x : A) => fun (y : B) => y x)

1
tests/alpha_equiv/not_same_free.lam Normal file
View File

@ -0,0 +1 @@
(fun (x : A) => z) & (fun (z : A) => z)

1
tests/alpha_equiv/same_but_different_order.lam Normal file
View File

@ -0,0 +1 @@
(fun (x : A) => fun (y : B) => x y) & (fun (y : A) => fun (x : B) => y x)

1
tests/alpha_equiv/same_free.lam Normal file
View File

@ -0,0 +1 @@
(fun (x : A) => z) & (fun (y : A) => z)

1
tests/alpha_equiv/same_term_but_not_same_type.lam Normal file
View File

@ -0,0 +1 @@
(fun (x : A) => z) & (fun (y : B) => z)

1
tests/free_or_not.lam Normal file
View File

@ -0,0 +1 @@
(fun (z : A) => (fun (x : A) => z)) (fun (y : A) => z)