├── docs
├── .nojekyll
├── _sidebar.md
├── definitions.md
├── anon.md
├── alg.md
├── index.html
├── indrelprop.md
├── pm.md
├── ho.md
├── hoeq.md
├── fix.md
├── mono.md
├── README.md
├── gen.md
└── decide.md
├── LICENSE
├── .gitattributes
├── .gitignore
├── theories
├── reflexivity.v
├── unfold_reflexivity.v
├── unfold_in.v
├── Transfos.v
├── fold_local_def.v
├── add_compdecs.v
├── anonymous_functions.v
├── refinement_elimination_elpi.v
├── pattern_matching_goal.v
├── higher_order.v
├── deciderel
│ ├── add_hypothesis_on_parameters.v
│ └── examples.v
├── expand.v
├── subterms.v
├── verit.v
├── tree.v
├── instantiate_type.v
├── case_analysis_existentials.v
├── refinement_elimination.v
└── elimination_pattern_matching.v
├── AUTHORS
├── examples
├── example_ho.v
└── examples.v
├── Makefile.local
├── _CoqProject
├── orchestrator
├── filters.v
├── simpleordo.v
├── run_tactic.v
├── printer.v
├── tests
│ └── tests.v
├── Sniper.v
├── triggers_tactics.v
└── orchestrator.v
├── .github
└── workflows
│ └── metacoq.yml
├── coq-sniper.opam
├── README.md
├── elpi
├── subterms.elpi
├── higher_order.elpi
├── ref_elim_utils.elpi
├── eliminate_fix.elpi
└── utilities.elpi
└── tests
└── tests.v
/docs/.nojekyll:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/smtcoq/sniper/HEAD/LICENSE
--------------------------------------------------------------------------------
/.gitattributes:
--------------------------------------------------------------------------------
1 | *.elpi linguist-language=prolog
2 | Makefile linguist-detectable=false
3 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *.d
2 | .*.aux
3 | *.vo
4 | *.vok
5 | *.vos
6 | *.glob
7 | .lia.cache
8 | Makefile.conf
9 | *~
10 |
--------------------------------------------------------------------------------
/theories/reflexivity.v:
--------------------------------------------------------------------------------
1 |
2 | Ltac assert_refl c :=
3 | let H := fresh in assert (H : c = c) by reflexivity.
4 |
5 | Goal False.
6 | assert_refl nat.
7 | assert_refl Nat.add.
8 | Abort.
--------------------------------------------------------------------------------
/AUTHORS:
--------------------------------------------------------------------------------
1 | Authors:
2 | Valentin Blot
3 | Louise Dubois de Prisque
4 | Chantal Keller
5 | Pierre Vial
6 | Tomaz Mascarenhas
7 |
8 | Institutes:
9 | Inria
10 | Université Paris-Saclay
11 | CNRS
12 |
13 | This work is funded by a Nomadic Labs-Inria collaboration.
14 |
--------------------------------------------------------------------------------
/theories/unfold_reflexivity.v:
--------------------------------------------------------------------------------
1 |
2 | Ltac unfold_refl H :=
3 | let T := type of H in
4 | match T with
5 | | ?x = ?x => try unfold x at 2 in H
6 | | _ => idtac
7 | end.
8 |
9 | Goal False.
10 | assert (H : length = length) by reflexivity.
11 | unfold_refl H.
12 | Abort.
--------------------------------------------------------------------------------
/theories/unfold_in.v:
--------------------------------------------------------------------------------
1 | Require List.
2 |
3 | Ltac unfold_in H t :=
4 | try unfold t in H.
5 |
6 | Section Tests.
7 | Variable (A B : Type).
8 | Variable (f : A -> B).
9 |
10 | Goal False.
11 | pose (mapf := List.map f).
12 | assert (H : mapf = List.map f) by reflexivity.
13 | unfold_in H List.map.
14 | Abort.
15 |
16 | End Tests.
--------------------------------------------------------------------------------
/docs/_sidebar.md:
--------------------------------------------------------------------------------
1 | * [Presentation](/)
2 | * [Definitions](definitions.md)
3 | * [Higher Order Equalities](hoeq.md)
4 | * [Elimination of Anonymous Fixpoints](fix.md)
5 | * [Pattern Matching](pm.md)
6 | * [Algebraic Datatypes](alg.md)
7 | * [Generation Principle](gen.md)
8 | * [Monomorphization](mono.md)
9 | * [Anonymous Functions](anon.md)
10 | * [Prenex Higher Order](ho.md)
11 | * [Inductive Relations in Prop](indrelprop.md)
12 | * [Decision of Inductive Relations](decide.md)
--------------------------------------------------------------------------------
/examples/example_ho.v:
--------------------------------------------------------------------------------
1 | From SMTCoq Require Import SMTCoq.
2 | From Sniper.orchestrator Require Import Sniper.
3 | From Sniper Require Import tree.
4 | From Sniper Require Import Transfos.
5 | Require Import String.
6 | Require Import ZArith.
7 | Require Import Bool.
8 | Require Import Coq.Lists.List.
9 | Import ListNotations.
10 |
11 |
12 | Section higher_order.
13 |
14 | Variable A B C: Type.
15 | Variable HA : CompDec A.
16 | Variable HB : CompDec B.
17 | Variable HC : CompDec C.
18 |
19 | Lemma map_compound : forall (f : A -> B) (g : B -> C) (l : list A),
20 | map g (map f l) = map (fun x => g (f x)) l.
21 | Proof.
22 | induction l; time scope_info. Admitted.
23 |
24 | End higher_order.
--------------------------------------------------------------------------------
/theories/Transfos.v:
--------------------------------------------------------------------------------
1 | From Trakt Require Export Trakt.
2 | From SMTCoq Require Export SMTCoq.
3 |
4 | Require Export indrel.
5 | Require Export reflexivity.
6 | Require Export unfold_reflexivity.
7 | Require Export unfold_in.
8 | Require Export expand.
9 | Require Export elimination_fixpoints.
10 | Require Export instantiate_type.
11 | Require Export elimination_pattern_matching.
12 | Require Export instantiate_state.
13 | Require Export interpretation_algebraic_types.
14 | Require Export case_analysis.
15 | Require Export case_analysis_existentials.
16 | Require Export higher_order.
17 | Require Export fold_local_def.
18 | Require Export anonymous_functions.
19 | Require Export add_compdecs.
20 | Require Export pattern_matching_goal.
21 | Require Export refinement_elimination.
22 |
--------------------------------------------------------------------------------
/Makefile.local:
--------------------------------------------------------------------------------
1 | examples: examples/examples.v
2 | $(SHOW)COQC $<
3 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA)
4 |
5 | tests: tests/tests.v
6 | $(SHOW)COQC $<
7 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA)
8 |
9 | tests_triggers: orchestrator/tests/tests.v
10 | $(SHOW)COQC $<
11 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA)
12 |
13 | test: examples tests tests_triggers
14 |
15 | clean::
16 | rm -f examples/examples.glob examples/examples.vo examples/examples.vok examples/examples.vos tests/tests.glob tests/tests.vo tests/tests.vok tests/tests.vos benchs/*.glob benchs/*.vo benchs/*.vok benchs/*.vos
17 |
18 | .PHONY: examples tests
19 |
--------------------------------------------------------------------------------
/theories/fold_local_def.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2.
2 |
3 | Ltac2 fold_local_def (c : constr) :=
4 | let hs := Control.hyps () in
5 | try (fold $c) ;
6 | let rec aux hs :=
7 | match hs with
8 | | (id, _, _) :: hs' =>
9 | try (fold $c in $id) ; aux hs'
10 | | [] => ()
11 | end
12 | in aux hs.
13 |
14 | Tactic Notation "fold_local_def" constr(t) :=
15 | let tac :=
16 | ltac2:(t |- let t := Ltac1.to_constr t in let t := Option.get t in fold_local_def t)
17 | in tac t.
18 |
19 | Ltac fold_local_def_in_hyp_goal H t :=
20 | try (fold t in H); fold t.
21 |
22 | Set Default Proof Mode "Classic".
23 | Section tests.
24 |
25 | Goal (let x := True in True -> True -> False -> True).
26 | intros.
27 | fold_local_def x. (* Undo. fold_local_def_in_hyp H x. *)
28 | Abort.
29 |
30 | End tests.
--------------------------------------------------------------------------------
/theories/add_compdecs.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2.
2 | From SMTCoq Require SMT_classes SMT_classes_instances.
3 | Require Import ZArith.
4 |
5 | (** Add compdecs is an atomic transformation not related to Trakt *)
6 |
7 | Ltac add_compdecs_terms t :=
8 | let T := type of t in
9 | first [ first [constr_eq T Type | constr_eq T Set] ;
10 | match goal with
11 | (* If it is already in the local context, do nothing *)
12 | | _ : SMT_classes.CompDec t |- _ => idtac
13 | (* Otherwise, add it in the local context *)
14 | | _ =>
15 | let p := fresh "p" in
16 | assert (p:SMT_classes.CompDec t);
17 | [ try (exact _) (* Use the typeclass machinery *)
18 | | .. ]
19 | end | idtac].
20 |
21 | Goal (forall (A: Type) (l : list A), False).
22 | intros. ltac1:(add_compdecs_terms A). Abort.
23 |
--------------------------------------------------------------------------------
/docs/definitions.md:
--------------------------------------------------------------------------------
1 | # Definitions
2 |
3 | This transformation is available in the file `theories/definitions.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation, at an atomic level, is called `get_def` and takes as an argument a Coq constant `c`.
8 | By delta-reduction, `c` is convertible to its definition `c_def`.
9 | Thus, `get_def c` asserts and proves the propositional equality `H: c = c_def` in the Coq proof context.
10 |
11 | ## An example
12 |
13 | ```
14 | Goal False.
15 |
16 | (* 1 goal
17 | ______________________________________(1/1)
18 | False *)
19 |
20 | get_def List.app.
21 |
22 | (* 1 goal
23 | app_def : app =
24 | (fun A : Type =>
25 | fix app (l m : list A) {struct l} : list A :=
26 | match l with
27 | | nil => m
28 | | a :: l1 => a :: app l1 m
29 | end)
30 | ______________________________________(1/1)
31 | False *)
32 |
33 | ```
--------------------------------------------------------------------------------
/theories/anonymous_functions.v:
--------------------------------------------------------------------------------
1 | Require Import utilities.
2 | Require Import List.
3 | From Ltac2 Require Import Ltac2.
4 |
5 | Ltac anonymous_fun f_body :=
6 | let f' := fresh "f" in pose (f' := f_body);
7 | try fold f';
8 | let tac :=
9 | ltac2:(f' |-
10 | let hs := Control.hyps () in
11 | List.iter (fun (x, _, _) =>
12 | ltac1:(f' x |- try (fold f' in x)) f' (Ltac1.of_ident x)) hs)
13 | in tac f'.
14 |
15 | Section tests.
16 |
17 | Set Default Proof Mode "Classic".
18 |
19 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C),
20 | map g (map f l) = map (fun x => g (f x)) l.
21 | intros.
22 | assert (H : (fun x => x + 1) 42 = 43) by reflexivity.
23 | anonymous_fun (fun x : nat => x + 1).
24 | anonymous_fun (fun x : A => g (f x)).
25 | Abort.
26 |
27 | Goal (forall (A: Type) (n : nat) (l : list A) (x : A),
28 | (fun (n : nat) (l : list A) (default : A) => nth n l default) n l x = x ->
29 | (n >= (fun (l : list A) => length l) l)).
30 | Proof. intros.
31 | anonymous_fun (fun (A: Type) (n: nat) (l : list A) (d : A) =>
32 | nth n l d).
33 | anonymous_fun (fun l0 : list A => length l0). Abort.
34 |
35 | End tests.
36 |
37 |
38 |
--------------------------------------------------------------------------------
/docs/anon.md:
--------------------------------------------------------------------------------
1 | # Anonymous functions
2 |
3 | This transformation is defined in the file `theories/anonymous_functions.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation takes all the anonymous functions in the local context
8 | of the form `fun (x: T) => ...`, creates a definition `f := fun (x: T) => ...`
9 | and folds the definition of `f`. It also proves and adds the propositional
10 | equality `f = fun (x: T) => ...` in the local context.
11 |
12 | Note that branches in pattern matching are anonymous functions
13 | that you may want to deal with differently, so the transformation avoids them.
14 |
15 | ## An example
16 |
17 | ```
18 | 1 goal
19 | A : Type
20 | B : Type
21 | C : Type
22 | l : list A
23 | f : A -> B
24 | g : B -> C
25 | H : (fun x : nat => x + 1) 42 = 43
26 | ______________________________________(1/1)
27 | map g (map f l) = map (fun x : A => g (f x)) l
28 |
29 | anonymous_funs.
30 |
31 | 1 goal
32 | A : Type
33 | B : Type
34 | C : Type
35 | l : list A
36 | f : A -> B
37 | g : B -> C
38 | f0 := fun x : A => g (f x) : A -> C
39 | H : (fun x : nat => x + 1) 42 = 43
40 | H0 : f0 = (fun x : A => g (f x))
41 | ______________________________________(1/1)
42 | map g (map f l) = map f0 l
43 | ```
44 |
45 |
--------------------------------------------------------------------------------
/_CoqProject:
--------------------------------------------------------------------------------
1 | # -R ./orchestrator Sniper.orchestrator
2 | -R . Sniper
3 | # -Q ./elpi Sniper.elpi
4 | -docroot Sniper
5 |
6 | orchestrator/triggers.v
7 | orchestrator/filters.v
8 | orchestrator/triggers_tactics.v
9 | orchestrator/run_tactic.v
10 | orchestrator/printer.v
11 | orchestrator/orchestrator.v
12 | orchestrator/Sniper.v
13 |
14 | theories/utilities.v
15 | theories/indrel.v
16 | theories/reflexivity.v
17 | theories/unfold_reflexivity.v
18 | theories/unfold_in.v
19 | theories/expand.v
20 | theories/fold_local_def.v
21 | theories/elimination_fixpoints.v
22 | theories/elimination_pattern_matching.v
23 | theories/pattern_matching_goal.v
24 | theories/anonymous_functions.v
25 | theories/higher_order.v
26 | theories/instantiate_type.v
27 | theories/instantiate_state.v
28 | theories/interpretation_algebraic_types.v
29 | theories/case_analysis.v
30 | theories/case_analysis_existentials.v
31 | theories/tree.v
32 | theories/add_compdecs.v
33 | theories/verit.v
34 | theories/Transfos.v
35 | theories/refinement_elimination.v
36 | theories/refinement_elimination_elpi.v
37 |
38 | theories/deciderel/add_hypothesis_on_parameters.v
39 | theories/deciderel/compdec_plugin.v
40 | theories/deciderel/linearize_plugin.v
41 | theories/deciderel/generate_fix.v
42 | theories/deciderel/proof_correctness.v
43 |
--------------------------------------------------------------------------------
/orchestrator/filters.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2 Init.
2 |
3 | (** A filter is useful to block the application of a transformation
4 | even if the transformation is triggered *)
5 |
6 | Ltac2 Type rec filter := [
7 | | FConstr (constr list)
8 | | FConstrList (constr list list)
9 | | FPredList (constr list -> bool)
10 | | FConj (filter, filter)
11 | | FTrivial ].
12 |
13 | Ltac2 fPred p := FPredList (List.exist p).
14 |
15 | Ltac2 Notation "FPred" p(tactic) := fPred p.
16 |
17 | Ltac2 trivial_filter := FTrivial.
18 |
19 | Ltac2 Type exn ::= [ WrongArgNumber(string) ].
20 |
21 | (** [l] is the list of arguments of the tactic (returned by the interpretation
22 | of the trigger
23 | and f is the filter applied to them *)
24 |
25 | Ltac2 rec pass_the_filter
26 | (l : constr list)
27 | (f : filter) : bool :=
28 | match f with
29 | | FConstr lc =>
30 | match l with
31 | | [] => true
32 | | x :: xs => if List.exist (Constr.equal x) lc then false else pass_the_filter xs f
33 | end
34 | | FConstrList lc => if List.exist (List.equal Constr.equal l) lc then false else true
35 | | FPredList p => if p l then false else true
36 | | FConj f1 f2 => Bool.and (pass_the_filter l f1) (pass_the_filter l f2)
37 | | FTrivial => true
38 | end.
--------------------------------------------------------------------------------
/orchestrator/simpleordo.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Init Message Int Bool.
2 |
3 | (* Ref.v *)
4 | Ltac2 Type 'a ref := 'a Init.ref.
5 |
6 | Ltac2 ref (v : 'a) : 'a ref := { contents := v}.
7 | Ltac2 get (r : 'a ref) : 'a := r.(contents).
8 | Ltac2 set (r : 'a ref) (v : 'a) : unit := r.(contents) := v.
9 |
10 | Ltac2 update (r : 'a ref) (f : 'a -> 'a) : unit :=
11 | r.(contents) := f (r.(contents)).
12 |
13 |
14 | (* Ça commence ici *)
15 | Ltac2 Type refs := [ .. ].
16 |
17 | Ltac2 Type refs ::= [ IR (int ref) ].
18 | Ltac2 bar r :=
19 | match r with
20 | | IR r =>
21 | set r (Int.add (get r) 1);
22 | ltac1:(idtac "youpi");
23 | set r (Int.add (get r) 1);
24 | print (of_int (get r))
25 | | _ => ltac1:(idtac "pas la bonne réf")
26 | end.
27 | Ltac2 initbar () : refs := IR (ref 3).
28 |
29 | Ltac2 Type refs ::= [ BR (bool ref) ].
30 | Ltac2 foo r :=
31 | match r with
32 | | BR b =>
33 | set b (Bool.neg (get b));
34 | print (of_string (if (get b) then "true" else "false"))
35 | | _ => ltac1:(idtac "pas la bonne réf")
36 | end.
37 | Ltac2 initfoo () : refs := BR (ref true).
38 |
39 | Ltac2 rec ordoSimplet transfos :=
40 | match transfos with
41 | | [] => ltac1:(idtac "finito pipo !")
42 | | (t, i)::transfos' =>
43 | let r := i () in
44 | t r;
45 | ordoSimplet transfos'
46 | end.
47 |
48 | Ltac2 transfos := [ (bar, initbar); (foo, initfoo) ].
49 | Ltac2 Eval (ordoSimplet transfos).
--------------------------------------------------------------------------------
/docs/alg.md:
--------------------------------------------------------------------------------
1 | # Algebraic Datatypes
2 |
3 | The corresponding `Coq` file is `/theories/interpretation_algebraic_types.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation, called `interp_alg_types`,
8 | takes as an argument an inductive type `I` (not applied to its eventual parameters).
9 | It will fail if the inductive type is not an algebraic datatype
10 | (that is, a datatype which can be encoded as a combination of sum types and product types),
11 | or if the datatype is applied to some parameter.
12 | For instance, `interp_alg_types (list nat)` will fail (because of the parameter),
13 | `interp_alg_types list` will succeed, and `interp_alg_types True` will fail
14 | (because `True` is not an algebraic datatype).
15 |
16 | The transformation generates and proves in the local context:
17 |
18 | * The *non-confusion principle*: each constructor of `I` is disjoint
19 | * The *injectivity of constructors*: each constuctor of `I` is injective
20 |
21 | The *generation principle* is dealt with in two separated files for technical reasons (see [Generation Principle](gen.md)).
22 |
23 | The transformation is written in `MetaCoq` and each application is proved thanks to a `Ltac` proof script.
24 |
25 | ## An example
26 |
27 | The transformation `interp_alg_types list` will generate
28 | and prove:
29 |
30 | ```
31 | H1 : forall (A : Type) (x : A) (xs : list A),
32 | [] = x :: xs -> False
33 | H2 : forall (A : Type) (x x' : A) (xs xs' : list A),
34 | x :: xs = x' :: xs' -> x = x' /\ xs = xs'
35 | ```
--------------------------------------------------------------------------------
/docs/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | Document
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
30 |
31 |
32 |
33 |
34 |
35 |
36 |
--------------------------------------------------------------------------------
/docs/indrelprop.md:
--------------------------------------------------------------------------------
1 | # Inductive Relations in Prop
2 |
3 | This transformation is defined in the file `theories/indrel.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | It is designed for intuitionnistic external backend that may not have access to the definition of some inductive relation `I`
8 | (that is, an inductive whose codomain is $Prop$).
9 |
10 | This transformation has no use for `SMTCoq` but it can be useful for other backends (work in progress...).
11 |
12 | The transformation adds and proves the definition of the constructors of `I` and the inversion principle of `I`
13 | in the local context.
14 |
15 | ## An example
16 |
17 | Suppose that we have this inductive:
18 |
19 | ```
20 | Inductive Add {A : Type} (a : A) : list A -> list A -> Prop :=
21 | | Add_head : forall l : list A, Add a l (a :: l)
22 | | Add_cons : forall (x : A) (l l' : list A),
23 | Add a l l' -> Add a (x :: l) (x :: l').
24 | ```
25 |
26 | Then, running the tactic `inversion_principle @Add`
27 | will add these hypothesis in the local context:
28 |
29 | ```
30 | Add_head0 : forall (A : Type) (a : A) (l : list A),
31 | Add a l (a :: l)
32 | Add_cons0 : forall (A : Type) (a x : A) (l l' : list A),
33 | Add a l l' -> Add a (x :: l) (x :: l')
34 | Hinv : forall (A : Type) (a : A) (l l' : list A),
35 | Add a l l' <->
36 | (exists l'' : list A, l = l'' /\ l' = a :: l'') \/
37 | (exists (x : A) (l1 l2 : list A),
38 | Add a l1 l2 /\ l = x :: l1 /\ l' = x :: l2)
39 | ```
40 |
41 |
42 |
--------------------------------------------------------------------------------
/docs/pm.md:
--------------------------------------------------------------------------------
1 | # Elimination of pattern matching
2 |
3 | This transformation is available in the file `theories/elimination_pattern_matching.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation `eliminate_dependent_pattern_matching`, takes as argument a hypothesis `H` whose type
8 | is of the form :
9 | ```Coq
10 | forall (x1: A1) ... (xn: An),
11 | C[match f xi1 ... xin with
12 | | c1 y11 ... y1j => g1 y11 ... y1j
13 | ...
14 | | ck yk1 ... ykj => gk yk1 ... ykj
15 | ...
16 | | cm ym1 ... ymj => gm ym1 ... ymj
17 | ]
18 | ```
19 |
20 | where `C[_]` is a context.
21 |
22 | The term `f xi1 ... xin` should be an inductive, of constructors `c1 ... cm`.
23 |
24 | For each branch of the `match`, a new hypothesis `Hk` is created:
25 |
26 | ```
27 | Hk: forall x1 ... xn yk1 ... ykj, f xi1 ... xin = ck yk1 ... ykj ->
28 | C[gk yk1 ... ykj]
29 | ```
30 |
31 | There is a version of the transformation `elim_match_with_no_forall` which works on hypotheses where the
32 | `match` construction is not under any universal quantification.
33 |
34 | ## An example
35 |
36 | ```
37 | H : forall (A : Type) (l : list A),
38 | length l =
39 | match l with
40 | | [] => 0
41 | | _ :: l' => S (length l')
42 | end
43 | ______________________________________(1/1)
44 | False
45 |
46 | eliminate_dependent_pattern_matching H.
47 |
48 | H1 : forall (A : Type), length [] = 0
49 | H2 : forall (A : Type) (x : A) (xs : list A),
50 | length (x::xs) = S (length xs)
51 | ______________________________________(1/1)
52 | False
53 | ```
54 |
--------------------------------------------------------------------------------
/docs/ho.md:
--------------------------------------------------------------------------------
1 | # Prenex higher-order
2 |
3 | This transformation is defined in the file `theories/higher_order.v`
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation is a very simple encoding of some higher-order features, in order to avoid complex encodings when they are not needed. It works only when there are higher-order functions taking concrete functions as arguments.
8 |
9 | For any higher-order application `f g`, the transformation poses the definition `f_g := f g`
10 | and folds the definition of `f_g` in order to hide the higher-order feature.
11 |
12 | In addition, it adds and proves the propositionnal equality `f_g = f g` in the local context.
13 |
14 | ## An example
15 |
16 | ```
17 | 1 goal
18 | A : Type
19 | B : Type
20 | C : Type
21 | l : list A
22 | f : A -> B
23 | g : B -> C
24 | ______________________________________(1/1)
25 | map g (map f l) = map (fun x : A => g (f x)) l
26 |
27 | prenex_higher_order.
28 |
29 | 1 goal
30 | A : Type
31 | B : Type
32 | C : Type
33 | l : list A
34 | f : A -> B
35 | g : B -> C
36 | f0 := map g : list B -> list C
37 | f1 := map f : list A -> list B
38 | f2 := map (fun x : A => g (f x)) : list A -> list C
39 | H : f0 =
40 | (fix map (l : list B) : list C :=
41 | match l with
42 | | [] => []
43 | | a :: t => g a :: map t
44 | end)
45 | H0 : f1 =
46 | (fix map (l : list A) : list B :=
47 | match l with
48 | | [] => []
49 | | a :: t => f a :: map t
50 | end)
51 | H1 : f2 =
52 | (fix map (l : list A) : list C :=
53 | match l with
54 | | [] => []
55 | | a :: t => g (f a) :: map t
56 | end)
57 | ______________________________________(1/1)
58 | f0 (f1 l) = f2 l
59 | ```
60 |
61 |
--------------------------------------------------------------------------------
/.github/workflows/metacoq.yml:
--------------------------------------------------------------------------------
1 | name: MetaCoq CI
2 |
3 | on:
4 | schedule:
5 | # Every week at sunday midnight
6 | - cron: '0 0 * * 0'
7 | # Enables manually running the workflow
8 | workflow_dispatch:
9 |
10 | permissions:
11 | contents: read
12 |
13 | jobs:
14 | build:
15 | runs-on: ubuntu-latest
16 |
17 | steps:
18 | - name: Checkout Metacoq Repository
19 | uses: actions/checkout@v3
20 | with:
21 | repository: metacoq/metacoq
22 | ref: main
23 | path: metacoq
24 |
25 | - name: Get Date of Last Commit
26 | id: get_last_commit_date
27 | run: |
28 | last_commit_date=$(cd metacoq && git log -1 --format=%cd --date=iso)
29 | echo "last_commit_date=$last_commit_date" >> $GITHUB_ENV
30 |
31 | - name: Check if Last Commit was Within Last Week
32 | id: check_commit_date
33 | run: |
34 | LAST_COMMIT_DATE=$(date -d "${{ env.last_commit_date }}" +%s)
35 | ONE_WEEK_AGO=$(date -d "1 week ago" +%s)
36 | if [ $LAST_COMMIT_DATE -gt $ONE_WEEK_AGO ]; then
37 | echo "recent_commit=true" >> $GITHUB_ENV
38 | else
39 | echo "recent_commit=false" >> $GITHUB_ENV
40 | fi
41 |
42 | - name: Checkout Sniper master
43 | if: env.recent_commit == 'true'
44 | uses: actions/checkout@v3
45 | with:
46 | ref: coq-master
47 |
48 | - name: Build Sniper
49 | if: env.recent_commit == 'true'
50 | uses: coq-community/docker-coq-action@v1
51 | with:
52 | coq_version: dev
53 | opam_file: 'coq-sniper.opam'
54 | custom_image: mattam82/metacoq:latest-coq-dev
55 | custom_script: |
56 | sudo chown -R coq:coq .
57 | opam update
58 | opam upgrade -y
59 | opam install . --deps-only -y
60 | make
61 |
--------------------------------------------------------------------------------
/orchestrator/run_tactic.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2.
2 | From Ltac2 Require Import Ltac1.
3 | From Ltac2 Require Import Constr.
4 | From Ltac2 Require Import String.
5 |
6 | (** We need to use a trick here: there
7 | is no function in Ltac2's API which returns
8 | a Ltac1 value given its ident. We always need the absolute path
9 | and we cannot look at several paths because the function [Ltac1.ref]
10 | throws an uncatchable exception whenever the path is not the good one.
11 | Consequently, all the Orchestrator's tactics should be in one file, or the user has to
12 | provide the absolute path herself, which is not convenient at all.
13 | Using elpi avoid these difficulties, even if the user needs
14 | to create its own copy of all the tactic which take arguments
15 | TODO : a PR in Coq to avoid this problem *)
16 |
17 | From elpi Require Import elpi.
18 |
19 | Elpi Tactic apply_ltac1.
20 | Elpi Accumulate lp:{{
21 |
22 | solve ((goal _ _ _ _ [str S| H]) as G) GS :-
23 | coq.ltac.call S H G GS.
24 |
25 | }}.
26 | Elpi Typecheck.
27 |
28 | Ltac2 get_opt o := match o with None => Control.throw Not_found | Some x => x end.
29 |
30 | (** [run] runs a Ltac1 tactic given its ident and its arguments (provided as a string) *)
31 |
32 | Ltac2 run (s : string) (l : constr list) :=
33 | let id := Ident.of_string s in
34 | let id := of_ident (get_opt id) in
35 | let l := of_list (List.map of_constr l) in
36 | Ltac1.apply ltac1val:(fun s l =>
37 | let id := s in elpi apply_ltac1 ltac_string:(id) ltac_term_list:(l)) [id; l] run.
38 |
39 | Section tests.
40 |
41 | (** For tests *)
42 | Ltac myapply2 A B := split ; [apply A | apply B].
43 | Ltac myexact t := exact t.
44 |
45 | Goal (True /\ True) /\ (True -> True -> True /\ True).
46 | Proof.
47 | run "split" [].
48 | let str := "split" in run str [].
49 | run "myexact" ['I].
50 | run "myexact" ['I].
51 | intros H1 H2.
52 | run "myapply2" ['H1; 'H2].
53 | Qed.
54 |
55 | End tests.
--------------------------------------------------------------------------------
/theories/refinement_elimination_elpi.v:
--------------------------------------------------------------------------------
1 | From elpi Require Import elpi.
2 |
3 | From Sniper.elpi Extra Dependency "ref_elim_utils.elpi" as ref_elim_utils.
4 |
5 | Elpi Tactic convert_sigless_tac.
6 |
7 | Elpi Accumulate File ref_elim_utils.
8 |
9 | Elpi Accumulate lp:{{
10 |
11 | solve (goal _ _ _ _ [str S, trm P] as G) GL :-
12 | !,
13 | coq.string->name S N,
14 | replace P P',
15 | refine (let N _ P' Tgt_) G GL.
16 |
17 | solve (goal _ _ _ _ [_, trm _]) _ :- coq.ltac.fail 0 "The first argument should be an identifier".
18 |
19 | solve (goal _ _ _ _ [_, _]) _ :- coq.ltac.fail 0 "The second argument should be a term".
20 |
21 | solve (goal _ _ _ _ _) _ :- coq.ltac.fail 0 "There should be exactly two arguments".
22 |
23 | }}.
24 | Elpi Typecheck.
25 |
26 | Elpi Tactic sig_expand_tac.
27 |
28 | Elpi Accumulate File ref_elim_utils.
29 |
30 | Elpi Accumulate lp:{{
31 |
32 | solve (goal _ _ _ _ [str S, trm P] as G) GL :-
33 | !,
34 | coq.string->name S N,
35 | smart_sig_expand P P',
36 | refine (let N _ P' Tgt_) G GL.
37 |
38 | solve (goal _ _ _ _ [_, trm _]) _ :- coq.ltac.fail 0 "The first argument should be an identifier".
39 |
40 | solve (goal _ _ _ _ [_, _]) _ :- coq.ltac.fail 0 "The second argument should be a term".
41 |
42 | solve (goal _ _ _ _ _) _ :- coq.ltac.fail 0 "There should be exactly two arguments".
43 |
44 | }}.
45 | Elpi Typecheck.
46 |
47 | Elpi Tactic sigfull_tac.
48 |
49 | Elpi Accumulate File ref_elim_utils.
50 |
51 | Elpi Accumulate lp:{{
52 |
53 | solve (goal _ _ _ _ [trm P]) _ :-
54 | sigfull P.
55 |
56 | solve (goal _ _ _ _ [trm _]) _ :-
57 | coq.ltac.fail 0 "The argument is not sigfull".
58 |
59 | solve (goal _ _ _ _ [_]) _ :-
60 | coq.ltac.fail 0 "The argument should be a term".
61 |
62 | solve (goal _ _ _ _ _) _ :-
63 | coq.ltac.fail 0 "There should be exactly 1 argument".
64 |
65 | }}.
66 | Elpi Typecheck.
67 |
--------------------------------------------------------------------------------
/theories/pattern_matching_goal.v:
--------------------------------------------------------------------------------
1 | Require Import ZArith.
2 |
3 | Ltac pose_case M :=
4 | let pat := fresh "pat" in
5 | let pf_refl := fresh "pf_refl" in
6 | pose (pat := M);
7 | assert (pf_refl : M = pat) by reflexivity;
8 | rewrite pf_refl;
9 | clearbody pat.
10 |
11 | Section Examples.
12 |
13 | Set Default Proof Mode "Classic".
14 |
15 | (* This did not work with fold (automatic reduction), but works with rewrite *)
16 | Goal match O with O => 42 | S _ => 41 end = 42.
17 | pose_case (match O with O => 42 | S _ => 41 end).
18 | reflexivity.
19 | Qed.
20 |
21 | (* pose_case does not work here (but regular scope works) -> we have to avoid lambdas? *)
22 | Goal forall x : nat , ((fun y => (match y with O => 42 | _ => 41 end)) x) = 41.
23 | intro x.
24 | Fail
25 | let m := constr:(match y with O => 42 | _ => 41 end) in
26 | pose_case m.
27 | Abort.
28 |
29 | (* This case was not covered before *)
30 | Goal forall (x : nat) (f g : nat -> nat) , ((match x with O => f | S _ => g end) 42 = 42).
31 | intros x f g.
32 | (* pose (m := match x with O => f | S _ => g end); assert (H : match x with O => f | S _ => g end = m) by reflexivity; rewrite H. *)
33 | pose_case (match x with O => f | S _ => g end).
34 | (* now one can do scope *)
35 | Abort.
36 |
37 | (* This one was already covered *)
38 | Goal forall y : nat , let x := match y with | O => 2 | S _ => 3 end in x = x.
39 | intro y.
40 | pose_case (match y with O => 2 | S _ => 3 end).
41 | Abort.
42 |
43 | (* veriT gets stuck here but z3 and cvc5 can solve it *)
44 | Goal forall (x : nat) , (match x with O => 3 | _ => 3 end) = 3.
45 | intro x.
46 | pose_case (match x with O => 3 | _ => 3 end).
47 | (* (* scope. *) *)
48 | (* (* verit. *) *)
49 | Abort.
50 |
51 | Goal forall y : nat , let x := (match y with | O => 2 | S _ => 3 end)%Z in x = x.
52 | intro y.
53 | pose_case (match y with O => 2%Z | S _ => 3%Z end).
54 | Abort.
55 |
56 | End Examples.
57 |
--------------------------------------------------------------------------------
/docs/hoeq.md:
--------------------------------------------------------------------------------
1 | # Elimination of higher-order equlities
2 |
3 | ## What does this transformation do?
4 |
5 | This transformation `expand_hyp`, takes as an argument a hypothesis `H` of
6 | type `f = g`, where `f` or `g` are functions taking `k` arguments.
7 | Suppose that `T1 ... Tk` are the types of these arguments.
8 |
9 | The tactic `expand_hyp` creates a new hypothesis `H'` starting from `H`:
10 | ```
11 | H': forall (x1: T1) ... (xk: Tk), f x1 ... xk = g x1 ... xk
12 | ```
13 |
14 | There is a version `expand_hyp_cont` taking an additional argument: a `Ltac` continuation,
15 | which can bind the produced hypothesis `H'`
16 |
17 | This transformation is written using `Ltac` and the [MetaCoq plugin](https://github.com/MetaCoq/metacoq).
18 | In particular, it uses `template-coq`, which is the metaprogramming tool for Coq written in Coq.
19 |
20 | ## An example
21 |
22 | ```
23 | Goal (forall (length_def :length =
24 | (fun A : Type =>
25 | fix length (l : list A) : nat :=
26 | match l with
27 | | [] => 0
28 | | _ :: l' => S (length l')
29 | end)) -> False). intros.
30 |
31 | 1 goal
32 | length_def : length =
33 | (fun A : Type =>
34 | fix length (l : list A) : nat :=
35 | match l with
36 | | [] => 0
37 | | _ :: l' => S (length l')
38 | end)
39 | ______________________________________(1/1)
40 | False
41 |
42 | expand_hyp length_def.
43 |
44 | 1 goal
45 | length_def : length =
46 | (fun A : Type =>
47 | fix length (l : list A) : nat :=
48 | match l with
49 | | [] => 0
50 | | _ :: l' => S (length l')
51 | end)
52 | H : forall (A : Type) (l : list A),
53 | length l =
54 | (fix length (l0 : list A) : nat :=
55 | match l0 with
56 | | [] => 0
57 | | _ :: l' => S (length l')
58 | end) l
59 | ______________________________________(1/1)
60 | False
61 | ```
--------------------------------------------------------------------------------
/coq-sniper.opam:
--------------------------------------------------------------------------------
1 | opam-version: "2.0"
2 | maintainer: "Chantal.Keller@lri.fr"
3 | homepage: "https://github.com/smtcoq/sniper"
4 | dev-repo: "git+https://github.com/smtcoq/sniper.git"
5 | bug-reports: "https://github.com/smtcoq/sniper/issues"
6 | authors: ["Valentin Blot "
7 | "Louise Dubois de Prisque "
8 | "Chantal Keller "
10 | "Tomaz Mascarenhas "
11 | ]
12 | license: "CECILL-C"
13 | build: [
14 | [make "-j%{jobs}%"]
15 | ]
16 | install: [
17 | [make "install"]
18 | ]
19 | depends: [
20 | "coq" {>= "8.17" & < "8.18~"}
21 | "coq-metacoq-utils" {= "1.3+8.17"}
22 | "coq-metacoq-template" {= "1.3+8.17"}
23 | "elpi"
24 | "coq-trakt"
25 | "coq-elpi"
26 | "coq-smtcoq"
27 | ]
28 | pin-depends: [
29 | [ "coq-smtcoq.dev" "git+https://github.com/smtcoq/smtcoq.git#with-trakt-coq-8.17" ]
30 | [ "coq-trakt.1.2" "git+https://github.com/ecranceMERCE/trakt.git#1.2" ]
31 | ]
32 | tags: [
33 | "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures"
34 | "category:Miscellaneous/Coq Extensions"
35 | "keyword: SMT"
36 | "keyword: automation"
37 | "logpath:Sniper"
38 | ]
39 | synopsis: "A Coq plugin for general proof automation"
40 | description: """
41 | Sniper is a Coq plugin that provides a new Coq tactic, snipe, for general proof automation.
42 |
43 | This plugin is an extension of SMTCoq, a plugin to safely call external SMT solvers from Coq. Sniper extends SMTCoq by translating (a subset) of Coq goals into first-order logic before calling SMTCoq.
44 |
45 | The translation is implemented through a combination of modular, small transformations that independently eliminate specific aspects of Coq logic towards first-order logic. These small transformations are safe, either generating proof terms on the fly (certifying transformations) or being proved once and for all in Coq (certified transformations).
46 | """
47 | url {
48 | src: "git+https://github.com/smtcoq/sniper.git#coq-8.17-with-trakt"
49 | }
50 |
--------------------------------------------------------------------------------
/docs/fix.md:
--------------------------------------------------------------------------------
1 | # Elimination of anonymous fixpoints
2 |
3 | This transformation is defined in the file `theories/elimination_fixpoints.v`.
4 |
5 | ## What does this transformation do?
6 |
7 | This transformation `eliminate_fix_hyp`, takes as an argument a hypothesis `H` whose type
8 | contains an anonymous fixpoint of the form `fix f_anon (x1: A1) ... (xn: An) := ...`.
9 |
10 | It looks in the global environment of Coq and in the local context to see if there is
11 | a constant `f` or a local definition `f := ...` which reduces to this anonymous fixpoint by delta-reduction.
12 |
13 | Similarly, it also looks if a *generalization* of `fix f_anon ...` (a constant which reduces to `fun x1 ... xn => fix f_anon ... := ...`) is convertible to a constant.
14 |
15 | The tactic transforms `H` into a new hypothesis of the same identifier `H`, in which each occurence of the anonymous fixpoint in its own body is replaced by the definition discovered.
16 | In addition, a step of beta-reduction is made if possible (that is, if the function is applied to some arguments).
17 |
18 | This transformation is written using the plugin [coq-elpi](https://github.com/LPCIC/coq-elpi), and the proof of each application of the transformation is a `Ltac` proof.
19 |
20 | There is a version `eliminate_fix_cont` taking an additional argument: a `Ltac` continuation,
21 | which can bind the transformed hypothesis `H`.
22 |
23 | ## An example
24 |
25 | ```
26 | Goal (forall (H : forall (A: Type) (l : A), @length A l =
27 | (fix length (l : list A) : nat :=
28 | match l with
29 | | [] => 0
30 | | _ :: l' => S (length l')
31 | end) A l), False). intros.
32 |
33 | 1 goal
34 | H : forall (A: Type) (l : A), @length A l =
35 | (fix length (l : list A) : nat :=
36 | match l with
37 | | [] => 0
38 | | _ :: l' => S (length l')
39 | end) A l
40 | ______________________________________(1/1)
41 | False
42 |
43 | eliminate_fix_hyp H.
44 |
45 | 1 goal
46 |
47 | H : forall (A : Type) (l : list A),
48 | length l =
49 | match l with
50 | | [] => 0
51 | | _ :: l' => S (length l')
52 | end
53 | ______________________________________(1/1)
54 | False
55 | ```
56 |
57 | In this example, the anonymous fixpoint `(fix length (l : list A) := ...` is **not** convertible to `length`
58 | as it is applied to the type variable `A`, but its abstraction over `A` is.
59 |
--------------------------------------------------------------------------------
/orchestrator/printer.v:
--------------------------------------------------------------------------------
1 | Require Import triggers.
2 | From Ltac2 Require Import Ltac2.
3 | Require Import Ltac2.Printf.
4 | Require Import Ltac2.Message.
5 |
6 | Ltac2 print_case (c: constr) :=
7 | match Constr.Unsafe.kind c with
8 | | Constr.Unsafe.Case _ c1 _ c2 ca => printf "%t" c1 ; printf "%t" c2 ; Array.iter (fun x => printf "%t" x) ca
9 | | _ => ()
10 | end.
11 |
12 | Ltac2 rec print_interp_trigger (ll : constr list list) :=
13 | match ll with
14 | | [] => printf "no more triggers to print"
15 | | l :: ll' => printf "trigger interpreted:" ; List.iter (fun x => printf "%t" x) l ; print_interp_trigger ll'
16 | end.
17 |
18 | (* Ltac2 Eval (print_case '(match 1 as t return
19 | match t with | 0 => Type | S _ => nat end with | 0 => Prop | S x => x end)). *)
20 |
21 | Ltac2 rec concat_list (l : message list) :=
22 | match l with
23 | | [] => of_string " "
24 | | x :: xs => concat x (concat (of_string " ") (concat_list xs))
25 | end.
26 |
27 | Ltac2 print_bool b :=
28 | if b then print (of_string "true") else
29 | print (of_string "false").
30 |
31 | Ltac2 of_option_constr o :=
32 | match o with
33 | | None => (of_string "None")
34 | | Some x => (concat (of_string "Some ") (of_constr x))
35 | end.
36 |
37 | Ltac2 print_hyp h :=
38 | let (x, y, z) := h in
39 | print
40 | (concat_list [of_ident x; of_option_constr y ; of_constr z]).
41 |
42 | Ltac2 print_hyps hyps :=
43 | List.iter print_hyp hyps.
44 |
45 | Ltac2 print_env env :=
46 | List.iter (fun (x, y) => print (concat_list [of_string x; of_string "is"; of_constr y])) env.
47 |
48 | Ltac2 print_state cg :=
49 | let (hs, g) := cg in
50 | print (of_string "The goal in the state is") ;
51 | print (of_option_constr g) ;
52 | print (of_string "The hyps in the state are of type") ;
53 | print_hyps hs ;
54 | Message.print (Message.of_string "End state").
55 |
56 | Ltac2 rec print_triggered_tacs trigtacs :=
57 | match trigtacs with
58 | | [] => Message.print (Message.of_string "empty list")
59 | | (name, l) :: xs => Message.print (Message.of_string name) ;
60 | print_triggered_tacs xs
61 | end.
62 |
63 | Ltac2 print_goal () :=
64 | let _ := print (of_string "The Goal is") in
65 | let g := Control.goal () in
66 | let _ := print (of_constr g) in
67 | let _ := print (of_string "The hypotheses are") in
68 | let hyps := Control.hyps () in
69 | print_hyps hyps.
70 |
71 |
72 | Ltac2 print_closed_subterms c :=
73 | let lc := closed_subterms c in List.iter (fun x => printf "%t" x) lc.
74 |
--------------------------------------------------------------------------------
/docs/mono.md:
--------------------------------------------------------------------------------
1 | # Monomorphization
2 |
3 | This transformation is available in two versions:
4 |
5 | * In `theories/instantiate_type.v` you will find the first strategy of instantiation.
6 | * In `theories/instantiate_inductive_pars.v` you will find the second strategy of instantiation.
7 |
8 | ## What does this transformation do?
9 |
10 | The transformation `inst` from `theories/instantiate_type.v`
11 | and the one `elimination_polymorphism` from `theories/instantiate_inductive_pars.v`
12 | both select instances and instantiate hypotheses with prenex polymorphism with these instances.
13 |
14 | That is, they instantiate all the statements of the form:
15 |
16 | $\forall (A : Type), B$
17 |
18 | where $B$ is a proposition.
19 |
20 | The `inst` strategy will select all the subterms of type $Type$
21 | in the local context and will create one instance for each subterm.
22 |
23 | The `elimination_polymorphism` strategy will look at all the
24 | ground parameters of inductives $I$ in the local context.
25 | Suppose that there is the ground parameter $u$ at the argument position $n$ for the inductive $I$
26 |
27 | If a type variable $A$ is also used at the $n$-th argument position of $I$, then $u$ is a relevant instance.
28 |
29 | ## An example
30 |
31 |
32 | ```
33 | H: forall (A : Type) (B : Type) (x x' : A) (y y' : B),
34 | (x, y) = (x', y') -> x = x'
35 | ______________________________________(1/1)
36 | forall (x x': nat) (y y': bool),
37 | (x, y) = (x', y') -> x = x'
38 |
39 | inst.
40 |
41 | H1: forall (x x' : nat*bool) (y y' : nat*bool),
42 | (x, y) = (x', y') -> x = x'
43 | H2: forall (x x' : nat*bool) (y y' : bool),
44 | (x, y) = (x', y') -> x = x'
45 | H3: forall (x x' : nat*bool) (y y' : nat),
46 | (x, y) = (x', y') -> x = x'
47 | H4: forall (x x' : nat) (y y' : nat*bool),
48 | (x, y) = (x', y') -> x = x'
49 | H5: forall (x x' : nat) (y y' : bool),
50 | (x, y) = (x', y') -> x = x'
51 | H6: forall (x x' : nat) (y y' : nat),
52 | (x, y) = (x', y') -> x = x'
53 | H7: forall (x x' : bool) (y y' : nat*bool),
54 | (x, y) = (x', y') -> x = x'
55 | H8: forall (x x' : bool) (y y' : bool),
56 | (x, y) = (x', y') -> x = x'
57 | H9: forall (x x' : bool) (y y' : nat),
58 | (x, y) = (x', y') -> x = x'
59 | ______________________________________(1/1)
60 | forall (x x': nat) (y y': bool),
61 | (x, y) = (x', y') -> x = x'
62 |
63 | Undo. elimination_polymorphism.
64 |
65 | H1: forall (x x' : nat) (y y' : bool),
66 | (x, y) = (x', y') -> x = x'
67 | ______________________________________(1/1)
68 | forall (x x': nat) (y y': bool),
69 | (x, y) = (x', y') -> x = x'
70 |
71 | ```
72 |
73 |
74 |
75 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Sniper
2 |
3 | `Sniper` is a Coq plugin that provides a new Coq tactic, `snipe`, that
4 | provides general proof automation.
5 |
6 | This plugin is an extension of [SMTCoq](https://smtcoq.github.io), a
7 | plugin to safely call external SMT solvers from Coq. `Sniper` extends
8 | SMTCoq by translating (a subset) of Coq goals into first-order logic
9 | before calling SMTCoq.
10 |
11 | The translation is implemented through a combination of modular, small
12 | transformations that independently eliminate specific aspects of Coq
13 | logic towards first-order logic. These small transformations are safe,
14 | either generating proof terms on the fly (*certifying* transformations)
15 | or being proved once and for all in Coq (*certified* transformations). A
16 | crucial transformation is given by the
17 | [Trakt](https://github.com/ecranceMERCE/trakt) plugin.
18 |
19 | This version is an experimental version using the Trakt plugin.
20 |
21 |
22 | ## Installation and use
23 |
24 | This part describes the steps required to try the `snipe` tactic. It can
25 | be used with Coq-8.17.
26 |
27 | You will need the following packages. The names are those for debian, please adapt as required for your distribution.
28 | - opam: for installing coqide, metacoq and smtcoq
29 | - pkg-config: required for creating an opam switch
30 | - libgtksourceview-3.0-dev: required by coqide
31 | - git: for installing smtcoq through opam
32 | - bison, flex: for compiling veriT
33 |
34 | If opam was not installed on your machine you have to initialize it (all the files are confined within ~/.opam):
35 | ```
36 | opam init --bare --no-setup
37 | ```
38 |
39 | It requires OCaml between 4.09 and 4.10:
40 | ```
41 | opam switch create 4.09.1
42 | eval $(opam env)
43 | ```
44 |
45 | You need to add two opam repositories:
46 | ```
47 | opam repo add coq-released https://coq.inria.fr/opam/released
48 | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev
49 | ```
50 |
51 | Then simply install this version of `Sniper`:
52 | ```
53 | opam install -y .
54 | ```
55 |
56 | ### Installation of the automatic prover and use
57 |
58 | You also need the veriT SMT solver, using [these sources](https://www.lri.fr/~keller/Documents-recherche/Smtcoq/veriT9f48a98.tar.gz).
59 | Once unpacked, compilation of veriT is as follows:
60 | ```
61 | cd veriT9f48a98
62 | ./configure
63 | make
64 | ```
65 |
66 | We need the veriT binary to be in PATH in order for `Sniper` to use it:
67 | ```
68 | export PATH="$PATH:$(pwd)"
69 | cd ..
70 | ```
71 |
72 | ## Examples, tests and benchmarks
73 |
74 | Commented examples are available at ``examples.v``.
75 |
76 | ## License
77 | As an extension of SMTCoq, `Sniper` is released under the same license
78 | as SMTCoq: CeCILL-C. See the file LICENSE for details.
79 |
80 |
81 | ## Authors
82 | See the file [AUTHORS](https://github.com/smtcoq/sniper/blob/master/AUTHORS).
83 |
--------------------------------------------------------------------------------
/elpi/subterms.elpi:
--------------------------------------------------------------------------------
1 | pred subterms i: term, o: (list term). %closed subterms of a term (can contain a context variable)
2 | subterms (sort U) [sort U] :- !.
3 | subterms (fun N Ty F) [fun N Ty F | R] :-
4 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2,
5 | std.append R1 R2 R.
6 | subterms (fun N Ty F) R :- !,
7 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2,
8 | std.append R1 R2 R.
9 | subterms (prod N Ty F) [prod N Ty F | R] :-
10 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2,
11 | std.append R1 R2 R.
12 | subterms (prod N Ty F) R :- !,
13 | subterms Ty R1, pi x\ decl x N Ty => subterms (F x) R2,
14 | std.append R1 R2 R.
15 | subterms (app L) R :- !,
16 | std.map L subterms R',
17 | std.flatten R' R.
18 | subterms (global G) [global G].
19 | subterms (let N Ty V F) [let N Ty V F| R] :-
20 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms (F x) R3,
21 | std.append R1 R2 R12,
22 | std.append R12 R3 R.
23 | subterms (let N Ty V F) R :- !,
24 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms (F x) R3,
25 | std.append R1 R2 R12,
26 | std.append R12 R3 R.
27 | subterms (match T U L) [match T U L | R] :- !,
28 | subterms T R1, subterms U R2, std.append R1 R2 R12,
29 | std.map L subterms R3,
30 | std.flatten R3 R',
31 | std.append R12 R' R.
32 | subterms (fix Na _ Ty F) [fix Na _ Ty F|R] :-
33 | subterms Ty R1, pi x\ decl x Na Ty => subterms (F x) R2,
34 | std.append R1 R2 R.
35 | subterms (fix Na _ Ty F) R :- !,
36 | subterms Ty R1, pi x\ decl x Na Ty => subterms (F x) R2,
37 | std.append R1 R2 R.
38 | subterms _ [].
39 |
40 | pred subterms2 i: term, o: (list term).
41 | subterms2 T L :- subterms T L1, names L2, std.filter L2 (x\ occurs x T) L2', append_nodup L1 L2' L.
42 |
43 | pred subterms2_list i: (list term), o: (list term).
44 | subterms2_list [X|XS] R :- subterms2 X L1, subterms2_list XS L2, append_nodup L1 L2 R.
45 | subterms2_list [] [].
46 |
47 | pred add_if_type i: term, i: (list term), o: (list term).
48 | add_if_type T L [T|L] :- not (std.mem! L T), coq.typecheck T {{ Prop }} (error _), coq.typecheck T {{Type}} ok.
49 | add_if_type _ L L.
50 |
51 | pred subterms_type i: term, o: (list term).
52 | subterms_type (sort U) [sort U].
53 | subterms_type (fun N Ty F) R :- !,
54 | subterms_type Ty R1, pi x\ decl x N Ty => subterms_type (F x) R2,
55 | std.append R1 R2 R.
56 | subterms_type (prod N Ty F) R :- !,
57 | subterms_type Ty R1, pi x\ decl x N Ty => subterms_type (F x) R2,
58 | std.append R1 R2 R.
59 | subterms_type (app L) R :- !,
60 | std.map L subterms_type R1,
61 | std.flatten R1 R',
62 | add_if_type (app L) R' R.
63 | subterms_type (global G) L :- !,
64 | add_if_type (global G) [] L.
65 | subterms_type (let N Ty V F) R :- !,
66 | subterms_type Ty R1, subterms_type V R2, pi x\ def x N Ty V => subterms_type (F x) R3,
67 | std.append R1 R2 R12,
68 | std.append R12 R3 R.
69 | subterms_type (fix Na _ Ty F) R :- !,
70 | subterms_type Ty R1, pi x\ decl x Na Ty => subterms_type (F x) R2,
71 | std.append R1 R2 R.
72 | subterms_type T R :- add_if_type T [] R.
73 |
--------------------------------------------------------------------------------
/theories/higher_order.v:
--------------------------------------------------------------------------------
1 | Require Import utilities.
2 | Require Import expand.
3 | Require Import elimination_fixpoints.
4 | Require Import elimination_pattern_matching.
5 | Require Import anonymous_functions.
6 |
7 | From elpi Require Import elpi.
8 |
9 | Ltac mypose_elpi t :=
10 | tryif (is_local_def t) then idtac else
11 | let t' :=
12 | match t with
13 | | ?u ?v =>
14 | match goal with
15 | | x := v |- _ => constr:(u x)
16 | | _ => t
17 | end
18 | | _ => t
19 | end in
20 | tryif (is_local_def t') then idtac else
21 | let Na := fresh "f" in pose t as Na ; (* HACK : fold local def eagerly in order
22 | to avoid unification failures with the fixpoint transformation *)
23 | match t with
24 | | ?u ?v =>
25 | match goal with
26 | | x := v |- _ => try (fold x in Na)
27 | | _ => idtac
28 | end
29 | | _ => idtac
30 | end.
31 |
32 | Elpi Tactic prenex_higher_order.
33 |
34 | From Sniper.elpi Extra Dependency "higher_order.elpi" as HigherOrder.
35 | From Sniper.elpi Extra Dependency "utilities.elpi" as Utils.
36 | From Sniper.elpi Extra Dependency "subterms.elpi" as Subterms.
37 | Elpi Accumulate File Utils.
38 | Elpi Accumulate File Subterms.
39 | Elpi Accumulate File HigherOrder.
40 |
41 | Elpi Accumulate lp:{{
42 |
43 | pred mypose_list i: list (pair term (list term)), i: goal, o: list sealed-goal.
44 | mypose_list [pr X L |XS] (goal Ctx _ _ _ _ as G) GL :-
45 | std.rev Ctx Ctx',
46 | std.map L (elim_pos_ctx Ctx') L',
47 | coq.ltac.call "mypose_elpi" [trm (app [X | L'])] G [G'],
48 | coq.ltac.open (mypose_list XS) G' GL.
49 | mypose_list [] _ _.
50 |
51 |
52 | solve (goal Ctx _ TyG _ _ as G) GL :- ctx_to_hyps Ctx Trms, names Na,
53 | subterms_list_and_args [TyG|Trms] Na Subs,
54 | std.filter Subs (x\ fst x X, contains_prenex_ho_ty X, prenex_ho1_ty X) L, trm_and_args_type_funs L L',
55 | std.rev Ctx Ctx',
56 | add_pos_ctx_pr Ctx' L' L'', mypose_list L'' G GL.
57 |
58 | }}.
59 | Elpi Typecheck.
60 |
61 | Require Import List.
62 |
63 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C),
64 | List.map g (List.map f l) = map (fun x => g (f x)) l.
65 | intros.
66 | elpi prenex_higher_order. Abort.
67 |
68 | Tactic Notation "prenex_higher_order" :=
69 | elpi prenex_higher_order.
70 |
71 | Import ListNotations.
72 |
73 | Section Tests.
74 |
75 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C),
76 | map g (map f l) = map (fun x => g (f x)) l.
77 | intros.
78 | prenex_higher_order.
79 | Abort.
80 |
81 | Lemma bar : forall (A B C : Type) (l : list A) (f : A -> B) (g : B -> C),
82 | map g (map f l) = map (fun x => g (f x)) l.
83 | intros.
84 | assert (IHl : map g (map f l) = map (fun x : A => g (f x)) l) by admit.
85 | prenex_higher_order. (* remove duplicates *)
86 | Abort.
87 |
88 | Goal (
89 | forall (A B C : Type)
90 | (f : A -> B)
91 | (g : B -> C),
92 | let f0 := fun x : A => g (f x) in
93 | ((forall x : A, f0 x = g (f x)) ->
94 | (forall (x : Type) (x0 x1 : x) (x2 x3 : list x),
95 | x0 :: x2 = x1 :: x3 -> x0 = x1 /\ x2 = x3) ->
96 | (forall (x : Type) (x0 : x) (x1 : list x),
97 | [] = x0 :: x1) ->
98 | map g (map f []) = map f0 [])).
99 | Proof. intros. prenex_higher_order. Abort.
100 |
101 | End Tests.
102 |
--------------------------------------------------------------------------------
/docs/README.md:
--------------------------------------------------------------------------------
1 | # Sniper
2 |
3 | `Sniper` is a Coq plugin that provides a new Coq tactic, `snipe`, that
4 | provides general proof automation.
5 |
6 | This plugin can be seen as an extension of [SMTCoq](https://smtcoq.github.io), a
7 | plugin to safely call external SMT solvers from Coq.
8 |
9 | `Sniper` extends
10 | SMTCoq by translating (a subset) of Coq goals into first-order logic
11 | before calling SMTCoq.
12 |
13 | The translation is implemented through a combination of modular, small
14 | transformations that independently eliminate specific aspects of Coq
15 | logic towards first-order logic. These small transformations are safe,
16 | generating proof terms on the fly (*certifying* transformations).
17 | They could have been *certified* and we plan to also write or use transformations proven once and for all in `Sniper`, as both methods are compatible with the plugin.
18 |
19 | A
20 | crucial transformation but external to this repository is given by the
21 | [Trakt](https://ecrancemerce.github.io/trakt/#/) plugin.
22 |
23 |
24 | ## Installation and use
25 |
26 | This part describes the steps required to try the `snipe` tactic.
27 |
28 |
29 | You will need the following packages. The names are those for debian, please adapt as required for your distribution.
30 | - opam: for installing coqide, metacoq and smtcoq
31 | - pkg-config: required for creating an opam switch
32 | - libgtksourceview-3.0-dev: required by coqide
33 | - git: for installing smtcoq through opam
34 | - bison, flex: for compiling veriT
35 |
36 | If opam was not installed on your machine you have to initialize it (all the files are confined within ~/.opam):
37 | ```
38 | opam init --bare --no-setup
39 | ```
40 |
41 | It requires OCaml between 4.09 and 4.10:
42 | ```
43 | opam switch create 4.09.1
44 | eval $(opam env)
45 | ```
46 |
47 | You need to add two opam repositories:
48 | ```
49 | opam repo add coq-released https://coq.inria.fr/opam/released
50 | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev
51 | ```
52 |
53 | Then simply install this version of `Sniper`:
54 | ```
55 | opam install coq-sniper
56 | ```
57 |
58 | ### Installation of the automatic prover and use
59 |
60 | You also need the veriT SMT solver, using [these sources](https://www.lri.fr/~keller/Documents-recherche/Smtcoq/veriT9f48a98.tar.gz).
61 | Once unpacked, compilation of veriT is as follows:
62 | ```
63 | cd veriT9f48a98
64 | ./configure
65 | make
66 | ```
67 |
68 | We need the veriT binary to be in PATH in order for `Sniper` to use it:
69 | ```
70 | export PATH="$PATH:$(pwd)"
71 | cd ..
72 | ```
73 |
74 | ## Examples
75 |
76 | Commented examples are available at ``examples.v``.
77 |
78 | ## Transformations
79 |
80 | The documentation about each transformation is available here:
81 |
82 | * [Definitions](definitions.md)
83 | * [Higher Order Equalities](hoeq.md)
84 | * [Elimination of Anonymous Fixpoints](fix.md)
85 | * [Pattern Matching](pm.md)
86 | * [Algebraic Datatypes](alg.md)
87 | * [Generation Principle](gen.md)
88 | * [Monomorphization](mono.md)
89 | * [Anonymous Functions](anon.md)
90 | * [Prenex Higher Order](ho.md)
91 | * [Inductive Relations in Prop](indrelprop.md)
92 | * [Decision of Inductive Relations](decide.md)
93 |
94 | ## License
95 | As an extension of SMTCoq, `Sniper` is released under the same license
96 | as SMTCoq: CeCILL-C. See the file LICENSE for details.
97 |
98 | ## Papers about Sniper
99 |
100 | * [CPP' 23](https://arxiv.org/pdf/2204.02643.pdf)
101 | * [PXTP' 21](https://hal.science/hal-03328935/document)
102 |
103 | ## Authors
104 | See the file [AUTHORS](https://github.com/smtcoq/sniper/blob/master/AUTHORS).
105 |
--------------------------------------------------------------------------------
/docs/gen.md:
--------------------------------------------------------------------------------
1 | # Generation Principle
2 |
3 | This transformation is available in two different versions,
4 | in two separated files:
5 |
6 | * The file `theories/case_analysis_existentials.v` for the version with *existentials*
7 | quantifiers
8 | * The file `theories/case_analysis.v` for the version with the
9 | *projection functions*
10 |
11 | ## What does this transformation do?
12 |
13 | This transformation takes an *algebraic datatype* `I`
14 | not applied to its parameters (an inductive type made of non dependent sums
15 | or products whose codomain is `Type` or `Set`)
16 | and states and proves its *generation principle*, that is,
17 | each term `t : I` comes from one of its constructors.
18 |
19 | If we have the following `Coq` definition (`S` is either
20 | `Set` or `Type`):
21 |
22 | ```
23 | Inductive I (a1 : A1) ... (an : An) : S :=
24 | | c1 : T11 -> ... -> T1k -> I a1 ... an
25 | ...
26 | | cl : Tl1 -> ... -> Tlk -> I a1 ... an
27 | ```
28 |
29 | then, the generation principle for `I` *with existentials* would be:
30 |
31 | $\forall (\overrightarrow{a_{i} : A_{i}}) (t : I \; \vec{a_{i}}), \;
32 | \exists (\overrightarrow{x_{1_{i}}: T_{1_{i}}}), \;
33 | t = c_{1} \; \vec{x_{1_{i}}} \lor ... \lor
34 | \exists (\overrightarrow{x_{l_{i}}: T_{l_{i}}}),
35 | t = c_{l} \; \vec{x_{l_{i}}}$.
36 |
37 | The tactic is `gen_statement_existentials I H`, where `I` is the
38 | inductive and `H` a fresh name.
39 |
40 | The version *without* existentials uses the projections functions $p_{u_{v}}$, each of
41 | of type $\forall (\overrightarrow{a_{i} : A_{i}})
42 | (t : I \; \vec{a_{i}}) (d_{u_{v}}: T_{u_{v}}), T_{u_{v}}$
43 |
44 | such that
45 | $p_{u_{v}} \; \vec{a_{i}} \; d_{u_{v}} \; (c_{u} \; \overrightarrow{x_{u_{i}}}) = x_{u_{v}}$
46 | and $p_{u_{v}} \; \vec{a_{i}} \; d_{u_{v}} \; t = d$ otherwise.
47 |
48 | In other words, the projection function $p_{u_{v}}$ returns
49 | either the $v$-th value of the constructor $u$, or a default value.
50 |
51 | With the projections, the generation statement becomes:
52 |
53 | $\forall (\overrightarrow{a_{i} : A_{i}}) (t : I \; \vec{a_{i}}) \overrightarrow{(d_{i_{j}} : T_{i_{j}})}, \;
54 | t = c_{1} \; \overrightarrow{p_{1_{i}} \; \vec{a_{i}} \; d_{1_{i}} \; x_{1_{i}}} \lor ... \lor
55 | t = c_{l} \; \overrightarrow{p_{l_{i}} \; \vec{a_{i}} \; d_{l_{i}} \; x_{l_{i}}}$.
56 |
57 | The tactic is `pose_gen_statement I`, with `I` the inductive we are
58 | interested in. The projections functions are added in the local context
59 | but their bodies are cleared.
60 |
61 | ## Why do we need a statement without existentials?
62 |
63 | The main backend of `Sniper` is the `SMTCoq` plugin, which does not handle existentials.
64 |
65 | For this reason, in order to help `SMTCoq` to perform case analysis on terms from an algebraic datatype, the generation principle should be stated without existentials.
66 |
67 | Furthermore, all terms on which `SMTCoq` is able to reason should be part of a typeclass in which all types are inhabited. Indeed, `SMTCoq` uses the `Array` theory, for which a default value is required.
68 |
69 | For this reason, the presence of default values required in the projection functions is not a problem: once the statement is monomorphized, we can instantiate each of them by a canonical inhabitant.
70 |
71 | ## An example
72 |
73 | * Generation principle for lists with existentials:
74 |
75 | ```
76 | forall (A : Type) (t : list A),
77 | t = [] \/ (exists (x : A) (xs : list A), t = x :: xs)
78 | ```
79 |
80 | * The generation principle for list with projections will add
81 | these variables in the local context:
82 |
83 | ```
84 | proj0: forall (A : Type), A -> list A -> A
85 | proj1: forall (A : Type), list A -> list A -> list A
86 | gen_list: forall (A : Type) (l ld : list A) (d : A),
87 | l = [] \/ l = proj0 A a l :: proj1 A ld l
88 | ```
89 |
90 |
91 |
--------------------------------------------------------------------------------
/theories/deciderel/add_hypothesis_on_parameters.v:
--------------------------------------------------------------------------------
1 | From MetaCoq.Template Require Import All.
2 | Require Import String.
3 | Require Import List.
4 | Import ListNotations.
5 | Require Import utilities.
6 | Unset MetaCoq Strict Unquote Universe Mode.
7 |
8 | (** The purpose of this file is to transform an
9 | inductive of type [A1 -> ... -> An -> B1 -> ... Bm],
10 | (where the Ais are parameters and the Bjs are indexes)
11 | into a new inductive of type
12 | [A1 -> P A1 -> ... -> An -> P An -> B1 ... -> Bm].
13 | [P] is a property on types (think of [EqDec], or in the SMTCoq case,
14 | of [CompDec]) *)
15 |
16 | Section P.
17 |
18 | Variable P : term.
19 | Definition P_app :=
20 | tApp P [tRel 0].
21 |
22 | (* As the source is the type A1 -> ... -> An
23 | and the target is the type A1 -> P A1 -> A2 -> P A2 ... -> An -> P An,
24 | we need to lift the first variable n times, the second variable n-1 times and so on *)
25 | Fixpoint liftn_aux (n n' : nat) (t : term) :=
26 | match n with
27 | | 0 => t
28 | | S m => lift 1 n' (liftn_aux m (S n') t)
29 | end.
30 |
31 | Definition liftn (n : nat) (t : term) := liftn_aux n 0 t.
32 |
33 | Fixpoint add_trm_parameter_aux
34 | (t : term) (* the term considered *)
35 | (n : nat) (* the db index of the inductive of interest *)
36 | (lrel : list term) (* the new parameters of the inductive considered (P A1) ... (P An) *)
37 | (fuel : nat) : term :=
38 | let len := Datatypes.length lrel in
39 | match fuel with
40 | | 0 => default_reif
41 | | S m =>
42 | match t with
43 | | tProd Na u v =>
44 | let u' := match u with
45 | | tApp (tRel k) l =>
46 | if Nat.eqb n k then tApp (tRel (k+ len)) (List.map (lift len 0) (List.firstn len l) ++ lrel ++
47 | (List.map (lift len (n - 1)) (List.skipn len l)))
48 | else (liftn_aux len (n - len) u)
49 | | _ => (liftn_aux len (n - len) u)
50 | end in
51 | tProd Na u' (add_trm_parameter_aux v (S n) (List.map (lift 1 0) lrel) m)
52 | | tApp u l => match u with
53 | | tRel k =>
54 | if Nat.eqb n k then tApp (tRel (k+ len)) (List.map (lift len 0) (List.firstn len l) ++ lrel ++
55 | (List.map (lift len (n - 1)) (List.skipn len l)))
56 | else tApp u l
57 | | _ => lift len 0 t
58 | end
59 | | _ => lift len 0 t
60 | end
61 | end.
62 |
63 | (* Auxiliary functions to find a new suitable name *)
64 | Definition find_name_trm : ident :=
65 | match P with
66 | | tInd i _ => ("H"++(i.(inductive_mind)).2)%bs
67 | | tConst k _ => k.2
68 | | _ => "new_ident"%bs
69 | end.
70 |
71 | Definition trm_aname (na : aname) :=
72 | let new_name :=
73 | match na.(binder_name) with
74 | | nNamed id => nNamed (find_name_trm++id)%bs
75 | | nAnon => nNamed find_name_trm
76 | end in
77 | {| binder_name := new_name; binder_relevance := na.(binder_relevance) |}.
78 |
79 | Definition is_prop (s: sort) :=
80 | match s with
81 | | sProp => true
82 | | _ => false
83 | end.
84 |
85 | Fixpoint add_trm_for_each_poly_var (t: term) (acc: list term) (fuel : nat) : term :=
86 | match t with
87 | | tProd Na u v =>
88 | match u with
89 | | tSort s =>
90 | if negb (is_prop s) then
91 | let acc' := (List.map (lift 1 0) acc) ++ [tRel 0] in
92 | tProd Na (tSort s) (mkProdName (find_name_trm) P_app (add_trm_for_each_poly_var v acc' fuel))
93 | else
94 | let len := Datatypes.length acc in (add_trm_parameter_aux t len acc fuel)
95 | | _ => let len := Datatypes.length acc in add_trm_parameter_aux t len acc fuel
96 | end
97 | | _ => let len := Datatypes.length acc in add_trm_parameter_aux t len acc fuel
98 | end.
99 |
100 | Fixpoint fuel_trm t :=
101 | match t with
102 | | tProd _ u v => fuel_trm u + fuel_trm v + 1
103 | | _ => 1
104 | end.
105 |
106 | Definition add_trm_parameter (t : term) :=
107 | let fuel := fuel_trm t in
108 | add_trm_for_each_poly_var t [] fuel.
109 |
110 | End P.
111 |
112 | Section tests.
113 |
114 | Variable (P : Type -> Type).
115 |
116 | MetaCoq Unquote Definition
117 | trm_unq := (add_trm_parameter <% P %> <% forall (A : Type) (a : A), list A -> list A -> Prop %>).
118 |
119 | MetaCoq Unquote Definition
120 | trm_unq2 := (add_trm_parameter <% P %> <% forall (A : Type) (B: Type), A -> B -> Prop %>).
121 |
122 | (* Print trm_unq. *)
123 | (* Print trm_unq2. *)
124 |
125 | End tests.
126 |
--------------------------------------------------------------------------------
/theories/expand.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 | Require Import MetaCoq.Template.All.
13 | Require Import utilities.
14 | Require Import reflexivity.
15 | Require Import unfold_reflexivity.
16 | Require Import unfold_in.
17 | Require Import List.
18 | Import ListNotations.
19 | Require Import String.
20 |
21 | Definition list_of_args_and_codomain (t : term) :=
22 | let fix aux acc t :=
23 | match t with
24 | | tProd _ t1 t2 => aux (t1 :: acc) t2
25 | | _ => (acc, t)
26 | end in aux [] t.
27 |
28 | Unset Guard Checking. (* Not dangerous: we do not use this function in proofs ! *)
29 |
30 | (* Takes a term, if it is a function or a fixpoint
31 | returns the names of its arguments, otherwise returns [].
32 | The goal is to improve names generation in Sniper *)
33 |
34 | Fixpoint get_names_args_fix (f : mfixpoint term) :=
35 | match f with
36 | | [] => []
37 | | {| dname := _ ; dtype := _ ; dbody := t ; rarg := _ |} :: xs =>
38 | get_names_args_fun t ++ get_names_args_fix xs
39 | end with
40 | get_names_args_fun (t : term) :=
41 | match t with
42 | | tLambda {| binder_name := x; binder_relevance := _ |} _ u =>
43 | let na :=
44 | match x with
45 | | nAnon => "x"%bs
46 | | nNamed y => y
47 | end
48 | in na :: get_names_args_fun u
49 | | tFix f _ => get_names_args_fix f
50 | | _ => []
51 | end.
52 |
53 | Set Guard Checking.
54 |
55 | Open Scope string_scope.
56 |
57 | Definition names_aux (l : list bytestring.string) :
58 | (bytestring.string * list bytestring.string) :=
59 | (hd "x"%bs l, tl l).
60 |
61 | (* gen_eq [A1; ...; An] B t u =
62 | tProd A1 ... (tProd An (tApp < @eq > (tApp (tApp ... (tApp (lift 1 n t) [tRel (n-1)]) ... [tRel 0])
63 | (tApp (tApp ... (tApp (lift 1 n u) [tRel (n-1)]) ... [tRel 0]) *)
64 |
65 | Fixpoint gen_eq
66 | (l : list term) (* types of args of the functions *)
67 | (B : term) (* codomain of functions *)
68 | (t : term) (* function 1 *)
69 | (u : term) (* function 2 *)
70 | (lnames : list bytestring.string) (* list of names *)
71 | {struct l} :=
72 | match l with
73 | | [] => mkEq B t u
74 | | A :: l' =>
75 | let p := names_aux lnames in
76 | mkProdName (p.1)%bs A
77 | (gen_eq l' B (tApp (lift 1 0 t) [tRel 0]) (tApp (lift 1 0 u) [tRel 0]) p.2)
78 | end.
79 |
80 | (* if H : t = u then expand_hyp H produces the hypothesis forall x1 ... xn, t x1 ... xn = u x1 ... xn *)
81 |
82 | Ltac expand_hyp_cont H := fun k =>
83 | lazymatch type of H with
84 | | @eq ?A ?t ?u =>
85 | let A := metacoq_get_value (tmQuote A) in
86 | let t := metacoq_get_value (tmQuote t) in
87 | let u := metacoq_get_value (tmQuote u) in
88 | let names1 := eval cbv in (get_names_args_fun t) in
89 | let names :=
90 | match names1 with
91 | | [] => constr:(get_names_args_fun u)
92 | | _ :: _ => names1
93 | end in
94 | let p := eval cbv in (list_of_args_and_codomain A) in
95 | let l := eval cbv in (rev p.1) in
96 | let B := eval cbv in p.2 in
97 | let eq := eval cbv in (gen_eq l B t u names)
98 | in let z := metacoq_get_value (tmUnquote eq) in
99 | let u := eval hnf in (z.(my_projT2)) in let H' := fresh in
100 | (assert (H': u) by now rewrite H ;
101 | k H')
102 | | _ => k H
103 | end.
104 |
105 | Ltac expand_tuple p := fun k =>
106 | match constr:(p) with
107 | | (?x, ?y) =>
108 | expand_hyp_cont x ltac:(fun H' => expand_tuple constr:(y) ltac:(fun p => k (H', p))) ; clear x
109 | | unit => k unit
110 | end.
111 |
112 | Ltac expand_hyp H := expand_hyp_cont H ltac:(fun _ => idtac).
113 |
114 | Ltac expand_fun f :=
115 | let f_def := eval unfold f in f in
116 | let H := fresh in assert (H : f = f_def) by reflexivity ;
117 | expand_hyp H ; clear H.
118 |
119 | Section tests.
120 |
121 | Goal False.
122 | assert_refl length.
123 | unfold_refl H.
124 | expand_hyp H.
125 | assert (forall x : string, length x = match x with
126 | | ""%string => 0
127 | | String _ s' => S (length s')
128 | end). intros x. destruct x ; simpl ; reflexivity.
129 | Abort.
130 |
131 | Goal False.
132 | expand_fun Datatypes.length.
133 | expand_fun hd.
134 | Abort.
135 |
136 | Variable (A B: Type).
137 | Variable (f: A -> B).
138 |
139 | Goal False.
140 | pose (map' := List.map f).
141 | assert_refl map'.
142 | unfold_refl H.
143 | expand_hyp H.
144 | unfold_refl H0.
145 | unfold_in H0 map.
146 | Abort.
147 |
148 | End tests.
149 |
150 |
151 |
152 |
153 |
154 |
155 |
156 |
157 |
--------------------------------------------------------------------------------
/elpi/higher_order.elpi:
--------------------------------------------------------------------------------
1 | pred is_prod i: term.
2 | is_prod (prod _ _ _).
3 | is_prod (global (const C)) :- coq.env.const C (some Bo) _, is_prod Bo.
4 |
5 | pred prenex_ho1 i: term.
6 | prenex_ho1 (prod _ Ty F) :- not (is_prod Ty), pi x\ decl x _ Ty => prenex_ho1 (F x).
7 | prenex_ho1 (prod _ ((prod _ Ty' _) as Ty) F) :- not (is_prod Ty'), pi x\ decl x _ Ty => prenex_ho1 (F x).
8 | prenex_ho1 T :- name T.
9 | prenex_ho1 (sort (typ _)).
10 | prenex_ho1 (global (const C)) :- (coq.env.const C (some Bo) _, prenex_ho1 Bo; coq.env.const C _ Ty, coq.unify-leq Ty {{Type}} ok).
11 | prenex_ho1 (global (indt _)).
12 | prenex_ho1 (app [global _ | _]).
13 |
14 | pred prenex_ho1_ty i: term.
15 | prenex_ho1_ty T :- coq.typecheck T Ty ok, prenex_ho1 Ty.
16 |
17 | pred contains_prenex_ho i: term.
18 | contains_prenex_ho (prod _ (prod _ _ _) _).
19 | contains_prenex_ho (prod Na Ty F) :- pi x\ decl x Na Ty => contains_prenex_ho (F x).
20 |
21 | pred contains_prenex_ho_ty i: term.
22 | contains_prenex_ho_ty T :- coq.typecheck T Ty ok, contains_prenex_ho Ty.
23 |
24 | pred replace i:list (pair A B), i:A, i: B, o: list (pair A B).
25 | replace [pr X _|LS] X Z [pr X Z |LS].
26 | replace [U |LS] X Z [U|R] :- replace LS X Z R.
27 |
28 | pred contains_only_context_variables i: list term, i: term.
29 | contains_only_context_variables Na T :- names Na', std.length Na N, std.drop N Na' Na'',
30 | std.forall Na'' (x\ not (occurs x T)).
31 | %contains_only_context_variables _ _ :- coq.error "the term contains free variables that are not context or section variables".
32 |
33 | % TODO : speed up predicate, ignore non pertinent subterms
34 | pred subterms_and_args i: term, i: list term, o: (list (pair term (list term))). %closed subterms of a term and their arguments if they are applied
35 | subterms_and_args (sort U) _ [pr (sort U) []] :- !.
36 | subterms_and_args (fun N Ty F) Na [pr (fun N Ty F) [] | R] :- contains_only_context_variables Na (fun N Ty F), !,
37 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
38 | std.append R1 R2 R. %backtracks when the function depends on a variable bound by a previous rule
39 | subterms_and_args (fun N Ty F) Na R :- !,
40 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
41 | std.append R1 R2 R.
42 | subterms_and_args (prod N Ty F) Na [pr (prod N Ty F) [] | R] :- contains_only_context_variables Na (prod N Ty F), !,
43 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
44 | std.append R1 R2 R.
45 | subterms_and_args (prod N Ty F) Na R :- !,
46 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
47 | std.append R1 R2 R.
48 | % TODO : define curry
49 | subterms_and_args (app [T|L]) Na [pr (app [T|L]) [], pr T L |R] :- contains_only_context_variables Na T,
50 | std.forall L (contains_only_context_variables Na), !,
51 | std.map L (x\ subterms_and_args x Na) R', std.flatten R' R.
52 | subterms_and_args (app [_T|L]) Na R :- !,
53 | std.map L (x\ subterms_and_args x Na) R', std.flatten R' R.
54 | subterms_and_args (global G) _Na [pr (global G) []] :- !.
55 | subterms_and_args (let N Ty V F) Na [pr (let N Ty V F) []| R] :- contains_only_context_variables Na (let N Ty V F), !,
56 | subterms_and_args Ty Na R1, subterms_and_args V Na R2, pi x\ def x N Ty V => subterms_and_args (F x) Na R3,
57 | std.append R1 R2 R12,
58 | std.append R12 R3 R.
59 | subterms_and_args (let N Ty V F) Na R :- !,
60 | subterms_and_args Ty Na R1, subterms_and_args V Na R2, pi x\ def x N Ty V => subterms_and_args (F x) Na R3,
61 | std.append R1 R2 R12,
62 | std.append R12 R3 R.
63 | subterms_and_args (match T U L) Na [pr (match T U L) [] | R] :- contains_only_context_variables Na (match T U L), !,
64 | subterms_and_args T Na R1, subterms_and_args U Na R2, std.append R1 R2 R12,
65 | std.map L (x\ subterms_and_args x Na) R3,
66 | std.flatten R3 R',
67 | std.append R12 R' R.
68 | subterms_and_args (match T U L) Na R :- !,
69 | subterms_and_args T Na R1, subterms_and_args U Na R2, std.append R1 R2 R12,
70 | std.map L (x\ subterms_and_args x Na) R3,
71 | std.flatten R3 R',
72 | std.append R12 R' R.
73 | subterms_and_args (fix N Rno Ty F) Na [pr (fix N Rno Ty F) []|R] :- contains_only_context_variables Na (fix N Rno Ty F), !,
74 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
75 | std.append R1 R2 R.
76 | subterms_and_args (fix N _ Ty F) Na R :- !,
77 | subterms_and_args Ty Na R1, pi x\ decl x N Ty => subterms_and_args (F x) Na R2,
78 | std.append R1 R2 R.
79 | subterms_and_args T Na [pr T []] :- contains_only_context_variables Na T.
80 | subterms_and_args _ _ [].
81 |
82 | pred subterms_list_and_args i: (list term), i: list term, o: (list (pair term (list term))).
83 | subterms_list_and_args [X|XS] Na R :- !, subterms_and_args X Na L1, subterms_list_and_args XS Na L2, std.append L1 L2 R.
84 | subterms_list_and_args [] _ [].
85 |
86 | shorten coq.ltac.{ open, set-goal-arguments }.
87 |
88 | pred select_args_type_funs i: list term, o: list term.
89 | select_args_type_funs [X | XS] [X |RS] :- (coq.typecheck X {{ Type }} ok ; coq.typecheck X {{ lp:_A -> lp:_B}} ok), select_args_type_funs XS RS.
90 | select_args_type_funs _ [].
91 |
92 | pred trm_and_args_type_funs i: list (pair term (list term)), o: list (pair term (list term)).
93 | trm_and_args_type_funs [pr X Y | XS] [pr X L| RS] :- select_args_type_funs Y L, trm_and_args_type_funs XS RS.
94 | trm_and_args_type_funs [] [].
--------------------------------------------------------------------------------
/theories/subterms.v:
--------------------------------------------------------------------------------
1 | From elpi Require Import elpi.
2 |
3 | Elpi Command Collect_subterms.
4 | Elpi Accumulate File "elpi/subterms.elpi".
5 | Elpi Accumulate File "elpi/utilities.elpi".
6 | Elpi Accumulate lp:{{
7 | main [trm Term] :- subterms Term L, coq.say L.
8 | }}.
9 | Elpi Typecheck.
10 |
11 | Elpi Collect_subterms (Prop).
12 | Elpi Collect_subterms (fun x : Prop => Prop).
13 | Elpi Collect_subterms (fun x : nat => x).
14 | Elpi Collect_subterms (nat).
15 | Elpi Collect_subterms
16 | (fun x : nat => match x with
17 | | 0 => unit
18 | | S x' => Type
19 | end).
20 | Elpi Collect_subterms
21 | (fun A : Type =>
22 | fix length (l : list A) {struct l} : nat :=
23 | match l with
24 | | nil => 0
25 | | (_ :: l')%list => S (length l')
26 | end).
27 |
28 | Definition toto := fun A : Type =>
29 | fix length (l : list A) : nat :=
30 | match l with
31 | | nil => 0
32 | | (_ :: l')%list => S (length l')
33 | end.
34 |
35 | Print toto.
36 |
37 | Elpi Collect_subterms (toto).
38 |
39 | (* TODO : struct *)
40 |
41 | Elpi Tactic tata.
42 | Elpi Accumulate File "elpi/subterms.elpi".
43 |
44 | Elpi Accumulate lp:{{
45 | solve (goal _ _ Ty _ _ as G) GL :- subterms Ty R, coq.say R.
46 |
47 | }}.
48 | Elpi Typecheck.
49 |
50 | Elpi Tactic test_nth.
51 | Elpi Accumulate File "elpi/utilities.elpi".
52 |
53 | Elpi Accumulate lp:{{
54 | solve (goal _ _ Ty _ _ as G) GL :- nth 4 [1, 2, 3] R, coq.say R.
55 | solve (goal _ _ Ty _ _ as G) GL :- nth 2 [1, 2, 3] R, coq.say R.
56 |
57 | }}.
58 | Elpi Typecheck.
59 |
60 | Goal False.
61 | elpi test_nth. Abort.
62 |
63 | Elpi Tactic test_context.
64 | Elpi Accumulate File "elpi/utilities.elpi".
65 | Elpi Accumulate File "elpi/instantiate.elpi".
66 | Elpi Accumulate lp:{{
67 |
68 | solve (goal _ _ Ty _ _ as G) GL :- globals_using_var Ty L, coq.say L.
69 | }}.
70 | Elpi Typecheck.
71 |
72 | Goal forall (A B: Type) (l : A*B), l = l.
73 | intro A.
74 | elpi test_context. Abort.
75 |
76 | Goal forall (A B : Type) (l: list B), l = l.
77 | elpi test_context. Abort.
78 |
79 |
80 | Goal toto = toto.
81 | unfold toto. elpi tata.
82 | Abort.
83 |
84 |
85 | Elpi Command Collect_subterms_type.
86 |
87 | Elpi Accumulate File "elpi/subterms.elpi".
88 | Elpi Accumulate lp:{{
89 | main [trm Term] :- subterms_type Term L, coq.say L.
90 | }}.
91 | Elpi Typecheck.
92 |
93 | Elpi Accumulate File "elpi/subterms.elpi".
94 | Elpi Collect_subterms_type (Prop).
95 | Elpi Collect_subterms_type (fun x : Prop => Prop).
96 | Elpi Collect_subterms_type ((fun x : Type => Prop) Prop).
97 | Elpi Collect_subterms_type (nat).
98 | Elpi Collect_subterms_type (fun x : nat => x).
99 | Elpi Collect_subterms_type (forall A : Type, nat -> unit).
100 |
101 | Elpi Tactic swap.
102 | Elpi Accumulate lp:{{
103 | pred last i: (list sealed-goal), o: sealed-goal.
104 | last [_ | GS] R :- last GS R.
105 | last [G] G.
106 | pred remove_last i: (list sealed-goal), o: (list sealed-goal).
107 | remove_last [G1, G2 | GS] R :- remove_last [G2 | GS] R1,
108 | std.append [G1] R1 R.
109 | remove_last [_] [].
110 | remove_last [] [].
111 | msolve GS R :- last GS R1, remove_last GS R2,
112 | std.append [R1] R2 R.
113 | }}.
114 | Elpi Typecheck.
115 |
116 |
117 |
118 | Elpi Tactic instantiate_with_subterms_type_type_of_goal.
119 | Elpi Accumulate File "elpi/subterms.elpi".
120 | Elpi Accumulate File "elpi/instantiate.elpi".
121 | Elpi Accumulate File "elpi/utilities.elpi".
122 | Elpi Typecheck.
123 | Elpi Accumulate File "elpi/construct_cuts.elpi".
124 | Elpi Accumulate lp:{{
125 |
126 | solve (goal _ _ Ty _ [trm T] as G) GL :- !,
127 | subterms_type Ty L, instantiate_term_list T L R, coq.say R, construct_cuts R Trm,
128 | refine Trm G GL.
129 |
130 | }}.
131 | Elpi Typecheck.
132 |
133 | Elpi Tactic assert_list.
134 | Elpi Accumulate File "elpi/construct_cuts.elpi".
135 |
136 | Elpi Accumulate lp:{{
137 |
138 | solve (goal _ _ _ _ L as G) GL :- construct_cuts_args L R, coq.say R,
139 | refine R G GL1,
140 | refine_list_of_true GL1 GL.
141 |
142 |
143 | }}.
144 | Elpi Typecheck.
145 |
146 | Goal False.
147 | assert (H : False).
148 | elpi assert_list (True) (True) (True).
149 | Show 2.
150 | all: elpi swap.
151 | Abort.
152 |
153 |
154 | Elpi Tactic create_new_goal.
155 | Elpi Accumulate lp:{{
156 |
157 | solve (goal _ _ _ _ [trm H, trm H1] as G) [GL1| GL] :-
158 | std.assert-ok! (coq.elaborate-ty-skeleton H _ H') "cut formula illtyped",
159 | refine (app[(fun `new_hyp` H' x\ G1_ x), G2_]) G [GL1, GL2],
160 | coq.ltac.open (refine (app [H1, _ , _])) GL2 GL.
161 |
162 | }}.
163 | Elpi Typecheck.
164 |
165 | Check pair_equal_spec.
166 |
167 | Goal False.
168 | elpi create_new_goal (forall (a1 a2 : nat) (b1 b2 : nat), (a1, b1) = (a2, b2) <-> a1 = a2 /\ b1 = b2) (pair_equal_spec).
169 |
170 |
171 |
172 |
173 |
174 | Goal False.
175 | elpi instantiate_with_subterms_type_type_of_goal (forall x: Type, x = x).
176 | Abort.
177 |
178 | Ltac instantiate_hyp_with_subterms_of_type_type H := let Ty := type of H in
179 | elpi instantiate_with_subterms_type_type_of_goal (Ty).
180 |
181 | Goal ((forall x: Type, x = x) -> unit -> nat -> Prop).
182 | intro H.
183 | instantiate_hyp_with_subterms_of_type_type H; try apply H.
184 | Abort.
185 |
186 |
187 |
188 | Elpi Command Tuple_to_list.
189 | Elpi Accumulate File "elpi/utilities.elpi".
190 | Elpi Accumulate lp:{{
191 | main [trm Term] :- tuple_to_list Term L, coq.say L.
192 | }}.
193 | Elpi Typecheck.
194 |
195 | Elpi Tuple_to_list ((1, unit, bool)).
196 |
197 | Lemma test_clever_instances : forall (A B C D E : Type) (l : list A) (l' : list B)
198 | (p : C * D) (p' : D*E), l = l -> l' = l' -> p = p -> (forall (A : Type) (x : A), x= x)
199 | -> (forall (A : Type) (l : list A), l = l) -> (forall (A B : Type) (p : A *B), p =p ) ->
200 | p' = p'.
201 | intros.
202 |
203 |
204 |
--------------------------------------------------------------------------------
/orchestrator/tests/tests.v:
--------------------------------------------------------------------------------
1 | Require Import orchestrator.triggers.
2 | Require Import orchestrator.printer.
3 | Require Import List.
4 | From Ltac2 Require Import Ltac2 Printf.
5 | From Ltac2 Require Import Constr.
6 | Import Unsafe.
7 | From Ltac2 Require Import Message.
8 | Import ListNotations.
9 |
10 | Ltac2 env_triggers () :=
11 | { env_triggers := [] }.
12 |
13 | Ltac2 init_already_triggered () :=
14 | { already_triggered := [] }.
15 |
16 | Ltac2 init_interpretation_state () :=
17 | (* subterms already computed in the goal *)
18 | { subterms_coq_goal := ([], None);
19 | (* hypotheses or/and goal considered *)
20 | local_env := (Control.hyps (), Some (Control.goal ())) ;
21 | (* are all the hypotheses considered ? *)
22 | global_flag := true;
23 | (* name of the tactic interpreted *)
24 | name_of_tac := "toto" }.
25 |
26 | Ltac2 test_trigger (t: trigger) :=
27 | let env := env_triggers () in
28 | let alr_triggered := init_already_triggered () in
29 | let init := init_interpretation_state () in
30 | let res := interpret_trigger init env alr_triggered t in
31 | match res with
32 | | _ :: _ => print_interp_trigger res
33 | | [] => printf "Not triggered"
34 | end.
35 |
36 | Ltac2 test_anon () :=
37 | TDisj (
38 | TMetaLetIn (TContains (TSomeHyp, Arg Constr.type) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"]
39 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"]
40 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg))))
41 | (TIs (TNamed "f", Arg id) tDiscard)))
42 | (TMetaLetIn (TContains (TGoal, Arg id) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"]
43 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"]
44 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) (TIs (TNamed "f", Arg id) tDiscard))).
45 |
46 | (* anonymous funs that are not branches of match *)
47 |
48 | Lemma test u : match u with | 0 => True | S u => False end -> (fun x : nat => x) u = u -> False.
49 | intros H H1. test_trigger (test_anon ()). Abort.
50 |
51 | Lemma test u : (fun x : nat => x) u = u -> False.
52 | intros H. test_trigger (test_anon ()). Abort.
53 |
54 | Lemma test u : match u with | 0 => True | S u => False end -> False.
55 | intros H. test_trigger (test_anon ()). Abort.
56 |
57 | (** Test De Brujin indexes, eq and anonymous functions **)
58 |
59 | Goal forall (n: nat), (fun x => x) n = n.
60 | intros n.
61 | test_trigger (TContains (TGoal , NotArg) (TRel 1 NotArg)).
62 | pose (H := fun (x : nat) => x).
63 | test_trigger (TContains (TSomeDef, NotArg) (TLambda (TTerm 'nat (Arg id)) tDiscard NotArg)).
64 | test_trigger (TContains (TGoal, NotArg) (TLambda tDiscard (TRel 1 NotArg) NotArg)). (* warning: as in
65 | the kernel, De Brujin indexes start with 1 *)
66 | test_trigger (TIs (TGoal, NotArg) (TEq (TTerm 'nat (Arg id)) tDiscard tDiscard (Arg id))).
67 | let g := Control.goal () in print_closed_subterms g.
68 | Abort.
69 |
70 | (** Test match, definitions and fixpoints **)
71 |
72 | Goal (length =
73 | fun A : Type =>
74 | fix length (l : list A) : nat := match l with
75 | | [] => 0
76 | | _ :: l' => S (length l')
77 | end).
78 | test_trigger (TContains (TGoal, NotArg) (TConstant None (Arg Constr.type))).
79 | test_trigger (TContains (TGoal, NotArg) (TConstant (Some "length") (Arg Constr.type))).
80 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)).
81 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)).
82 | test_trigger (TContains (TGoal, NotArg) (TCase tDiscard tDiscard (Some [TTerm '0 NotArg; tDiscard]) NotArg)).
83 | Abort.
84 |
85 | Goal (forall A, @length A =
86 | fix length (l : list A) : nat := match l with
87 | | [] => 0
88 | | _ :: l' => S (length l')
89 | end).
90 | test_trigger (TContains (TGoal, NotArg) (TFix (TAny (Arg id)) tDiscard NotArg)).
91 | test_trigger (TContains (TGoal, NotArg) (TFix tDiscard tDiscard NotArg)).
92 | Abort.
93 |
94 | (* Test named *)
95 |
96 | Goal (forall (A B C : Prop), (A /\ B) -> (A /\ B) \/ C).
97 | intros A B C H.
98 | test_trigger (TIs (TGoal, NotArg) (TOr tDiscard tDiscard NotArg)).
99 | test_trigger (TMetaLetIn (TIs (TGoal, NotArg) (TOr tArg tDiscard NotArg)) ["A"] (TIs ((TNamed "A"), NotArg) (TAnd tArg tDiscard NotArg))).
100 | Abort.
101 |
102 | Goal unit.
103 | test_trigger (TIs (TGoal, NotArg) (TTerm 'unit (Arg id))). (* unit is in the list of used arguments *)
104 | Abort.
105 |
106 | Goal False.
107 | ltac1:(pose proof app_nil_end).
108 | test_trigger (TIs (TSomeHyp, NotArg) (TProd (TSort TBigType NotArg) tDiscard NotArg)).
109 | Abort.
110 |
111 | Ltac2 trigger_trakt_bool () :=
112 | TMetaLetIn (TIs (TSomeHyp, (Arg type)) (TType 'Prop NotArg)) ["H"]
113 | (TNot (TIs (TNamed "H", NotArg) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))).
114 |
115 | (* test for trakt tactic *)
116 | Lemma toto (H : true = false) (H1 : andb true true = true) (n : nat) (H2 : False) : True.
117 | Proof.
118 | test_trigger (trigger_trakt_bool ()).
119 | Abort.
120 |
121 | Goal False.
122 | ltac1:(pose proof app_nil_end).
123 | test_trigger (trigger_trakt_bool ()).
124 | Abort.
125 |
126 | Fixpoint zip {A B : Type} (l : list A) (l' : list B) :=
127 | match l, l' with
128 | | [], _ => []
129 | | x :: xs, [] => []
130 | | x :: xs, y :: ys => (x, y) :: zip xs ys
131 | end.
132 |
133 | Ltac2 trigger_pattern_matching :=
134 | TContains (TSomeHyp, Arg id) (TCase tDiscard tDiscard None NotArg).
135 |
136 | Goal (forall (H1 : forall (A B : Type) (l : list A) (l' : list B),
137 | zip l l' =
138 | match l with
139 | | [] => []
140 | | x :: xs => match l' with
141 | | [] => []
142 | | y :: ys => (x, y) :: zip xs ys
143 | end end), False).
144 | Proof. intros. test_trigger (trigger_pattern_matching). Abort.
145 |
146 |
147 |
148 |
--------------------------------------------------------------------------------
/theories/verit.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2.
2 | From Trakt Require Import Trakt.
3 | Require Import ZArith.
4 |
5 | Require Import add_compdecs.
6 |
7 | From SMTCoq Require SMT_classes Conversion Tactics.
8 | Import Tactics.
9 |
10 | Ltac trakt_rels rels :=
11 | lazymatch rels with
12 | | Some ?rels' => first [trakt Z bool with rel rels' | trakt bool with rel rels']
13 | | None => first [trakt Z bool | trakt bool]
14 | end.
15 |
16 | Ltac revert_and_trakt Hs rels :=
17 | lazymatch Hs with
18 | | (?Hs, ?H) =>
19 | revert H;
20 | revert_and_trakt Hs rels
21 | (* intro H *)
22 | | ?H =>
23 | revert H;
24 | trakt_rels rels
25 | (* intro H *)
26 | end.
27 |
28 | Definition sep := True.
29 |
30 | Ltac get_hyps_upto_sep :=
31 | lazymatch goal with
32 | | H' : ?P |- _ =>
33 | lazymatch P with
34 | | sep => constr:(@None unit)
35 | | _ =>
36 | let T := type of P in
37 | lazymatch T with
38 | | Prop =>
39 | let _ := match goal with _ => revert H' end in
40 | let acc := get_hyps_upto_sep in
41 | let _ := match goal with _ => intro H' end in
42 | lazymatch acc with
43 | | Some ?acc' => constr:(Some (acc', H'))
44 | | None => constr:(Some H')
45 | end
46 | | _ =>
47 | let _ := match goal with _ => revert H' end in
48 | let acc := get_hyps_upto_sep in
49 | let _ := match goal with _ => intro H' end in
50 | acc
51 | end
52 | end
53 | end.
54 |
55 |
56 | (* Goal False -> 1 = 1 -> unit -> false = true -> True. *)
57 | (* Proof. *)
58 | (* intros H1 H2. *)
59 | (* assert (H : sep) by exact I. *)
60 | (* intros H3 H4. *)
61 | (* let Hs := get_hyps_upto_sep in idtac Hs. *)
62 | (* Abort. *)
63 |
64 |
65 | Ltac intros_names :=
66 | let H := fresh in
67 | let _ := match goal with _ => assert (H : sep) by exact I; intros end in
68 | let Hs := get_hyps_upto_sep in
69 | let _ := match goal with _ => clear H end in
70 | Hs.
71 |
72 |
73 | (* Goal False -> 1 = 1 -> unit -> false = true -> True. *)
74 | (* Proof. *)
75 | (* intros H1 H2. *)
76 | (* let Hs := intros_names in idtac Hs. *)
77 | (* Abort. *)
78 |
79 |
80 | Ltac post_trakt Hs :=
81 | lazymatch Hs with
82 | | (?Hs1, ?Hs2) =>
83 | post_trakt Hs1;
84 | post_trakt Hs2
85 | | ?H => try (revert H; trakt_reorder_quantifiers; trakt_boolify_arrows; intro H)
86 | end.
87 |
88 | Ltac trakt1 rels Hs :=
89 | lazymatch Hs with
90 | | Some ?Hs => revert_and_trakt Hs rels
91 | | None => trakt_rels rels
92 | end.
93 |
94 | (** Remove add compdecs from SMTCoq's preprocess1 *)
95 |
96 | Ltac preprocess1 Hs :=
97 | Conversion.remove_compdec_hyps_option Hs;
98 | let cpds := Conversion.collect_compdecs in
99 | let rels := Conversion.generate_rels cpds in
100 | trakt1 rels Hs.
101 |
102 |
103 | Tactic Notation "verit_bool_no_check" constr(h) :=
104 | let tac :=
105 | ltac2:(h |- Tactics.get_hyps_cont_ltac1 (ltac1:(h hs |-
106 | match hs with
107 | | Some ?hs => verit_bool_no_check_base_auto (Some (h, hs))
108 | | None => verit_bool_no_check_base_auto (Some h)
109 | end;
110 | QInst.vauto) h)) in tac h.
111 |
112 | Tactic Notation "verit_bool_no_check" :=
113 | ltac2:(Tactics.get_hyps_cont_ltac1 ltac1:(hs |- verit_bool_no_check_base_auto hs; QInst.vauto)).
114 |
115 | Tactic Notation "verit_no_check_orch" constr(global) :=
116 | let tac :=
117 | ltac2:(h |- intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 (ltac1:(h local |-
118 | let Hsglob := Conversion.pose_hyps h (@None unit) in
119 | let Hs :=
120 | lazymatch local with
121 | | Some ?local' => Conversion.pose_hyps local' Hsglob
122 | | None => constr:(Hsglob)
123 | end
124 | in
125 | preprocess1 Hs;
126 | [ .. |
127 | let Hs' := Conversion.intros_names in
128 | Conversion.preprocess2 Hs';
129 | verit_bool_no_check_base_auto Hs';
130 | QInst.vauto
131 | ]) h)) in tac global.
132 |
133 | Tactic Notation "verit_no_check_orch" :=
134 | ltac2:(intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 ltac1:(local |-
135 | let Hs :=
136 | lazymatch local with
137 | | Some ?local' => Conversion.pose_hyps local' (@None unit)
138 | | None => constr:(@None unit)
139 | end
140 | in
141 | preprocess1 Hs;
142 | [ .. |
143 | let Hs' := Conversion.intros_names in
144 | Conversion.preprocess2 Hs';
145 | verit_bool_no_check_base_auto Hs';
146 | QInst.vauto
147 | ])).
148 |
149 | Tactic Notation "verit_bool_base_auto" constr(h) := verit_bool_base h; try (exact _).
150 |
151 | Tactic Notation "verit_bool" constr(h) :=
152 | let tac :=
153 | ltac2:(h |- Tactics.get_hyps_cont_ltac1 (ltac1:(h hs |-
154 | match hs with
155 | | Some ?hs => verit_bool_base_auto (Some (h, hs))
156 | | None => verit_bool_base_auto (Some h)
157 | end;
158 | QInst.vauto) h)) in tac h.
159 |
160 | Tactic Notation "verit_bool" :=
161 | ltac2:(Tactics.get_hyps_cont_ltac1 ltac1:(hs |- verit_bool_base_auto hs; QInst.vauto)).
162 |
163 | Tactic Notation "verit_orch" constr(global) :=
164 | let tac :=
165 | ltac2:(h |- intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 (ltac1:(h local |-
166 | let Hsglob := Conversion.pose_hyps h (@None unit) in
167 | let Hs :=
168 | lazymatch local with
169 | | Some ?local' => Conversion.pose_hyps local' Hsglob
170 | | None => constr:(Hsglob)
171 | end
172 | in
173 | preprocess1 Hs;
174 | [ .. |
175 | let Hs' := Conversion.intros_names in
176 | Conversion.preprocess2 Hs';
177 | verit_bool_base_auto Hs';
178 | QInst.vauto
179 | ]) h)) in tac global.
180 |
181 | Tactic Notation "verit_orch" :=
182 | ltac2:(intros; unfold is_true in *; Tactics.get_hyps_cont_ltac1 ltac1:(local |-
183 | let Hs :=
184 | lazymatch local with
185 | | Some ?local' => Conversion.pose_hyps local' (@None unit)
186 | | None => constr:(@None unit)
187 | end
188 | in
189 | preprocess1 Hs;
190 | [ .. |
191 | let Hs' := Conversion.intros_names in
192 | Conversion.preprocess2 Hs';
193 | verit_bool_base_auto Hs';
194 | QInst.vauto
195 | ])).
196 |
--------------------------------------------------------------------------------
/elpi/ref_elim_utils.elpi:
--------------------------------------------------------------------------------
1 | shorten std.{map}.
2 |
3 | % Checks if the input term contains a `sig` in its definition up to evaluation.
4 | pred sigfull i:term.
5 | pred sigfull_rec i:term.
6 |
7 | sigfull_rec ({{ @sig _ _ }}).
8 |
9 | sigfull_rec (fun _ T _) :-
10 | sigfull T.
11 | sigfull_rec (fun _ T F) :-
12 | pi x\ decl x _ T => sigfull (F x).
13 |
14 | sigfull_rec (let _ T _ _) :-
15 | sigfull T.
16 | sigfull_rec (let _ _ B _) :-
17 | sigfull B.
18 | sigfull_rec (let _ T _ F) :-
19 | pi x\ decl x _ T => sigfull (F x).
20 |
21 | sigfull_rec (prod _ T _) :-
22 | sigfull T.
23 | sigfull_rec (prod _ T F) :-
24 | pi x\ decl x _ T => sigfull (F x).
25 |
26 | sigfull_rec (app L) :- std.exists L sigfull.
27 |
28 | sigfull_rec (fix _ _ Ty _) :-
29 | sigfull Ty.
30 | sigfull_rec (fix _ _ Ty F) :-
31 | pi x\ decl x _ Ty => sigfull (F x).
32 |
33 | sigfull_rec (match T _ _) :-
34 | sigfull T.
35 | sigfull_rec (match _ Rty _) :-
36 | sigfull Rty.
37 | sigfull_rec (match _ _ B) :-
38 | std.exists B sigfull.
39 |
40 | sigfull_rec (uvar _ L) :- std.exists L sigfull.
41 |
42 | sigfull I :-
43 | coq.reduction.lazy.whd I Ir,
44 | sigfull_rec Ir.
45 |
46 | % Expand all the necessary subterms of `i` in order to reveal any `sig`.
47 | pred smart_sig_expand i:term o:term.
48 | pred sig_expand i:term o:term.
49 | pred sig_expand_rec i:term o:term.
50 |
51 | smart_sig_expand I O :-
52 | sigfull I, !,
53 | sig_expand I O.
54 | smart_sig_expand I I.
55 |
56 | sig_expand I O :-
57 | coq.reduction.lazy.whd I Ir,
58 | sig_expand_rec Ir O.
59 |
60 | % There probably is a more direct algorithm that simultaneously checks whether there is a `sig` inside the term and
61 | % expands. Chantal's idea: as we traverse the tree, remember which constructors we went through and rebuild then when
62 | % we find a `sig`. Another approach would be to understand how to use memoization
63 | sig_expand_rec (global _ as C) C :- !.
64 | sig_expand_rec (pglobal _ _ as C) C :- !.
65 | sig_expand_rec (sort _ as C) C :- !.
66 | sig_expand_rec (fun N T F) (fun N T1 F1) :- !,
67 | smart_sig_expand T T1, pi x\ decl x _ T => smart_sig_expand (F x) (F1 x).
68 | sig_expand_rec (let N T B F) (let N T1 B1 F1) :- !,
69 | smart_sig_expand T T1, smart_sig_expand B B1, pi x\ decl x _ T => smart_sig_expand (F x) (F1 x).
70 | sig_expand_rec (prod N T F) (prod N T1 F1) :- !,
71 | smart_sig_expand T T1, (pi x\ decl x _ T => smart_sig_expand (F x) (F1 x)).
72 | sig_expand_rec (app L) (app L1) :-
73 | std.map L smart_sig_expand L1.
74 | sig_expand_rec (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !,
75 | smart_sig_expand Ty Ty1, pi x\ decl x _ Ty => smart_sig_expand (F x) (F1 x).
76 | sig_expand_rec (match T Rty B) (match T1 Rty1 B1) :- !,
77 | smart_sig_expand T T1, smart_sig_expand Rty Rty1,
78 | std.map B smart_sig_expand B1.
79 | sig_expand_rec (primitive _ as C) C :- !.
80 | sig_expand_rec (uvar M L) W :- !,
81 | std.map L smart_sig_expand L1, coq.mk-app-uvar M L1 W.
82 | % when used in CHR rules
83 | sig_expand_rec (uvar X L) (uvar X L1) :-
84 | std.map L smart_sig_expand L1.
85 |
86 | % Checks if the input term contains `sig`, `proj1_sig` or `exist` in its definition up to evaluation.
87 | pred refinefull i:term.
88 | pred refinefull_rec i:term.
89 |
90 | refinefull_rec ({{ exist _ _ _ }}).
91 | refinefull_rec ({{ @sig _ _ }}).
92 | refinefull_rec ({{ @proj1_sig _ _ _ }}).
93 |
94 | refinefull_rec (fun _ T _) :- refinefull_rec T, !.
95 | refinefull_rec (fun _ T F) :-
96 | pi x\ decl x _ T =>
97 | refinefull_rec (F x), !.
98 |
99 | refinefull_rec (let _ T _ _) :-
100 | refinefull T, !.
101 | refinefull_rec (let _ _ B _) :-
102 | refinefull B, !.
103 | refinefull_rec (let _ T _ F) :-
104 | pi x\ decl x _ T => refinefull (F x), !.
105 |
106 | refinefull_rec (prod _ T _) :-
107 | refinefull T, !.
108 | refinefull_rec (prod _ T F) :-
109 | pi x\ decl x _ T => refinefull (F x), !.
110 |
111 | refinefull_rec (app L) :- !, std.exists L refinefull.
112 |
113 | refinefull_rec (fix _ _ Ty _) :-
114 | refinefull Ty, !.
115 | refinefull_rec (fix _ _ Ty F) :-
116 | pi x\ decl x _ Ty => refinefull (F x), !.
117 |
118 | refinefull_rec (match T _ _) :- refinefull T, !.
119 | refinefull_rec (match _ Rty _) :- refinefull Rty, !.
120 | refinefull_rec (match _ _ B) :- !,
121 | std.exists B refinefull.
122 |
123 | refinefull_rec (uvar _ L) :- std.exists L refinefull, !.
124 |
125 | refinefull I :-
126 | coq.reduction.lazy.whd I Ir,
127 | refinefull_rec Ir.
128 |
129 | % Remove all refinement types in the input term. `sig A P` is replaced by `A`, `proj1_sig x` is replaced by `x` and
130 | % `exist p h` is replaced by p. Works up to delta reduction.
131 | pred replace i:term, o:term.
132 | replace ({{ exist _ lp:P _ }}) P' :- !, replace P P'.
133 | replace ({{ @sig lp:A _ }}) A' :- !, replace A A'.
134 | replace ({{ @proj1_sig _ _ lp:X }}) X' :- !, replace X X'.
135 | replace (fun N T F) (fun N T1 F1) :- !,
136 | % We should add another variable and figure out which rule to add between the two introduced variables
137 | replace T T1, pi x\ decl x _ T => replace (F x) (F1 x).
138 | replace X Y :- name X, !, X = Y, !. % avoid loading "replace x x" at binders
139 | replace (global _ as C) C1 :-
140 | refinefull C, !,
141 | @redflags! coq.redflags.delta => coq.reduction.lazy.whd C C2,
142 | replace C2 C1.
143 | replace (global _ as C) C.
144 | replace (pglobal _ _ as C) C1 :-
145 | refinefull C, !,
146 | @redflags! coq.redflags.delta => coq.reduction.lazy.whd C C2,
147 | replace C2 C1.
148 | replace (pglobal _ _ as C) C :- !.
149 | replace (sort _ as C) C :- !.
150 | replace (let N T B F) (let N T1 B1 F1) :- !,
151 | replace T T1, replace B B1, pi x\ decl x _ T => replace (F x) (F1 x).
152 | replace (prod N T F) (prod N T1 F1) :- !,
153 | replace T T1, (pi x\ decl x _ T => replace (F x) (F1 x)).
154 | replace (app L) (app L1) :- !, map L replace L1.
155 | replace (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !,
156 | replace Ty Ty1, pi x\ decl x _ Ty => replace (F x) (F1 x).
157 | replace (match T Rty B) (match T1 Rty1 B1) :- !,
158 | replace T T1, replace Rty Rty1, map B replace B1.
159 | replace (primitive _ as C) C :- !.
160 | replace (uvar M L as X) W :- var X, !, map L replace L1, coq.mk-app-uvar M L1 W.
161 | % when used in CHR rules
162 | replace (uvar X L) (uvar X L1) :- map L replace L1.
163 |
--------------------------------------------------------------------------------
/orchestrator/Sniper.v:
--------------------------------------------------------------------------------
1 | From SMTCoq Require Export SMTCoq.
2 |
3 | From Ltac2 Require Import Ltac2.
4 |
5 | Require Import ZArith.
6 | Require Import PArith.BinPos.
7 | Require Import NArith.BinNatDef.
8 |
9 | From SMTCoq Require Import SMT_classes SMT_classes_instances BVList FArray.
10 |
11 | From Trakt Require Import Trakt.
12 |
13 | From Sniper Require Import Transfos.
14 |
15 | Require Import triggers_tactics.
16 | Require Import run_tactic.
17 | Require Import triggers.
18 | Require Import printer.
19 | Require Import orchestrator.
20 | Require Import filters.
21 | Require Import verit.
22 |
23 | Require Import tree.
24 |
25 | Local Open Scope bs_scope.
26 |
27 | Ltac revert_all :=
28 | repeat match goal with
29 | | H : _ |- _ => try revert H
30 | end.
31 |
32 | Ltac my_reflexivity t := assert_refl t.
33 |
34 | Ltac my_unfold_refl H := unfold_refl H.
35 |
36 | Ltac my_unfold_in H t := unfold_in H t.
37 |
38 | (* Ltac my_trakt_bool := revert_all ; trakt bool ; intros. *)
39 |
40 | Ltac my_higher_order_equalities H := expand_hyp H ; clear H.
41 |
42 | Ltac my_higher_order := prenex_higher_order.
43 |
44 | Ltac my_fixpoints H := eliminate_fix_hyp H.
45 |
46 | Ltac my_pattern_matching H := try (eliminate_dependent_pattern_matching H).
47 |
48 | Ltac my_anonymous_function f := anonymous_fun f.
49 |
50 | Ltac my_algebraic_types t := try (interp_alg_types t).
51 |
52 | Ltac my_gen_principle t :=
53 | pose_gen_statement t.
54 |
55 | Ltac my_gen_principle_temporary := ltac2:(get_projs_in_variables '(Z, bool, True, False, positive, and, or, Init.Peano.le,
56 | @CompDec, Comparable, EqbType, Inhabited, OrderedType.Compare)).
57 |
58 | Ltac my_polymorphism_state :=
59 | ltac2:(Notations.do0 max_quantifiers elimination_polymorphism) ;
60 | clear_prenex_poly_hyps_in_context.
61 |
62 |
63 | Ltac my_polymorphism := elimination_polymorphism_exhaustive unit.
64 |
65 | Ltac my_add_compdec t := add_compdecs_terms t.
66 |
67 | Ltac my_fold_local_def_in_hyp_goal H t := fold_local_def_in_hyp_goal H t.
68 |
69 | Ltac my_pose_case := pose_case.
70 |
71 | Ltac my_elim_refinement_types := elim_refinement_types.
72 |
73 | Ltac2 trigger_generation_principle := TAlways.
74 |
75 | (* Ltac2 trigger_anonymous_funs := TAlways. *)
76 |
77 | Ltac2 trigger_higher_order :=
78 | TAlways.
79 |
80 | Ltac2 scope_verbos v := orchestrator 5
81 | { all_tacs := [
82 | ((trigger_elim_refinement_types (), false, None), "my_elim_refinement_types", filter_elim_refinement_types ());
83 | ((trigger_pose_case (), false, None), "my_pose_case", trivial_filter);
84 | ((trigger_anonymous_fun (), false, None), "my_anonymous_function", trivial_filter);
85 | ((trigger_higher_order, false, None), "my_higher_order", trivial_filter) ;
86 | ((trigger_reflexivity (), false, None), "my_reflexivity", filter_reflexivity ());
87 | ((trigger_unfold_reflexivity (), false, None), "my_unfold_refl", filter_unfold_reflexivity ());
88 | ((trigger_unfold_in (), false, None), "my_unfold_in", filter_unfold_in ());
89 | ((trigger_higher_order_equalities, false, None), "my_higher_order_equalities", trivial_filter) ;
90 | ((trigger_fixpoints, false, None), "my_fixpoints", trivial_filter) ;
91 | ((trigger_pattern_matching, false, None), "my_pattern_matching", trivial_filter);
92 | ((trigger_algebraic_types, false, None), "my_algebraic_types", filter_algebraic_types ()) ;
93 | ((trigger_generation_principle, false, None), "my_gen_principle_temporary", trivial_filter) ;
94 | ((trigger_polymorphism (), true, None), "my_polymorphism_state", trivial_filter) ;
95 | ((trigger_fold_local_def_in_hyp (), false, None), "my_fold_local_def_in_hyp_goal", trivial_filter);
96 | ((trigger_add_compdecs (), false, Some (2, 2)), "my_add_compdec", filter_add_compdecs ()) ]}
97 | { already_triggered := [] } v.
98 |
99 | Ltac2 scope () := scope_verbos Nothing.
100 |
101 | Ltac2 scope_info () := scope_verbos Info.
102 |
103 | Ltac2 scope_debug () := scope_verbos Debug.
104 |
105 | Ltac2 scope_full () := scope_verbos Full.
106 |
107 | Ltac2 scope2_verbos v := orchestrator 5
108 | { all_tacs :=
109 | [((trigger_pose_case (), false, None), "my_pose_case", trivial_filter);
110 | ((trigger_anonymous_fun (), false, None), "my_anonymous_function", trivial_filter) ;
111 | ((trigger_higher_order, false, None), "my_higher_order", trivial_filter) ;
112 | ((trigger_reflexivity (), false, None), "my_reflexivity", filter_reflexivity ());
113 | ((trigger_unfold_reflexivity (), false, None), "my_unfold_refl", trivial_filter);
114 | ((trigger_higher_order_equalities, false, None), "my_higher_order_equalities", trivial_filter);
115 | ((trigger_fixpoints, false, None), "my_fixpoints", trivial_filter);
116 | ((trigger_pattern_matching, false, None), "my_pattern_matching", trivial_filter);
117 | ((trigger_algebraic_types, false, None), "my_algebraic_types", filter_algebraic_types ());
118 | ((trigger_generation_principle, false, None), "my_gen_principle_temporary", trivial_filter) ;
119 | ((trigger_fold_local_def_in_hyp (), false, None), "my_fold_local_def_in_hyp_goal", trivial_filter);
120 | ((trigger_polymorphism (), false, Some (2, 2)), "my_polymorphism", trivial_filter);
121 | ((trigger_add_compdecs (), false, None), "my_add_compdec", filter_add_compdecs ()) ] }
122 | { already_triggered := [] } v.
123 |
124 | Ltac2 scope2 () := scope2_verbos Nothing.
125 |
126 | Ltac2 scope2_info () := scope2_verbos Info.
127 |
128 | Ltac2 scope2_debug () := scope2_verbos Debug.
129 |
130 | Ltac2 scope2_full () := scope2_verbos Full.
131 |
132 | Tactic Notation "scope" := ltac2:(Control.enter (fun () => intros; scope ())).
133 |
134 | Tactic Notation "scope_info" := ltac2:(Control.enter (fun () => intros; scope_info ())).
135 |
136 | Tactic Notation "scope_full" := ltac2:(Control.enter (fun () => intros; scope_full ())).
137 |
138 | Tactic Notation "scope2" := ltac2:(Control.enter (fun () => intros ; scope2 ())).
139 |
140 | Tactic Notation "snipe_no_check" :=
141 | ltac2:(Control.enter (fun () => intros; scope (); ltac1:(verit_no_check_orch))).
142 |
143 | Tactic Notation "snipe2_no_check" :=
144 | ltac2:(Control.enter (fun () => intros; scope2 (); ltac1:(verit_no_check_orch))).
145 |
146 | Tactic Notation "snipe" :=
147 | ltac2:(Control.enter (fun () => intros; scope (); ltac1:(verit_orch))).
148 |
149 | Tactic Notation "snipe2" :=
150 | ltac2:(Control.enter (fun () => intros; scope2 (); ltac1:(verit_orch))).
151 |
152 |
--------------------------------------------------------------------------------
/theories/deciderel/examples.v:
--------------------------------------------------------------------------------
1 | From MetaCoq.Template Require Import All.
2 | Unset MetaCoq Strict Unquote Universe Mode.
3 | From SMTCoq Require Import SMTCoq.
4 | From Sniper.orchestrator Require Import Sniper.
5 | Import MCMonadNotation.
6 | Require Import List.
7 | Import ListNotations.
8 | Require Import String.
9 | Require Import ZArith.
10 | Require Import Bool.
11 | Require Import proof_correctness.
12 | Import Decide. (* We import the module containing the main command *)
13 |
14 |
15 | Section Examples.
16 | (* A first example :
17 | - mem n l is true whenever n belongs to l
18 | - the plugin linearize the type of MemMatch because n is mentionned twice (and
19 | we want to define a function by pattern matching so we need fresh pattern variables)
20 | - then it generates an equivalent boolean fixpoint defined by pattern matching
21 | on the list
22 | - it also generates the correctness lemma and uses a tactic based on
23 | heuristics to inhabitate it
24 | *)
25 | Inductive mem : Z -> list Z -> Prop :=
26 | MemMatch : forall (xs : list Z) (n : Z), mem n (n :: xs)
27 | | MemRecur : forall (xs : list Z) (n n' : Z), mem n xs -> mem n (n' :: xs).
28 |
29 | (* running the main command *)
30 | MetaCoq Run (decide mem []).
31 | Next Obligation.
32 | (* the proof can be automatized thanks to tactics :
33 | it generates a proof term decidable_proof that we use here
34 | *)
35 | apply decidable_proof. Qed.
36 |
37 | (* Another parametric example :
38 | the predicate smaller_than_all holds between a
39 | natural number and a list of integers whenever the term is
40 | smaller than all the elements of the list
41 | Here, we need to pass the quotations of Z.le, the boolean version of Z.le and the proof
42 | of equivalence as arguments to the command
43 | *)
44 |
45 | Inductive smaller_than_all : Z -> list Z -> Prop :=
46 | | sNil : forall n, smaller_than_all n nil
47 | | sCons : forall n n' l, BinInt.Z.le n n' -> smaller_than_all n l -> smaller_than_all n (n' :: l).
48 |
49 |
50 | (* Here the proof should be done manually because we need to use an
51 | intermediate lemma Z.leb_le *)
52 | MetaCoq Run (decide (smaller_than_all) [(<%Z.le%>, <%Z.leb%>, <%Z.leb_le%>)]).
53 | Next Obligation.
54 | split.
55 | - intros H1. induction H1; auto.
56 | simpl. apply Z.leb_le in H. rewrite H. rewrite IHsmaller_than_all. auto.
57 | - intros H1. induction H0. constructor. simpl in H1;
58 | elim_and_and_or. constructor. apply Z.leb_le. assumption. apply IHlist. assumption. Qed.
59 |
60 |
61 | (* Example of proof automation with snipe and the decided predicates *)
62 |
63 | Lemma mem_imp_not_nil_fail : (forall (n : Z) (l : list Z),
64 | mem n l -> l <> []).
65 | Proof. Fail snipe. (* snipe does not know about inductive predicates *) Abort.
66 |
67 | (* We add to Trakt's database the information that mem_linear_decidable
68 | is a decidable version of mem and the proof of this fact
69 | and snipe will use it to reason about the boolean function instead
70 | of the predicate *)
71 |
72 | Trakt Add Relation 2 (mem) (mem_linear_decidable) (decidable_lemma).
73 |
74 | Require Import elimination_pattern_matching.
75 |
76 | Lemma mem_imp_not_nil : (forall (n : Z) (l : list Z),
77 | mem n l -> l <> []).
78 | Proof. trakt bool; snipe_no_check. Qed.
79 |
80 | (* We do the same for smaller_than_all *)
81 | Trakt Add Relation 2 (smaller_than_all) (smaller_than_all_decidable) (decidable_lemma0).
82 |
83 | Lemma smaller_than_all_nil : (forall (z: Z), smaller_than_all z nil).
84 | Proof. trakt bool; snipe_no_check. Qed.
85 |
86 | (* An example with an inductive type which takes a parameter:
87 | all the elements of the list are smaller than the one given as parameters *)
88 |
89 | Inductive elt_smaller_than (n : nat) : list nat -> Prop :=
90 | | smThanNil : elt_smaller_than n nil
91 | | smThanCons : forall (n' : nat) (l : list nat), Nat.le n' n -> elt_smaller_than n l ->
92 | elt_smaller_than n (n' :: l).
93 |
94 | MetaCoq Run (decide (elt_smaller_than) [(<%Nat.le%>, <%Nat.leb%>, <%Nat.leb_le%>)]).
95 | Next Obligation.
96 | split.
97 | - intro Hyp. induction Hyp. auto. simpl. rewrite IHHyp. simpl. rewrite Nat.leb_le.
98 | assumption.
99 | - intros Hyp. induction H. constructor. constructor; simpl in Hyp;
100 | elim_and_and_or. apply Nat.leb_le. assumption. apply IHlist. assumption. Qed.
101 |
102 | Trakt Add Relation 2 (elt_smaller_than) (elt_smaller_than_decidable) (decidable_lemma1).
103 |
104 | (* Lemma smaller_than_mem :
105 | forall (n n' : Z) (l : list Z), smaller_than_all n l -> mem n' l -> Z.le n n'.
106 | Proof.
107 | intros n n' l H1 H2. induction l; snipe. Qed. TODO silent simplifications veriT *)
108 |
109 | (* An example with instantiated polymorphic types :
110 | the inductive says that second list is smaller than the second one
111 | We do not handle polymorphism (with an hypothesis of decidable equality whenever it is needed)
112 | for now because Trakt does not either
113 | *)
114 |
115 | Inductive smaller_list {A : Type} : list A -> list A -> Prop :=
116 | | smNil : forall l, smaller_list [] l
117 | | smCons: forall l l' x x', smaller_list l l' -> smaller_list (x :: l) (x' :: l').
118 |
119 | MetaCoq Run (decide (@smaller_list nat) []).
120 | Next Obligation.
121 | split.
122 | - revert_all ; ltac2:(completeness_auto_npars 'smaller_list_decidable 0).
123 | - revert_all. induction H. constructor. destruct H0 eqn:E; intro H1; inversion H1.
124 | constructor. apply IHlist. assumption. Qed.
125 |
126 | Variable A : Type.
127 | Variable HA : CompDec A. (* commenting this line makes the command fail because of
128 | universe instances *)
129 |
130 | MetaCoq Run (decide (@Add) []).
131 | Next Obligation. intros A0 H a l1 l2.
132 | split.
133 | - intro H1. induction H1. destruct l; simpl. rewrite eqb_of_compdec_reflexive. auto.
134 | rewrite eqb_of_compdec_reflexive. rewrite eqb_of_compdec_reflexive. auto.
135 | simpl. rewrite eqb_of_compdec_reflexive. rewrite IHAdd. rewrite orb_comm.
136 | auto.
137 | - revert l2. induction l1. intro l2. intro H1.
138 | destruct l2. simpl in H1. inversion H1.
139 | simpl in H1. elim_and_and_or; elim_eq. unfold is_true in H0.
140 | unfold is_true in H1. rewrite <- compdec_eq_eqb in H1. rewrite <- compdec_eq_eqb in H0.
141 | subst. constructor.
142 | intros. simpl in H0. destruct l2 ; simpl in *.
143 | inversion H0. elim_and_and_or; unfold is_true in * ; elim_eq. subst. constructor.
144 | subst. constructor. apply IHl1. assumption.
145 | Qed.
146 |
147 | (* Trakt does not handle polymorphism yet but Deciderel deals with polymorphism with
148 | CompDec hypothesis *)
149 |
150 | End Examples.
151 |
152 |
153 |
--------------------------------------------------------------------------------
/theories/tree.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 |
13 | Require Import SMTCoq.SMTCoq.
14 | Require Import Bool OrderedType OrderedTypeEx.
15 |
16 | Section tree.
17 |
18 | Variable A : Type.
19 |
20 | Inductive tree : Type :=
21 | | Leaf : tree
22 | | Node : tree -> A -> tree -> tree.
23 |
24 |
25 |
26 | Definition is_empty (t : tree) :=
27 | match t with
28 | | Leaf => true
29 | | _ => false
30 | end.
31 |
32 |
33 | Fixpoint rev_elements_aux acc s :=
34 | match s with
35 | | Leaf => acc
36 | | Node l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
37 | end.
38 |
39 | Definition rev_elements := rev_elements_aux nil.
40 |
41 | Fixpoint cardinal (s : tree) : nat :=
42 | match s with
43 | | Leaf => 0
44 | | Node l _ r => S (cardinal l + cardinal r)
45 | end.
46 |
47 | Fixpoint maxdepth s :=
48 | match s with
49 | | Leaf => 0
50 | | Node l _ r => S (max (maxdepth l) (maxdepth r))
51 | end.
52 |
53 |
54 |
55 |
56 | Context `{HA : CompDec A}.
57 |
58 |
59 | Fixpoint tree_eqb (xs ys : tree) : bool :=
60 | match xs, ys with
61 | | Leaf, Leaf => true
62 | | Node t1 a t2, Node u1 b u2 => @eqb_of_compdec _ HA a b && tree_eqb t1 u1 && tree_eqb t2 u2
63 | | _, _ => false
64 | end.
65 |
66 |
67 |
68 |
69 | Lemma tree_eqb_spec : forall (t t' : tree), tree_eqb t t' = true <-> t = t'.
70 | Proof.
71 | induction t as [ |t1 IHt1 a t2 IHt2]; intros [ |t1' b t2']; simpl; split; try discriminate; auto.
72 | - rewrite andb_true_iff. intros [H1 H2].
73 | destruct (eqb_of_compdec HA a b) eqn:E. rewrite Typ.eqb_compdec_spec in E.
74 | simpl in H1. rewrite IHt1 in H1. rewrite IHt2 in H2. now subst.
75 | inversion H1.
76 | - intros H. inversion H as [H1]. rewrite andb_true_iff; split.
77 | + rewrite andb_true_iff; split. now rewrite Typ.eqb_compdec_spec.
78 | * subst t1'. now rewrite IHt1.
79 | + subst t2'. now rewrite IHt2.
80 | Qed.
81 |
82 | Instance tree_eqbtype : EqbType (tree) := Build_EqbType _ _ tree_eqb_spec.
83 |
84 | Fixpoint tree_lt (t1 t2 : tree) : Prop :=
85 | match t1, t2 with
86 | | Leaf, Leaf => False
87 | | Leaf, Node _ _ _ => True
88 | | Node _ _ _, Leaf => False
89 | | Node t1 a t2, Node u1 b u2 => (lt a b) \/ (@eqb_of_compdec _ HA a b /\ tree_lt t1 u1)
90 | \/ (tree_eqb t1 u1 /\ @eqb_of_compdec _ HA a b /\ tree_lt t2 u2)
91 | end.
92 |
93 |
94 | Lemma tree_lt_trans : forall (x y z : tree),
95 | tree_lt x y -> tree_lt y z -> tree_lt x z.
96 | Proof.
97 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2] [ |z1 c z2]; simpl; auto.
98 | - inversion 1.
99 | - intros [H1a | H1b] [H2a | H2b].
100 | + left; eapply lt_trans; eauto.
101 | + left. destruct H2b as [H2b | H2c].
102 | * destruct H2b as [H2c H2d]. unfold is_true in H2c. rewrite Typ.eqb_compdec_spec in H2c.
103 | subst c. assumption.
104 | * destruct H2c as [H2c [H2d H2e]]. unfold is_true in H2d. rewrite Typ.eqb_compdec_spec in H2d.
105 | subst c. assumption.
106 | + left. destruct H1b as [ [H1b H1c] | [H1d [H1e H1f]]]. unfold is_true in H1b. rewrite Typ.eqb_compdec_spec in H1b.
107 | now subst b. unfold is_true in H1e. rewrite Typ.eqb_compdec_spec in H1e. now subst b.
108 | + right. destruct H1b as [ [H1c H1d] | [H1e [H1f H1g]]]. destruct H2b as [ [H2c H2d] | [H2e [H2f H2g]]]. left. split.
109 |
110 | * unfold is_true in H1c. rewrite Typ.eqb_compdec_spec in H1c. now subst a.
111 | * apply IHx1 with y1. assumption. assumption.
112 | * left. split. unfold is_true in H2f. rewrite Typ.eqb_compdec_spec in H2f. now subst b. unfold is_true in H2e.
113 | rewrite tree_eqb_spec in H2e. subst. assumption.
114 | * destruct H2b as [ [H2c H2d] | [H2e [H2f H2g]]].
115 | { left. unfold is_true in H1f. rewrite Typ.eqb_compdec_spec in H1f. subst.
116 | split. assumption. unfold is_true in H1e. rewrite tree_eqb_spec in H1e. subst. assumption. }
117 | right. unfold is_true in H1e. rewrite tree_eqb_spec in H1e. subst. split. assumption.
118 | unfold is_true in H1f. rewrite Typ.eqb_compdec_spec in H1f. subst b. split. assumption.
119 | apply IHx2 with y2; easy.
120 | Qed.
121 |
122 |
123 |
124 | Lemma tree_lt_not_eq : forall (x y : tree), tree_lt x y -> x <> y.
125 | Proof.
126 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2]; simpl; auto.
127 | - discriminate.
128 | - intros [H1 |[ [H1 H2] | [H3 [H4 H5]]]]; intros H; inversion H; subst.
129 | + apply lt_not_eq in H1. auto.
130 | + eapply IHx1; eauto.
131 | + apply IHx2 in H5. auto.
132 | Qed.
133 |
134 |
135 | Instance tree_ord : OrdType (tree) :=
136 | Build_OrdType _ _ tree_lt_trans tree_lt_not_eq.
137 |
138 | Definition tree_compare : forall (x y : tree), Compare tree_lt Logic.eq x y.
139 | Proof.
140 | induction x as [ |x1 IHx1 a x2 IHx2]; intros [ |y1 b y2]; simpl.
141 | - now apply EQ.
142 | - now apply LT.
143 | - now apply GT.
144 | - specialize (IHx1 y1). case_eq (compare a b); intros l H.
145 |
146 | + apply LT. simpl. now left.
147 | + destruct IHx1 as [H1 | H2 | H3].
148 | * apply LT. simpl. right. left. split; auto. now apply Typ.eqb_compdec_spec.
149 | * specialize (IHx2 y2). destruct IHx2 as [H4 | H5 | H6]. apply LT. subst.
150 | simpl. right. right. split. apply tree_eqb_spec. reflexivity.
151 | split. apply Typ.eqb_compdec_spec. reflexivity. assumption. apply EQ. subst. reflexivity.
152 | apply GT. simpl. right. right. split; auto. now apply tree_eqb_spec. split.
153 | now apply Typ.eqb_compdec_spec. easy.
154 | * apply GT. simpl. right. left. split. apply Typ.eqb_compdec_spec. subst. reflexivity.
155 | assumption.
156 | + specialize (IHx2 y2). destruct IHx2 as [H4 | H5 | H6].
157 | * apply GT. simpl. left. assumption.
158 | * apply GT. simpl. left. assumption.
159 | * apply GT. simpl. left. assumption.
160 | Defined.
161 |
162 |
163 | Instance tree_comp : Comparable (tree) := Build_Comparable _ _ tree_compare.
164 |
165 |
166 | Instance tree_inh : Inhabited (tree) := Build_Inhabited _ Leaf.
167 |
168 |
169 | Instance tree_compdec : CompDec (tree) := {|
170 | Eqb := tree_eqbtype;
171 | Ordered := tree_ord;
172 | Comp := tree_comp;
173 | Inh := tree_inh
174 | |}.
175 |
176 |
177 |
178 |
179 | End tree.
180 |
181 | Arguments tree {_}.
182 | Arguments Leaf {_}.
183 | Arguments Node {_} _ _ _.
184 | Arguments is_empty {_} _.
185 |
186 |
187 |
188 | #[export] Hint Resolve tree_compdec : typeclass_instances.
189 |
--------------------------------------------------------------------------------
/elpi/eliminate_fix.elpi:
--------------------------------------------------------------------------------
1 | % returns the recursive argument of a fixpoint
2 | pred index_struct_argument i:term, o:int.
3 | index_struct_argument (fix _ N _ _) N.
4 | index_struct_argument (fun _ _ F) N1 :-
5 | pi x\ index_struct_argument (F x) N, % get the body and recurse
6 | N1 is N + 1.
7 |
8 | pred args_before_fix i: term, o: int.
9 | args_before_fix (global (const C)) I :- coq.env.const C (some Bo) _, args_before_fix Bo I.
10 | args_before_fix (fun _ _ F) N1 :-
11 | pi x\ args_before_fix (F x) N,
12 | N1 is N + 1.
13 | args_before_fix (fix _ _ _ _) 0.
14 |
15 | % builds the equality between two terms
16 | % (applied to the same list of terms)
17 | pred mkEq_aux i: term, i: term, i: term, i: list term, o: term.
18 | mkEq_aux T1 T2 (prod Na Ty F) L (prod Na Ty R) :- pi x\ decl x Na Ty =>
19 | mkEq_aux T1 T2 (F x) [x | L] (R x).
20 | mkEq_aux T1 T2 T3 L (app [ {{ @eq }}, T3, app [T1|L'], app [T2| L'] ]) :- std.rev L L'.
21 |
22 | pred mkEq i: term, i: term, o: term.
23 | mkEq T1 T2 R :- coq.typecheck T2 T3 ok, mkEq_aux T1 T2 T3 [] R.
24 |
25 | pred nb_prod i: term, o: int.
26 | nb_prod (prod Na Ty F) N' :- !, pi x\ decl x Na Ty => nb_prod (F x) N, N' is N + 1.
27 | nb_prod _ 0.
28 |
29 | pred mk_napp i: term, i: int, o: term.
30 | mk_napp T1 0 T1 :- !.
31 | mk_napp T1 N' (app [T2, _]) :- N is N' - 1, mk_napp T1 N T2.
32 |
33 | pred subst_anon_fix i: term, i: term, o: term.
34 | subst_anon_fix (fun Na Ty F) T2 (fun Na Ty R) :- pi x\ decl x Na Ty =>
35 | subst_anon_fix (F x) T2 (R x).
36 | subst_anon_fix (fix Na I Ty F) T2 T3 :-
37 | coq.typecheck (fix Na I Ty F) TyF ok,
38 | args_before_fix T2 Nb, mk_napp T2 Nb T2',
39 | @holes! =>
40 | coq.elaborate-skeleton (F T2') TyF T3 ok.
41 |
42 | pred is_fix i: term.
43 | is_fix (fix _ _ _ _).
44 | is_fix (fun N Ty F) :- pi x\ decl x N Ty => is_fix (F x).
45 | is_fix T :- whd1 T T', is_fix T'.
46 | is_fix (app [T|_L]) :- is_fix T.
47 |
48 | pred recover_types i: (list term), o: (list (pair term term)).
49 | recover_types [X | XS] [pr X Ty | R] :- coq.typecheck X Ty ok,
50 | recover_types XS R.
51 | recover_types [] [].
52 |
53 | type abs term.
54 |
55 | pred bind i: bool, i: term, i: term, o: term.
56 | bind tt T Ty T1 :- T1 = {{ fun (x : lp:Ty) => lp:(B x) }},
57 | pi x\ (copy (abs) x :- !) => bind ff T Ty (B x).
58 | bind ff T _ T1 :- copy T T1.
59 |
60 | pred abstract i: term, i: list (pair term term), o: term.
61 | abstract T [pr X Ty | XS] R :- (copy X abs :- !) => copy T T1,
62 | bind tt T1 Ty T2,
63 | abstract T2 XS R.
64 | abstract T [] T.
65 |
66 | % all the subterms which are fixpoints of a function except its toplevel fix
67 | pred subterms_fix_fun i: term, o: (list term).
68 | subterms_fix_fun (fun N Ty F) R :- pi x\ decl x N Ty => subterms_fix_fun (F x) R.
69 | subterms_fix_fun (fix N _ Ty F) R :- pi x\ decl x N Ty => subterms_fix (F x) R.
70 |
71 | %warning: does not work with not real fixpoints (there must be a recursive call)
72 | pred subterms_fix i: term, o: (list term).
73 | subterms_fix (sort _U) [] :- !.
74 | subterms_fix (fun N Ty F) R :- !,
75 | subterms_fix Ty R1, pi x\ decl x N Ty => subterms_fix (F x) R2,
76 | std.append R1 R2 R.
77 | subterms_fix (prod N Ty F) R :- !,
78 | subterms_fix Ty R1, pi x\ decl x N Ty =>
79 | subterms_fix (F x) R2,
80 | std.append R1 R2 R.
81 | subterms_fix (app L) R :- !,
82 | std.map L subterms_fix R',
83 | std.flatten R' R.
84 | subterms_fix (global _G) [] :- !.
85 | subterms_fix (let N Ty V F) R :- !,
86 | subterms_fix Ty R1, subterms_fix V R2, pi x\ def x N Ty V => subterms_fix (F x) R3,
87 | std.append R1 R2 R12,
88 | std.append R12 R3 R.
89 | subterms_fix (match T U L) R :- !,
90 | subterms_fix T R1, subterms_fix U R2, std.append R1 R2 R12,
91 | std.map L subterms_fix R3,
92 | std.flatten R3 R',
93 | std.append R12 R' R.
94 | subterms_fix ((fix Na _I Ty F) as Fix) [Res|R] :-
95 | names Nms, std.filter Nms (x\ occurs x Fix) Nms',
96 | std.rev Nms' Nmsrev, recover_types Nmsrev NTy,
97 | abstract Fix NTy Res, !,
98 | subterms_fix Ty R1, pi x\ decl x Na Ty => subterms_fix (F x) R2,
99 | std.append R1 R2 R.
100 | subterms_fix _T [].
101 |
102 | pred subterms_glob_const i: term, o: (list term).
103 | subterms_glob_const (sort _U) [] :- !.
104 | subterms_glob_const (fun N Ty F) R :- !,
105 | subterms_glob_const Ty R1, pi x\ decl x N Ty => subterms_glob_const (F x) R2,
106 | std.append R1 R2 R.
107 | subterms_glob_const (prod N Ty F) R :- !,
108 | subterms_glob_const Ty R1, pi x\ decl x N Ty => subterms_glob_const (F x) R2,
109 | std.append R1 R2 R.
110 | subterms_glob_const (app L) R :- !,
111 | std.map L subterms_glob_const R',
112 | std.flatten R' R.
113 | subterms_glob_const (global (const G)) [global (const G)].
114 | subterms_glob_const (let N Ty V F) R :- !,
115 | subterms Ty R1, subterms V R2, pi x\ def x N Ty V => subterms_glob_const (F x) R3,
116 | std.append R1 R2 R12,
117 | std.append R12 R3 R.
118 | subterms_glob_const (match T U L) R :- !,
119 | subterms_glob_const T R1, subterms_glob_const U R2, std.append R1 R2 R12,
120 | std.map L subterms_glob_const R3,
121 | std.flatten R3 R',
122 | std.append R12 R' R.
123 | subterms_glob_const (fix Na _ Ty F) R :- !,
124 | subterms_glob_const Ty R1, pi x\ decl x Na Ty => subterms_glob_const (F x) R2,
125 | std.append R1 R2 R.
126 | subterms_glob_const _ [].
127 |
128 | pred globals_const_or_def_in_goal i: goal-ctx, o: (list term).
129 | globals_const_or_def_in_goal [(decl _ _ X)| L] L1 :- subterms_glob_const X L',
130 | globals_const_or_def_in_goal L L'', std.append L' L'' L1.
131 | globals_const_or_def_in_goal [(def _X0 _ _Ty X)| L] L1 :- subterms_glob_const X L',
132 | globals_const_or_def_in_goal L L'', std.append L' L'' L1.
133 | globals_const_or_def_in_goal [] [].
134 |
135 | pred abstract_unify_aux i: term, i: term, i: term.
136 | abstract_unify_aux (fun _ _ F1) (fun Na Ty F2) (prod _Na Ty F3) :- !,
137 | pi x\ decl x Na Ty =>
138 | abstract_unify_aux (F1 _) (F2 _) (F3 x).
139 | abstract_unify_aux (fun _Na _Ty F1) T2 T3 :- !,
140 | abstract_unify_aux (F1 _) T2 T3.
141 | abstract_unify_aux T1 (fun _ _ F2) (prod Na Ty F3) :- !,
142 | pi x\ decl x Na Ty =>
143 | abstract_unify_aux T1 (F2 _) (F3 x).
144 | abstract_unify_aux T1 T2 T3 :- @holes! => !,
145 | coq.elaborate-skeleton T1 T3 T1' ok, coq.elaborate-skeleton T2 T3 T2' ok,
146 | coq.unify-leq T1' T2' ok.
147 |
148 | pred abstract_unify i: term, i: term.
149 | abstract_unify T1 T2 :- coq.typecheck T2 T3 ok, whd1 T1 T1', abstract_unify_aux T1' T2 T3.
150 |
151 | % if we have a term of the form forall x1 ... xn, t x1 ... xn = u x1 ... xn
152 | % and another one of the form forall y1 ... yn, u y1 ... yn = v y1 ... xn,
153 | % returns forall x1 ... xn, t x1 ... xn = v y1 ... yn
154 | pred setoid_rewrite i: term, i: term, o: term.
155 | setoid_rewrite (prod Na Ty F) (prod _Na' _Ty' G) (prod Na Ty R) :- pi x\ decl x Na Ty =>
156 | setoid_rewrite (F x) (G x) (R x).
157 | setoid_rewrite (app [{{@eq}}, Ty, T, U]) (app [{{@eq}}, _, U, V]) (app [{{@eq}}, Ty, T, V]).
--------------------------------------------------------------------------------
/elpi/utilities.elpi:
--------------------------------------------------------------------------------
1 | % the type term is extended by one constructor, the position in the local context
2 | type pos_ctx int -> term.
3 |
4 | pred pos_ctx_to_var i: goal-ctx, i: term, o: term.
5 | pos_ctx_to_var Ctx (pos_ctx N) X :- nth N Ctx (decl X _ _).
6 | pos_ctx_to_var Ctx (pos_ctx N) X :- nth N Ctx (def X _ _ _).
7 | pos_ctx_to_var Ctx (app L) (app X) :- std.map L (pos_ctx_to_var Ctx) X.
8 | pos_ctx_to_var _ T T.
9 |
10 | pred var_to_pos_ctx i: goal-ctx, i: term, o: term.
11 | var_to_pos_ctx Ctx X (pos_ctx N) :- nth N Ctx (decl X _ _).
12 | var_to_pos_ctx Ctx X (pos_ctx N) :- nth N Ctx (def X _ _ _).
13 | var_to_pos_ctx Ctx (app L) (app X) :- std.map L (var_to_pos_ctx Ctx) X.
14 | var_to_pos_ctx _ T T.
15 |
16 | % version with the integer representing the position in the context already given and with two outputs
17 | pred var_pos_ctx i: prop, i: int, o: term, o: term.
18 | var_pos_ctx (decl X _ _) I X (pos_ctx I).
19 | var_pos_ctx (def X _ _ _) I X (pos_ctx I).
20 |
21 | pred add_pos_ctx_aux i: goal-ctx, i: int, i: term, o: term.
22 | add_pos_ctx_aux [X | XS] I A B :- !, var_pos_ctx X I T1 T2,
23 | (copy T1 T2 :- !) => (I' is I + 1, !, add_pos_ctx_aux XS I' A B).
24 | add_pos_ctx_aux [] _ A B :- !, copy A B.
25 |
26 | pred add_pos_ctx i: goal-ctx, i: term, o: term.
27 | add_pos_ctx L T1 T2 :- add_pos_ctx_aux L 0 T1 T2.
28 |
29 | pred add_pos_ctx_pr i: goal-ctx, i: (list (pair term (list term))), o: (list (pair term (list term))).
30 | add_pos_ctx_pr Ctx [pr T L | XS] [pr T L'|XS'] :- std.map L (add_pos_ctx Ctx) L', add_pos_ctx_pr Ctx XS XS'.
31 | add_pos_ctx_pr _ [] [].
32 |
33 | pred elim_pos_ctx_aux i: goal-ctx, i: int, i: term, o: term.
34 | elim_pos_ctx_aux [X | XS] I A B :- var_pos_ctx X I T1 T2, (copy T2 T1 :- !) => (I' is I + 1, elim_pos_ctx_aux XS I' A B).
35 | elim_pos_ctx_aux [] _ A B :- copy A B.
36 |
37 | pred elim_pos_ctx i: goal-ctx, i: term, o: term.
38 | elim_pos_ctx Ctx A B :- elim_pos_ctx_aux Ctx 0 A B.
39 |
40 | pred pos_ctx_to_var_in_term_aux i: goal-ctx, i: list term, o: list term.
41 | pos_ctx_to_var_in_term_aux Ctx [(pos_ctx N)| XS] [X|XS'] :- nth N Ctx (decl X _ _), !, pos_ctx_to_var_in_term_aux Ctx XS XS'.
42 | pos_ctx_to_var_in_term_aux Ctx [(pos_ctx N)| XS] [X|XS'] :-
43 | pos_ctx_to_var_in_term_aux Ctx XS XS', nth N Ctx (def X _ _ _).
44 | pos_ctx_to_var_in_term_aux Ctx [(app L)| XS] [app L'|XS'] :- !, std.map L (pos_ctx_to_var Ctx) L',
45 | pos_ctx_to_var_in_term_aux Ctx XS XS'.
46 | pos_ctx_to_var_in_term_aux Ctx [T|XS] [T| XS'] :- pos_ctx_to_var_in_term_aux Ctx XS XS'.
47 | pos_ctx_to_var_in_term_aux _Ctx [] [].
48 |
49 | pred pos_ctx_to_var_in_term i: goal-ctx, i:(list (pair term (list term))), o: list (pair term (list term)).
50 | pos_ctx_to_var_in_term Ctx L1 L2 :- std.unzip L1 LT LI, std.map LI (pos_ctx_to_var_in_term_aux Ctx) L2', std.zip LT L2' L2.
51 |
52 | pred type_global i: term, o: term.
53 | type_global (global (indt I)) Ty :- coq.env.indt I _ _ _ Ty _ _.
54 | type_global (global (indc C)) Ty :- coq.env.indc C _ _ _ Ty.
55 |
56 | pred ctx_to_trms i: goal-ctx, o: list term.
57 | ctx_to_trms [(decl X _ _)|XS] [X|R] :- ctx_to_trms XS R.
58 | ctx_to_trms [(def X _ _ _)|XS] [X|R] :- ctx_to_trms XS R.
59 | ctx_to_trms [] [].
60 |
61 | pred ctx_to_hyps i: goal-ctx, o: list term.
62 | ctx_to_hyps [(decl _ _ Ty)|XS] [Ty|R] :- coq.typecheck Ty {{ Prop }} ok, ctx_to_hyps XS R.
63 | ctx_to_hyps [_|XS] R :- ctx_to_hyps XS R.
64 | ctx_to_hyps [] [].
65 |
66 | pred codomain i:term, o:term.
67 | codomain (prod Na Ty F) R :- !, pi x\ decl x Na Ty => codomain (F x) R.
68 | codomain T T.
69 |
70 | pred is_not_prop i: term, o: diagnostic.
71 | is_not_prop T ok :- not (coq.unify-leq T {{Prop}} ok).
72 |
73 | pred codomain_not_prop i: term, o: diagnostic.
74 | codomain_not_prop (prod Na Ty F) D :- !, pi x\ decl x Na Ty => codomain_not_prop (F x) D.
75 | codomain_not_prop T ok :- !, is_not_prop T ok.
76 |
77 | pred get_number_of_parameters i: term, o: int.
78 | get_number_of_parameters (global (indt I)) NB :- coq.env.indt I _ NB _ _ _ _.
79 | get_number_of_parameters (global (indc C)) NB :- coq.env.indc C NB _ _ _.
80 | get_number_of_parameters _ 0.
81 |
82 | pred tuple_to_list i: term, o: (list term).
83 | tuple_to_list {{ pair lp:P1 lp:P2 }} R :- !, tuple_to_list P1 R1, tuple_to_list P2 R2,
84 | std.append R1 R2 R.
85 | tuple_to_list T [T].
86 |
87 | pred singl_tuple_to_list i: (list argument), o: (list term).
88 | singl_tuple_to_list [trm T] R :- tuple_to_list T R.
89 | singl_tuple_to_list [] [].
90 |
91 | pred add_if_polymorphic i: term, i: (list term), o: (list term).
92 | add_if_polymorphic ((prod _Na Ty _Bod) as T) L [T | L] :- coq.unify-eq Ty {{ Type }} ok.
93 | add_if_polymorphic _ L L.
94 |
95 | pred is_polymorphic i: pair term term.
96 | is_polymorphic (pr _ (prod _Na Ty _F)) :- coq.unify-eq Ty {{ Type }} ok.
97 |
98 | pred polymorphic_hypotheses i: (list (pair term term)), o: (list (pair term term)).
99 | polymorphic_hypotheses L R :- std.filter L is_polymorphic R.
100 |
101 | pred collect_hypotheses_from_context i: goal-ctx, o: list term, o: list (pair term term).
102 | collect_hypotheses_from_context [(decl X _ Ty)| XS] [Ty|R] [pr X Ty|R'] :- !, collect_hypotheses_from_context XS R R'.
103 | collect_hypotheses_from_context [def _ _ _ _ | XS] R R' :- !, collect_hypotheses_from_context XS R R'.
104 | collect_hypotheses_from_context [] [] [].
105 |
106 | pred find_pos_in_context_aux i: goal-ctx, i: term, i: int, o: term.
107 | find_pos_in_context_aux [(decl T' _ _)| _XS] T N (pos_ctx N) :- coq.unify-eq T' T ok.
108 | find_pos_in_context_aux [(decl _T' _ _)| XS] T N R :- !, M is N + 1, find_pos_in_context_aux XS T M R.
109 | find_pos_in_context_aux [(def T' _ _ _) | _XS] T N (pos_ctx N) :- coq.unify-eq T' T ok.
110 | find_pos_in_context_aux [(def _T' _ _ _)| XS] T N R :- !, M is N + 1, find_pos_in_context_aux XS T M R.
111 | find_pos_in_context_aux [] T _ T.
112 |
113 | pred find_pos_in_context i: goal-ctx, i: term, o: term.
114 | find_pos_in_context Ctx (app L) (app L') :- !,
115 | std.map L (x\ find_pos_in_context_aux Ctx x 0) L'.
116 | find_pos_in_context Ctx T Inst :- find_pos_in_context_aux Ctx T 0 Inst.
117 |
118 | pred append_nodup i: list A, i: list A, o: list A.
119 | append_nodup [X|XS] Y R :- append_nodup XS Y R, std.mem! R X.
120 | append_nodup [X|XS] Y [X|R] :- !, append_nodup XS Y R.
121 | append_nodup [] Y Y.
122 |
123 | pred find_occurences_aux i: list A, i: A, i: int, o: list int.
124 | find_occurences_aux [X|XS] X N [N|R] :- !, M is N + 1, find_occurences_aux XS X M R.
125 | find_occurences_aux [_Y |XS] X N R :- M is N + 1, find_occurences_aux XS X M R.
126 | find_occurences_aux [] _X _N [].
127 |
128 | pred find_occurences i: list A, i: A, o: list int.
129 | find_occurences L X R :- find_occurences_aux L X 0 R.
130 |
131 | pred nth i:int, i:list A, o:A. % a version of nth with no fatal error to handle backtracking
132 | nth 0 [X|_ ] R :- !, X = R.
133 | nth N [_|XS] R :- N > 0, !, N1 is N - 1, nth N1 XS R.
134 |
135 | pred argument_to_term i: list argument, o: list (pair term term).
136 | argument_to_term [trm T| XS] [pr T Ty|R] :- !, coq.typecheck T Ty ok, argument_to_term XS R.
137 | argument_to_term [] [].
138 |
139 | pred term_to_argument i: list term, o: list argument.
140 | term_to_argument [T| XS] [trm T|R] :- !, term_to_argument XS R.
141 | term_to_argument [] [].
142 |
143 | pred int_to_term i: int, o: term.
144 | int_to_term 0 {{ 0 }}.
145 | int_to_term N (app [{{ S }}, N']) :- calc (N - 1) N1, int_to_term N1 N'.
146 |
--------------------------------------------------------------------------------
/theories/instantiate_type.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 |
13 | From MetaCoq.Template Require Import All.
14 | Require Import List.
15 | Require Import utilities.
16 | Import ListNotations.
17 | Require Import String.
18 |
19 |
20 | (* Instantiate a hypothesis with the parameter x *)
21 | Ltac instantiate_par H x :=
22 | let T := type of H in
23 | lazymatch T with
24 | | forall (y : ?A), _ => tryif (let H':= fresh H "_" x in assert (H':= H) ;
25 | let U := type of (H' x) in notHyp U ; specialize (H' x)) then idtac else (let H':= fresh H in assert (H':= H) ;
26 | let U := type of (H' x) in notHyp U ; specialize (H' x))
27 | | _ => fail
28 | end.
29 |
30 |
31 | (* Instantiate a hypothesis with the parameter x and return its identifier *)
32 | Ltac instantiate_par_ident H x :=
33 | let T := type of H in
34 | lazymatch T with
35 | | forall (y : ?A), _ => let H':= fresh H in
36 | let _ := match goal with _ => assert (H':= H) ;
37 | let U := type of (H' x) in notHyp U ; specialize (H' x) end in H'
38 | | _ => fail
39 | end.
40 |
41 |
42 | Goal (forall (A : Type) (B : Type), A = A /\ B = B) -> forall (x : nat) (y : bool), x=x /\ y= y.
43 | intro H.
44 | let H' := instantiate_par_ident H bool in instantiate_par H' bool.
45 | Abort.
46 |
47 |
48 | Ltac instantiate_tuple_terms H t1 t2 := match t1 with
49 | | (?x, ?t1') => try (let H' := instantiate_par_ident H x in let u := type of H' in
50 | instantiate_tuple_terms H' t2 t2 ) ; try (instantiate_tuple_terms H t1' t2)
51 | | default => let T := type of H in
52 | match T with
53 | | forall (y : ?A), _ => constr_eq A Type ; clear H
54 | | _ => idtac
55 | end
56 | end.
57 |
58 |
59 | (* Reifies a term and calls is_type *)
60 | Ltac is_type_quote t := idtac t ;
61 | let t' := eval hnf in t in
62 | let T := metacoq_get_value (tmQuote t') in
63 | if_else_ltac idtac fail ltac:(idtac T ; eval compute in (is_type T)).
64 |
65 |
66 | Ltac is_type_quote_bool t := let t' := eval hnf in t in let T :=
67 | metacoq_get_value (tmQuote t') in constr:(is_type T).
68 |
69 | Fixpoint list_of_subterms (t: term) : list term := match t with
70 | | tLambda _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u)
71 | | tProd _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u)
72 | | tLetIn _ u v w => t :: (list_of_subterms u) ++ (list_of_subterms v) ++ (list_of_subterms w)
73 | | tCast t1 _ t2 => t :: (list_of_subterms t1) ++ (list_of_subterms t2)
74 | | tApp u l => t :: (list_of_subterms u) ++ (List.flat_map list_of_subterms l)
75 | | tCase _ _ t2 l => t:: (list_of_subterms t2) ++
76 | (List.flat_map (fun x => list_of_subterms (bbody x)) l)
77 | | tFix l _ => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l)
78 | | tCoFix l _ => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l)
79 | | _ => [t]
80 | end.
81 |
82 | Definition filter_closed (l: list term) := List.filter (closedn 0) l.
83 |
84 |
85 | Ltac get_list_of_closed_subterms t := let t_reif := metacoq_get_value (tmQuote t) in
86 | let l := eval cbv in (filter_closed (list_of_subterms t_reif)) in l.
87 |
88 | Ltac return_unquote_tuple_terms l := let rec aux l acc :=
89 | match constr:(l) with
90 | | nil => constr:(acc)
91 | | cons ?x ?xs =>
92 | let y := metacoq_get_value (tmUnquote x) in
93 | let u := constr:(y.(my_projT2)) in
94 | let w := eval hnf in u in
95 | let T := type of w in
96 | let b0 := ltac:(is_type_quote_bool T) in
97 | let b := eval hnf in b0 in
98 | match b with
99 | | true => (aux xs (pair w acc))
100 | | false => aux xs acc
101 | end
102 | end
103 | in aux l default.
104 |
105 | Ltac return_tuple_subterms_of_type_type := match goal with
106 | |- ?x => let l0 := (get_list_of_closed_subterms x) in let l := eval cbv in l0 in return_unquote_tuple_terms l
107 | end.
108 |
109 | Goal forall (A: Type) (x:nat) (y: bool) (z : list A), y = y -> z=z -> x = x.
110 | let t := return_tuple_subterms_of_type_type in pose t.
111 | Abort.
112 |
113 | Goal forall (A : Type) (l : list A), Datatypes.length l = 0 -> l = nil.
114 | let t := return_tuple_subterms_of_type_type in pose t.
115 | Abort.
116 |
117 | Ltac instantiate_tuple_terms_goal H := let t0 := return_tuple_subterms_of_type_type in
118 | let t := eval cbv in t0 in instantiate_tuple_terms H t t.
119 |
120 | Goal (forall (A B C : Type), B = B -> C = C -> A = A) -> nat = nat -> bool = bool.
121 | intros H.
122 | let p := return_tuple_subterms_of_type_type in pose p.
123 | instantiate_tuple_terms_goal H.
124 | Abort.
125 |
126 |
127 | Ltac instantiate_tuple_terms_tuple_hyp t terms := match t with
128 | | (?H, ?t') => instantiate_tuple_terms H terms terms ; instantiate_tuple_terms_tuple_hyp t' terms
129 | | default => idtac
130 | end.
131 |
132 |
133 | Ltac instantiate_tuple_terms_tuple_hyp_no_ip_term t terms := lazymatch t with
134 | | (?t1, ?t2 ) => instantiate_tuple_terms_tuple_hyp_no_ip_term t1 terms ;
135 | instantiate_tuple_terms_tuple_hyp_no_ip_term t2 terms
136 | | ?H => let T := type of H in
137 | match T with
138 | | forall (y : ?A), _ => constr_eq A Type ; try (instantiate_tuple_terms H terms terms)
139 | | _ => try (let U := type of T in constr_eq U Prop ; notHyp H ; let H0 := fresh H in assert (H0 : T) by exact H)
140 | end
141 | end.
142 |
143 | Ltac elimination_polymorphism_exhaustive t0 :=
144 | let t := eval cbv in t0 in
145 | let terms0 := return_tuple_subterms_of_type_type in
146 | let terms := eval cbv in terms0 in
147 | let h0 := hyps in
148 | let h := eval cbv in h0 in
149 | instantiate_tuple_terms_tuple_hyp_no_ip_term t terms ;
150 | instantiate_tuple_terms_tuple_hyp h terms.
151 |
152 | Ltac test t0 :=
153 | let t := eval cbv in t0 in
154 | let h0 := hyps in
155 | let h := eval cbv in h0 in
156 | let x := constr:((nat, (bool, unit))) in
157 | instantiate_tuple_terms_tuple_hyp_no_ip_term t x ;
158 | instantiate_tuple_terms_tuple_hyp h x.
159 |
160 | Ltac test2 t0 :=
161 | let h0 := hyps in
162 | let t := eval cbv in t0 in
163 | let x := constr:((nat, (bool, unit))) in
164 | instantiate_tuple_terms_tuple_hyp_no_ip_term t0 x.
165 |
166 |
167 | Goal (forall (A B C : Type), B = B -> C = C -> A = A) -> nat = nat -> bool = bool.
168 | intro.
169 | elimination_polymorphism_exhaustive (rev_involutive, default).
170 |
171 | Abort.
172 |
173 |
174 | Tactic Notation "inst" := elimination_polymorphism_exhaustive unit.
175 | Tactic Notation "inst" constr(t) := elimination_polymorphism_exhaustive (t, default).
176 |
177 |
178 | Goal (forall (A : Type) (a : A), a = a) -> (forall (x : nat), x = x).
179 | Proof. intros H. inst app_length.
180 | Abort.
181 |
182 | Section test.
183 |
184 | Variable A : Type.
185 | Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
186 | Proof.
187 | intros. unfold "<>". intro H. inversion H.
188 | Qed.
189 |
190 | Goal False -> forall (x : nat) (y : bool), x=x /\ y= y.
191 | inst (pair_equal_spec, app_length, nil_cons, app_comm_cons).
192 | Abort.
193 |
194 |
195 | Goal True -> forall (x:A) (l:list A), [] <> x :: l.
196 | intros.
197 | test2 nil_cons. apply nil_cons0. Qed.
198 |
199 | End test.
200 |
201 |
202 |
203 |
204 |
205 |
206 |
207 |
208 |
209 |
210 |
211 |
212 |
213 |
214 |
--------------------------------------------------------------------------------
/theories/case_analysis_existentials.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 |
13 | Require Import utilities.
14 | Require Import instantiate_type.
15 | Require Import MetaCoq.Template.All.
16 | Require Import String.
17 | Require Import List.
18 | Require Import ZArith.
19 | Require Import interpretation_algebraic_types.
20 | Require Import case_analysis.
21 | Unset MetaCoq Strict Unquote Universe Mode.
22 |
23 | Local Open Scope bs_scope.
24 |
25 | (** Generates the generation statement in a non-constructive way:
26 | the projection functions are replaced by existentials :
27 | see the example st_list *)
28 |
29 | Fixpoint statement_one_constructor
30 | (n : nat) (* De Brujin index of the list we consider *)
31 | (n' : nat) (* the number of arguments of the constructor *)
32 | (c : term) (* the constructor not applied to its parameters *)
33 | (largs : list term) (* the list of the arguments of the constructor, initialized with the parameters
34 | and updated with one variable after one recursive call *)
35 | := match n' with
36 | | 0 => mkEq hole (tRel n) (tApp c largs)
37 | | S n' => tApp <% ex %> [hole ;
38 | tLambda (mkNamed "x") hole (statement_one_constructor (S n) n' c ((List.map (lift 1 0) largs)++[tRel 0])) ]
39 | end.
40 |
41 | Definition statement_constructors
42 | (I : term) (* the inductive we want to deal with *)
43 | (typars : list term) (* the type of the parameters *)
44 | (lc : list term) (* the constructors of the inductive (not applied) *)
45 | (largs : list nat) (* for each constructor, the number of their non parametric arguments *)
46 | :=
47 | let n := Datatypes.length typars in
48 | let lpars := Rel_list n 0 in
49 | let fix aux lpars lc largs :=
50 | match lc, largs with
51 | | [], [] => []
52 | | c :: lc', args :: largs' => statement_one_constructor 0 args c lpars :: aux lpars lc' largs'
53 | | _, _ => []
54 | end
55 | in
56 | mkProd_rec typars (mkProdName "t" (tApp I lpars) (mkOr_n (aux (List.map (lift 1 0) lpars) lc largs))).
57 |
58 | Definition statement_list := statement_constructors <%@list %> [<% Type %>] [<%@nil%> ; <%@cons%>] [0 ; 2].
59 |
60 | MetaCoq Unquote Definition st_list := statement_list.
61 |
62 | (* Print st_list.
63 | st_list =
64 | forall (x : Type) (t : list x),
65 | t = [] \/ (exists (x0 : x) (x1 : list x), t = x0 :: x1)
66 | : Prop *)
67 |
68 | MetaCoq Quote Recursively Definition list_reif_rec := @list.
69 |
70 | Fixpoint skipn_forall (n : nat) (t : term) :=
71 | match n with
72 | | 0 => t
73 | | S n' =>
74 | match t with
75 | | tProd _ _ u => skipn_forall n' u
76 | | _ => t
77 | end
78 | end.
79 |
80 | Definition get_nb_args_not_params (t : term) (npars : nat) :=
81 | let t' := skipn_forall npars t in
82 | let fix aux t' n :=
83 | match t' with
84 | | tProd _ _ u => aux u (S n)
85 | | _ => n
86 | end in aux t' 0.
87 |
88 | (* generates two lists : the constructors and the number of their arguments *)
89 | Fixpoint find_nb_args_constructors_and_ctors
90 | (I : inductive) (inst : Instance.t) (npars n : nat) (l : list ((ident × term) × nat))
91 | :=
92 | match l with
93 | | [] => ([], [])
94 | | x :: xs =>
95 | let resu := find_nb_args_constructors_and_ctors I inst npars (S n) xs in
96 | let nb := get_nb_args_not_params x.1.2 npars in
97 | (tConstruct I n inst :: resu.1, nb :: resu.2)
98 | end.
99 |
100 | Definition get_indu_and_instance (t : term) :=
101 | match t with
102 | | tInd Ind inst => (Ind, inst)
103 | | _ => ( {|
104 | inductive_mind :=
105 | (MPfile ["utilities"; "theories"; "Sniper"],
106 | "impossible_term");
107 | inductive_ind := 0
108 | |}, [])
109 | end.
110 |
111 | Definition dest_app (t : term) :=
112 | match t with
113 | | tApp u v => (u, v)
114 | | _ => (t, [])
115 | end.
116 |
117 | Ltac prove_by_destruct_varn n :=
118 | match n with
119 | | 0 =>
120 | let x := fresh in
121 | intro x ; destruct x; repeat eexists ; repeat first [ left ; progress (eauto) | first [right | eauto]]
122 | | S ?m => let y := fresh in intro y ; prove_by_destruct_varn m
123 | end.
124 |
125 | Ltac gen_statement_existentials I H :=
126 | let I_reif := metacoq_get_value (tmQuoteRec I) in
127 | let res0 := eval cbv in (dest_app I_reif.2) in
128 | let I_no_app := eval cbv in (res0.1) in
129 | let params := eval cbv in (res0.2) in
130 | let len_params := eval cbv in (Datatypes.length params) in
131 | let indu := eval cbv in (info_inductive I_reif.1 I_no_app ) in
132 | let constructors := eval cbv in (info_nonmutual_inductive I_reif.1 I_no_app).2 in
133 | match indu with
134 | | Some ?i =>
135 | let info_params := eval cbv in (get_params_from_mind i) in
136 | let npars := eval cbv in info_params.1 in
137 | let typars := eval cbv in info_params.2 in
138 | let res1 := eval cbv in (get_indu_and_instance I_no_app) in
139 | let indu := eval cbv in res1.1 in
140 | let inst := eval cbv in res1.2 in
141 | let res2 := eval cbv in (find_nb_args_constructors_and_ctors indu inst npars 0
142 | (get_na_nb_args_type_list_constructor_body constructors)) in
143 | let largs := eval cbv in res2.2 in
144 | let lc := eval cbv in res2.1 in
145 | let gen_st_reif := eval cbv in (statement_constructors I_no_app typars lc largs) in
146 | let gen_st_reif_instances := eval cbv in (subst params 0 (skipn_forall len_params gen_st_reif)) in
147 | let gen_st := metacoq_get_value (tmUnquoteTyped Prop gen_st_reif_instances) in
148 | let nb_vars_intro := eval cbv in (npars-len_params) in
149 | assert (H : gen_st) by (prove_by_destruct_varn (nb_vars_intro))
150 | | None => fail
151 | end.
152 |
153 | Section test_gen_statement.
154 |
155 | Goal False.
156 | gen_statement_existentials nat H. clear.
157 | gen_statement_existentials list H. clear.
158 | gen_statement_existentials @nelist H. clear.
159 | gen_statement_existentials @biclist H. clear.
160 | gen_statement_existentials Ind_test H. clear.
161 | gen_statement_existentials Ind_test2 H. clear.
162 | gen_statement_existentials (@list nat) H. clear.
163 | Abort.
164 |
165 | End test_gen_statement.
166 |
167 | (* Checks if a given term is a variable *)
168 | Ltac is_var v :=
169 | let v_reif := metacoq_get_value (tmQuote v) in
170 | match v_reif with
171 | | tVar _ => idtac
172 | | _ => fail
173 | end.
174 |
175 | (* Returns the tuple of variables in a local context *)
176 | Ltac vars :=
177 | match goal with
178 | | v : _ |- _ => let _ := match goal with _ => is_var v ; revert v end in let acc := vars in
179 | let _ := match goal with _ => intro v end in constr:((v, acc))
180 | | _ => constr:(unit)
181 | end.
182 |
183 | Ltac get_gen_statement_for_variables_in_context :=
184 | let t := vars in
185 | let rec tac_rec v :=
186 | match v with
187 | | (?v1, ?v') => let T := type of v1 in first [ let U := type of T in constr_eq U Prop ; tac_rec v' |
188 | first [let H := fresh in
189 | gen_statement_existentials T H; specialize (H v1) ; try (tac_rec v') | tac_rec v' ]]
190 | | _ => idtac
191 | end in tac_rec t.
192 |
193 | Section test_vars_in_context.
194 |
195 | Goal forall (A: Type) (x : list nat) (y : nat) (u : list A), 1 = 2 -> False.
196 | Proof. intros ; get_gen_statement_for_variables_in_context. inversion H. Qed.
197 |
198 | End test_vars_in_context.
199 |
200 |
--------------------------------------------------------------------------------
/examples/examples.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 | From Sniper Require Import Sniper.
13 | From Sniper Require Import tree.
14 | Require Import String.
15 | Require Import ZArith.
16 | Require Import Bool.
17 | Require Import Coq.Lists.List.
18 | Import ListNotations.
19 |
20 |
21 | Local Open Scope Z_scope.
22 |
23 | (** Examples on lists *)
24 |
25 | (* A simple example *)
26 | Goal forall (l : list Z) (x : Z), hd_error l = Some x -> (l <> nil).
27 | Proof. snipe. Qed.
28 |
29 | (* The `snipe` and `snipe_no_check` tactics requires instances of equality to be decidable.
30 | It is in particular visible with type variables. *)
31 | Section Generic.
32 |
33 | Variable A : Type.
34 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil).
35 | Proof.
36 | scope. 3: verit.
37 | (* New goals are open that require instances of equality to be
38 | decidable. On usual types such as `Z` in the previous example,
39 | these goals are automatically discharged. On other concrete
40 | types, it is up to the user to prove it or admit it. *)
41 | Abort.
42 |
43 | (* On abstract type, it has to be assumed. *)
44 | Hypothesis HA : CompDec A.
45 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil).
46 | Proof. snipe_no_check. Qed.
47 |
48 | End Generic.
49 |
50 |
51 | (* When the goal is automatically provable by the `snipe` tactic, it is
52 | often done in a few seconds. To avoid too long runs when the goal is
53 | not provable, the tactic can be called with a timeout, in seconds. *)
54 | Section Timeout.
55 |
56 | Variable A : Type.
57 | Hypothesis HA : CompDec A.
58 | Goal forall (l : list A) (x : A), hd_error l = Some x -> (l <> nil).
59 | Proof. (* snipe_timeout 10. *) snipe_no_check. Qed.
60 |
61 | End Timeout.
62 |
63 |
64 | (* A more involved example *)
65 | Section destruct_auto.
66 |
67 | Variable A : Type.
68 | Variable HA : CompDec A.
69 |
70 |
71 | (* This theorem needs a case analysis on x and y *)
72 | Theorem app_eq_unit (x y:list A) (a:A) :
73 | x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
74 | Proof.
75 | destruct x as [|a' l]; [ destruct y as [|a' l] | destruct y as [| a0 l0] ];
76 | simpl.
77 | intros H; discriminate H.
78 | left; split; auto.
79 | intro H; right; split; auto.
80 | generalize H.
81 | generalize (app_nil_r l); intros E.
82 | rewrite -> E; auto.
83 | intros H.
84 | injection H as [= H H0].
85 | assert ([] = l ++ a0 :: l0) as H1 by auto.
86 | apply app_cons_not_nil in H1 as [].
87 | Qed.
88 |
89 | Theorem app_eq_unit_auto :
90 | forall (x y: list A) (a:A),
91 | x ++ y = a :: nil -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
92 | Proof. snipe_no_check. Qed.
93 |
94 |
95 | End destruct_auto.
96 |
97 | Section search.
98 |
99 | Variable (A: Type).
100 | Variable (H : CompDec A).
101 |
102 |
103 | (* Example of searching an element in a list *)
104 | Fixpoint search (x : A) l :=
105 | match l with
106 | | [] => false
107 | | x0 :: l0 => eqb_of_compdec H x x0 || search x l0
108 | end.
109 |
110 | Lemma search_app : forall (x: A) (l1 l2: list A),
111 | search x (l1 ++ l2) = ((search x l1) || (search x l2))%bool.
112 | Proof.
113 | intros x l1 l2. induction l1 as [ | x0 l0 IH].
114 | - reflexivity.
115 | - simpl. destruct (eqb_of_compdec H x x0).
116 | + reflexivity.
117 | + rewrite IH. reflexivity.
118 | Qed.
119 |
120 | (* The proof of this lemma, except induction, can be automatized *)
121 | Lemma search_app_snipe : forall (x: A) (l1 l2: list A),
122 | @search x (l1 ++ l2) = ((@search x l1) || (@search x l2))%bool.
123 | Proof. induction l1 ; snipe_no_check. Qed.
124 |
125 |
126 | (* Manually using this lemma *)
127 | Lemma search_lemma : forall (x: A) (l1 l2 l3: list A),
128 | search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1).
129 | Proof.
130 | intros x l1 l2 l3. rewrite !search_app.
131 | rewrite orb_comm with (b1 := search x l3).
132 | rewrite orb_comm with (b1 := search x l2) (b2 := search x l1 ).
133 | rewrite orb_assoc.
134 | reflexivity.
135 | Qed.
136 |
137 | (* It can be fully automatized *)
138 | Lemma snipe_search_lemma : forall (x: A) (l1 l2 l3: list A),
139 | search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1).
140 | Proof. pose proof search_app. snipe_no_check. Qed.
141 |
142 | Lemma in_inv : forall (a b:A) (l:list A),
143 | search b (a :: l) -> orb (eqb_of_compdec H a b) (search b l).
144 | Proof. snipe. Qed.
145 |
146 |
147 | (* Another example with an induction *)
148 | Lemma app_nil_r : forall (A: Type) (H: CompDec A) (l:list A), (l ++ [])%list = l.
149 | Proof. intros ; induction l; snipe_no_check. Qed.
150 |
151 | End search.
152 |
153 | Section higher_order.
154 |
155 |
156 | Variable A B C: Type.
157 | Variable HA : CompDec A.
158 | Variable HB : CompDec B.
159 | Variable HC : CompDec C.
160 |
161 |
162 | Lemma map_compound : forall (f : A -> B) (g : B -> C) (l : list A),
163 | map g (map f l) = map (fun x => g (f x)) l.
164 | Proof.
165 | induction l; time snipe. Qed.
166 |
167 | End higher_order.
168 |
169 | (** Examples on trees *)
170 |
171 | Section Tree.
172 |
173 |
174 | Lemma empty_tree_Z2 : forall (t : @tree Z) a t' b,
175 | is_empty t = true -> t <> Node a t' b.
176 | Proof. snipe. Qed.
177 |
178 | Lemma rev_elements_app :
179 | forall A (H:CompDec A) s acc, tree.rev_elements_aux A acc s = ((tree.rev_elements A s) ++ acc)%list.
180 | Proof. intros A H s ; induction s.
181 | - pose proof List.app_nil_r; snipe.
182 | - pose proof app_ass ; pose proof List.app_nil_r; snipe.
183 | Qed.
184 |
185 | Lemma rev_elements_node c (H: CompDec c) l x r :
186 | rev_elements c (Node l x r) = (rev_elements c r ++ x :: rev_elements c l)%list.
187 | Proof. pose proof app_ass ; pose proof rev_elements_app ; snipe. Qed.
188 |
189 | End Tree.
190 |
191 | Section RefinementTypes.
192 |
193 | (* Source: CompCert (https://github.com/AbsInt/CompCert/blob/bf8a3e19dcdd8fec1f8b49e137262c7280d6d8a8/lib/IntvSets.v#L326) *)
194 | (* Note: we did modify the example *)
195 | Inductive data : Type := Nil | Cons (lo hi: Z) (tl: data).
196 |
197 | (* The original version of this was an equivalent function returning `Prop` *)
198 | Fixpoint InBool (x: Z) (s: data) : bool :=
199 | match s with
200 | | Nil => false
201 | | Cons l h s' => ((Z.leb l x) && (Z.ltb x h)) || InBool x s'
202 | end.
203 |
204 | (* The original version of this was an equivalent function returning `Prop` *)
205 | Fixpoint ok (x : data) : bool :=
206 | match x with
207 | | Nil => true
208 | | Cons l1 h1 s =>
209 | match s with
210 | | Nil => l1 (l1 l <= x < h.
236 | snipe. (* Not fully proved due to a bug in SMTCoq *)
237 | Abort.
238 |
239 | End RefinementTypes.
240 |
--------------------------------------------------------------------------------
/docs/decide.md:
--------------------------------------------------------------------------------
1 | # Automatic decision of Inductive Relations
2 |
3 | This transformation is divided in 5 files and it is presented
4 | as a separated plugin called `Decide`.
5 |
6 | * File: `theories/deciderel/add_hypothesis_on_parameters.v`
7 | * File: `theories/deciderel/compdec_plugin.v`
8 | * File: `theories/deciderel/linearize_plugin.v`
9 | * File: `theories/deciderel/generate_fix.v`
10 | * File: `theories/deciderel/proof_correctness.v`
11 |
12 | These files provide `Coq` vernacular commands but no tactic.
13 |
14 | ## What does the transformation do?
15 |
16 | Some inductives relations (`Coq` inductives whose codomain
17 | is $Prop$) are inductively-defined whereas there are decidable.
18 |
19 | The transformation transforms a subset of the decidable inductive relations into an equivalent function whose return type is `bool`. A `Ltac2` proof script tries to generate the proof of the equivalence and if it fails, the proof is left to the user.
20 |
21 | Example:
22 |
23 | ```
24 | Inductive even (n: nat) : Prop :=
25 | | evenO : even 0
26 | | evenSucc n : even n -> even (S (S n)).
27 | ```
28 |
29 | is transformed into
30 |
31 | ```
32 | Fixpoint even_dec (n: nat) : bool :=
33 | match n with
34 | | 0 => true
35 | | 1 => false
36 | | S (S n') => even_dec n'
37 | end.
38 | ```
39 |
40 | Each constructor of these decidable relations should have a
41 | conclusion which mentions *every* constructor variable in order to the transformation to be applicable.
42 |
43 | For instance, this constructor (for the typing relation in the simply-typed lambda-calculus) is not in the scope of the
44 | transformation:
45 |
46 | ```
47 | Inductive has_type : env -> term -> typ -> Prop :=
48 | ...
49 | | typ_app G A B t u :
50 | has_type G t (Arrow A B) ->
51 | has_type G u A ->
52 | has_type G (App t u) B
53 | ...
54 | ```
55 |
56 | Indeed, the variable `A` does not occurs in the conclusion
57 | `has_type G (App t u) B`.
58 |
59 | In addition, in the current state of the plugin, if you want to generate an equivalent function, each type mentionned by the inductive relation (except $Prop$) must be a member of a specific typeclass from the `SMTCoq` plugin called `CompDec`.
60 |
61 | Indeed, decidable equalities are often required during the transformation and the `CompDec` types are also member of the `EqDec` typeclass. Furthermore, the main purpose of this transformation is to be useful for `SMTCoq`, so it relies on its typeclasses.
62 |
63 | An improvement would be to replace `CompDec` by `EqDec` and to ask for decidable equalities on the fly (during the [linearization](#linearization) procedure).
64 |
65 | ## Add hypothesis on parameters
66 |
67 | Suppose given $P: Type \to Type$ and an inductive $I$ of type
68 | $\forall \overrightarrow{(A_{i}: Type)},\; B$.
69 |
70 | The purpose of this file is to transform an inductive $I$ quoted in `MetaCoq`
71 | into $I': \; \forall \overrightarrow{(A_{i}: Type) (H_{A_{i}}: \; P \; A_{i})}, \; B$, still quoted.
72 |
73 | ## CompDec Plugin
74 |
75 | The `SMTCoq` plugin relies heavily on the `CompDec` typeclass
76 | (see [here](https://github.com/smtcoq/smtcoq/blob/coq-8.13/src/classes/SMT_classes.v#L148)):
77 | each type on which a proof is built in `SMTCoq` should belong to this typeclass (types of this typeclass are inhabited, are well-ordered and have a decidable equality `eqb_of_compdec`).
78 |
79 | The file `theories/deciderel/compdec_plugin.v` instantiates
80 | the previous predicate $P$ by `CompDec`. It will generate in the global environement the inductive $I'$ (so unquoted).
81 |
82 | For each concrete type `T` mentioned by the inductive, a proof `HT` of `CompDec T` will be researched in the global environment, and the pair
83 | `(T, HT)` will be registered and used later (for the linearization step may need it).
84 |
85 | ## Linearization
86 |
87 | The linearization procedure is required as `Coq`'s pattern matching
88 | always introduces *fresh* pattern variables.
89 |
90 | As the fixpoint which decides our inductive relation $I$ will perfom *pattern matching* on the variables that occurs in the conclusion of the constructors of $I$, we need a *linear* conclusion.
91 |
92 | Consider the following inductive relation:
93 |
94 | ```
95 | Inductive mem : nat -> list nat -> Prop :=
96 | | MemMatch n l : mem n (n::l)
97 | | MemRecur n n' l : mem n l -> mem n (n' :: l).
98 | ```
99 |
100 | Its equivalent boolean fixpoint is *NOT*:
101 |
102 | ```
103 | Fixpoint mem_dec (n: nat) (l : list nat) : bool :=
104 | match l with
105 | | [] => false
106 | | n :: xs => true
107 | | x :: xs => mem n xs
108 | end
109 | ```
110 |
111 | The second occurence of `n` replaces the first occurence and is *NOT* the same variable.
112 |
113 | We need to linearize the conclusion of `mem`.
114 |
115 | Thus, the file `linearize_plugin.v` creates a new relation `mem_linear`
116 | in the global environment:
117 |
118 |
119 | ```
120 | Inductive mem_linear :
121 | nat -> list nat -> Prop :=
122 | | MemMatch_linear n n' l :
123 | eqb_of_compdec nat_compdec n n' ->
124 | mem_linear n (n'::l)
125 | | MemRecur_linear n n' l : mem_linear n l ->
126 | mem_linear n (n' :: l).
127 | ```
128 |
129 | A new variable `n'` is introduced to replace an occurence of `n` in the conclusion, and the two variables are supposed to be equal.
130 |
131 | As we have previously registered proofs of `CompDec nat` thanks to the ["compdec plugin"](#compdec-plugin), we have at our disposal the proof `nat_compdec` which has to be the first argument of `eqb_of_compdec` (the decidable equality of the `CompDec` typeclass).
132 |
133 | ## Generation of fixpoint
134 |
135 | Taking the linearized version of $I$, say, $I_{linear}$,
136 | the purpose of this file is to generate the equivalent fixpoint in `bool`.
137 |
138 | It relies on an unification algorithm: each variable given to the fixpoint
139 | is destructed by pattern matching until a case which unifies with a conclusion of a constructor of $I_{linear}$ is reached. Then, either the conjonction of the premises should hold, or we continue the algorithm for the other constructors of $I_{linear}$.
140 |
141 | To go back to our `mem` example, the fixpoint generated is the following:
142 |
143 | ```
144 | Fixpoint mem_dec (n: nat) (l : list nat) : bool :=
145 | match l with
146 | | [] => false (* no constructor of mem_linerar has [] for second argument in its conclusion *)
147 | | x :: xs => eqb_of_compdec x n || (* first constructor *)
148 | mem_dec n xs (* second constructor *)
149 | end.
150 | ```
151 |
152 | The `TemplateMonad` of `MetaCoq` is used to define vernacular commands
153 | to build the fixpoints.
154 |
155 | In this file, the available commands are:
156 |
157 | `MetaCoq Run (build_fixpoint_auto I_linear l)`
158 |
159 | Here, `l` is a list of triple of decidable inductive relations, their boolean version and the proof of their equivalence in the `term` inductive type of `MetaCoq` quoted terms.
160 |
161 | Indeed, some inductive relations may mention other inductive relations, and in its current state the plugin is not able to decide them recursively.
162 |
163 | There is also the command:
164 |
165 | `MetaCoq Run (build_fixpoint_recarg I_linear l n)`
166 |
167 | Indeed, our plugin may not be able to find the structurally decreasing
168 | argument automatically, so it should be provided by the user in some cases.
169 |
170 | The last command is:
171 |
172 | `MetaCoq Run (linearize_and_fixpoint_auto I l).`
173 |
174 | which also perfoms the linearization step.
175 |
176 |
177 | ## Proof of equivalence
178 |
179 | The main command of this file `theories/proof_correctness.v` is:
180 |
181 | `MetaCoq Run (decide I l).`
182 |
183 | When it succeeds, it generates automatically the fixpoint version `I_linear_decidable` of `I`,
184 | and a proof of equivalence between `I` and `I_linear_decidable`.
185 |
186 | Because of `MetaCoq`'s `TemplateMonad` limitations (there is no way of catching an exception, so it is not possible to handle a failure case when the proof cannot be generated automatically), the proof is only printed. That is, if the proof is called `decidable_proof` the user should write:
187 |
188 | ```
189 | Next Obligation.
190 | exact decidable_proof.
191 | Qed.
192 | ```
193 | in order to define it in the global environment.
194 |
195 | If the `Ltac2` proof script fails, the user can write its own proof of equivalence thanks to:
196 |
197 | ```
198 | Next Obligation.
199 | my_proof_script.
200 | Qed.
201 | ```
202 |
203 | In particular, whenever some kind of strong induction is required, the proof script will fail.
204 |
205 | It is the case for the `even` predicate, for instance, as the induction step of the proof with weak induction will ask
206 | for `even (S n)` knowing only `even n` whereas we would have needed
207 | to be asked to prove
208 | `even (S (S n))` knowing `even n`.
209 |
--------------------------------------------------------------------------------
/theories/refinement_elimination.v:
--------------------------------------------------------------------------------
1 | (* TODO: The trigger should work with equality modulo delta, but it doesn't yet *)
2 | (* TODO: Check again how far we are from proving automatically the `interval` example in CompCert *)
3 | (* TODO: Currently we are relying on the fact that if the user has an application `f x` such that `f` takes *)
4 | (* a refinement type and `x` has a refinement in its type then the transformation will be fired on `f` before *)
5 | (* `x`. We shouldn't rely on this. Maybe we could split it into two transformations, one for generating the term *)
6 | (* and proving the equality; other for rewriting the equality. *)
7 | (* TODO: Create a new version of this tactic that will operate in terms without a body. *)
8 | (* - NOTE: It will only work if the input symbol does not contain refinement types in its domain *)
9 | (* - The new symbol should be defined using `p` directly, instead of the body of `p` *)
10 | (* - After defining the new symbol, the rest of the tactic should be approximately the same *)
11 | (* TODO: In the future we will want to support dependent records - for that we need to generalize the parts in *)
12 | (* which we deal specifically with `proj1_sig` *)
13 | (* TODO: Depending on the place we put this transformation in orchestrator, then some other transformation fails *)
14 | (* Investigate if this is due to the transformation itself or is a bug in orchestrator *)
15 | (* Ref: https://github.com/smtcoq/sniper/issues/27 *)
16 |
17 | Require Import refinement_elimination_elpi.
18 | From elpi Require Import elpi.
19 | From Ltac2 Require Import Ltac2.
20 | Import Constr.Unsafe.
21 |
22 | (* The trigger should be activated for any symbol that contains a refinement type in its type *)
23 | (* param p: symbol whose type contain a refinement type *)
24 | (* 1. Define new equivalent symbol free of refinement types *)
25 | (* 2. Prove that the first projection of p is equal to the new symbol *)
26 | (* 3. Prove that the new symbol satisfies the predicate of p *)
27 | (* 4. Replace p by the new symbol everywhere *)
28 |
29 | (* Assumes `t` is the type of a function. Computes the arity of the function. *)
30 | Ltac2 rec arity (t : constr) : int :=
31 | match kind t with
32 | | Prod _ c => Int.add 1 (arity c)
33 | | _ => 0
34 | end.
35 |
36 | (* Assumes `t` is the type of a function. Computer the number of arguments that are refinement types. *)
37 | Ltac2 rec count_ref_types (t : constr) : int :=
38 | match kind t with
39 | | Prod b c =>
40 | lazy_match! Constr.Binder.type b with
41 | | @sig _ _ => Int.add 1 (count_ref_types c)
42 | | _ => count_ref_types c
43 | end
44 | | _ => 0
45 | end.
46 |
47 | (* Assumes that `t` is the type of a function that returns a refinement type. Returns the predicate of the return type. *)
48 | Ltac2 rec get_ret_sig (t : constr) : constr option :=
49 | match kind t with
50 | | Prod _ c => get_ret_sig c
51 | | _ =>
52 | lazy_match! t with
53 | | @sig _ ?p => Some p
54 | | _ => None
55 | end
56 | end.
57 |
58 | (* Auxiliary function for `make_eq`. Traverses the arrows of the type of `g`, adding `proj1_sig` whenever it encouters an argument *)
59 | (* which is a refinement type. `i` is the De Bruijn index of the current argument. The arguments to be applied to `f` and `g` are *)
60 | (* accumulated in `argsF` and `argsG`, respectively. *)
61 | Ltac2 rec make_eq' (f : constr) (g : constr) (body_type_g : constr) (i : int) (argsF : constr list) (argsG : constr list) :=
62 | match kind body_type_g with
63 | | Prod b c =>
64 | (* If the current argument is a `sig`, we apply the function to `proj1_sig (Rel i)`, otherwise is just `Rel i` *)
65 | lazy_match! Constr.Binder.type b with
66 | | @sig ?d ?p =>
67 | let argF : constr := make (App constr:(@proj1_sig) (Array.of_list [d; p; make (Rel i)])) in
68 | make (Prod b (make_eq' f g c (Int.sub i 1) (argF :: argsF) (make (Rel i) :: argsG)))
69 | | _ => make (Prod b (make_eq' f g c (Int.sub i 1) (make (Rel i) :: argsF) (make (Rel i) :: argsG)))
70 | end
71 | | _ =>
72 | let lhs := make (App f (Array.of_list (List.rev argsF))) in
73 | let rhs := make (App g (Array.of_list (List.rev argsG))) in
74 | (* If the return type is a `sig` we apply `proj1_sig` to the right side of the equality *)
75 | lazy_match! body_type_g with
76 | | @sig ?d ?p =>
77 | let rhs' := make (App constr:(@proj1_sig) (Array.of_list [d; p; rhs])) in
78 | make (App constr:(@eq) (Array.of_list [d; lhs; rhs']))
79 | | _ => make (App constr:(@eq) (Array.of_list [body_type_g; lhs; rhs]))
80 | end
81 | end.
82 |
83 | (* Given two symbols `f` and `g` produces the term corresponding to `forall x1 .. xn , f x1 .. xn = g x1 .. xn, applying `proj1_sig` *)
84 | (* whenever there is a type mismatch in the arguments or in the return value *)
85 | Ltac2 make_eq (f : constr) (g : constr) (body_type_g : constr) :=
86 | (* `arity body_type_g` represents the De Bruijn index of `x1` in the final expression *)
87 | make_eq' f g body_type_g (arity body_type_g) [] [].
88 |
89 | Ltac2 rec make_pred' (f : constr) (body_type_g : constr) (pred : constr) (i : int) (args : constr list) :=
90 | match kind body_type_g with
91 | | Prod b c =>
92 | lazy_match! Constr.Binder.type b with
93 | (* In this case we want to produce forall x : d , forall h : pred x , (recursive call) *)
94 | | @sig ?d ?p =>
95 | (* binder for a variable of type `d` *)
96 | let binder_d := Constr.Binder.make None d in
97 | (* binder for a proof of `pred` of the variable we just introduced *)
98 | let d_pred := make (App pred (Array.of_list [make (Rel 1)])) in
99 | let binder_d_pred := Constr.Binder.make None d_pred in
100 | (* Here instead of adding just `x` to the args of `f` in the final expression, we add `proj1_sig (exist x h)` *)
101 | (* Which evaluates to `x`. This is necessary since, when proving that the resulting expression holds, we will *)
102 | (* use the result of the previous step, which states that `f (proj1_sig x) = g x`. *)
103 | (* Note: `Rel i` is `x` and `Rel (Int.sub i 1)` is `h` in the final expression. *)
104 | let exist_arg := make (App constr:(@exist) (Array.of_list [d; p; make (Rel i); make (Rel (Int.sub i 1))])) in
105 | let arg := make (App constr:(@proj1_sig) (Array.of_list [d; p; exist_arg])) in
106 | (* We subtract 2 from `i` in the recursive call since we added two binders *)
107 | let rest := make_pred' f c pred (Int.sub i 2) (arg :: args) in
108 | make (Prod binder_d (make (Prod binder_d_pred rest)))
109 | | _ => make (Prod b (make_pred' f c pred (Int.sub i 1) (make (Rel i) :: args)))
110 | end
111 | | _ =>
112 | let fApplied := make (App f (Array.of_list (List.rev args))) in
113 | make (App pred (Array.of_list [fApplied]))
114 | end.
115 |
116 | (* Given a symbol `f` and a predicate `pred`, produces the term corresponding to *)
117 | (* `forall x1 .. xn , pred y1 -> .. -> pred ym -> pred (f x1 .. xn) *)
118 | (* The variables `y1` .. `ym` are defined based on which parameters in `body_type_g` are refinement types. *)
119 | (* The parameters of `f` and `g` need to have the same type, except for some parameters that have the form *)
120 | (* `sig A P` in `g` and `A` in `f`. *)
121 | Ltac2 make_pred (body_type_g : constr) (f : constr) (pred : constr) :=
122 | (* Int.add (arity body_type_g) (count_ref_types body_type_g) represents the De Bruijn index of x1 in the final expression *)
123 | make_pred' f body_type_g pred (Int.add (arity body_type_g) (count_ref_types body_type_g)) [].
124 |
125 | Tactic Notation "convert_sigless" ident(i) constr(x) :=
126 | elpi convert_sigless_tac ltac_string:(i) ltac_term:(x).
127 |
128 | Tactic Notation "sig_expand" ident(i) constr(x) :=
129 | elpi sig_expand_tac ltac_string:(i) ltac_term:(x).
130 |
131 | Ltac elim_refinement_types p :=
132 | let sigless_p := fresh "sigless_symbol" in
133 | let reduced_p := eval hnf in p in
134 |
135 | (* Replace every `sig`s, `proj1_sig`s and `exist`s in reduced_p *)
136 | convert_sigless sigless_p reduced_p;
137 |
138 | (* Replace sigless_p by its body *)
139 | let sigless_p := eval cbn in sigless_p in
140 |
141 | let id_conversion := fresh "id_conversion" in
142 | let type_p := type of p in
143 | let type_p_expanded := fresh "type_symbol" in
144 |
145 | (* Delta expand every `sig` in type_p *)
146 | sig_expand type_p_expanded type_p;
147 |
148 | (* Extract body from type_p_expanded *)
149 | let body_type_p := eval red in type_p_expanded in
150 |
151 | (* Declare and prove equality between `p` and `sigless_p` *)
152 | let tac := ltac2:(sigless_p' p' body_type_p' id_conversion' |-
153 | let sigless_p'' := Option.get (Ltac1.to_constr sigless_p') in
154 | let p'' := Option.get (Ltac1.to_constr p') in
155 | let body_type_p'' := Option.get (Ltac1.to_constr body_type_p') in
156 | let eq := make_eq sigless_p'' p'' body_type_p'' in
157 | ltac1:(eq' id_conversion'' |- assert (id_conversion'' : eq') by reflexivity ) (Ltac1.of_constr eq) id_conversion'
158 | ) in tac sigless_p p body_type_p id_conversion;
159 |
160 | (* Declare and prove the fact that `sigless_p` also has the property of `p` *)
161 | let tac := ltac2:(sigless_p' body_type_p' id_conversion' |-
162 | let body_type_p'' := Option.get (Ltac1.to_constr body_type_p') in
163 | match get_ret_sig body_type_p'' with
164 | | Some pred =>
165 | let pred_applied := make_pred body_type_p'' (Option.get (Ltac1.to_constr sigless_p')) pred in
166 | ltac1:(pred' sigless_p'' id_conversion'' |-
167 | let H := fresh "H" in
168 | assert (pred') by (intros; rewrite id_conversion''; apply proj2_sig);
169 | cbn in H (* eliminate `proj1_sig (exist ...)` introduced by make_pred *)
170 | ) (Ltac1.of_constr pred_applied) sigless_p' id_conversion'
171 | (* If `p` only has refinement types in its arguments we skip this step, since we can't guarantee the property for the returned value *)
172 | | _ => ()
173 | end
174 | )
175 | in tac sigless_p body_type_p id_conversion;
176 |
177 | (* Replace `p` by `sigless_p` everywhere in the context *)
178 | try (rewrite <- id_conversion in *; clear id_conversion);
179 | clear type_p_expanded.
180 |
--------------------------------------------------------------------------------
/orchestrator/triggers_tactics.v:
--------------------------------------------------------------------------------
1 | From Ltac2 Require Import Ltac2.
2 | From Ltac2 Require Import Constr.
3 | From Ltac2 Require Import String.
4 | Require Import List ZArith.
5 | Import ListNotations.
6 | Require Import printer.
7 | Require Import triggers.
8 | Require Import filters.
9 |
10 | From SMTCoq Require SMT_classes Conversion Tactics Trace State SMT_classes_instances QInst BVList FArray.
11 |
12 | Ltac2 is_prod (c: constr) :=
13 | match Constr.Unsafe.kind c with
14 | | Constr.Unsafe.Prod _ _ => true
15 | | _ => false
16 | end.
17 |
18 | Ltac2 higher_order (c: constr) :=
19 | let t := Constr.type c in
20 | let rec aux t :=
21 | match Constr.Unsafe.kind t with
22 | | Constr.Unsafe.Prod bind t' =>
23 | Bool.or (let ty := Constr.Binder.type bind in (is_prod ty)) (aux t')
24 | | _ => false
25 | end
26 | in aux t.
27 |
28 | Ltac2 is_prop (c: constr) := Constr.equal c 'Prop.
29 |
30 | Ltac2 is_proof (c: constr) :=
31 | let t := Constr.type c in
32 | let t2 := Constr.type t in
33 | is_prop t2.
34 |
35 | Ltac2 rec codomain_not_prop_aux (c: constr) :=
36 | match Constr.Unsafe.kind c with
37 | | Constr.Unsafe.Prod bi c' => codomain_not_prop_aux c'
38 | | Constr.Unsafe.App x1 arr => codomain_not_prop_aux x1
39 | | _ => Bool.neg (is_prop c)
40 | end.
41 |
42 | Require Import refinement_elimination_elpi.
43 | From elpi Require Import elpi.
44 |
45 | Tactic Notation "sigfull" constr(x) :=
46 | elpi sigfull_tac ltac_term:(x).
47 |
48 | Ltac2 contains_refinement_type (c: constr) : bool :=
49 | match! constr:(true) with
50 | | _ => (ltac1:(c' |- (sigfull c'))) (Ltac1.of_constr (Constr.type c)); true
51 | | _ => false
52 | end.
53 |
54 | Ltac2 codomain_not_prop (c: constr) := codomain_not_prop_aux (Constr.type c).
55 |
56 | Ltac2 codomain_prop (c: constr) := Bool.neg (codomain_not_prop c).
57 |
58 | Ltac2 trigger_hyp_or_goal trig := TDisj (trig TSomeHyp) (trig TGoal).
59 |
60 | (* Ltac2 Eval (higher_order '@nth). *)
61 |
62 | (** Triggers and filters for Sniper tactics *)
63 |
64 | Ltac2 trigger_reflexivity () :=
65 | TDisj (TIs (TSomeDef, (Arg id)) (TAny NotArg))
66 | (TDisj (TContains (TSomeHyp, NotArg) (TConstant None (Arg id)))
67 | (TContains (TGoal, NotArg) (TConstant None (Arg id)))).
68 |
69 | Ltac2 filter_reflexivity () :=
70 | FConj
71 | (FConj
72 | (FConstr
73 | ['Z.add; 'Z.sub; 'Z.mul; 'Z.eqb; 'Z.ltb; 'Z.leb; 'Z.geb; 'Z.gtb; 'Z.lt;
74 | 'Z.le; 'Z.ge; 'Z.gt; 'Pos.lt; 'Pos.le; 'Pos.ge; 'Pos.gt; 'Z.to_nat; 'Pos.mul;
75 | 'Pos.sub; 'Init.Nat.add; 'Init.Nat.mul; 'Nat.eqb; 'Nat.leb; 'Nat.ltb; 'ge; 'gt;
76 | 'N.add; 'N.mul; 'N.eqb; 'N.leb; 'N.leb; 'N.ltb; 'Peano.lt; 'negb; 'not; 'andb; 'orb; 'implb; 'xorb;
77 | 'Bool.eqb; 'iff; 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_eq;
78 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_and;
79 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_or;
80 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_xor;
81 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_add;
82 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_mult;
83 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_ult;
84 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_slt;
85 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_concat;
86 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shl;
87 | 'SMTCoq.bva.BVList.BITVECTOR_LIST.bv_shr;
88 | '@FArray.select;
89 | '@FArray.diff;
90 | 'is_true;
91 | '@SMTCoq.classes.SMT_classes.eqb_of_compdec;
92 | '@SMTCoq.classes.SMT_classes.CompDec;
93 | '@SMTCoq.classes.SMT_classes_instances.Nat_compdec;
94 | '@SMTCoq.classes.SMT_classes_instances.list_compdec;
95 | '@SMTCoq.classes.SMT_classes_instances.prod_compdec;
96 | '@SMTCoq.classes.SMT_classes_instances.option_compdec;
97 | '@SMTCoq.classes.SMT_classes_instances.Z_compdec])
98 | (FPred higher_order))
99 | (FConj (FPred is_proof) (FPred contains_refinement_type)).
100 |
101 | Ltac2 trigger_unfold_reflexivity () :=
102 | TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard tDiscard NotArg).
103 |
104 | Ltac2 filter_unfold_reflexivity () :=
105 | FPred (fun x => (Bool.neg
106 | (
107 | let ty := Constr.type x in
108 | match! ty with
109 | | @eq ?a ?t ?u => Constr.equal t u
110 | | _ => false
111 | end))).
112 |
113 | Ltac2 trigger_unfold_in () :=
114 | TDisj (TMetaLetIn (TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard (TAny (Arg id)) NotArg)) ["H"; "eq"]
115 | (TConj (TIs (TNamed "H", Arg id) tDiscard)
116 | (TContains (TNamed "eq", NotArg) (TConstant None (Arg id)))))
117 | (TMetaLetIn (TIs (TSomeHyp, Arg id) (TEq tDiscard tDiscard tDiscard (Arg id))) ["H"; "eq"]
118 | (TConj (TIs (TNamed "H", Arg id) tDiscard)
119 | (TContains (TNamed "eq", NotArg) (TVar TLocalDef (Arg id))))).
120 |
121 | Ltac2 filter_unfold_in () :=
122 | FPredList (fun l => match l with | [x; y] =>
123 | Bool.or
124 | (let t := type x in
125 | match! t with
126 | | @eq ?a ?u ?v => Bool.neg (Constr.is_var u)
127 | end) (Bool.neg (higher_order y)) | _ => true end).
128 |
129 | Ltac2 trigger_higher_order_equalities :=
130 | TIs (TSomeHyp, Arg id) (TEq (TProd tDiscard tDiscard NotArg) tDiscard tDiscard NotArg).
131 |
132 | Ltac2 trigger_fixpoints :=
133 | TContains (TSomeHyp, Arg id) (TFix tDiscard tDiscard NotArg).
134 |
135 | Ltac2 trigger_pattern_matching :=
136 | TContains (TSomeHyp, Arg id) (TCase tDiscard tDiscard None NotArg).
137 |
138 | Ltac2 trigger_polymorphism () :=
139 | TDisj (TIs (TSomeHypProp, NotArg)
140 | (TProd (TSort TSet NotArg) tDiscard NotArg))
141 | (TIs (TSomeHypProp, NotArg)
142 | (TProd (TSort TBigType NotArg) tDiscard NotArg)).
143 |
144 | Ltac2 trigger_higher_order :=
145 | TContains (TSomeHyp, NotArg) (TProd (TProd tDiscard tDiscard NotArg) tDiscard NotArg).
146 |
147 |
148 | Ltac2 trigger_algebraic_types :=
149 | TDisj (TContains (TGoal, NotArg) (TInd None (Arg id))) (TContains (TSomeHyp, NotArg) (TInd None (Arg id))).
150 |
151 | Ltac2 filter_algebraic_types () :=
152 | FConj (FConstr
153 | ['Z; 'bool; 'positive; 'N; 'nat ; 'FArray.farray; 'SMTCoq.classes.SMT_classes.EqbType;
154 | 'SMTCoq.classes.SMT_classes.CompDec;
155 | 'SMTCoq.classes.SMT_classes.Comparable;
156 | 'SMTCoq.classes.SMT_classes.Inhabited ; 'Coq.Structures.OrderedType.Compare])
157 | (FPred codomain_prop).
158 |
159 | Ltac2 trigger_generation_principle () :=
160 | TIs (TSomeHyp, NotArg) (TInd None (Arg id)).
161 |
162 | Ltac2 filter_generation_principle () :=
163 | FConj (FConstr
164 | ['Z; 'bool; 'positive; 'FArray.farray; 'SMTCoq.classes.SMT_classes.EqbType;
165 | 'SMTCoq.classes.SMT_classes.CompDec;
166 | 'SMTCoq.classes.SMT_classes.Comparable;
167 | 'SMTCoq.classes.SMT_classes.Inhabited ; 'Coq.Structures.OrderedType.Compare])
168 | (FPred codomain_prop).
169 |
170 | Ltac2 trigger_anonymous_fun () :=
171 | TDisj (
172 | TMetaLetIn (TContains (TSomeHyp, Arg Constr.type) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"]
173 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"]
174 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg))))
175 | (TIs (TNamed "f", Arg id) tDiscard)))
176 | (TMetaLetIn (TContains (TGoal, Arg id) (TLambda tDiscard tDiscard (Arg id))) ["H"; "f"]
177 | (TConj (TNot (TMetaLetIn (TContains (TNamed "H", NotArg) (TCase tDiscard tDiscard None (Arg id))) ["c"]
178 | (TContains (TNamed "c", NotArg) (TTrigVar (TNamed "f") NotArg)))) (TIs (TNamed "f", Arg id) tDiscard))).
179 |
180 | Ltac2 trigger_add_compdecs () :=
181 | TDisj
182 | (triggered when (AnyHyp) contains TEq (TAny (Arg id)) tDiscard tDiscard NotArg)
183 | (triggered when (TGoal) contains TEq (TAny (Arg id)) tDiscard tDiscard NotArg).
184 |
185 | Ltac2 filter_add_compdecs () :=
186 | (FConj
187 | (FConstr ['Z; 'bool; 'positive; 'nat ; 'FArray.farray; 'Prop; 'Set; 'Type])
188 | (FPred (fun x => Bool.or (is_prod x)
189 | (match Constr.Unsafe.kind x with | Constr.Unsafe.App u ca => Bool.or (Constr.equal u '@SMT_classes.CompDec) (Constr.equal u '@sig) | _=> false end )))).
190 |
191 |
192 | (* Ltac2 trigger_fold_local_def () :=
193 | tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in
194 | TConj (triggered when (TSomeHypProp) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (NotArg))
195 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id))
196 | (* trick to get as argument the definition not unfolded*). *)
197 |
198 | Ltac2 trigger_fold_local_def_in_hyp () :=
199 | TDisj
200 | (tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in
201 | TConj (triggered when (TSomeHypProp) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (Arg id))
202 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id)))
203 | (tlet def ; def_unfold := (triggered when (TSomeDef) is (tArg) on (Arg id)) in
204 | TConj (triggered when (TSomeDef) contains (TTrigVar (TNamed "def_unfold") (NotArg)) on (Arg id))
205 | (triggered when (TNamed "def") is (TTrigVar (TNamed "def") (NotArg)) on (Arg id))).
206 | (* trick to get as argument the definition not unfolded*)
207 |
208 | (** warning A TNot is not interesting whenever all hypotheses are not considered !!! *)
209 | Ltac2 trigger_trakt_bool_hyp () :=
210 | (TNot (TIs (TSomeHypProp, Arg id) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))).
211 |
212 | Ltac2 trigger_trakt_bool_goal () :=
213 | (TNot (TIs (TGoal, NotArg) (TEq (TTerm 'bool NotArg) tDiscard tDiscard NotArg))).
214 |
215 | Ltac2 trigger_pose_case () :=
216 | TMetaLetIn (TContains (TGoal, NotArg) (TCase tDiscard tDiscard None (Arg id))) ["M"]
217 | (TConj
218 | (TNot (TMetaLetIn (TContains (TGoal, NotArg) (TProd tArg tDiscard NotArg)) ["f"]
219 | (TContains (TNamed "f", NotArg) (TTrigVar (TNamed "M") NotArg))))
220 | (TIs (TNamed "M", Arg id) tDiscard)).
221 |
222 |
223 | (* There is an hypothesis or the goal which contain a term whose type contains a `sig` and it returns the set of minimal such terms *)
224 | Ltac2 trigger_elim_refinement_types_loc loc :=
225 | let containsSigInType trig_var :=
226 | TMetaLetIn (TIs (trig_var, Arg type) tDiscard) ["T"]
227 | (TContains (TNamed "T", NotArg) (TTerm 'sig NotArg))
228 | in
229 | TMetaLetIn (TContainsClosed (loc, NotArg) tArg) ["x"]
230 | (TConj
231 | (TConj
232 | (containsSigInType (TNamed "x"))
233 | (TNot (TMetaLetIn (TContainsClosed (TNamed "x", NotArg) tArg) ["y"]
234 | (TConj
235 | (TNot (TIs (TNamed "x", NotArg) (TTrigVar (TNamed "y") NotArg)))
236 | (containsSigInType (TNamed "y"))
237 | ))))
238 | (TIs (TNamed "x", Arg id) tDiscard)).
239 |
240 | Ltac2 trigger_elim_refinement_types () :=
241 | trigger_hyp_or_goal trigger_elim_refinement_types_loc.
242 |
243 | Ltac2 filter_elim_refinement_types () :=
244 | FConstr ['@proj1_sig].
245 |
--------------------------------------------------------------------------------
/theories/elimination_pattern_matching.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyfalse (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 |
13 | Require Import MetaCoq.Template.All.
14 | Require Import String.
15 | Require Import utilities.
16 | Require Import reflexivity.
17 | Require Import unfold_reflexivity.
18 | Require Import elimination_fixpoints.
19 | Require Import expand.
20 | Require Import List.
21 | Import ListNotations.
22 |
23 | Ltac create_evars_for_each_constructor i :=
24 | let i_reif := metacoq_get_value (tmQuote i) in
25 | match i_reif with
26 | | tInd (?indu ?kn _) ?inst =>
27 | let y := metacoq_get_value (tmQuoteInductive kn) in
28 | let n:= eval cbv in (get_nb_constructors_dcl y) in
29 | let rec tac_rec u := match constr:(u) with
30 | | 0 => idtac
31 | | S ?m => let H' := fresh in let H'_evar := fresh H' in epose (H' := ?[H'_evar] : Prop) ; tac_rec m
32 | end in tac_rec n
33 | | _ => idtac
34 | end.
35 |
36 | Goal True.
37 | create_evars_for_each_constructor bool.
38 | create_evars_for_each_constructor unit.
39 | create_evars_for_each_constructor nat.
40 | Abort.
41 |
42 | Ltac intro_and_tuple_rec n l :=
43 | match constr:(n) with
44 | | 0 => let u := fresh in let _ := match goal with _ => intro u end in constr:((u, l))
45 | | S ?m => let H := fresh in let _ := match goal with _ => intro H end in intro_and_tuple_rec m (H, l)
46 | end.
47 |
48 | Ltac intro_and_tuple n :=
49 | intro_and_tuple_rec n unit.
50 |
51 | Ltac intro_return_vars_aux l :=
52 | lazymatch goal with
53 | | |- forall _, forall _, _ => let H := fresh in
54 | let _ := match goal with _ => intro H end in intro_return_vars_aux (H, l)
55 | | |- forall _, _ => let H := fresh in let _ := match goal with _ => intro H end in constr:(l)
56 | | _ => constr:(l)
57 | end.
58 |
59 | Ltac intro_return_vars := intro_return_vars_aux default.
60 |
61 | Ltac specialize_tuple p H :=
62 | lazymatch constr:(p) with
63 | | (?x, ?y) => specialize_tuple y H ; try (specialize (H x))
64 | | default => idtac
65 | end.
66 |
67 | Goal forall (A : Type) (l : list A) (n : nat), False.
68 | assert (foo : forall (A : Type) (l : list A) (n : nat), l = l) by reflexivity.
69 | let x := intro_return_vars in specialize_tuple x foo. Abort.
70 |
71 |
72 | Ltac revert_tuple_clear p indu :=
73 | lazymatch constr:(p) with
74 | | (?x, ?y) => match indu with
75 | | context [x] => clear x
76 | | _ => revert x
77 | end
78 | ; revert_tuple_clear y indu
79 | | unit => idtac
80 | end.
81 |
82 | Definition head_tuple (A B : Type) (x : A×B) := match x with
83 | |(y, z) => y
84 | end.
85 |
86 | Definition tail_tuple (A B : Type) (x : A*B) := match x with
87 | |(y, z) => z
88 | end.
89 |
90 | Ltac detect_var_match H :=
91 |
92 | let T := type of H in
93 | let H' := fresh in
94 | assert (H' : False -> T) by
95 | (match goal with | |-context C[match ?x with _ => _ end] => idtac end; let Hfalse := fresh in
96 | intro Hfalse; destruct Hfalse) ; clear H' ; idtac.
97 |
98 | Ltac remove_app t :=
99 | lazymatch constr:(t) with
100 | | ?u ?v => remove_app u
101 | | _ => t
102 | end.
103 |
104 | Goal forall (A : Type) (x: list A), x = x.
105 | Proof. intros. let T := type of x in let T' := remove_app T in pose T'.
106 | reflexivity.
107 | Qed.
108 |
109 | Ltac revert_count :=
110 | let rec revert_count_rec n :=
111 | match goal with
112 | | H : _ |- _ => let _ := match goal with _ => revert H end in revert_count_rec (S n)
113 | | _ => n
114 | end in revert_count_rec 0.
115 |
116 | Ltac contains t u :=
117 | match t with
118 | | context [u] => idtac
119 | | _ => fail
120 | end.
121 |
122 | Ltac all_quantifers_introduced :=
123 | lazymatch goal with
124 | | |- forall _, _ => fail
125 | | _ => idtac
126 | end.
127 |
128 | Ltac elim_match_with_no_forall H :=
129 | let U := type of H in
130 | match U with
131 | | context C[match ?expr with _ => _ end] =>
132 | let Ty := type of expr in
133 | let T' := remove_app Ty in
134 | create_evars_for_each_constructor T' ;
135 | let foo := fresh in
136 | assert (foo : False -> U)
137 | by (let Hfalse := fresh in
138 | intro Hfalse ;
139 | (case_eq expr) ;
140 | match goal with
141 | | u : Prop |- ?G => instantiate (u := G); destruct Hfalse
142 | end) ; clear foo ;
143 | repeat match goal with
144 | | u : Prop |-_ => let H0 := fresh in let u' := eval unfold u in u in assert (H0 : u') by
145 | (first [ try (rewrite H); reflexivity
146 | |intros ; match goal with
147 | | Hinv : _ |- _ => rewrite Hinv in H ; auto
148 | end]); try elim_match_with_no_forall H0 ; clear u
149 | end
150 | end ; clear H.
151 |
152 | (* Tests *)
153 |
154 | Fixpoint leb (n:nat)(m:nat) :=
155 | match n,m with
156 | | 0,_ => true
157 | | (S _) , 0 => false
158 | | S n, S m => leb n m
159 | end.
160 |
161 | Lemma leb_le : forall n m, (leb n m = true) -> le n m.
162 | intros n. induction n. intros m.
163 | intros H. induction m.
164 | constructor. constructor. apply IHm.
165 | constructor. intros m. intro H. simpl in H.
166 | elim_match_with_no_forall H. Abort.
167 |
168 |
169 | Ltac eliminate_dependent_pattern_matching H :=
170 | let n := fresh "n" in
171 | let T := fresh "T" in
172 | epose (n := ?[n_evar] : nat) ;
173 | epose (T := ?[T_evar]) ;
174 | let U := type of H in
175 | let H' := fresh in
176 | assert (H' : False -> U);
177 | [ let HFalse := fresh in
178 | intro HFalse;
179 | let rec tac_rec m x :=
180 | match goal with
181 | | |- context C[match ?expr with _ => _ end] => match constr:(m) with
182 | | 0 => fail
183 | | S ?p => contains expr x ; instantiate (n_evar := p) ;
184 | let Ty := type of expr in let T' := remove_app Ty in
185 | instantiate (T_evar := T')
186 | end
187 | | |- forall _, _ => let y := fresh in intro y; tac_rec (S m) y
188 | | _ => fail
189 | end
190 | in
191 | tac_rec 0 ltac:(fresh) ;
192 | destruct HFalse
193 | | clear H' ; let indu := eval unfold T in T in
194 | create_evars_for_each_constructor indu ; let foo := fresh in assert
195 | (foo : False -> U) by
196 | (let Hfalse' := fresh in intro Hfalse' ;
197 | let nb_var := eval unfold n in n in
198 | let t := intro_and_tuple nb_var in
199 | match goal with
200 | |- context C[match ?expr with _ => _ end] =>
201 | let var_match := eval cbv in (head_tuple _ _ t) in
202 | let var_to_revert := eval cbv in (tail_tuple _ _ t) in
203 | tryif (constr_eq var_match expr)
204 | then
205 | (case var_match ;
206 | let indu' := type of var_match in clear var_match ;
207 | revert_tuple_clear var_to_revert indu')
208 | else
209 | (case_eq expr ;
210 | let indu' := type of expr in revert var_match ;
211 | revert_tuple_clear var_to_revert indu')
212 | end
213 | ; match goal with
214 | | u : Prop |- ?G => instantiate (u := G) ; destruct Hfalse' end)
215 | ; clear foo ;
216 | repeat match goal with
217 | | u : Prop |-_ => let H0 := fresh in let u' := eval unfold u in u in assert (H0 : u') by
218 | first [ intros; rewrite H ; reflexivity
219 | | let hyps := intro_return_vars in specialize_tuple hyps H ;
220 | lazymatch goal with
221 | | Hrew : _ |- _ => solve [rewrite Hrew in H; assumption]
222 | end
223 | ] ; clear u ; try (eliminate_dependent_pattern_matching H0) end] ; clear H ;
224 | clear n; clear T.
225 |
226 | Tactic Notation "eliminate_dependent_pattern_matching" constr(H) :=
227 | first [eliminate_dependent_pattern_matching H | elim_match_with_no_forall H].
228 |
229 | Module Tests.
230 |
231 | Definition dumb_def (n m : nat) := match Nat.eqb n m with true => true | false => false end.
232 |
233 | Goal (forall n m : nat, dumb_def n m = false)-> False.
234 | intros. assert_refl dumb_def.
235 | unfold_refl H0.
236 | expand_hyp H0.
237 | eliminate_dependent_pattern_matching H1.
238 | assert_refl length. unfold_refl H1. expand_hyp H1.
239 | eliminate_fix_hyp H2. eliminate_dependent_pattern_matching H2.
240 | Abort.
241 |
242 |
243 | Lemma foo x y :( if (Nat.leb x y) then 2 + 2 = 4 else 3+4 = 6) -> False.
244 | intros.
245 | eliminate_dependent_pattern_matching H.
246 | Abort.
247 |
248 | Lemma bar: ( forall x y, if (Nat.leb x y) then 2 + 2 = 4 else 3+4 = 6) -> False.
249 | intros. eliminate_dependent_pattern_matching H.
250 | Abort.
251 |
252 | Lemma toto (A : Type) (x : list A) :
253 | match x with
254 | | nil => 0 = 0
255 | | y :: ys => ys = ys
256 | end
257 | -> True.
258 | Proof. intros. eliminate_dependent_pattern_matching H.
259 | exact I. Qed.
260 |
261 |
262 | Definition min1 (x : nat) := match x with
263 | | 0 => 0
264 | | S x => x
265 | end.
266 | Definition min1' := min1.
267 |
268 | Definition min1'' := min1'.
269 |
270 | Definition min1''' := min1''.
271 |
272 |
273 | MetaCoq Quote Definition hyp_cons_reif := ((forall (A: Type) (x : A) (a : A) (l : list A),
274 | @hd A x (@cons A a l) = match (@cons A a l) with
275 | | nil => x
276 | | y :: xs => y
277 | end)).
278 |
279 | Definition bool_pair := (bool * bool)%type.
280 | Inductive dep_type : Type -> Type :=
281 | | ToBool : bool -> dep_type bool
282 | | ToUnit : bool -> dep_type unit.
283 |
284 | Definition dep_fun : bool -> bool_pair -> bool := fun d : bool => match d with
285 | | true => fst
286 | | false => snd
287 | end
288 | .
289 |
290 | Definition dep_match : forall (ω : bool_pair) (a : Type) (D : dep_type a), (match D with
291 | | ToBool _ => bool
292 | | ToUnit _ => unit
293 | end) -> bool :=
294 | fun ω a D => match D with
295 | | ToBool d => fun x => Bool.eqb (dep_fun d ω) x
296 | | ToUnit d => fun x => true
297 | end.
298 |
299 |
300 | Goal True.
301 | assert_refl Nat.add. unfold_refl H. expand_hyp H. eliminate_fix_hyp H0.
302 | eliminate_dependent_pattern_matching H0.
303 | assert_refl dep_match.
304 | unfold_refl H0.
305 | expand_hyp H0.
306 | clear - H1. eliminate_dependent_pattern_matching H1.
307 | Abort.
308 |
309 | Fixpoint nth {A : Type} (n:nat) (l:list A) (default:A) {struct l} : A :=
310 | match n, l with
311 | | O, x :: l' => x
312 | | O, _other => default
313 | | S m, [] => default
314 | | S m, x :: t => nth m t default
315 | end.
316 |
317 | Goal False.
318 | assert_refl @nth. unfold_refl H.
319 | expand_hyp H.
320 | eliminate_fix_hyp H0.
321 | eliminate_dependent_pattern_matching H0.
322 | assert_refl @nth_default. unfold_refl H0.
323 | expand_hyp H0.
324 | eliminate_dependent_pattern_matching H1.
325 | Abort.
326 |
327 | End Tests.
328 |
--------------------------------------------------------------------------------
/tests/tests.v:
--------------------------------------------------------------------------------
1 | (**************************************************************************)
2 | (* *)
3 | (* Sniper *)
4 | (* Copyright (C) 2021 *)
5 | (* *)
6 | (* See file "AUTHORS" for the list of authors *)
7 | (* *)
8 | (* This file is distributed under the terms of the CeCILL-C licence *)
9 | (* *)
10 | (**************************************************************************)
11 |
12 | From Sniper Require Import Sniper.
13 | From Sniper Require Import Transfos.
14 | Require Import String.
15 | Require Import ZArith.
16 | Require Import Bool.
17 | Require Import List.
18 | Import ListNotations.
19 |
20 | Section poly.
21 |
22 |
23 | Goal (forall A B C : Type,
24 | forall (f : A -> B) (g : A -> C),
25 | let f0 := fun x : A => (f x, g x) in
26 | let f1 := @map A (B * C) f0 in
27 | let f2 := @map A B f in
28 | let f3 := @map A C g in
29 | (forall (H5 H7 : Type) (l' : list H7), @zip H5 H7 [] l' = []) ->
30 | (forall (H7 H9 : Type) (H10 : H7) (H11 : list H7), @zip H7 H9 (H10 :: H11) [] = []) ->
31 | (forall (H7 H9 : Type) (H10 : H7) (H11 : list H7) (h : H9) (l : list H9),
32 | @zip H7 H9 (H10 :: H11) (h :: l) = (H10, h) :: @zip H7 H9 H11 l) ->
33 | f1 [] = [] ->
34 | (forall (a : A) (l : list A), f1 (a :: l) = f0 a :: f1 l) ->
35 | f2 [] = [] ->
36 | (forall (a : A) (l : list A), f2 (a :: l) = f a :: f2 l) ->
37 | f3 [] = [] ->
38 | (forall (a : A) (l : list A), f3 (a :: l) = g a :: f3 l) ->
39 | (forall (x : Type) (x0 x1 : x) (x2 x3 : list x), x0 :: x2 = x1 :: x3 -> x0 = x1 /\ x2 = x3) ->
40 | (forall (x : Type) (x0 : x) (x1 : list x), [] = x0 :: x1 -> False) ->
41 | (forall (x x0 : Type) (x1 x2 : x) (x3 x4 : x0), (x1, x3) = (x2, x4) -> x1 = x2 /\ x3 = x4) ->
42 | f1 [] = @zip B C (f2 []) (f3 [])).
43 | Proof. intros. elimination_polymorphism. Abort.
44 |
45 | End poly.
46 |
47 | Section tests_for_decidable_relations.
48 |
49 | Variable (A : Type).
50 | Variable (HA : CompDec A).
51 |
52 | Fixpoint smaller_dec_bis (l l' : list A) :=
53 | match l with
54 | | nil => true
55 | | cons x xs => false
56 | end
57 | ||
58 | match l with
59 | | nil => false
60 | | cons x xs => match l' with
61 | | nil => false
62 | | cons x' xs' => smaller_dec_bis xs xs'
63 | end
64 | end.
65 |
66 | Goal forall (l l' l'' : list A) (x : A),
67 | smaller_dec_bis l l' -> l' = [] -> l <> cons x l''.
68 | Proof. snipe. Qed.
69 |
70 | End tests_for_decidable_relations.
71 |
72 | Section tests.
73 |
74 | Goal ((forall (A : Type) (l : list A),
75 | length l = match l with
76 | | [] => 0
77 | | _ :: xs => S (length xs)
78 | end) -> True).
79 | intro H.
80 | eliminate_dependent_pattern_matching H.
81 | exact I.
82 | Qed.
83 |
84 | Definition true_hidden := true.
85 | Definition definition_no_variables := if true_hidden then 1=1 else 2=2.
86 |
87 | Goal definition_no_variables -> True.
88 | intros.
89 | unfold definition_no_variables in H.
90 | eliminate_dependent_pattern_matching H.
91 | Abort.
92 |
93 | Lemma if_var_in_context x y : (if Nat.eqb x y then x = x else y = y) -> True.
94 | intros H.
95 | scope.
96 | Abort.
97 |
98 | Lemma nth_default_eq :
99 | forall (A : Type) (HA : CompDec A) n l (d:A), nth_default d l n = nth n l d.
100 | Proof. intros A HA n ; induction n.
101 | - snipe.
102 | - intros l ; destruct l.
103 | * snipe.
104 | * scope. get_projs_st option. (* specialize (gen_option A d). *)
105 | (* verit does not succed because p and p0 are not Zified by trakt (see "Preprocessing" channel *)
106 | Abort.
107 |
108 | (* Test polymorphism *)
109 | Goal (forall (A B : Type) (x1 x2 : A) (y1 y2 : B),
110 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) -> ((forall (x1 x2 : bool) (y1 y2 : nat),
111 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) /\ (forall (x1 x2 : nat) (y1 y2 : bool),
112 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2)) /\ (forall (x1 x2 : bool) (y1 y2 : bool),
113 | (x1, y1) = (x2, y2) -> (x1 = x2 /\ y1 = y2))).
114 | intro H. elimination_polymorphism. split. assumption. split. assumption. assumption.
115 | Qed.
116 |
117 | (* Test projs *)
118 | Variable A : Type.
119 | Variable a : A.
120 |
121 | Goal forall (n : nat) (l : list A)(x : A) (xs: list A), l = nil \/ l = cons x xs.
122 | Proof.
123 | get_projs_in_goal.
124 | Abort.
125 |
126 | Variable HA : CompDec A.
127 |
128 | Definition search :=
129 | fix search {A : Type} {H : CompDec A} (x : A) (l : list A) {struct l} : bool :=
130 | match l with
131 | | [] => false
132 | | x0 :: l0 => orb (eqb_of_compdec H x x0) (search x l0)
133 | end.
134 |
135 | Local Open Scope list_scope.
136 | Import ListNotations.
137 |
138 | Lemma search_append_neq :
139 | forall l1 l2 l3 x, search x (l1 ++ l2) <> search x l3 -> l1 ++ l2 <> l3.
140 | Proof.
141 | Time snipe. Qed.
142 |
143 |
144 | Open Scope list_scope.
145 |
146 | Import ListNotations.
147 | Variable a_0 : A.
148 |
149 | (** The boolean In *)
150 | Fixpoint Inb (a:A) (l:list A) : bool :=
151 | match l with
152 | | [] => false
153 | | b :: m => orb (eqb_of_compdec HA a b) (Inb a m)
154 | end.
155 |
156 |
157 | (*
158 | Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
159 | Proof.
160 | Time snipe.
161 | Abort. *)
162 |
163 | Lemma hd_error_tl_repr : forall l (a:A) r,
164 | hd_error l = Some a /\ tl l = r <-> l = a :: r.
165 | Proof. Time snipe.
166 | Qed.
167 |
168 | Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil.
169 | Proof.
170 | Time snipe_no_check.
171 | Qed.
172 |
173 | Theorem hd_error_nil : hd_error (@nil A) = None.
174 | Proof.
175 | Time snipe_no_check.
176 | Qed.
177 |
178 |
179 | (* Theorem in_eq : forall (a:A) (l:list A), Inb a (a :: l) = true.
180 | Proof.
181 | Time snipe.
182 | Qed. *)
183 |
184 | Theorem in_cons : forall (a b:A) (l:list A), Inb b l = true -> Inb b (a :: l) = true.
185 | Proof.
186 | Time snipe_no_check.
187 | Qed.
188 |
189 | Theorem not_in_cons (x b : A) (l : list A):
190 | ~ Inb x (a::l) = true <-> x<>a /\ ~ Inb x l = true.
191 | Proof.
192 | Time snipe_no_check.
193 | Qed.
194 |
195 | Theorem in_nil : forall a:A, ~ Inb a nil.
196 | Proof.
197 | Time snipe_no_check.
198 | Qed.
199 |
200 | Lemma in_inv : forall (a b:A) (l:list A), Inb b (a :: l) -> a = b \/ Inb b l.
201 | Proof.
202 | Time snipe.
203 | Qed.
204 |
205 | Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> ((a :: y) ++ x).
206 | Proof.
207 | Time snipe_no_check.
208 | Qed.
209 |
210 | Theorem app_nil_l : forall l:list A, [] ++ l = l.
211 | Proof.
212 | Time snipe_no_check.
213 | Qed.
214 |
215 | Theorem app_nil_r : forall l:list A, l ++ [] = l.
216 | Proof.
217 | Time induction l ; snipe_no_check.
218 | Qed.
219 |
220 | Theorem app_nil_end : forall (l:list A), l = l ++ [].
221 | Proof. pose proof app_nil_r. snipe_no_check. Qed.
222 |
223 | Theorem app_assoc : forall l m n:list A, (l ++ m ++ n) = ((l ++ m) ++ n).
224 | Proof.
225 | Time intros l ; induction l ; snipe_no_check.
226 | Qed.
227 |
228 | Theorem app_assoc_reverse : forall l m n:list A, ((l ++ m) ++ n) = (l ++ m ++ n).
229 | Proof.
230 | pose proof app_assoc. Time snipe_no_check.
231 | Qed.
232 |
233 | Theorem app_comm_cons : forall (x y:list A) (a:A), (a :: (x ++ y)) = ((a :: x) ++ y).
234 | Proof.
235 | Time snipe_no_check.
236 | Qed.
237 |
238 | Theorem app_eq_nil' : forall l l':list A,
239 | (l ++ l') = nil -> l = nil /\ l' = nil.
240 | Proof.
241 | Time snipe_no_check. Qed.
242 |
243 | Theorem app_eq_unit :
244 | forall (x y:list A) (a:A),
245 | x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil.
246 | Proof.
247 | Time snipe_no_check. Qed.
248 |
249 | Lemma app_inj_tail :
250 | forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b.
251 | Proof.
252 | Time induction x ; snipe_no_check.
253 | Qed.
254 |
255 | Lemma in_app_or : forall (l m:list A) (a:A), Inb a (l ++ m) -> or (Inb a l) (Inb a m).
256 | Proof.
257 | intros l m b. Time induction l; snipe_no_check.
258 | Qed.
259 |
260 | Lemma app_inv_head:
261 | forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
262 | Proof.
263 | Time induction l ; snipe_no_check. Qed.
264 |
265 | Goal forall (l : list A), l = [] -> hd_error l = None.
266 | snipe_no_check. Qed.
267 |
268 | End tests.
269 |
270 | Section Pairs.
271 | Variable A B : Type.
272 | Variable HA : CompDec A.
273 | Variable HB : CompDec B.
274 |
275 | Definition fst (p:A * B) := match p with (x, y) => x end.
276 | Definition snd (p:A * B) := match p with (x, y) => y end.
277 |
278 | Lemma surjective_pairing :
279 | forall (p:A * B), p = (fst p, snd p).
280 | Proof. Time snipe_no_check. Qed.
281 |
282 | End Pairs.
283 |
284 | Check N.
285 |
286 | (* `expand_hyp` shouldn't rely on the body of the symbol, but on the proof of equality *)
287 | Section expand_hyp_without_body.
288 |
289 | Variable x : nat.
290 | Variable f g : nat -> nat.
291 | Variable h1 : f 42 = 42.
292 | Variable h2 : g 42 = 42.
293 | Variable M : nat -> nat.
294 | Variable pf_refl : M = match x with | 0 => f | S _ => g end.
295 |
296 | Goal M 42 = 42.
297 | scope.
298 | Abort.
299 |
300 | End expand_hyp_without_body.
301 |
302 | (* Testing interaction of `pose_case` with other transformations - verit won't conclude the goal due to silent simplification *)
303 | Goal forall (x : nat) (f g : nat -> nat) , (f 2 = 2) -> (g 2 = 2) -> ((match x with O => f | S _ => g end) 2 = 2).
304 | Proof.
305 | scope.
306 | verit.
307 | Abort.
308 |
309 | Set Default Proof Mode "Classic".
310 |
311 | Definition p := fun x : nat => x > 3.
312 |
313 | Program Definition k : nat -> sig p -> nat -> sig p -> nat -> sig p := fun _ _ _ _ _ => exist _ 4 _.
314 | Next Obligation.
315 | unfold p.
316 | auto.
317 | Qed.
318 |
319 | Goal 4 > 3.
320 | elim_refinement_types k.
321 | assert (five: 5 > 3) by auto.
322 | exact (H 5 5 five 5 5 five 5).
323 | Qed.
324 |
325 | Fixpoint rep_sig (i : nat) : Set :=
326 | match i with
327 | | 0 => nat
328 | | S i' => @sig (rep_sig i') (fun x => x = x)
329 | end.
330 |
331 | Goal True.
332 | convert_sigless h (rep_sig 100).
333 | trivial.
334 | Qed.
335 |
336 | Section CompCertExample.
337 |
338 | Local Open Scope Z_scope.
339 |
340 | (* The trigger does not work up to delta conversion, but the tactic does *)
341 | Inductive data : Type := Nil | Cons (lo hi: Z) (tl: data).
342 |
343 | Fixpoint ok (x : data) : bool :=
344 | match x with
345 | | Nil => true
346 | | Cons l1 h1 s =>
347 | match s with
348 | | Nil => l1 (l1 []
19 | | (tr, na', f) :: xs =>
20 | if String.equal na na' then xs
21 | else (tr, na', f) :: remove_tac na xs
22 | end.
23 |
24 | Ltac2 rec list_pair_equal (eq : 'a -> 'a -> bool) l1 l2 :=
25 | match l1, l2 with
26 | | [], [] => true
27 | | (x1, y1) :: l1', (x2, y2) :: l2' =>
28 | Bool.and (Bool.and (eq x1 x2) (eq y1 y2)) (list_pair_equal eq l1' l2')
29 | | _ => false
30 | end.
31 |
32 | (** Checks if the tactic was already triggered *)
33 |
34 | Ltac2 already_triggered
35 | (l : (string * ((constr*constr) list)) list)
36 | (p : string * constr list) :=
37 | let (nametac, largs) := p in
38 | let tyargs := List.map type largs in
39 | let largstyargs := List.combine largs tyargs in
40 | let rec aux l :=
41 | match l with
42 | | (s, llc) :: l' =>
43 | if String.equal s nametac then
44 | if list_pair_equal equal largstyargs llc then true else aux l'
45 | else aux l'
46 | | [] => false
47 | end in aux l.
48 |
49 | Ltac2 hyp_equal h h' :=
50 | let (id1, opt1, c1) := h in
51 | let (id2, opt2, c2) := h' in
52 | if Ident.equal id1 id2 then
53 | if Constr.equal c1 c2 then
54 | match opt1, opt2 with
55 | | Some x, Some y => Constr.equal x y
56 | | None, Some _ => false
57 | | Some _, None => false
58 | | None, None => true
59 | end
60 | else false
61 | else false.
62 |
63 | Ltac2 rec diff_hyps hs1 hs2 :=
64 | match hs1, hs2 with
65 | | [], hs2' => hs2'
66 | | x :: xs, y :: ys =>
67 | if hyp_equal x y then diff_hyps xs ys
68 | else y :: diff_hyps xs ys
69 | | x :: xs, [] => [] (* we do not consider removed hypotheses *)
70 | end.
71 |
72 | Ltac2 Type verbosity :=
73 | [ Nothing | Info | Debug | Full ].
74 |
75 | Ltac2 leq_verb (v1 : verbosity) (v2 : verbosity) :=
76 | match v1 with
77 | | Nothing => true
78 | | Info =>
79 | match v2 with
80 | | Nothing => false
81 | | _ => true
82 | end
83 | | Debug =>
84 | match v2 with
85 | | Nothing => false
86 | | Info => false
87 | | _ => true
88 | end
89 | | Full =>
90 | match v2 with
91 | | Full => true
92 | | _ => false
93 | end
94 | end.
95 |
96 | Ltac2 print_tactic_not_triggered (v : verbosity) (s : string) :=
97 | if leq_verb v Debug then () else
98 | printf "NONE: The following tactic was not triggered: %s" s.
99 |
100 | Ltac2 print_tactic_already_applied (v : verbosity) (s : string) (l : constr list) :=
101 | if leq_verb v Debug then () else
102 | (printf "%s was already applied with the following args :" s ;
103 | List.iter (fun x => printf "%t" x) l).
104 |
105 | Ltac2 print_tactic_already_applied_once (v : verbosity) (s : string) :=
106 | if leq_verb v Debug then () else
107 | printf "%s was already applied one time" s.
108 |
109 | Ltac2 print_tactic_global_in_local (v : verbosity) (s : string) :=
110 | if leq_verb v Debug then () else
111 | printf "%s is global and cannot be applied in a local state" s.
112 |
113 | Ltac2 print_state_verb (v : verbosity) it :=
114 | if leq_verb v Debug then () else
115 | print_state (it.(local_env)).
116 |
117 | Ltac2 print_applied_tac (v : verbosity) (s : string) (l : constr list) :=
118 | if leq_verb v Nothing then () else
119 | (printf "Applied %s with the following args" s ;
120 | List.iter (fun x => printf "%t: %t" x (Constr.type x)) l).
121 |
122 | Ltac2 print_tactic_trigger_filtered (v : verbosity) (s : string) (l : constr list) :=
123 | if leq_verb v Debug then () else
124 | (printf "The tactic %s was filtered with the following args" s ;
125 | List.iter (fun x => printf "%t" x) l).
126 |
127 | Ltac2 rec remove_dups (ll : constr list list) :=
128 | match ll with
129 | | [] => []
130 | | l :: ll' => if List.mem (List.equal Constr.equal) l ll' then remove_dups ll' else l :: remove_dups ll'
131 | end.
132 |
133 | Ltac2 Type count := { mutable count : int }.
134 |
135 | Ltac2 numgoals () :=
136 | let c := { count := 0 } in
137 | Control.enter (fun _ =>
138 | c.(count) := Int.add 1 (c.(count))
139 | ); (c).(count).
140 |
141 | Ltac2 rec orchestrator_aux
142 | alltacs (* the mutable field of all tactics *)
143 | init_fuel
144 | fuel
145 | it (* the interpretation state (see [triggers.v]) *)
146 | env (* local triggers variables *)
147 | (trigstacsfis : ((trigger * bool * (int * int) option) * string * filter) list)
148 | (trigtacs : already_triggered) (* Triggered tactics, pair between a string and a list of arguments and their types *)
149 | (v: verbosity) : (* number of information required *) unit :=
150 | if Int.le fuel 0 then (* a problematic tactic used all the fuel *)
151 | match trigstacsfis with
152 | | [] => ()
153 | | (_, name, _) :: trs => (alltacs).(all_tacs) := remove_tac name ((alltacs).(all_tacs)) ;
154 | Control.enter (fun () => orchestrator init_fuel alltacs trigtacs v)
155 | end
156 | else
157 | print_state_verb v it ;
158 | match trigstacsfis with
159 | | [] =>
160 | if (it).(global_flag) then ()
161 | else Control.enter (fun () => orchestrator fuel alltacs trigtacs v)
162 | | ((trig, multipletimes, opt), name, fi) :: trigstacsfis' =>
163 | (it).(name_of_tac) := name ;
164 | Control.enter (fun () => let interp := interpret_trigger it env trigtacs trig in
165 | match interp with
166 | | [] =>
167 | print_tactic_not_triggered v name ;
168 | orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v
169 | | ll =>
170 | let rec aux ll := (* if String.equal name "my_fold_local_def_in_hyp_goal" then print_interp_trigger ll else () ; DEBUG *)
171 | match ll with
172 | | [] => orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v
173 | | l :: ll' =>
174 | if Bool.and (Int.equal 0 (List.length l)) (Bool.neg ((it).(global_flag))) then
175 | print_tactic_global_in_local v name ;
176 | orchestrator_aux alltacs init_fuel fuel it env trigstacsfis' trigtacs v
177 | else if Bool.and (Bool.neg multipletimes) (already_triggered ((trigtacs).(already_triggered)) (name, l)) then
178 | print_tactic_already_applied v name l ;
179 | aux ll'
180 | else if Bool.neg (pass_the_filter l fi) then
181 | print_tactic_trigger_filtered v name l ;
182 | let ltysargs := List.map (fun x => type x) l in
183 | let argstac := List.combine l ltysargs in
184 | trigtacs.(already_triggered) := (name, argstac) :: (trigtacs.(already_triggered)) ;
185 | aux ll'
186 | else
187 | let ltysargs := List.map (fun x => type x) l in (* computes types before a hypothesis may be removed *)
188 | print_applied_tac v name l ;
189 | let hs1 := Control.hyps () in
190 | let g1 := Control.goal () in
191 | run name l;
192 | let argstac := List.combine l ltysargs in
193 | trigtacs.(already_triggered) := (name, argstac) :: (trigtacs.(already_triggered)) ;
194 | match opt with
195 | | None =>
196 | Control.enter (fun () =>
197 | let cg' := (it).(local_env) in
198 | let hs2 := Control.hyps () in
199 | let g2 := Control.goal () in
200 | let goalChanged := Bool.neg (Constr.equal g1 g2) in
201 | let g3 := if goalChanged then Some g2 else None in
202 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else ();
203 | let diff := diff_hyps hs1 hs2 in
204 | let hypsChanged := Int.gt (List.length diff) 0 in
205 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else ();
206 | it.(local_env) := (diff, g3) ;
207 | it.(global_flag) := false ;
208 | let fuel' :=
209 | if multipletimes then
210 | Int.sub fuel 1 else fuel in
211 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v)
212 | | Some (nbg1, nbg2) =>
213 | let nb := numgoals () in if Int.lt nb nbg2 then
214 | Control.enter (fun () =>
215 | let cg' := (it).(local_env) in
216 | let hs2 := Control.hyps () in
217 | let g2 := Control.goal () in
218 | let goalChanged := Bool.neg (Constr.equal g1 g2) in
219 | let g3 := if goalChanged then Some g2 else None in
220 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else ();
221 | let diff := diff_hyps hs1 hs2 in
222 | let hypsChanged := Int.gt (List.length diff) 0 in
223 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else ();
224 | it.(local_env) := (diff, g3) ;
225 | it.(global_flag) := false ;
226 | let fuel' :=
227 | if multipletimes then
228 | Int.sub fuel 1 else fuel in
229 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v) else
230 | Control.focus nbg1 nbg2 (fun () =>
231 | let cg' := (it).(local_env) in
232 | let hs2 := Control.hyps () in
233 | let g2 := Control.goal () in
234 | let goalChanged := Bool.neg (Constr.equal g1 g2) in
235 | let g3 := if goalChanged then Some g2 else None in
236 | if goalChanged then (let (hyps, _) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := (hyps, None)) else ();
237 | let diff := diff_hyps hs1 hs2 in
238 | let hypsChanged := Int.gt (List.length diff) 0 in
239 | if hypsChanged then (let (_, g) := it.(subterms_coq_goal) in it.(subterms_coq_goal) := ([], g)) else ();
240 | it.(local_env) := (diff, g3) ;
241 | it.(global_flag) := false ;
242 | let fuel' :=
243 | if multipletimes then
244 | Int.sub fuel 1 else fuel in
245 | orchestrator_aux alltacs init_fuel fuel' it env trigstacsfis trigtacs v)
246 | end
247 | end in aux (remove_dups ll)
248 | end)
249 | end
250 | with orchestrator n alltacs trigtacs v :=
251 | if Int.le n 0 then () else
252 | let g := Control.goal () in
253 | let hyps := Control.hyps () in
254 | let env := { env_triggers := [] } in
255 | let it := { subterms_coq_goal := ([], None) ; local_env := (hyps, Some g); global_flag := true ; name_of_tac := ""} in
256 | orchestrator_aux alltacs n n it env ((alltacs).(all_tacs)) trigtacs v.
257 |
258 | (**
259 | - TODO : essayer avec les tactiques de Sniper en les changeant le moins possible (scope)
260 | - position des arguments
261 | - Ltac2 notations (thunks)
262 | - idée de Matthieu Sozeau, tag pour ce qui doit être unfoldé ou non, plutôt que de le mettre à l'intérieur des triggers
263 | - regarder crush ou le crush des software foundations
264 | - essayer d'ajouter autoinduct à Snipe
265 | - 2 types de tactiques: celles qui disent ce qu'elles font et celles qui ne le disent pas
266 | - relancer sur Actema
267 | *)
268 |
269 |
--------------------------------------------------------------------------------