(**

<<
                   Lecture 2: Fundamentals of Coq
      -------------------------------------------------------------
        Anders Mörtberg (Carnegie Mellon and Stockholm University)
        Minor modifications made by Marco Maggesi (Univesity of Florence).
>>

The Coq proof assistant is a programming language for writing
proofs: https://coq.inria.fr/

It has been around since 1984 and was initially implemented by Thierry
Coquand and his PhD supervisor Gérard Huet. The first version, called
CoC, implemented the Calculus of Constructions as presented in:

"The Calculus of Constructions"
Thierry Coquand and Gérard Huet
Information and Computation 76(2–3): 95–120. 1988.

It was later extended to the Calculus of Inductive Constructions and
the name changed to Coq. These type theories are similar to Martin-Löf
type theory. As Coq is supposed to be a programming language for
developing proofs all programs have to be terminating, so it can be
seen as a "total" programming language.

The Coq system has a very long and detailed reference manual:

https://coq.inria.fr/distrib/current/refman/

However, UniMath is only using a small subset of Coq, so there is a
lot of information that is not relevant for UniMath development in
there. The fragment of Coq that UniMath uses consists of:

- Pi-types (with judgmental eta)
- Sigma-types (with judgmental eta)
- The inductive types of natural numbers, booleans, unit and empty
- Coproduct types
- A universe UU

The reason we only have one universe is that there is no support for
universe resizing axioms in Coq yet. Because of this we assume the
inconsistent rule UU : UU, but we are working on improving this so
that we can make use of Coq's universe consistency checker.
Furthermore, the reason UniMath only relies on this subset is that
everything in UniMath has to be motivated by the model in simplicial
sets:

https://arxiv.org/abs/1211.2851

In this lecture I will show some things than can be done in UniMath as
a programming language. In the later lectures we will also see how to
prove properties about the programs that we can write in UniMath.

The UniMath library can be found at:

https://github.com/UniMath/UniMath

This whole file is a Coq file and it hence has the file ending ".v" (v
for "vernacular") and can be processed using:

- emacs with proof-general: https://proofgeneral.github.io/

- Coq IDE

I use emacs as it is also an extremely powerful text editor, but if
you never saw emacs before it might be quite overwhelming. An
alternative that might be easier for newcomers is Coq IDE (interactive
development environment). It also has some features that emacs doesn't
have so some Coq experts use it as well, but in this talk I will use
emacs.

In order to make emacs interact with Coq one should install Proof
General. This is an extension to emacs that enables it to interact
with a range of proof assistants, including Coq. For UniMath
development one should also install agda-mode in order to be able to
properly insert unicode characters.

The basic keybinding that I use when working in Proof General are:
<<
C-c C-n      -- Process one line
C-c C-u      -- Unprocess a line
C-c C-ENTER  -- Process the whole buffer up until the cursor
C-c C-b      -- Process the whole file
C-c C-r      -- Unprocess (retract) the whole file
C-x C-c      -- Kill the Coq process
>>
For more commands see:

https://proofgeneral.github.io/doc/master/userman/Basic-Script-Management/#Script-processing-commands
https://proofgeneral.github.io/doc/master/userman/Coq-Proof-General/#Coq_002dspecific-commands

Here C = CTRL and M = ALT on a standard emacs setup, so "C-c C-n"
means "press c while holding CTRL and then press n while still holding
CTRL" (note that the keybindings are case sensitive). ENTER is the
"return" key on my keyboard.

Various basic emacs commands:
<<
C-x C-f      -- Find file
C-x C-s      -- Save file
C-x C-x      -- Exit emacs
C-x b        -- Kill buffer
C-_          -- Undo
C-x 1        -- Maximize buffer
C-x 2        -- Split buffer horizontally
C-x 3        -- Split buffer vertically
M-%          -- Search-and-replace
M-;          -- Comment region
>>
For more commands see: https://www.gnu.org/software/emacs/ (or just
Google "emacs tutorial")

*)

(** To import a file write:
<<
Require Import Dir.Filename.
>>
*)

(**

This will import the file Filename in the directory Dir. This assumes
that directory Dir is visible to Coq, that is, in the list of
directories in which Coq looks for files to import. If you are working
in the UniMath directory then Coq will be able to find all of the
files in the UniMath library, but if you are in another directory you
need to the update your LoadPath by running
<<
Add LoadPath "/path/to/UniMath".
>>
(where "/path/to/UniMath/" is replaced to the path where UniMath is
located on your computer).

Coq has a fancy module system which allows you to import and export
definitions in various complicated ways. We extremely rarely use
this in UniMath so you can safely ignore it for now. The only thing
you need to know is that there is an alternative to Require Import:
<<
Require Export Dir.Filename.
>>
that is used in some files. This will make the file you are working
on import all of the definitions in Dir.Filename and then export
them again so that any file that imports this file also gets the
definitions in Dir.Filename. I personally only use Require Import.

*)

(* Let's import one of the most basic UniMath file: *)
Require Import UniMath.Foundations.Preamble.
(* This file contains definition of the inductive types of UniMath,
makes UU the name for the universe and various other basic things. *)

(** * Definitions, lambda terms *)

(** The polymorphic identity function *)
Definition idfun : forall (A : UU), A -> A := fun (A : UU) (a : A) => a.

(** forall = Pi *)
(** fun = lambda *)

Check idfun.  (* Or use Ctrl-Alt-C or Ctrl-Cmd-C on idfun. *)
Print idfun.  (* Or use Ctrl-Alt-P or Ctrl-Cmd-P on idfun. *)

Definition idfun' (A : UU) (a : A) : A := a.

Check idfun'.
Print idfun'.

(** The constant function that returns its first argument *)
Definition const (A B : UU) (a : A) (b : B) : A := a.

(** The booleans are defined in UniMath.Foundations.Preamble *)
About bool.
Print bool.
Locate bool.

(** These are generated by true and false *)
Check true.
Check false.

(** They also come with an induction principle *)
About bool_rect.

(** Using this we can define a "recursion" principle *)
Definition ifbool (A : UU) (x y : A) : bool -> A :=
  bool_rect (fun _ : bool => A) x y.

(** We can define boolean negation: *)
Definition negbool : bool -> bool :=
  ifbool bool false true.

(* Alternative definition using pattern matching.
   Idiomatic in Coq, but we avoid doing this in UniMath. *)

Definition negbool' (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

(** The normalization of negbool and negbool' give the same term. *)
Eval compute in negbool.
Eval compute in negbool'.

(** and compute with it *)
Eval compute in negbool true.

(** Coq supports many evaluation strategies, like cbn and cbv, for
details see:

https://coq.inria.fr/refman/tactics.html#Conversion-tactics

*)

(** boolean and *)
Definition andbool (b : bool) : bool -> bool :=
  ifbool (bool -> bool) (idfun bool) (const bool bool false) b.

Eval compute in andbool true true.
Eval compute in andbool true false.
Eval compute in andbool false true.
Eval compute in andbool false false.

(** The natural numbers are defined in UniMath.Foundations.Preamble *)
About nat.
Print nat.

(** They are defined as Peano numbers, but we can use numerals *)
Check 3.

(** This type also comes with an induction principle *)
Check nat_rect.

(** We can define the recursor: *)
Definition nat_rec (A : UU) (a : A) (f : nat -> A -> A) : nat -> A :=
  nat_rect (fun _ : nat => A) a f.

(**

This can be understood as a function defined by the following clauses:
<<
nat_rec m f 0 = m
nat_rec m f (S n) = f n (nat_rec m f n)
>>
*)

(** We can look at the normal form of the recursor by *)
Eval compute in nat_rec.

(** This contains a both a "fix" and "match _ with _". These primitives
of Coq are not allowed in UniMath. Instead we write everything using
recursors. The reason is that everything we write in UniMath has to be
justified by the simplicial set model and the situation for general
inductive types with match is not spelled out in detail. *)

(** If you are used to regular programming languages it might seem very
strange to only program with the recursors, but it's actually not too
bad and we can do many programs quite directly. *)

(** Truncated predecessor function *)
Definition pred : nat -> nat := nat_rec nat 0 (const nat nat).

Eval compute in pred 3.
Eval compute in pred 1.
Eval compute in pred 0.

(** We can test if a number is even by: *)
Definition even : nat -> bool := nat_rec bool true (fun _ b => negbool b).

Eval compute in even 3.
Eval compute in even 4.

(** Addition *)
Definition add (m : nat) : nat -> nat := nat_rec nat m (fun _ y => S y).

Eval compute in add 2 3.

(** We can define a nice notation for addition by: *)
Notation "x + y" := (add x y).

Eval compute in 4 + 9.

(* Use command palette "Coq: Display All Basic Low-level Contents" to
   enable/disable printing notations. *)

Check (add 3 4).  (* 3 + 4 : nat *)
(* Use command palette "Coq: Display All Basic Low-level Contents" *)
Check (add 3 4). (* add (S (S (S O))) (S (S (S (S O)))) : nat *)
(* Use command palette "Coq: Display All Basic Low-level Contents" *)
Check (add 3 4).  (* 3 + 4 : nat *)

(** To find information about a notation we can write: *)
Locate "+".

(** Coq allows us to write very sophisticated notations, for details
see: https://coq.inria.fr/refman/syntax-extensions.html *)

(** In UniMath we use a lot of unicode symbols. To input a unicode
symbol type \ and then the name of the symbol. For example \alpha
gives α. To get information about a unicode character, including
how to write it, put the cursor on top of the symbol and type:
M-x describe-char

We can write:
<<
  λ x, e        instead of   fun x => e
  ∏ (x : A), T  instead of   forall (x : A), T
  A → B         instead of   A -> B
>>
*)

(** Iterate a function n times *)
Definition iter (A : UU) (a : A) (f : A → A) (n : nat) : A :=
  nat_rec A a (λ _ y, f y) n.

Notation "f ^ n" := (λ x, iter _ x f n).

Eval compute in (pred ^ 2) 5.

Definition sub (m n : nat) : nat := (pred ^ n) m.

Eval compute in sub 15 4.
Eval compute in sub 11 15.

Definition is_zero : nat → bool := nat_rec bool true (λ _ _, false).

Eval compute in is_zero 3.
Eval compute in is_zero 0.

Definition eqnat (m n : nat) : bool :=
  andbool (is_zero (sub m n)) (is_zero (sub n m)).

Notation "m == n" := (eqnat m n) (at level 50).

Eval compute in 1 + 1 == 2.
Eval compute in 5 == 3.
Eval compute in 9 == 5.

(** Note that I could omit the A from the definition of f ̂ n and just
replace it by _. The reason is that Coq very often can infer what
arguments are so that we can omit them. *)

(** For example if I omit nat in *)
Check idfun _ 3.
(** Coq will figure it out for us. *)

(** We can tell Coq to always put _ for an argument by using curly
braces in the definition: *)

Definition idfun'' {A : UU} (a : A) : A := a.

Check idfun'' 3.
Check idfun'' true.

(** Such an argument is called an "implicit" and these are very useful
to get definitions that don't take too many arguments. However, it is
sometimes necessary to be able to give some of the arguments
explicitly, this is using "@". *)

Check @idfun'' nat 3.

(** * More inductive types *)

(** The inductive types we have seen so far come from the standard
library, but Coq allows us to define any inductive types we want. In
UniMath we don't allow this and the additional inductive types we have
are defined in Foundations. *)

(** One of these is the coproduct (disjoint union) of types *)
About coprod.
Print coprod.
Check ii1.
Check ii2.
Print inl.
Print inr.

Check (λ A B C : UU, @coprod_rect A B (λ _, C)).

Definition coprod_rec {A B C : UU} (f : A → C) (g : B → C) : coprod A B → C :=
  @coprod_rect A B (λ _, C) f g.

(** We can define integers as a coproduct of nat with itself *)

Definition Z : UU := coprod nat nat.

(* NB: Use \hermitconjmatrix to type the symbol ⊹.
       Use \minus to type the symbol − *)
Notation "⊹ x" := (inl x) (at level 20).
Notation "─ x" := (inr x) (at level 40).

(** +1 = inl 1 *)
(** 0 = inl 0 *)
(** -1 = inr 0 *)
(** Note that we get the negative numbers "off-by-one". *)

Definition Z1 : Z := ⊹ 1.
Definition Z0 : Z := ⊹ 0.
Definition Zn3 : Z := ─ 2.

(** We can define a function by case on whether the number is ⊹ n or ─ n *)
Definition Zcase (A : UU) (fpos : nat → A) (fneg : nat → A) : Z → A :=
  coprod_rec fpos fneg.

Definition negate : Z → Z :=
  Zcase Z (λ x, ifbool Z Z0 (─ pred x) (is_zero x)) (λ x, ⊹ S x).

Eval compute in negate Z0.
Eval compute in negate Z1.
Eval compute in negate Zn3.

(** We also have two more inductive types: *)

(** The unit type with one inhabitant tt *)
About unit.
Print unit.

(** The empty type with no inhabitants *)
About empty.
Print empty.

(** Terms as proofs.  *)
(* Proof that true and false are different. *)

Require Import UniMath.Foundations.PartA.

(** Section's can be very useful to only write parameters that are used
many times once and for all. They are also useful for organizing your
files into logical sections. *)
Section True_not_False.

Variable (p : true = false).

Definition P : bool → UU :=
  bool_rect _ unit ∅.

Definition true_eq_false_imp_empty : ∅ :=
  (transportf P p tt).

End True_not_False.

About true_eq_false_imp_empty.

Definition true_not_false : true != false :=
  true_eq_false_imp_empty.

(* Alternative definition, in one shot. *)
Definition true_not_false' : true != false :=
  λ p, transportf (bool_rect _ unit ∅) p tt.

(* Normalization of the proof term. *)
Eval compute in true_not_false.

(** * Sigma types *)

(** Sigma types are called total2 and this is the only example of a
Record in the whole UniMath library. The reason we use a record is so
that we can get the eta principle definitionally. *)

About total2.
Print total2.

(** We have a notation ∑ (x : A), B for Sigma types *)

(** To form a pair use *)
Check tpair.
Locate ",,".

(** and to project out of a pair use *)
Check pr1.
Check pr2.

(** In PartA.v we define the direct product as a Sigma type *)
Definition dirprod (X Y : UU) : UU := ∑ x : X, Y.

Notation "A × B" := (dirprod A B) (at level 75, right associativity) : type_scope.

Definition dirprod_pr1 {X Y : UU} : X × Y → X := pr1.
Definition dirprod_pr2 {X Y : UU} : X × Y → Y := pr2.

Definition dirprodf {X Y X' Y' : UU} (f : X → Y) (f' : X' → Y')
  (xx' : X × X') : Y × Y' := (f (pr1 xx'),,f' (pr2 xx')).

Definition swap {X Y : UU} (xy : X × Y) : Y × X :=
  dirprodf dirprod_pr2 dirprod_pr1 (xy,,xy).

(** We can define the type of even numbers as a Sigma-type: *)
Definition even_nat : UU := ∑ (n : nat), ifbool _ unit empty (even n).

Definition test20 : even_nat := (20,,tt).

(** This Definition does not work *)
Fail Definition test3 : even_nat := (3,,tt).

Section curry.

Variables A B C : UU.

(** To make these arguments implicit use:
<<
Context {A B C : UU}.
>>
*)

Definition curry : (A × B → C) → (A → B → C) :=
  λ (f : A × B → C) (a : A) (b : B), f (a,,b).

Definition uncurry : (A → B → C) → (A × B → C) :=
  λ (f : A → B → C) (ab : A × B), f (pr1 ab) (pr2 ab).

End curry.

Check curry.
Print curry.
Check uncurry.
Print uncurry.

(** These were all the basics for interacting with Coq in this
lecture. The UniMath library is a very large library and so far we
have only seen parts of Preamble.v. When writing programs and proofs
in UniMath it is very important to be able to search the library so
that you don't do something someone else has already done. *)

(** To find everything about nat type: *)
Search nat.

(** To search for all lemmas involving the pattern *)
(* Search _ (_ -> _ -> _). *)

(** To find information about a notation *)
Locate "+".

(** More information about searching can be found in the reference
manual:

https://coq.inria.fr/distrib/current/refman/proof-engine/vernacular-commands.html?highlight=search#coq:cmd.search
*)

(**

One can also generate HTML documentation for UniMath that is a bit
easier to browse than reading text files. This is done by typing:
<<
> make html
>>
You can then open this documentation in your browser:
<<
> firefox html/toc.html
>>
In order to have your comments display properly in the HTML use the
following format:

(** This comment will be displayed *)
(** * This will be displayed as a section header *)
(** ** This will be a subsection *)

For more details see:

https://coq.inria.fr/distrib/current/refman/tools.html#coqdoc

*)

(**

The UniMath library is organized into a collection of packages that
can be found in the UniMath folder. The library is then compiled using
a Makefile which specifies in which order things has to be compiled
and how they should be compiled.

In order to have your file get compiled when you type "make" add it to
the .package/files file of the package where it belongs. See for
example: UniMath/UniMath/Foundations/.package/files

If you're working on a new package then you need to add it to the
Makefile by writing:

PACKAGES += MyPackage

*)

               (*⋆⋆⋆⋆⋆⋆ THE END ⋆⋆⋆⋆⋆⋆*)


From Perennial.program_proof.mvcc Require Export mvcc_prelude mvcc_misc mvcc_ghost mvcc_inv.
From Goose.github_com.mit_pdos.go_mvcc Require Export tuple.

Definition pver := (u64 * bool * string)%type.

(* TODO: rename to [pver_to_val]. *)
Definition ver_to_val (x : pver) :=
  (#x.1.1, (#x.1.2, (#(LitString x.2), #())))%V.

Definition spec_find_ver_step (tid : u64) (res : option pver) (ver : pver) : option pver :=
  match res with
  | Some x => Some x
  | None => if decide (int.Z tid > int.Z ver.1.1) then Some ver else None
  end.

Definition spec_find_ver_reverse (vers : list pver) (tid : u64) : option pver :=
  foldl (spec_find_ver_step tid) None vers.

Definition spec_find_ver (vers : list pver) (tid : u64) : option pver :=
  spec_find_ver_reverse (reverse vers) tid.

Definition spec_lookup (vers : list pver) (tid : u64) : dbval :=
  match (spec_find_ver vers tid) with
  | Some ver => if ver.1.2 then Nil else Value ver.2
  | None => Nil
  end.

Lemma val_to_ver_with_lookup (x : val) (l : list (u64 * bool * string)) (i : nat) :
  (ver_to_val <$> l) !! i = Some x ->
  (∃ (b : u64) (d : bool) (v : string), x = ver_to_val (b, d, v) ∧ l !! i = Some (b, d, v)).
Proof.
  intros H.
  apply list_lookup_fmap_inv in H as [[[y1 y2] y3] [Heq Hsome]].
  naive_solver.
Qed.

Lemma spec_find_ver_step_Some_noop vers tid ver :
  foldl (spec_find_ver_step tid) (Some ver) vers = Some ver.
Proof.
  induction vers; done.
Qed.

Lemma spec_find_ver_lt_Some (vers : list pver) (tid : u64) (ver : pver) :
  ver ∈ vers ->
  int.Z ver.1.1 < int.Z tid ->
  ∃ ver', spec_find_ver vers tid = Some ver'.
Proof.
  intros Hin Hlt.
  apply elem_of_reverse, elem_of_list_lookup_1 in Hin as [idx Hlookup].
  unfold spec_find_ver, spec_find_ver_reverse.
  rewrite -(take_drop_middle _ _ _ Hlookup).
  rewrite foldl_app.
  destruct (foldl _ None _) as [ver' |].
  - exists ver'.
    by rewrite spec_find_ver_step_Some_noop.
  - exists ver.
    simpl.
    case_decide; last word.
    by rewrite  spec_find_ver_step_Some_noop.
Qed.

Lemma spec_find_ver_reverse_match vers tid :
  ∀ vers_take vers_drop ver,
    vers_take ++ ver :: vers_drop = vers ->
    spec_find_ver_reverse vers_take tid = None ->
    (int.Z tid > int.Z ver.1.1) ->
    spec_find_ver_reverse vers tid = Some ver.
Proof.
  intros vers_take vers_drop ver Hvers Htake Hver.
  rewrite -Hvers.
  unfold spec_find_ver_reverse in *.
  rewrite foldl_app.
  rewrite Htake.
  simpl.
  case_decide.
  - induction vers_drop.
    + done.
    + by rewrite spec_find_ver_step_Some_noop.
  - contradiction.
Qed.

Lemma spec_find_ver_reverse_not_match vers tid :
  ∀ vers_take ver,
    vers_take ++ [ver] = vers ->
    spec_find_ver_reverse vers_take tid = None ->
    (int.Z tid ≤ int.Z ver.1.1) ->
    spec_find_ver_reverse vers tid = None.
Proof.
  intros vers_take ver Hvers Htake Hver.
  rewrite -Hvers.
  unfold spec_find_ver_reverse in *.
  rewrite foldl_app.
  rewrite Htake.
  simpl.
  case_decide.
  - contradiction.
  - done.
Qed.

Lemma spec_find_ver_extensible vers (tidlast tid1 tid2 : u64) :
  int.Z tidlast ≤ int.Z tid1 ->
  int.Z tidlast ≤ int.Z tid2 ->
  Forall (λ ver, int.Z ver.1.1 < int.Z tidlast) vers ->
  spec_find_ver vers tid1 = spec_find_ver vers tid2.
Proof.
  intros Htid1 Htid2 Hlast.
  unfold spec_find_ver.
  unfold spec_find_ver_reverse.
  destruct (reverse _) eqn:E; first done.
  simpl.
  setoid_rewrite Forall_forall in Hlast.
  assert (H : p ∈ vers).
  { apply elem_of_reverse. rewrite E. apply elem_of_list_here. }
  assert (H1 : int.Z p.1.1 < int.Z tid1).
  { apply Hlast in H. apply Z.lt_le_trans with (int.Z tidlast); done. }
  assert (H2 : int.Z p.1.1 < int.Z tid2).
  { apply Hlast in H. apply Z.lt_le_trans with (int.Z tidlast); done. }
  apply Z.lt_gt in H1, H2.
  do 2 (case_decide; last contradiction).
  by do 2 rewrite spec_find_ver_step_Some_noop.
Qed.

Lemma spec_lookup_snoc_l vers ver (tid tidx : u64) :
  ver.1.1 = tidx ->
  int.Z tid ≤ int.Z tidx ->
  spec_lookup (vers ++ [ver]) tid = spec_lookup vers tid.
Proof.
  intros Heq Hle.
  unfold spec_lookup, spec_find_ver, spec_find_ver_reverse.
  rewrite reverse_snoc.
  simpl.
  case_decide.
  - by rewrite Heq in H.
  - done.
Qed.

Lemma spec_lookup_snoc_r vers ver (tid tidx : u64) :
  ver.1.1 = tidx ->
  int.Z tidx < int.Z tid ->
  spec_lookup (vers ++ [ver]) tid = (if ver.1.2 then Nil else Some ver.2).
Proof.
  intros Heq Hle.
  unfold spec_lookup, spec_find_ver, spec_find_ver_reverse.
  rewrite reverse_snoc.
  simpl.
  case_decide.
  - by rewrite spec_find_ver_step_Some_noop.
  - rewrite Heq in H. word.
Qed.

Lemma spec_lookup_extensible vers (tidlast tid1 tid2 : u64) :
  int.Z tidlast ≤ int.Z tid1 ->
  int.Z tidlast ≤ int.Z tid2 ->
  Forall (λ ver, int.Z ver.1.1 < int.Z tidlast) vers ->
  spec_lookup vers tid1 = spec_lookup vers tid2.
Proof.
  intros Htid1 Htid2 Hlast.
  unfold spec_lookup.
  by rewrite (spec_find_ver_extensible _ _ _ _ Htid1 Htid2); last done.
Qed.


Require Export HoTT HoTT.types.Sum.
Require Export Notations NotationsUtf8.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

(** Ported from catdb Common file **)

(* The standard library does not provide projections of [sigT2] or [sig2].
   I define coercions to [sigT] and [sig], so that [projT1], [projT2],
   [proj1_sig], and [proj2_sig] do the right thing, and I define [projT3],
   [proj3_sig]. *)
Section sig.
  Definition sigT_of_sigT2 A P Q (x : @sigT2 A P Q) := let (a, h, _) := x in existT _ a h.
  Global Coercion sigT_of_sigT2 : sigT2 >-> sigT.
  Definition projT3 A P Q (x : @sigT2 A P Q) :=
    let (x0, _, h) as x0 return (Q (projT1 x0)) := x in h.

(*  Definition sig_of_sig2 A P Q (x : @sig2 A P Q) := let (a, h, _) := x in exist _ a h.
  Global Coercion sig_of_sig2 : sig2 >-> sig.
  Definition proj3_sig A P Q (x : @sig2 A P Q) :=
    let (x0, _, h) as x0 return (Q (proj1_sig x0)) := x in h.*)
End sig.

(* fail if [tac] succeeds, do nothing otherwise *)
Tactic Notation "not_tac" tactic(tac) := (tac; fail 1) || idtac.

(* fail if [tac] fails, but don't actually execute [tac] *)
Tactic Notation "test_tac" tactic(tac) := not_tac (not_tac tac).

(* fail if [x] is a function application, a dependent product ([fun _ => _]),
   or a sigma type ([forall _, _]) *)
Ltac atomic x :=
  match x with
    | ?f _ => fail 1 x "is not atomic"
    | (fun _ => _) => fail 1 x "is not atomic"
    | forall _, _ => fail 1 x "is not atomic"
    | _ => idtac
  end.

(* [pose proof defn], but only if no hypothesis of the same type exists.
   most useful for proofs of a proposition *)
Ltac unique_pose defn :=
  let T := type of defn in
    match goal with
      | [ H : T |- _ ] => fail 1
      | _ => pose proof defn
    end.

(* [pose defn], but only if that hypothesis doesn't exist *)
Ltac unique_pose_with_body defn :=
  match goal with
    | [ H := defn |- _ ] => fail 1
    | _ => pose defn
  end.

(* check's if the given hypothesis has a body, i.e., if [clearbody]
   could ever succeed.  We can't just do [test_tac (clearbody H)],
   because maybe the correctness of the proof depends on the body
   of H *)
Tactic Notation "has_no_body" hyp(H) :=
  not_tac (let H' := fresh in pose H as H'; unfold H in H').

Tactic Notation "has_body" hyp(H) :=
  not_tac (has_no_body H).

(* find the head of the given expression *)
Ltac head expr :=
  match expr with
    | ?f _ => head f
    | _ => expr
  end.

Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'.

(* call [tac H], but first [simpl]ify [H].
   This tactic leaves behind the simplified hypothesis. *)
Ltac simpl_do tac H :=
  let H' := fresh in pose H as H'; simpl; simpl in H'; tac H'.

(* clear the left-over hypothesis after [simpl_do]ing it *)
Ltac simpl_do_clear tac H := simpl_do ltac:(fun H => tac H; try clear H) H.

Ltac do_with_hyp tac :=
  match goal with
    | [ H : _ |- _ ] => tac H
  end.

Ltac rewrite_hyp' := do_with_hyp ltac:(fun H => rewrite H).
Ltac rewrite_hyp := repeat rewrite_hyp'.
Ltac rewrite_rev_hyp' := do_with_hyp ltac:(fun H => rewrite <- H).
Ltac rewrite_rev_hyp := repeat rewrite_rev_hyp'.

Ltac apply_hyp' := do_with_hyp ltac:(fun H => apply H).
Ltac apply_hyp := repeat apply_hyp'.
Ltac eapply_hyp' := do_with_hyp ltac:(fun H => eapply H).
Ltac eapply_hyp := repeat eapply_hyp'.

(* some simple tactics to solve the goal by rewriting *)
Ltac t' := repeat progress (simpl in *; intros; try split; trivial).
Ltac t'_long := repeat progress (simpl in *; intuition).

Ltac t_con_with con tac := tac;
  repeat (match goal with
            | [ H : context[con] |- _ ] => rewrite H
            | _ => progress autorewrite with core in *
          end; tac).

Ltac t_con_rev_with con tac := tac;
  repeat (match goal with
            | [ H : context[con] |- _ ] => rewrite <- H
            | _ => progress autorewrite with core in *
          end; tac).

Ltac t_with tac := t_con_with @paths tac.

Ltac t_rev_with tac := t_con_rev_with @paths tac.

Ltac t_con con := t_con_with con t'; t_con_with con t'_long.
Ltac t_con_rev con := t_con_rev_with con t'; t_con_rev_with con t'_long.

Ltac t := t_with t'; t_with t'_long.
Ltac t_rev := t_rev_with t'; t_rev_with t'_long.

(* solve simple setiod goals that can be solved by [transitivity] *)
Ltac simpl_transitivity :=
  try solve [ match goal with
                | [ _ : ?Rel ?a ?b, _ : ?Rel ?b ?c |- ?Rel ?a ?c ] => transitivity b; assumption
              end ].

(* given a [matcher] that succeeds on some hypotheses and fails on
   others, destruct any matching hypotheses, and then execute [tac]
   after each [destruct].

   The [tac] part exists so that you can, e.g., [simpl in *], to
   speed things up. *)
Ltac destruct_all_matches_then matcher tac :=
  repeat match goal with
           | [ H : ?T |- _ ] => matcher T; destruct H; tac
         end.

Ltac destruct_all_matches matcher := destruct_all_matches_then matcher ltac:(simpl in *).
Ltac destruct_all_matches' matcher := destruct_all_matches_then matcher idtac.

(* matches anything whose type has a [T] in it *)
Ltac destruct_type_matcher T HT :=
  match HT with
    | context[T] => idtac
  end.
Ltac destruct_type T := destruct_all_matches ltac:(destruct_type_matcher T).
Ltac destruct_type' T := destruct_all_matches' ltac:(destruct_type_matcher T).

Ltac destruct_head_matcher T HT :=
  match head HT with
    | T => idtac
  end.
Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T).
Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T).

Ltac destruct_head_hnf_matcher T HT :=
  match head_hnf HT with
    | T => idtac
  end.
Ltac destruct_head_hnf T := destruct_all_matches ltac:(destruct_head_hnf_matcher T).
Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(destruct_head_hnf_matcher T).

Ltac destruct_hypotheses_matcher HT :=
  let HT' := eval hnf in HT in
    match HT' with
      | sigT _ => idtac
      | sigT2 _ => idtac
      | and _ _ => idtac
      | prod _ _ => idtac
    end.
Ltac destruct_hypotheses := destruct_all_matches destruct_hypotheses_matcher.
Ltac destruct_hypotheses' := destruct_all_matches' destruct_hypotheses_matcher.

Ltac destruct_sig_matcher HT :=
  let HT' := eval hnf in HT in
    match HT' with
(*      | @sig _ _ => idtac*)
      | @sigT _ _ => idtac
(*      | @sig2 _ _ _ => idtac*)
      | @sigT2 _ _ _ => idtac
    end.
Ltac destruct_sig := destruct_all_matches destruct_sig_matcher.
Ltac destruct_sig' := destruct_all_matches' destruct_sig_matcher.

Ltac destruct_all_hypotheses := destruct_all_matches ltac:(fun HT =>
  destruct_hypotheses_matcher HT || destruct_sig_matcher HT
).

(* if progress can be made by [exists _], but it doesn't matter what
   fills in the [_], assume that something exists, and leave the two
   goals of finding a member of the apropriate type, and proving that
   all members of the appropriate type prove the goal *)
Ltac destruct_exists' T := cut T; try (let H := fresh in intro H; exists H).
Ltac destruct_exists := destruct_head_hnf @sigT;
  match goal with
(*    | [ |- @sig ?T _ ] => destruct_exists' T*)
    | [ |- @sigT ?T _ ] => destruct_exists' T
(*    | [ |- @sig2 ?T _ _ ] => destruct_exists' T*)
    | [ |- @sigT2 ?T _ _ ] => destruct_exists' T
  end.

(* if the goal can be solved by repeated specialization of some
   hypothesis with other [specialized] hypotheses, solve the goal
   by brute force *)
Ltac specialized_assumption tac := tac;
  match goal with
    | [ x : ?T, H : forall _ : ?T, _ |- _ ] => specialize (H x); specialized_assumption tac
    | _ => assumption
  end.

(* for each hypothesis of type [H : forall _ : ?T, _], if there is exactly
   one hypothesis of type [H' : T], do [specialize (H H')]. *)
Ltac specialize_uniquely :=
  repeat match goal with
           | [ x : ?T, y : ?T, H : _ |- _ ] => test_tac (specialize (H x)); fail 1
           | [ x : ?T, H : _ |- _ ] => specialize (H x)
         end.

(* specialize all hypotheses of type [forall _ : ?T, _] with
   appropriately typed hypotheses *)
Ltac specialize_all_ways_forall :=
  repeat match goal with
           | [ x : ?T, H : forall _ : ?T, _ |- _ ] => unique_pose (H x)
         end.

(* try to specialize all hypotheses with all other hypotheses.
   This includes [specialize (H x)] where [H x] requires a coercion
   from the type of [H] to Funclass. *)
Ltac specialize_all_ways :=
  repeat match goal with
           | [ x : ?T, H : _ |- _ ] => unique_pose (H x)
         end.

(* try to do [tac] after [repeat rewrite] on [rew_H], in both directions *)
Ltac try_rewrite rew_H tac :=
  (rewrite ?rew_H; tac) ||
    (rewrite <- ?rew_H; tac).

Ltac try_rewrite_by rew_H by_tac tac :=
  (rewrite ?rew_H by by_tac; tac) ||
    (rewrite <- ?rew_H by by_tac; tac).

Ltac try_rewrite_repeat rew_H tac :=
  (repeat (rewrite rew_H; tac)) ||
    (repeat (rewrite <- rew_H; tac)).

Ltac solve_repeat_rewrite rew_H tac :=
  solve [ repeat (rewrite rew_H; tac) ] ||
    solve [ repeat (rewrite <- rew_H; tac) ].

(*Lemma sig_eq A P (s s' : @sig A P) : proj1_sig s = proj1_sig s' -> s = s'.
  destruct s, s'; simpl; intro; subst; f_equal; apply proof_irrelevance.
Qed.

Lemma sig2_eq A P Q (s s' : @sig2 A P Q) : proj1_sig s = proj1_sig s' -> s = s'.
  destruct s, s'; simpl; intro; subst; f_equal; apply proof_irrelevance.
Qed.

Lemma sigT_eq A P (s s' : @sigT A P) : projT1 s = projT1 s' -> projT2 s == projT2 s' -> s = s'.
  destruct s, s'; simpl; intros; firstorder; repeat subst; reflexivity.
Qed.

Lemma sigT2_eq A P Q (s s' : @sigT2 A P Q) :
  projT1 s = projT1 s'
  -> projT2 s == projT2 s'
  -> projT3 s == projT3 s'
  -> s = s'.
  destruct s, s'; simpl; intros; firstorder; repeat subst; reflexivity.
Qed.

Lemma injective_projections_JMeq (A B A' B' : Type) (p1 : A * B) (p2 : A' * B') :
  fst p1 == fst p2 -> snd p1 == snd p2 -> p1 == p2.
Proof.
  destruct p1, p2; simpl; intros H0 H1; subst;
    rewrite H0; rewrite H1; reflexivity.
Qed.

Ltac clear_refl_eq :=
  repeat match goal with
           | [ H : ?x = ?x |- _ ] => clear H
         end.

(* reduce the proving of equality of sigma types to proving equality
   of their components *)
Ltac simpl_eq' :=
  apply sig_eq
        || apply sig2_eq
        || ((apply sigT_eq || apply sigT2_eq); intros; clear_refl_eq)
        || apply injective_projections
        || apply injective_projections_JMeq.

Ltac simpl_eq := intros; repeat (
  simpl_eq'; simpl in *
).
*)
(* For things with decidable equality, we have [forall x (P : x = x),
   P = eq_refl].  So replace such hypotheses with [eq_refl]. *)
(*
Ltac subst_eq_refl_dec :=
  repeat match goal with
           | [ H : ?a = ?a |- _ ] => clear H
           | [ H : ?a = ?a |- _ ] => assert (idpath = H)
                                    by abstract solve
                                                [ apply K_dec;
                                                  solve [ try decide equality; try congruence ]
                                                | assumption
                                                | easy ];
                                    subst H
         end.

Ltac subst_eq_refl :=
  repeat match goal with
           | _ => progress subst_eq_refl_dec
           | [ H : ?a = ?a |- _ ] => assert (eq_refl = H) by apply ProofIrrelevance.proof_irrelevance;
                                    subst H
         end.
*)
(** Finds things of the form [match E with _ => _ end] in the goal and
    tries to replace them with [eq_refl] *)
(*
Ltac subst_eq_refl_dec_in_match :=
  repeat match goal with
           | [ |- appcontext[match ?E with _ => _ end] ] =>
             let H := fresh in
             set (H := E) in *;
               clearbody H;
               hnf in H;
               simpl in H;
               match type of H with
                 | ?a = ?a => idtac
                 | _ = _ => compute in H
               end;
               progress subst_eq_refl_dec; simpl in *
         end.

Ltac subst_eq_refl_in_match :=
  repeat match goal with
           | [ |- appcontext[match ?E with _ => _ end] ] =>
             let H := fresh in
             set (H := E) in *;
               clearbody H;
               hnf in H;
               simpl in H;
               match type of H with
                 | ?a = ?a => idtac
                 | _ = _ => compute in H
               end;
               progress subst_eq_refl; simpl in *
         end.
*)
(** [generalize] any construction in an [eq] match *)
Ltac generalize_eq_match :=
  repeat match goal with
           | [ |- appcontext[match ?f ?x with idpath => _ end] ] =>
             let H := fresh in
             progress set (H := f x);
               clearbody H
         end.

(** [destruct] any matches on variables of type [_ = _] *)
Ltac destruct_eq_in_match :=
  repeat match goal with
           | [ |- appcontext[match ?E with _ => _ end] ] => let t := type of E in
                                                            match eval hnf in t with
                                                              | @paths _ _ _ => destruct E
                                                            end
         end.

(* Coq's build in tactics don't work so well with things like [iff]
   so split them up into multiple hypotheses *)
Ltac split_in_context ident funl funr :=
  repeat match goal with
           | [ H : context p [ident] |- _ ] =>
             let H0 := context p[funl] in let H0' := eval simpl in H0 in assert H0' by (apply H);
               let H1 := context p[funr] in let H1' := eval simpl in H1 in assert H1' by (apply H);
                 clear H
         end.

Ltac split_iff := split_in_context iff (fun a b : Prop => a -> b) (fun a b : Prop => b -> a).

Ltac split_and' :=
  repeat match goal with
           | [ H : ?a /\ ?b |- _ ] => let H0 := fresh in let H1 := fresh in
             assert (H0 := fst H); assert (H1 := snd H); clear H
         end.
Ltac split_and := split_and'; split_in_context and (fun a b : Type => a) (fun a b : Type => b).

Ltac clear_hyp_of_type type :=
  repeat match goal with
           | [ H : type |- _ ] => clear H
         end.

(* If [conVar] is not mentioned in any hypothesis other than [hyp],
   nor in the goal, then clear any hypothesis of the same type as [hyp] *)
Ltac clear_hyp_unless_context hyp conVar :=
  let hypT := type of hyp in
    match goal with
      | [ H0 : hypT, H : context[conVar] |- _ ] => fail 1 (* there is a hypotheses distinct from [hyp] which mentions [conVar] *)
      | [ |- context[conVar] ] => fail 1
      | _ => clear_hyp_of_type hypT
    end.

Ltac recur_clear_context con :=
  repeat match goal with
           | [ H : appcontext[con] |- _ ] =>
             recur_clear_context H; try clear H
           | [ H := appcontext[con] |- _ ] =>
             recur_clear_context H; try clear H
         end.

(* equivalent to [idtac] if [subexpr] appears nowhere in [expr],
   equivalent to [fail] otherwise *)
Ltac FreeQ expr subexpr :=
  match expr with
    | appcontext[subexpr] => fail 1
    | _ => idtac
  end.

Ltac subst_mor x :=
  match goal with
    | [ H : ?Rel ?a x |- _ ] => FreeQ a x; rewrite <- H in *;
      try clear_hyp_unless_context H x
    | [ H : ?Rel x ?a |- _ ] => FreeQ a x; rewrite H in *;
      try clear_hyp_unless_context H x
  end.

Ltac repeat_subst_mor_of_type type :=
  repeat match goal with
           | [ m : context[type] |- _ ] => subst_mor m; try clear m
         end.

(* Using [rew] instead of [rew'] makes this fail... WTF? *)
Ltac subst_by_rewrite_hyp_rew a H rew' :=
  rew' H; clear H;
  match goal with
    | [ H : appcontext[a] |- _ ] => fail 1 "Rewrite failed to clear all instances of" a
    | [ |- appcontext[a] ] => fail 1 "Rewrite failed to clear all instances of" a
    | _ => idtac
  end.

Ltac subst_by_rewrite_hyp a H :=
  subst_by_rewrite_hyp_rew a H ltac:(fun H => try rewrite H in *; try setoid_rewrite H).

Ltac subst_by_rewrite_rev_hyp a H :=
  subst_by_rewrite_hyp_rew a H ltac:(fun H => try rewrite <- H in *; try setoid_rewrite <- H).

Ltac subst_by_rewrite a :=
  match goal with
    | [ H : ?Rel a ?b |- _ ] => subst_by_rewrite_hyp a H
    | [ H : ?Rel ?b a |- _ ] => subst_by_rewrite_rev_hyp a H
  end.

Ltac subst_atomic a := first [ atomic a | fail "Non-atomic variable" a ];
                      subst_by_rewrite a.

Ltac subst_rel rel :=
  match goal with
    | [ H : rel ?a ?b |- _ ] => (atomic a; subst_by_rewrite_hyp a H) || (atomic b; subst_by_rewrite_rev_hyp b H)
  end.

Ltac subst_body :=
  repeat match goal with
           | [ H := _ |- _ ] => subst H
         end.

(* So we know the difference betwen the [sigT]s we're using and the [sigT]s others use *)
Inductive Common_sigT (A : Type) (P : A -> Type) : Type :=
    Common_existT : forall x : A, P x -> Common_sigT P.
Definition Common_projT1 (A : Type) (P : A -> Type) (x : @Common_sigT A P) := let (a, _) := x in a.
Definition Common_projT2 (A : Type) (P : A -> Type) (x : @Common_sigT A P) := let (x0, h) as x0 return (P (Common_projT1 x0)) := x in h.

Ltac uncurryT H :=
  match eval simpl in H with
    | forall (x : ?T1) (y : @?T2 x), @?f x y => uncurryT (forall xy : @Common_sigT T1 T2, f (Common_projT1 xy) (Common_projT2 xy))
    | ?H' => H'
  end.

Ltac curryT H :=
  match eval simpl in H with
    | forall xy : @Common_sigT ?T1 ?T2, @?f xy => curryT (forall (x : T1) (y : T2 x), f (@Common_existT T1 T2 x y))
    | ?H' => H'
  end.

Ltac uncurry H := let HT := type of H in
  match eval simpl in HT with
    | forall (x : ?T1) (y : @?T2 x) (z : @?T3 x y), @?f x y z =>
      uncurry (fun xyz => H (Common_projT1 (Common_projT1 xyz)) (Common_projT2 (Common_projT1 xyz)) (Common_projT2 xyz))
    | forall (x : ?T1) (y : @?T2 x), @?f x y => uncurry (fun xy : @Common_sigT T1 T2 => H (Common_projT1 xy) (Common_projT2 xy))
    | ?H' => H
  end.

Ltac curry H := let HT := type of H in
  match eval simpl in HT with
    | forall xy : @Common_sigT ?T1 ?T2, @?f xy => curry (fun (x : T1) (y : T2 x) => H (@Common_existT T1 T2 x y))
    | ?H' => H
  end.
(*
Monomorphic Definition equal_f_dep
: forall A B (f g : forall a : A, B a), f = g -> forall x : A, f x = g x
  := fun A B f g H x => eq_ind_r (fun f0 => f0 x = g x) eq_refl H.
Monomorphic Definition equal_f
: forall A B (f g : A -> B), f = g -> forall x : A, f x = g x
  := fun A B => @equal_f_dep _ _.
*)
Lemma fg_equal : forall A B (f g : A -> B), f = g -> forall x : A, f x = g x.
  intros; path_induction; reflexivity.
Qed.

Section telescope.
  Inductive telescope :=
  | Base : forall (A : Type) (B : A -> Type), (forall a, B a) -> (forall a, B a) -> telescope
  | Quant : forall A : Type, (A -> telescope) -> telescope.

  Fixpoint telescopeOut (t : telescope) :=
    match t with
      | Base _ _ x y => x = y
      | Quant _ f => forall x, telescopeOut (f x)
    end.

  Fixpoint telescopeOut' (t : telescope) :=
    match t with
      | Base _ _ f g => forall x, f x = g x
      | Quant _ f => forall x, telescopeOut' (f x)
    end.

  Theorem generalized_fg_equal : forall (t : telescope),
    telescopeOut t
    -> telescopeOut' t.
    induction t; simpl; intros; path_induction; trivial.
    apply_hyp.
  Qed.
End telescope.

Ltac curry_in_Quant H :=
  match eval simpl in H with
    | @Quant (@Common_sigT ?T1 ?T2) (fun xy => @?f xy) => curry_in_Quant (@Quant T1 (fun x => @Quant (T2 x) (fun y => f (@Common_existT T1 T2 x y))))
    | ?H' => H'
  end.

Ltac reifyToTelescope' H := let HT := type of H in let H' := uncurryT HT in
  match H' with
    | @paths ?T ?f ?g => let T' := eval hnf in T in
      match T' with
        | forall x : ?a, @?b x => constr:(@Base a b f g)
      end
    | forall x, @paths (@?T x) (@?f x) (@?g x) => let T' := eval hnf in T in (* XXX does [hnf] even do anything on [(fun _ => _)]?  I want to do [hnf] inside the function, but I don't want to do [compute] *)
      match T' with
        | (fun x => forall y : @?a x, @?b x y) => constr:(Quant (fun x => @Base (a x) (b x) (f x) (g x)))
      end
  end.

Ltac reifyToTelescope H := let t' := reifyToTelescope' H in curry_in_Quant t'.
Ltac fg_equal_in H := let t := reifyToTelescope H in apply (generalized_fg_equal t) in H; simpl in H.

Ltac fg_equal :=
  repeat match goal with
           | [ H : _ |- _ ] => fg_equal_in H
         end.

Lemma f_equal_helper A0 (A B : A0 -> Type) (f : forall a0, A a0 -> B a0) (x y : forall a0, A a0) :
  (forall a0, x a0 = y a0) -> (forall a0, f a0 (x a0) = f a0 (y a0)).
  intros H a0; specialize (H a0); rewrite H; reflexivity.
Qed.

Local Notation f_equal := ap.

Ltac f_equal_in_r H k := let H' := uncurry H in let H'T := type of H' in
  let k' := (fun v => let v' := curry v in let H := fresh in assert (H := v'); simpl in H) in
    match eval simpl in H'T with
      | @paths ?A ?x ?y => k (fun B (f : A -> B) => @f_equal A B f x y H') k'
      | forall a0 : ?A0, @paths (@?A a0) (@?x a0) (@?y a0)
        => k (fun (B : A0 -> Type) (f : forall a0 : A0, A a0 -> B a0) => @f_equal_helper A0 A B f x y H') k'
    end; clear H.
Ltac f_equal_in f H := f_equal_in_r H ltac:(fun pf k => k (pf _ f)).

Ltac eta_red :=
  repeat match goal with
           | [ H : appcontext[fun x => ?f x] |- _ ] => change (fun x => f x) with f in H
           | [ |- appcontext[fun x => ?f x] ] => change (fun x => f x) with f
         end.

Lemma sigT_eta : forall A (P : A -> Type) (x : sigT P),
  x = existT _ (projT1 x) (projT2 x).
  destruct x; reflexivity.
Qed.

Lemma sigT_eta_2 A B P (x : @sigT A (fun a : A => @sigT (B a) (P a)))
: (x.1; (x.2.1; x.2.2)) = x.
Proof.
  destruct x as [? [? ?]].
  reflexivity.
Qed.

Lemma sigT2_eta : forall A (P Q : A -> Type) (x : sigT2 P Q),
  x = existT2 _ _ (projT1 x) (projT2 x) (projT3 x).
  destruct x; reflexivity.
Qed.
(*
Lemma sig_eta : forall A (P : A -> Prop) (x : sig P),
  x = exist _ (proj1_sig x) (proj2_sig x).
  destruct x; reflexivity.
Qed.

Lemma sig2_eta : forall A (P Q : A -> Prop) (x : sig2 P Q),
  x = exist2 _ _ (proj1_sig x) (proj2_sig x) (proj3_sig x).
  destruct x; reflexivity.
Qed.
*)

Ltac rewrite_eta_in Hf :=
  repeat match type of Hf with
(*           | context[match ?E with existT2 _ _ _ => _ end] => rewrite (sigT2_eta E) in Hf; simpl in Hf
           | context[match ?E with exist2 _ _ _ => _ end] => rewrite (sig2_eta E) in Hf; simpl in Hf*)
           | context[match ?E with existT _ _ => _ end] => rewrite (sigT_eta E) in Hf; simpl in Hf
(*           | context[match ?E with exist _ _ => _ end] => rewrite (sig_eta E) in Hf; simpl in Hf*)
           | context[match ?E with pair _ _ => _ end] => rewrite (eta_prod E) in Hf; simpl in Hf
         end.

Ltac destruct_match_in' T :=
  match T with
    | appcontext[match ?E with _ => _ end] => let x := fresh in set (x := E) in *; destruct x
  end.

Ltac destruct_match_in T :=
  repeat match T with
           | appcontext[match ?E with _ => _ end] => let x := fresh in set (x := E) in *; destruct x
         end.

Ltac destruct_match_in_goal :=
  repeat match goal with
           | [ |- appcontext[match ?E with _ => _ end] ] => let x := fresh in set (x := E) in *; destruct x
         end.

Ltac destruct_match_in_hyp Hf :=
  repeat (let T := type of Hf in
          destruct_match_in' T).

Ltac rewrite_eta :=
  repeat match goal with
           | [ |- context[match ?E with existT2 _ _ _ => _ end] ] => rewrite (sigT2_eta E); simpl
(*           | [ |- context[match ?E with exist2 _ _ _ => _ end] ] => rewrite (sig2_eta E); simpl*)
           | [ |- context[match ?E with existT _ _ => _ end] ] => rewrite (sigT_eta E); simpl
(*           | [ |- context[match ?E with exist _ _ => _ end] ] => rewrite (sig_eta E); simpl*)
           | [ |- context[match ?E with pair _ _ => _ end] ] => rewrite (eta_prod E); simpl
         end.
(*
Ltac intro_proj2_sig_from_goal'_by tac :=
  repeat match goal with
           | [ |- appcontext[proj1_sig ?x] ] => tac (proj2_sig x)
           | [ |- appcontext[proj1_sig (sig_of_sig2 ?x)] ] => tac (proj3_sig x)
         end.

Ltac intro_proj2_sig_from_goal_by tac :=
  repeat match goal with
           | [ |- appcontext[proj1_sig ?x] ] => tac (proj2_sig x)
           | [ |- appcontext[proj1_sig (sig_of_sig2 ?x)] ] => tac (proj3_sig x)
         end; simpl in *.
*)
Ltac intro_projT2_from_goal_by tac :=
  repeat match goal with
           | [ |- appcontext[projT1 ?x] ] => tac (projT2 x)
           | [ |- appcontext[projT1 (sigT_of_sigT2 ?x)] ] => tac (projT3 x)
         end; simpl in *.
(*
Ltac intro_proj2_sig_by tac :=
  repeat match goal with
           | [ |- appcontext[proj1_sig ?x] ] => tac (proj2_sig x)
           | [ H : appcontext[proj1_sig ?x] |- _ ] => tac (proj2_sig x)
           | [ H := appcontext[proj1_sig ?x] |- _ ] => tac (proj2_sig x)
           | [ |- appcontext[proj1_sig (sig_of_sig2 ?x)] ] => tac (proj3_sig x)
           | [ H : appcontext[proj1_sig (sig_of_sig2 ?x)] |- _ ] => tac (proj3_sig x)
           | [ H := appcontext[proj1_sig (sig_of_sig2 ?x)] |- _ ] => tac (proj3_sig x)
         end; simpl in *.
*)
Ltac intro_projT2_by tac :=
  repeat match goal with
           | [ |- appcontext[projT1 ?x] ] => tac (projT2 x)
           | [ H : appcontext[projT1 ?x] |- _ ] => tac (projT2 x)
           | [ H := appcontext[projT1 ?x] |- _ ] => tac (projT2 x)
           | [ |- appcontext[projT1 (sigT_of_sigT2 ?x)] ] => tac (projT3 x)
           | [ H : appcontext[projT1 (sigT_of_sigT2 ?x)] |- _ ] => tac (projT3 x)
           | [ H := appcontext[projT1 (sigT_of_sigT2 ?x)] |- _ ] => tac (projT3 x)
         end; simpl in *.

(*
Ltac intro_proj2_sig_from_goal' := intro_proj2_sig_from_goal'_by unique_pose.
Ltac intro_proj2_sig_from_goal := intro_proj2_sig_from_goal_by unique_pose.*)
Ltac intro_projT2_from_goal := intro_projT2_from_goal_by unique_pose.
Ltac intro_projT2_from_goal_with_body := intro_projT2_from_goal_by unique_pose_with_body.
(*Ltac intro_proj2_sig := intro_proj2_sig_by unique_pose.*)
Ltac intro_projT2 := intro_projT2_by unique_pose.
Ltac intro_projT2_with_body := intro_projT2_by unique_pose_with_body.

Ltac recr_destruct_with tac H :=
  let H0 := fresh in let H1 := fresh in
    (tac H; try reflexivity; try clear H) ||
      (destruct H as [ H0 H1 ];
        simpl in H0, H1;
          recr_destruct_with tac H0 || recr_destruct_with tac H1;
            try clear H0; try clear H1).

Ltac do_rewrite H := rewrite H.
Ltac do_rewrite_rev H := rewrite <- H.
Ltac recr_destruct_rewrite H := recr_destruct_with do_rewrite H.
Ltac recr_destruct_rewrite_rev H := recr_destruct_with do_rewrite_rev H.

(*
Ltac use_proj2_sig_with tac :=
  repeat match goal with
           | [ |- appcontext[proj1_sig ?x] ] =>
             match x with
               | context[proj1_sig] => fail 1
               | _ => simpl_do_clear tac (proj2_sig x)
             end
         end.

Ltac rewrite_proj2_sig := use_proj2_sig_with recr_destruct_rewrite.
Ltac rewrite_rev_proj2_sig := use_proj2_sig_with recr_destruct_rewrite_rev.
*)
Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x.
Implicit Arguments is_unique [A].

Ltac rewrite_unique :=
  match goal with
    | [ H : is_unique _ |- _ ] => unfold is_unique in H; rewrite H || rewrite <- H; reflexivity
  end.

Ltac generalize_is_unique_hyp H T :=
  assert (forall a b : T, a = b) by (intros; etransitivity; apply H || symmetry; apply H); clear H.

Ltac generalize_is_unique :=
  repeat match goal with
           | [ H : @is_unique ?T _ |- _ ] => generalize_is_unique_hyp H T
         end.

Ltac intro_fresh_unique :=
  repeat match goal with
           | [ H : @is_unique ?T ?x |- _ ] => let x' := fresh in assert (x' := x); rewrite <- (H x') in *; generalize_is_unique_hyp H T
         end.

Ltac specialize_with_evars_then_do E tac :=
  lazymatch type of E with
    | forall x : ?T, _ =>
      let y := fresh in evar (y : T);
        let y' := (eval unfold y in y) in clear y;
          specialize_with_evars_then_do (E y') tac
    | _ => tac E
  end.

Ltac specialize_hyp_with_evars E :=
  repeat match type of E with
           | forall x : ?T, _ =>
             let y := fresh in evar (y : T);
               let y' := (eval unfold y in y) in clear y;
                 specialize (E y')
         end.

(* tries to convert an existential to an evar *)
Ltac existential_to_evar x :=
  is_evar x;
  let x' := fresh in
  set (x' := x) in *.

(* converts existentials in the goal into evars *)
Ltac existentials_to_evars_in_goal :=
  repeat match goal with
           | [ |- context[?x] ] => existential_to_evar x
         end.

(* converts all the existentials in the hypotheses to evars *)
Ltac existentials_to_evars_in_hyps :=
  repeat match goal with
           | [ H : context[?x] |- _ ] => existential_to_evar x
         end.

(* converts all the existentials in the hypothesis [H] to evars *)
Ltac existentials_to_evars_in H :=
  repeat match type of H with
           | context[?x] => existential_to_evar x
         end.

Tactic Notation "existentials_to_evars" := existentials_to_evars_in_goal.
Tactic Notation "existentials_to_evars" "in" "|-" "*" := existentials_to_evars_in_goal.
Tactic Notation "existentials_to_evars" "in" "*" := existentials_to_evars_in_goal; existentials_to_evars_in_hyps.
Tactic Notation "existentials_to_evars" "in" "*" "|-" := existentials_to_evars_in_hyps.
Tactic Notation "existentials_to_evars" "in" hyp(H) "|-" "*" := existentials_to_evars_in H; existentials_to_evars_in_goal.
Tactic Notation "existentials_to_evars" "in" hyp(H) := existentials_to_evars_in H.
Tactic Notation "existentials_to_evars" "in" hyp(H) "|-" := existentials_to_evars_in H.

(* rewrite fails if hypotheses depend on one another.  simultaneous rewrite does not *)
Ltac simultaneous_rewrite' E :=
  match type of E with
    | ?X = _ => generalize E; generalize dependent X; intros until 1;
      let H := fresh in intro H at top;
        match type of H with
          ?X' = _ => subst X'
        end
  end.

Ltac simultaneous_rewrite_rev' E :=
  match type of E with
    | _ = ?X => generalize E; generalize dependent X; intros until 1;
      let H := fresh in intro H at top;
        match type of H with
          _ = ?X' => subst X'
        end
  end.

Ltac simultaneous_rewrite E := specialize_with_evars_then_do E ltac:(fun E =>
  match type of E with
    | ?T = _ => let H := fresh in
      match goal with
        | [ _ : context[?F] |- _ ] =>
          assert (H : T = F) by reflexivity; clear H
      end; simultaneous_rewrite' E
  end
).

Ltac simultaneous_rewrite_rev E := specialize_with_evars_then_do E ltac:(fun E =>
  match type of E with
    | _ = ?T => let H := fresh in
      match goal with
        | [ _ : context[?F] |- _ ] =>
          assert (H : T = F) by reflexivity; clear H
      end; simultaneous_rewrite_rev' E
  end
).

(* rewrite by convertiblity rather than syntactic equality *)
Ltac conv_rewrite_with rew_tac H := specialize_with_evars_then_do H ltac:(fun H =>
  lazymatch type of H with
    | ?a = _ => match goal with
                  | [ |- appcontext[?a'] ]
                    => change a' with a; rew_tac H
                end
  end
).
Ltac conv_rewrite_rev_with rew_tac H := specialize_with_evars_then_do H ltac:(fun H =>
  lazymatch type of H with
    | _ = ?a => match goal with
                  | [ |- appcontext[?a'] ]
                    => change a' with a; rew_tac H
                end
  end
).

Ltac conv_rewrite H := conv_rewrite_with ltac:(fun h => rewrite h) H.
Ltac conv_rewrite_rev H := conv_rewrite_rev_with ltac:(fun h => rewrite <- h) H.
Ltac conv_repeat_rewrite H := repeat conv_rewrite_with ltac:(fun h => repeat rewrite h) H.
Ltac conv_repeat_rewrite_rev H := repeat conv_rewrite_rev_with ltac:(fun h => repeat rewrite <- h) H.

Ltac rewrite_by_context ctx H :=
  match type of H with
    | ?x = ?y => let ctx' := context ctx[x] in let ctx'' := context ctx[y] in
      cut ctx'; [ let H' := fresh in intro H'; simpl in H' |- *; exact H' | ];
        cut ctx''; [ let H' := fresh in intro H'; etransitivity; try apply H'; rewrite H; reflexivity
          |
        ]
  end.

Ltac rewrite_rev_by_context ctx H :=
  match type of H with
    | ?x = ?y => let ctx' := context ctx[y] in let ctx'' := context ctx[x] in
      cut ctx'; [ let H' := fresh in intro H'; simpl in H' |- *; exact H' | ];
        cut ctx''; [ let H' := fresh in intro H'; etransitivity; try apply H'; rewrite <- H; reflexivity
          |
        ]
  end.

Ltac do_for_each_hyp' tac fail_if_seen :=
  match goal with
    | [ H : _ |- _ ] => fail_if_seen H; tac H; try do_for_each_hyp' tac ltac:(fun H' => fail_if_seen H'; match H' with | H => fail 1 | _ => idtac end)
  end.
Ltac do_for_each_hyp tac := do_for_each_hyp' tac ltac:(fun H => idtac).

(* [change a with b in *] fails if it would create a self-referential hypothesis.
   This version does not. *)
Tactic Notation "change_in_all" constr(from) "with" constr(to) :=
  change from with to; do_for_each_hyp ltac:(fun H => change from with to in H).

(* [expand] replaces both terms of an equality (either [eq] or [JMeq]
   in the goal with their head normal forms *)
Ltac expand :=
  match goal with
    | [ |- @paths ?T ?X ?Y ] =>
      let X' := eval hnf in X in let Y' := eval hnf in Y in change (@paths T X' Y')
    | [ |- ?X == ?Y ] =>
      let X' := eval hnf in X in let Y' := eval hnf in Y in change (X' == Y')
  end; simpl.

Ltac pre_abstract_trailing_props_helper T B Rel :=
  cut { A : T | Rel A B };
  [ let x := fresh in intro x; exists (proj1_sig x); destruct x as [ ? x ]; unfold proj1_sig; destruct x; reflexivity
  | ].

Ltac pre_abstract_trailing_props :=
  match goal with
    | [ |- { F0 : ?T | @?P F0 } ] => let T' := eval hnf in T in change { F0 : T' | P F0 }; cbv beta
  end;
  try match goal with
        | [ |- { A : ?T | identity A ?B } ] => pre_abstract_trailing_props_helper T B (@paths T)
        | [ |- { A : ?T | identity ?B A } ] => pre_abstract_trailing_props_helper T B (@paths T)
        | [ |- { A : ?T | ?B = A } ] => pre_abstract_trailing_props_helper T B (@paths T)
(*        | [ |- { A : ?T | @JMeq ?TB ?B ?T A } ] => pre_abstract_trailing_props_helper T B (fun a b => @JMeq T a TB b)*)
      end.

Ltac clear_then_exact pf :=
  match goal with
    | [ H : _ |- _ ] => clear H; clear_then_exact pf
    | _ => abstract (exact pf)
  end.

Ltac do_replace_trailing_matching_with_goal term matcher tac :=
  match term with
    | ?f ?x => (first [ (matcher x;
                         let t := type of x in
                         let t' := (eval simpl in t) in
                         let y := fresh in
                         assert (y : t') by ((clear; abstract (exact x)) || clear_then_exact x);
                         (do_replace_trailing_matching_with_goal f matcher ltac:(fun H => tac (H y)))
                           || fail 2 "tactic failed")
                      | (tac term || fail 1 "tactic failed") ])
    | _ => tac term || fail 1 "tactic failed"
  end.

Ltac exact_replace_trailing_matching_with_goal term matcher :=
  do_replace_trailing_matching_with_goal term matcher ltac:(fun H => exact H).

Ltac type_of_type_of_matches T :=
  fun term =>
    let t := type of term in
    let t' := type of t in
    match eval hnf in t' with
      | T => idtac
    end.

Ltac abstract_trailing_props term :=
  let term' := (eval hnf in term) in
  exact_replace_trailing_matching_with_goal term' ltac:(type_of_type_of_matches Prop).

Ltac hnf_simpl_abstract_trailing_props term :=
  let term' := (eval hnf in term) in
  let term'' := (eval simpl in term') in
  exact_replace_trailing_matching_with_goal term'' ltac:(type_of_type_of_matches Prop).

Ltac evar_evar_Type t :=
  let T := fresh in evar (T : Type); evar (t : T); subst T.

(* [hideProof' pf] generalizes [pf] only if it does not already exist
   as a hypothesis *)
Ltac hideProof' pf :=
  match goal with
    | [ x : _ |- _ ] => match x with
                          | pf => fail 2
                        end
    | _ => generalize pf; intro
  end.

(* TODO(jgross): Is there a better way to do this? *)
Tactic Notation "hideProofs" constr(pf)
  := hideProof' pf.
Tactic Notation "hideProofs" constr(pf0) constr(pf1)
  := progress (try hideProof' pf0; try hideProof' pf1).
Tactic Notation "hideProofs" constr(pf0) constr(pf1) constr(pf2)
  := progress (try hideProof' pf0; try hideProof' pf1; try hideProof' pf2).
Tactic Notation "hideProofs" constr(pf0) constr(pf1) constr(pf2) constr(pf3)
  := progress (try hideProof' pf0; try hideProof' pf1; try hideProof' pf2; try hideProof' pf3).
Tactic Notation "hideProofs" constr(pf0) constr(pf1) constr(pf2) constr(pf3) constr(pf4)
  := progress (try hideProof' pf0; try hideProof' pf1; try hideProof' pf2; try hideProof' pf3; try hideProof' pf4).
Tactic Notation "hideProofs" constr(pf0) constr(pf1) constr(pf2) constr(pf3) constr(pf4) constr(pf5)
  := progress (try hideProof' pf0; try hideProof' pf1; try hideProof' pf2; try hideProof' pf3; try hideProof' pf4; try hideProof' pf5).

Section unique.
  Definition uniqueT (A : Type) (P : A -> Type) (x : A)
    := P x + forall x' : A, P x' -> x = x'.
End unique.

Ltac destruct_to_empty_set :=
  match goal with
    | [ H : Empty |- _ ] => destruct H
    | [ H : ?T -> Empty, a : ?T |- _ ] => destruct (H a)
    | [ H : context[Empty] |- _ ] => solve [ destruct H; trivial; assumption ]
  end.

Ltac destruct_to_empty_set_in_match :=
  match goal with
    | [ |- appcontext[match ?x with end] ] => solve [ destruct x || let H := fresh in pose x as H; destruct H ]
    | [ _ : appcontext[match ?x with end] |- _ ] => solve [ destruct x || let H := fresh in pose x as H; destruct H ]
  end.

Ltac destruct_first_if_not_second a b :=
  (constr_eq a b; fail 1)
    || (let t := type of b in
        let H := fresh in
        set (H := a : t) in *;
          destruct H).

Ltac destruct_singleton_constructor c :=
  let t := type of c in
  repeat match goal with
           | [ H : t |- _ ] => destruct H
           | [ H : context[?e] |- _ ] => destruct_first_if_not_second e c
           | [ |- context[?e] ] => destruct_first_if_not_second e c
         end.

Ltac destruct_units := destruct_singleton_constructor tt.
Ltac destruct_Trues := destruct_singleton_constructor I.
(*
Section contr.
  (** Contr taken from HoTT *)
  Class Contr (A : Type) :=
    {
      center : A ;
      contr : (forall y : A, center = y)
    }.

  Global Arguments center A {_}.

  Notation IsHProp A := (forall x y : A, Contr (x = y)).

  Global Instance ContrIsHProp `{Contr A} : IsHProp A.
  Proof.
    repeat intro.
    exists (match contr x, contr y with eq_refl, eq_refl => eq_refl end).
    intro H0.
    destruct H0.
    destruct (contr x).
    reflexivity.
  Defined.

  Global Instance ContrIsHProp' `{Contr A} (x y : A) : Contr (x = y).
  Proof (ContrIsHProp x y).

  Lemma contr_eq A : forall x y : Contr A, x = y.
  Proof.
    repeat intro.
    pose x as x'; destruct x as [ centerx contrx ].
    pose y as y'; destruct y as [ centery contry ].
    destruct (contry centerx).
    apply f_equal.
    apply functional_extensionality_dep.
    intros.
    apply center.
    eauto with typeclass_instances.
  Defined.

  Global Instance PiContr `(H : forall x : A, Contr (T x)) : Contr (forall x, T x).
  Proof.
    exists (fun _ => center _).
    intros; apply functional_extensionality_dep.
    intros; apply contr.
  Defined.

  Global Instance SigmaContr `{Contr A} `{forall x : A, Contr (P x)} : Contr (sigT P).
  Proof.
    exists (existT P (center _) (center _)).
    intros [x ?].
    cut (center _ = x); [ intro; subst | apply contr ].
    apply f_equal.
    apply contr.
  Defined.

  Global Instance SigContr `{Contr A} (P : A -> Prop) `{forall x : A, Contr (P x)} : Contr (sig P).
  Proof.
    exists (exist P (center _) (center _)).
    intros [x ?].
    cut (center _ = x); [ intro; subst | apply contr ].
    apply f_equal.
    apply contr.
  Defined.

  Global Instance Sigma2Contr `{Contr A} `{forall x : A, Contr (P x)} `{forall x : A, Contr (Q x)} : Contr (sigT2 P Q).
  Proof.
    exists (existT2 P Q (center _) (center _) (center _)).
    intros [x ? ?].
    cut (center _ = x); [ intro; subst | apply contr ].
    apply f_equal2;
      apply contr.
  Defined.

  Global Instance Sig2Contr `{Contr A} (P Q : A -> Prop) `{forall x : A, Contr (P x)} `{forall x : A, Contr (Q x)} : Contr (sig2 P Q).
  Proof.
    exists (exist2 P Q (center _) (center _) (center _)).
    intros [x ? ?].
    cut (center _ = x); [ intro; subst | apply contr ].
    apply f_equal2;
      apply contr.
  Defined.

  Local Ltac contr_eq_t :=
    intros;
    repeat match goal with
             | [ x : _ |- _ ] => progress destruct (contr x)
           end;
    reflexivity.

  Lemma contr_eqT `{Contr A} : forall x x' y y' : A, @paths Type (x = x') (y = y').
    contr_eq_t.
  Defined.

  Lemma contr_eqS `{Contr A} : forall x x' y y' : A, @paths Set (x = x') (y = y').
    contr_eq_t.
  Defined.

  Lemma contr_eqP `{Contr A} : forall x x' y y' : A, @paths Prop (x = x') (y = y').
    contr_eq_t.
  Defined.
End contr.

Notation IsHProp A := (forall x y : A, Contr (x = y)).
*)(*
Section True.
  Global Instance True_contr : Contr True
    := @BuildContr True I (fun x => match x with I => idpath end).

  Definition True_singleton u : u = I := @symmetry True (@paths True) _ I u (contr u).
  Definition True_eq (u u' : True) : u = u' := center _.
  Definition True_eq_singleton (u u' : True) (H : u = u') : H = True_eq _ _ := center _.
  Definition True_eq_eq (u u' : True) (H H' : u = u') : H = H' := center _.

(*  Lemma True_JMeq (u u' : True) : u == u'.
    case u; case u'; reflexivity.
  Defined.*)
(*
  Definition True_eqT_eq (u u' v v' : True) : @paths Type (u = u') (v = v') := contr_eqT _ _ _ _.
  Definition True_eqS_eq (u u' v v' : True) : @paths Set (u = u') (v = v') := contr_eqS _ _ _ _.
  Definition True_eqP_eq (u u' v v' : True) : @paths Prop (u = u') (v = v') := contr_eqP _ _ _ _.
*)(*
  Lemma True_eq_JMeq (u u' v v' : True) (H : u = u') (H' : v = v') : H == H'.
    destruct_head @eq; destruct_head True; reflexivity.
  Defined.
*)
  Global Instance FalseIsHProp : IsHProp False.
  Proof.
    intros [].
  Defined.
Print center.
  Definition False_eq (a b : False) : a = b := @center _ (FalseIsHProp  _.

  Lemma False_JMeql (a : False) T (b : T) : a == b.
    destruct a.
  Defined.

  Lemma False_JMeqr T (a : T) (b : False) : a == b.
    destruct b.
  Defined.
End True.

Section unit.
  Global Instance unit_contr : Contr unit
    := @Build_Contr unit tt (fun x => match x with tt => eq_refl end).

  Definition unit_singleton u : u = tt := eq_sym (contr u).
  Definition unit_eq (u u' : unit) : u = u' := center _.
  Definition unit_eq_singleton (u u' : unit) (H : u = u') : H = unit_eq _ _ := center _.
  Definition unit_eq_eq (u u' : unit) (H H' : u = u') : H = H' := center _.

  Lemma unit_JMeq (u u' : unit) : u == u'.
    case u; case u'; reflexivity.
  Defined.

  Definition unit_eqT_eq (u u' v v' : unit) : @paths Type (u = u') (v = v') := contr_eqT _ _ _ _.
  Definition unit_eqS_eq (u u' v v' : unit) : @paths Set (u = u') (v = v') := contr_eqS _ _ _ _.
  Definition unit_eqP_eq (u u' v v' : unit) : @paths Prop (u = u') (v = v') := contr_eqP _ _ _ _.

  Lemma unit_eq_JMeq (u u' v v' : unit) (H : u = u') (H' : v = v') : H == H'.
    destruct_head @eq; destruct_head unit; reflexivity.
  Defined.

  Global Instance Empty_setIsHProp : IsHProp Empty_set.
  Proof.
    intros [].
  Defined.

  Definition Empty_set_eq (a b : Empty_set) : a = b := center _.

  Lemma Empty_set_JMeql (a : Empty_set) T (b : T) : a == b.
    destruct a.
  Defined.

  Lemma Empty_set_JMeqr T (a : T) (b : Empty_set) : a == b.
    destruct b.
  Defined.
End unit.

Hint Rewrite True_singleton.
Hint Extern 0 (@paths True _ _) => apply True_eq.
Hint Extern 0 (@paths (@paths True _ _) _ _) => apply True_eq_eq.
Hint Extern 0 (@JMeq True _ True _) => apply True_JMeq.
Hint Extern 0 (@JMeq (@paths True _ _) _ (@paths True _ _) _) => apply True_eq_JMeq.
Hint Extern 0 (@paths Set (@paths True _ _) (@paths True _ _)) => apply True_eqS_eq.
Hint Extern 0 (@paths Prop (@paths True _ _) (@paths True _ _)) => apply True_eqP_eq.
Hint Extern 0 (@paths Type (@paths True _ _) (@paths True _ _)) => apply True_eqT_eq.
Hint Extern 0 True => constructor.
Hint Extern 0 (@paths False _ _) => apply False_eq.
Hint Extern 0 (@JMeq False _ _ _) => apply False_JMeql.
Hint Extern 0 (@JMeq _ _ False _) => apply False_JMeqr.

Hint Rewrite unit_singleton.
Hint Extern 0 (@paths unit _ _) => apply unit_eq.
Hint Extern 0 (@paths (@paths unit _ _) _ _) => apply unit_eq_eq.
Hint Extern 0 (@JMeq unit _ unit _) => apply unit_JMeq.
Hint Extern 0 (@JMeq (@paths unit _ _) _ (@paths unit _ _) _) => apply unit_eq_JMeq.
Hint Extern 0 (@paths Set (@paths unit _ _) (@paths unit _ _)) => apply unit_eqS_eq.
Hint Extern 0 (@paths Prop (@paths unit _ _) (@paths unit _ _)) => apply unit_eqP_eq.
Hint Extern 0 (@paths Type (@paths unit _ _) (@paths unit _ _)) => apply unit_eqT_eq.
Hint Extern 0 unit => constructor.
Hint Extern 0 (@paths Empty_set _ _) => apply Empty_set_eq.
Hint Extern 0 (@JMeq Empty_set _ _ _) => apply Empty_set_JMeql.
Hint Extern 0 (@JMeq _ _ Empty_set _) => apply Empty_set_JMeqr.
*)
(* The following makes Examples.v slower by about a minute *)
(* Hint Extern 0 (@paths _ _ _) => try solve [ refine (center _) ]. *)

(** Fixes for HoTT library **)

Notation "0" := (trunc_S (trunc_S minus_two)) : trunc_scope.
Notation "1" := (trunc_S 0) : trunc_scope.
Notation "2" := (trunc_S 1) : trunc_scope.
Notation "3" := (trunc_S 3) : trunc_scope.

Tactic Notation "subst" :=
  repeat match goal with
           | [ H : ?x = ?y |- _ ]
             => is_var y; (destruct H || induction H)
           | [ H : ?x = ?y |- _ ]
             => is_var x; symmetry in H;
                (destruct H || induction H)
         end.

Lemma transport_projT1_path_sigma_uncurried
      A (P : A -> Type) (u v : sigT P)
      (pq : { p : u.1 = v.1 & transport P p u.2 = v.2 })
      Q Qx
: transport (fun x => Q x.1) (@path_sigma_uncurried A P u v pq) Qx
  = transport _ pq.1 Qx.
Proof.
  destruct pq as [p q], u, v; simpl in *.
  destruct p, q; simpl in *.
  reflexivity.
Defined.

Lemma transport_path_prod_uncurried A B (P : A * B -> Type) (x y : A * B)
      (H : (fst x = fst y) * (snd x = snd y))
      Px
: transport P (path_prod_uncurried _ _ H) Px
  = match y as y' return P (fst y', snd y') -> P y' with
      | (_, _) => idmap
    end (transport (fun x => P (x, snd y))
                   (fst H)
                   (transport (fun y => P (fst x, y))
                              (snd H)
                              (match x as x' return P x' -> P (fst x', snd x') with
                                 | (_, _) => idmap
                               end Px))).
Proof.
  destruct x, y, H; simpl in *.
  path_induction.
  reflexivity.
Defined.

Definition transport_path_prod A B (P : A * B -> Type) (x y : A * B)
           (HA : fst x = fst y)
           (HB : snd x = snd y)
           Px
: transport P (path_prod _ _ HA HB) Px
  = match y as y' return P (fst y', snd y') -> P y' with
      | (_, _) => idmap
    end (transport (fun x => P (x, snd y))
                   HA
                   (transport (fun y => P (fst x, y))
                              HB
                              (match x as x' return P x' -> P (fst x', snd x') with
                                 | (_, _) => idmap
                               end Px)))
  := transport_path_prod_uncurried P x y (HA, HB) Px.

Definition transport_path_prod'
           A B (P : A * B -> Type)
           (x y : A)
           (x' y' : B)
           (HA : x = y)
           (HB : x' = y')
           Px
: transport P (path_prod' HA HB) Px
  = transport (fun x => P (x, y'))
              HA
              (transport (fun y => P (x, y))
                         HB
                         Px)
  := transport_path_prod P (x, x') (y, y') HA HB Px.

(** A variant of [induction] which also tries [destruct] and [case], and may be extended to using other [destruct]-like tactics. *)
Ltac induction_hammer H :=
  destruct H || induction H || (case H; clear H).

(** Takes a term of type [_ = _], and tries to replace it by [idpath] by trying to prove that it's an hProp. *)
Ltac clear_contr_path p :=
  let H := fresh in
  let T := type of p in
  progress (
      first [ assert (H : idpath = p) by exact (center _)
            | assert (H : idpath = p)
              by (
                  let a := match goal with |- @paths (?x = ?y) ?a ?b => constr:(a) end in
                  let b := match goal with |- @paths (?x = ?y) ?a ?b => constr:(b) end in
                  let x := match goal with |- @paths (?x = ?y) ?a ?b => constr:(x) end in
                  let y := match goal with |- @paths (?x = ?y) ?a ?b => constr:(y) end in
                  apply (@equiv_inv _ _ _ (@equiv_ap _ _ _ (@isequiv_apD10 _ _ _ x y) a b));
                  exact (center _)
                )
            | pose proof (@path_contr T _ idpath p) as H ];
      destruct H;
      (* now reduce any matches on [idpath] (and on other things too) *)
      cbv iota in *
    ).

(** Use both [induction_hammer] and [clear_contr_path] on a path, to try to get rid of it *)
Ltac clear_path_no_check p :=
  induction_hammer p || clear_contr_path p.
Ltac clear_path p :=
  let t := type of p in
  lazymatch eval hnf in t with
    | @paths _ _ _ => clear_path_no_check p
    | _ => fail 0 "clear_path only works on paths;" p "is not a path"
  end.

(** Run [clear_path] on hypotheses *)
(** We don't match only on things of type [_ = _], because maybe that's the head normal form, but it's hiding behind something else; [clear_path] will make sure it's of the right type.  We include some redundant cases at the top, for speed; it is faster to try to destruct everything first, and then do the full battery of tactics, than to just run the hammer. *)
Ltac step_clear_paths :=
  match goal with
    | [ p : _ = _ |- _ ] => destruct p
    | [ p : _ = _ |- _ ] => clear_path_no_check p
    | [ p : _ |- _ ] => clear_path p
  end.
Ltac clear_paths := progress repeat step_clear_paths.

(** Run [clear_path] on anything inside a [match] *)
Ltac step_clear_paths_in_match :=
  match goal with
    | [ |- appcontext[match ?p with idpath => _ end] ] => progress destruct p
    | [ |- appcontext[match ?p with idpath => _ end] ] => clear_path_no_check p
  end.
Ltac clear_paths_in_match := progress repeat step_clear_paths_in_match.

(** Now some lemmas about trivial [match]es *)
Definition match_eta T (x y : T) (H0 : x = y)
: (H0 = match H0 in (_ = y) return (x = y) with
          | idpath => idpath
        end)
  := match H0 with idpath => idpath end.

Definition match_eta1 T (x : T) (E : x = x)
: (match E in (_ = y) return (x = y) with
     | idpath => idpath
   end = idpath)
  -> idpath = E
  := fun H => ((H # match_eta E) ^)%path.

Definition match_eta2 T (x : T) (E : x = x)
: (idpath
   = match E in (_ = y) return (x = y) with
       | idpath => idpath
     end)
  -> idpath = E
  := fun H => match_eta1 E (H ^)%path.

(** And now the actual tactic. *)
Ltac step_path_induction_hammer :=
  match goal with
    | _ => reflexivity
    | _ => intro
    | _ => progress simpl in *
    | _ => exact (contr _)
    | [ p : _ = _ |- _ ]
      => progress destruct p (* placed up here for speed *)
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta1 _ H); destruct H'
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta2 _ H); destruct H'
    | _ => step_clear_paths
    | _ => expand; step_clear_paths_in_match
    | _ => progress auto with path_hints
    | _ => done
    | _ => exact (center _)
  end.

Ltac path_induction_hammer := repeat step_path_induction_hammer.

Ltac do_unless_goal_has_evar tac :=
  match goal with
    | [ |- ?G ] => has_evar G; fail 1 "Goal has evars"
    | _ => idtac
  end;
  tac.

(*Hint Extern 100 => do_unless_goal_has_evar ltac:(apply @IsTrunc_path) : typeclass_instances.*)

(*Hint Extern 1 => progress cbv beta : typeclass_instances.*)
Hint Extern 0 => assumption : typeclass_instances.
Hint Extern 3 => progress cbv beta : typeclass_instances.
Hint Extern 1000 => progress simpl : typeclass_instances.
Hint Extern 1000 => progress intros : typeclass_instances.
(*Hint Extern 100 => do_unless_goal_has_evar ltac:(apply @IsTrunc_path') : typeclass_instances.*)
(*Hint Extern 0 => match goal with
                   | [ |- appcontext[(fun _ => _) _] ] => cbv beta
                 end : typeclass_instances.*)

Global Instance trunc_pointwise_paths `{Funext} A B (f g : forall x : A, B x) `{IsTrunc n (f = g)}
: IsTrunc n (f == g) | 1000
  := @trunc_equiv' _ _ (symmetry _ _ (equiv_path_forall _ _)) _ _.
(*Global Instance trunc_contr `{H : forall (x y : T) (pf1 pf2 : x = y), Contr (pf1 = pf2)} : IsTrunc 0 T | 10000
  := H.*)

Definition unique A (P : A -> Type) (x : A)
  := P x /\ forall x', P x' -> x = x'.

(** New to HoTT common file **)

Hint Extern 0 => apply false_ne_true; solve [ trivial ].
Hint Extern 0 => apply true_ne_false; solve [ trivial ].

Lemma transport_inverse A P x y p
: @transport A P x y p ^
  = ((@transport A P y x p) ^-1)%equiv.
Proof.
  path_induction; reflexivity.
Defined.

Definition transport_path_universe_fun `{Univalence} `{Funext}
           A B f `{IsEquiv A B f}
: transport idmap (path_universe f) = f.
Proof.
  apply path_forall; intro.
  apply transport_path_universe.
Defined.

Definition transport_path_universe_fun_inv `{Univalence} `{Funext}
           A B f `{IsEquiv A B f}
: ((transport idmap (path_universe f)) ^-1 = f ^-1)%equiv.
Proof.
  apply path_forall; intro.
  etransitivity; [ | apply transport_path_universe ].
  simpl.
  rewrite <- path_universe_V.
  reflexivity.
Defined.


Require Import list_examples.

Definition dealloc_code :=
  While (Dup 0::nil) (Dup 0::Plus1++Swap::Dealloc
                    ::Dup 0::Load::Swap::Dealloc::nil)
  ::Drop::Ret::nil.

Inductive dealloc_spec : Spec cfg :=
  dealloc_claim : forall l, fun_claim dealloc_spec
    "dealloc" dealloc_code 1 (rep_list l) 0 emptyP
 |loop_claim : forall l, loop_claim dealloc_spec
            0 dealloc_code 1 (rep_list l) 0 emptyP.

Lemma dealloc_proof : sound stack_step dealloc_spec.
Proof. list_solver. Qed.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.revarray.
Require Import VST.floyd.sublist.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition reverse_spec :=
 DECLARE _reverse
  WITH a0: val, sh : share, contents : list int, size: Z
  PRE [ tptr tint, tint ]
          PROP (0 <= size <= Int.max_signed; writable_share sh)
          PARAMS (a0; Vint (Int.repr size))
          SEP (data_at sh (tarray tint size) (map Vint contents) a0)
  POST [ tvoid ]
     PROP() RETURN()
     SEP(data_at sh (tarray tint size) (map Vint (rev contents)) a0).

Definition main_spec :=
  DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [reverse_spec; main_spec]).

Definition flip_ends {A} lo hi (contents: list A) :=
  sublist 0 lo (rev contents)
  ++ sublist lo hi contents
  ++ sublist hi (Zlength contents) (rev contents).

Definition reverse_Inv a0 sh contents size :=
 (EX j:Z,
  (PROP  (0 <= j; j <= size-j)
   LOCAL  (temp _a a0; temp _lo (Vint (Int.repr j)); temp _hi (Vint (Int.repr (size-j))))
   SEP (data_at sh (tarray tint size) (flip_ends j (size-j) contents) a0)))%assert.

Lemma Zlength_flip_ends:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_ends i j al) = Zlength al.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. lia.
Qed.
Hint Rewrite @Zlength_flip_ends using (autorewrite with sublist; lia) : sublist.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_ends j (size - j) contents = rev contents.
Proof.
  intros.
  unfold flip_ends.
  rewrite <- (Zlen_le_1_rev (sublist j (size-j) contents))
      by (autorewrite with sublist; lia).
  rewrite !sublist_rev by (autorewrite with sublist; lia).
 rewrite <- !rev_app_distr, ?H.
 autorewrite with sublist; auto.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
sublist 0 j (flip_ends j (size - j) al) ++
sublist (size - j - 1) (size - j) al ++
sublist (j + 1) size
  (sublist 0 (size - j - 1) (flip_ends j (size - j) al) ++
   sublist j (j + 1) (flip_ends j (size - j) al) ++
   sublist (size - j) size (flip_ends j (size - j) al)) =
flip_ends (j + 1) (size - (j + 1)) al.
Proof.
intros.
unfold flip_ends.
rewrite <- H.
autorewrite with sublist.
rewrite (sublist_split 0 j (j+1)) by (autorewrite with sublist; lia).
rewrite !app_ass.
f_equal. f_equal.
rewrite !sublist_rev, <- ?H by lia.
rewrite Zlen_le_1_rev by (autorewrite with sublist; lia).
f_equal; lia.
rewrite (sublist_app2 (size-j) size)
 by (autorewrite with sublist; lia).
autorewrite with sublist.
rewrite sublist_app'
 by (autorewrite with sublist; lia).
autorewrite with sublist.
f_equal.
f_equal; lia.
autorewrite with sublist.
  rewrite <- (Zlen_le_1_rev (sublist j (1+j) al))
      by (autorewrite with sublist; lia).
rewrite !sublist_rev, <- ?H by lia.
 rewrite <- !rev_app_distr, <- ?H.
 autorewrite with sublist.
 f_equal; f_equal; lia.
Qed.

Lemma flip_ends_map:
  forall A B (F: A -> B) lo hi (al: list A),
  flip_ends lo hi (map F al) = map F (flip_ends lo hi al).
Proof.
intros.
unfold flip_ends.
rewrite !map_app.
rewrite !map_sublist, !map_rev, Zlength_map.
auto.
Qed.

Lemma flip_fact_2:
  forall {A}{d: Inhabitant A} (al: list A) size j,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al =
  Znth (size - j - 1) (flip_ends j (size - j) al).
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. auto.
Qed.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* lo = 0; *)
forward. (* hi = n; *)

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
Exists 0.
entailer!.
unfold flip_ends; autorewrite with sublist; auto.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
forward. (* t = a[lo]; *)
{
  entailer!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by old_list_solve.
  apply I.
}
forward.  (* s = a[hi-1]; *)
{
  entailer!.
  clear - H H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by old_list_solve.
  apply I.
}
rewrite <- flip_fact_2 by (rewrite ?Zlength_flip_ends; lia).
forward. (*  a[hi-1] = t; *)
forward. (* a[lo] = s; *)
forward. (* lo++; *)
forward. (* hi--; *)
(* Prove postcondition of loop body implies loop invariant *)
 Exists (Z.succ j).
 entailer!.
 f_equal; f_equal; lia.
 simpl.
 apply derives_refl'.
 unfold data_at.    f_equal.
 clear - H0 HRE H1.
 unfold Z.succ.
 rewrite <- flip_fact_3 by auto.
 rewrite <- (Znth_map (Zlength (map Vint contents)-j-1) Vint) by (autorewrite with sublist in *; old_list_solve).
 forget (map Vint contents) as al. clear contents.
 remember (Zlength al) as size.
 repeat match goal with |- context [reptype ?t] => change (reptype t) with val end.
 rewrite upd_Znth_old_upd_Znth. 2 : {
   rewrite upd_Znth_Zlength; rewrite Zlength_flip_ends; lia.
 }
 rewrite upd_Znth_old_upd_Znth. 2 : {
   rewrite Zlength_flip_ends; lia.
 }
 unfold old_upd_Znth.
 rewrite !Znth_cons_sublist by (repeat rewrite Zlength_flip_ends; try lia).
 rewrite ?Zlength_app, ?Zlength_firstn, ?Z.max_r by lia.
 rewrite ?Zlength_flip_ends by lia.
 rewrite ?Zlength_sublist by (rewrite ?Zlength_flip_ends ; lia).
 unfold Z.succ. rewrite <- Heqsize. autorewrite with sublist.
 replace (size - j - 1 + (1 + j)) with size by (clear; lia).
 reflexivity.
* (* after the loop *)
forward. (* return; *)
entailer!.
rewrite map_rev. rewrite flip_fact_1; try lia; auto.
cancel.
Qed.

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.
forward_call  (*  revarray(four,4); *)
  (gv _four, Ews, four_contents, 4).
forward_call  (*  revarray(four,4); *)
    (gv _four,Ews, rev four_contents,4).
rewrite rev_involutive.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.

Module Alternate.

(* Lemma calc_Zlength_rev : forall A (l : list A) len,
  Zlength l = len ->
  Zlength (rev l) = len.
Proof.
  intros.
  rewrite Zlength_rev.
  auto.
Qed.

Ltac calc_Zlength_extra l ::=
  lazymatch l with
  | @rev ?A ?l =>
    calc_Zlength l;
    let H := get_Zlength l in
    add_Zlength_res (calc_Zlength_rev A l _ H)
  end. *)

Hint Rewrite Zlength_rev : Zlength.
Hint Rewrite @Znth_rev using Zlength_solve : Znth.
#[export] Hint Unfold flip_ends : list_solve_unfold.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
repeat step.

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
simpl (data_at _ _ _).
Time repeat step!.
* (* Prove that loop invariant implies typechecking condition *)
Time repeat step!.
* (* Prove that loop body preserves invariant *)
(* unfold flip_ends. *) (* seems good to do this, but it makes step VERY slow *)
Time repeat step!.
(* Finished transaction in 32.154 secs (32.031u,0.s) (successful) *)
(* solved in step! *)
* (* after the loop *)
repeat step!.
(* Finished transaction in 2.587 secs (2.593u,0.s) (successful) *)
Time Qed.
(* Finished transaction in 6.801 secs (6.796u,0.015s) (successful) *)

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.

forward_call  (*  revarray(four,4); *)
  (gv _four, Ews, four_contents, 4).
forward_call  (*  revarray(four,4); *)
    (gv _four,Ews, rev four_contents,4).
rewrite rev_involutive.
forward. (* return s; *)
Qed.

End Alternate.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module ValidatorBaseProofs (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Existing Instance monadStateT.
Existing Instance monadStateStateT.

(* ValidatorBase_Ф_Constructor2 *)

Lemma ValidatorBase_Ф_Constructor2_exec : forall ( Л_validatorWallet : XAddress ) (l: Ledger) ,
    exec_state (  ValidatorBase_Ф_Constructor2 Л_validatorWallet ) l =
    {$ l With ValidatorBase_ι_m_validatorWallet := Л_validatorWallet $} .
 Proof.
   intros. auto.
 Qed.

 Lemma ValidatorBase_Ф_Constructor2_eval : forall ( Л_validatorWallet : XAddress ) (l: Ledger) ,
 	 eval_state ( ValidatorBase_Ф_Constructor2 Л_validatorWallet ) l = I .
 Proof.
   intros. auto.
 Qed.

 End ValidatorBaseProofs.


(* * ZF set theory with Skolem function symbols *)
(* ** Axiomatisations *)

Require Export Undecidability.FOL.Utils.FullSyntax.
From Undecidability.FOL.Sets Require Export ZF minZF binZF Signatures.
Import Vector.VectorNotations.
Require Import List.

Declare Scope syn.
Open Scope syn.

(* ** Signature for ZF axiomatisation, containing function symbols for set operations *)

Import ZFSignature.
Export ZFSignature.
(* ** Problems *)

Notation extensional M :=
  (forall x y, @i_atom _ ZF_pred_sig _ M equal ([x; y]) <-> x = y).

(* Semantic entailment restricted to core axioms (without sep and rep) with equality axioms. *)

Definition entailment_ZFeq' phi :=
  forall D (M : interp D) (rho : nat -> D), (forall sigma psi, In psi ZFeq' -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment restricted to extensional models and hereditarily finite sets. *)

Definition entailment_HF phi :=
  forall D (M : interp D) (rho : nat -> D), extensional M -> (forall sigma psi, In psi HF -> sigma ⊨ psi) -> rho ⊨ phi.

Definition entailment_HFN phi :=
  forall D (M : interp D) (rho : nat -> D), extensional M -> (forall sigma psi, In psi HFN -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment restricted to extensional models and core axioms (without sep and rep). *)

Definition entailment_ZF' phi :=
  forall D (M : interp D) (rho : nat -> D), extensional M -> (forall sigma psi, In psi ZF' -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment for Z restricted to extensional models. *)

Definition entailment_Z phi :=
  forall D (M : interp D) (rho : nat -> D), extensional M -> (forall sigma psi, Z psi -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment for ZF restricted to extensional models. *)

Definition entailment_ZF phi :=
  forall D (M : interp D) (rho : nat -> D), extensional M -> (forall sigma psi, ZF psi -> sigma ⊨ psi) -> rho ⊨ phi.

(* Deductive entailment restricted to hereditarily finite sets. *)

Definition deduction_HF phi :=
  HFeq ⊢I phi.

Definition deduction_HFN phi :=
  HFNeq ⊢I phi.

(* Deductive entailment restricted to intuitionistic rules and core axioms (without sep and rep). *)

Definition deduction_ZF' phi :=
  ZFeq' ⊢I phi.

(* Deductive entailment for Z restricted to intuitionistic rules. *)

Definition deduction_Z phi :=
  Zeq ⊢TI phi.

(* Deductive entailment for ZF restricted to intuitionistic rules. *)

Definition deduction_ZF phi :=
  ZFeq ⊢TI phi.

(* ** MinZF *)

(* Semantic entailment restricted to core axioms (without sep and rep) with equality axioms. *)

Definition entailment_minZFeq' phi :=
  forall D (M : interp D) (rho : nat -> D), (forall sigma psi, In psi minZFeq' -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment restricted to extensional models and core axioms (without sep and rep). *)

Definition entailment_minZF' phi :=
  forall D (M : @interp sig_empty _ D) (rho : nat -> D), extensional M -> (forall sigma psi, In psi minZF' -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment for Z restricted to extensional models. *)

Definition entailment_minZ phi :=
  forall D (M : @interp sig_empty _ D) (rho : nat -> D), extensional M -> (forall sigma psi, minZ psi -> sigma ⊨ psi) -> rho ⊨ phi.

(* Semantic entailment for ZF restricted to extensional models. *)

Definition entailment_minZF phi :=
  forall D (M : @interp sig_empty _ D) (rho : nat -> D), extensional M -> (forall sigma psi, minZF psi -> sigma ⊨ psi) -> rho ⊨ phi.

(* Deductive entailment restricted to intuitionistic rules and core axioms (without sep and rep). *)

Definition deduction_minZF' phi :=
  minZFeq' ⊢I phi.

(* Deductive entailment for Z restricted to intuitionistic rules. *)

Definition deduction_minZ phi :=
  minZeq ⊢TI phi.

(* Deductive entailment for ZF restricted to intuitionistic rules. *)

Definition deduction_minZF phi :=
  minZFeq ⊢TI phi.

(* ** BinZF *)

(* Semantic entailment restricted to extensional models and core axioms (without sep and rep). *)

Definition entailment_binZF phi :=
  forall D (M : @interp sig_empty _ D) (rho : nat -> D), (forall psi, In psi binZF -> rho ⊨ psi) -> rho ⊨ phi.

(* Deductive entailment restricted to intuitionistic rules and core axioms (without sep and rep). *)

Definition deduction_binZF phi :=
  binZF ⊢I phi.


(*******************************************************************
 * Este archivo especifica el estado.
 * Los mapping A B fueron cambiados a funciones f: A -> option B
 ******************************************************************)

Section State.

(** Identificadores de OSs e Hypercalls *)

Parameter os_ident : Set.
Parameter os_ident_eq : forall oi1 oi2 : os_ident, {oi1 = oi2} + {oi1 <> oi2}.

Parameter Hyperv_call: Set.

(* Memoria y direcciones *)

(* Direcciones Virtuales. *)
Parameter vadd: Set.
Parameter vadd_eq : forall va1 va2 : vadd, {va1 = va2} + {va1 <> va2}.

(** Direcciones de Máquina. *)
Parameter madd :  Set.
Parameter madd_eq : forall ma1 ma2 : madd, {ma1 = ma2} + {ma1 <> ma2}.

(** Direcciones Físicas :
Los sitemas operativos utilizan este tipo de direcciones para ver regiones de memoriea
contigua. Estos no ven direcciones de máquina. *)
Parameter padd: Set.
Parameter padd_eq : forall pa1 pa2 : padd, {pa1 = pa2} + {pa1 <> pa2}.

(** Memory values. *)
Parameter value: Set.
Parameter value_eq:forall val1 val2 : value, {val1 = val2} + {val1 <> val2}.

(* Environment *)
Record context : Set :=
  Context
    {(** una dirección virtual es accesible, i.e. no está reserveda
         por el Hypervisor *)
       ctxt_vadd_accessible: vadd -> bool;
     (** guest Oss (Confiable/No Confiable) **)
       ctxt_oss : os_ident -> bool
    }.

(*******************************************************************
********************************************************************)

Record os :=
  OS
    {
       curr_page : padd;
       hcall : option Hyperv_call
    }.

Notation "A |-> B" := (A -> option B) (at level 60).

Inductive exec_mode :=
| usr : exec_mode
| svc : exec_mode.

Inductive os_activity :=
| running : os_activity
| waiting : os_activity.

Inductive content : Set :=
| RW : option value -> content
| PT : (vadd |-> madd) -> content
| Other : content.

Inductive page_owner : Set :=
| Hyp : page_owner
| Os : os_ident -> page_owner
| No_Owner : page_owner.

Record page :=
  Page
    {
       page_content : content;
       page_owned_by : page_owner
    }.

Definition oss_map := os_ident |-> os.

Definition hypervisor_map := os_ident |-> (padd |-> madd).

Definition system_memory := madd |-> page.

Record State :=
  St
    {
       active_os : os_ident;
       aos_exec_mode : exec_mode;
       aos_activity : os_activity;
       oss : oss_map;
       hypervisor : hypervisor_map;
       memory : system_memory
    }.

(* Differ s valor s' 1 2 y 3 dicen que s' = s, excepto s'.(campo) = valor *)
Inductive differ_active_os : State -> os_ident -> State -> Prop :=
  differ1_intro : forall (s1 s2 : State) (o : os_ident),
                  s2.(active_os) = o
                  -> s2.(aos_exec_mode) = s1.(aos_exec_mode)
                  -> s2.(aos_activity) = s1.(aos_activity)
                  -> s2.(oss) = s1.(oss)
                  -> s2.(hypervisor) = s1.(hypervisor)
                  -> s2.(memory) = s1.(memory)
                  -> differ_active_os s1 o s2.

Inductive differ_aos_exec_mode : State -> exec_mode -> State -> Prop :=
  differ2_intro : forall (s1 s2 : State) (ex : exec_mode),
                  s2.(active_os) = s1.(active_os)
                  -> s2.(aos_exec_mode) = ex
                  -> s2.(aos_activity) = s1.(aos_activity)
                  -> s2.(oss) = s1.(oss)
                  -> s2.(hypervisor) = s1.(hypervisor)
                  -> s2.(memory) = s1.(memory)
                  -> differ_aos_exec_mode s1 ex s2.

Inductive differ_aos_activity : State -> os_activity -> State -> Prop :=
  differ3_intro : forall (s1 s2 : State) (act : os_activity),
                  s2.(active_os) = s1.(active_os)
                  -> s2.(aos_exec_mode) = s1.(aos_exec_mode)
                  -> s2.(aos_activity) = act
                  -> s2.(oss) = s1.(oss)
                  -> s2.(hypervisor) = s1.(hypervisor)
                  -> s2.(memory) = s1.(memory)
                  -> differ_aos_activity s1 act s2.

(* Differ 4 5 y 6 dicen que s' difiere de s solo en el valor del id del map
 respectivo *)

Inductive differ_oss : State -> os_ident -> State -> Prop :=
  differ4_intro : forall (s1 s2 : State) (id : os_ident),
                  s2.(active_os) = s1.(active_os)
                  -> s2.(aos_exec_mode) = s1.(aos_exec_mode)
                  -> s2.(aos_activity) = s1.(aos_activity)
                  -> (forall id2 : os_ident, id <> id2 ->
                  s2.(oss) id2 = s1.(oss) id2)
                  -> s2.(hypervisor) = s1.(hypervisor)
                  -> s2.(memory) = s1.(memory)
                  -> differ_oss s1 id s2.

Inductive differ_hypervisor : State -> os_ident -> State -> Prop :=
  differ5_intro : forall (s1 s2 : State) (id : os_ident),
                  s2.(active_os) = s1.(active_os)
                  -> s2.(aos_exec_mode) = s1.(aos_exec_mode)
                  -> s2.(aos_activity) = s1.(aos_activity)
                  -> s2.(oss) = s1.(oss)
		  -> (forall id2 : os_ident, id <> id2 ->
                  s2.(hypervisor) id2 = s1.(hypervisor) id2)
                  -> s2.(memory) = s1.(memory)
                  -> differ_hypervisor s1 id s2.

Inductive differ_memory : State -> madd -> State -> Prop :=
  differ6_intro : forall (s1 s2 : State) (ma : madd),
                  s2.(active_os) = s1.(active_os)
                  -> s2.(aos_exec_mode) = s1.(aos_exec_mode)
                  -> s2.(aos_activity) = s1.(aos_activity)
                  -> s2.(oss) = s1.(oss)
		  -> s2.(hypervisor) = s1.(hypervisor)
                  -> (forall ma2 : madd, ma <> ma2 ->
                  s2.(memory) ma2 = s1.(memory) ma2)
                  -> differ_memory s1 ma s2.

Inductive is_RW : content -> Prop :=
  is_RW_intro : forall (x : option value), is_RW (RW x).

End State.