Require Import
        FJ.Base
        FJ.Syntax
        FJ.Typing.Wellformedness.WellformedExp
        FJ.Tactics.

(* well formed definitions for declarations *)

Section WF.

  Variable CT : ClassTable.

  Inductive WellFormedFormalArg : FormalArg -> Prop :=
    WFFormalArg
    : forall n C CD, M.MapsTo C CD CT ->
                     WellFormedFormalArg (mkFormalArg n C).

  Inductive WellFormedField : Field -> Prop :=
    WFField
    : forall n C CD, M.MapsTo C CD CT ->
                     WellFormedField (mkField n C).

  Inductive WellFormedConstructor : Constructor -> Prop :=
    WFConstructor
    : forall C args sups inis CD,
      M.MapsTo C CD CT ->
      Forall WellFormedFormalArg args ->
      WellFormedConstructor (mkConstructor C args sups inis).

  Inductive WellFormedMethod : Method -> Prop :=
    WFMethod
    : forall C m args nodup e CD,
      M.MapsTo C CD CT ->
      Forall WellFormedFormalArg args ->
      WellFormedExp CT e ->
      WellFormedMethod (mkMethod C m args nodup e).

  Inductive WellFormedClass : ClassDecl -> Prop :=
    WFClass : forall C D fs K ms CD DD,
      M.MapsTo C CD CT ->
      M.MapsTo D DD CT ->
      Forall WellFormedField (values fs) ->
      WellFormedConstructor K ->
      Forall WellFormedMethod (values ms) ->
      WellFormedClass (mkClassDecl C D fs K ms).
End WF.

  Hint Constructors
       WellFormedFormalArg
       WellFormedField
       WellFormedConstructor
       WellFormedMethod
       WellFormedClass.

Section DEC.
  Variable CT : ClassTable.

  Definition WellFormedFormalArgDec
    : forall fa, {WellFormedFormalArg CT fa} + {~ WellFormedFormalArg CT fa}.
    refine (fun fa =>
               match fa return {WellFormedFormalArg CT fa} + {~ WellFormedFormalArg CT fa} with
               | mkFormalArg n C =>
                 match MapsToDec C CT with
                 | !! => No
                 | [|| CD ||] => Yes
                 end
               end).
    simpl in * ; eauto.
    intro H ; inverts H ; try map_solver.
  Defined.

  Definition WellFormedFieldDec
    : forall fd, {WellFormedField CT fd} + {~ WellFormedField CT fd}.
    refine (fun fa =>
               match fa return {WellFormedField CT fa} + {~ WellFormedField CT fa} with
               | mkField n C =>
                 match MapsToDec C CT with
                 | !! => No
                 | [|| CD ||] => Yes
                 end
               end) ; simpl in * ; eauto ; try (intro H ; inverts* H) ; try map_solver.
  Defined.

  Definition WellFormedConstructorDec
    : forall K, {WellFormedConstructor CT K} + {~ WellFormedConstructor CT K}.
    refine (fun K =>
              match K return {WellFormedConstructor CT K} + {~ WellFormedConstructor CT K} with
              | mkConstructor C args sups inis =>
                match MapsToDec C CT with
                | [|| CD ||] =>
                  match Forall_dec WellFormedFormalArgDec args with
                  | Yes => Yes
                  | No  => No
                  end
                | !! => No
                end
              end) ; simpl in * ; eauto ; try (intro H ; inverts* H) ; try map_solver.
  Defined.

  Definition WellFormedMethodDec
    : forall M, {WellFormedMethod CT M} + {~ WellFormedMethod CT M}.
    refine (fun M =>
              match M return {WellFormedMethod CT M} + {~ WellFormedMethod CT M} with
              | mkMethod C m args nodup e =>
                match MapsToDec C CT with
                | !! => No
                | [|| CD ||] =>
                  match Forall_dec WellFormedFormalArgDec args with
                  | No => No
                  | Yes =>
                    match WellFormedExpDec CT e with
                    | Yes => Yes
                    | No  => No
                    end
                  end
                end
              end) ; simpl in * ; try (intro H ; inverts H) ; try map_solver ; eauto.
  Defined.

  Definition WellFormedClassDec
    : forall CD, {WellFormedClass CT CD} + {~ WellFormedClass CT CD}.
    refine (fun CD =>
              match CD return {WellFormedClass CT CD} + {~ WellFormedClass CT CD} with
              | mkClassDecl C D fs K ms =>
                match MapsToDec C CT with
                | !! => No
                | [|| CD1 ||] =>
                  match MapsToDec D CT with
                  | !! => No
                  | [|| DD ||] =>
                    match Forall_dec WellFormedFieldDec (values fs) with
                    | No => No
                    | Yes =>
                      match WellFormedConstructorDec K with
                      | No => No
                      | Yes =>
                        match Forall_dec WellFormedMethodDec (values ms) with
                        | Yes => Yes
                        | No  => No
                        end
                      end
                    end
                  end
                end
              end) ; simpl in * ; try (intro H ; inverts* H) ; eauto ; try map_solver.
  Defined.

End DEC.


(* correct failure of injection/discriminate on types whose inductive
   status derives from the substitution of an argument *)

Inductive t : nat -> Type :=
| M : forall n: nat, nat -> t n.

Lemma eq_t : forall n n' m m',
   existT (fun B : Type => B) (t n) (M n m) =
   existT (fun B : Type => B) (t n') (M n' m') -> True.
Proof.
  intros.
  injection H.
  intro Ht.
  exact I.
Qed.

Lemma eq_t' : forall n n' : nat,
   existT (fun B : Type => B) (t n) (M n 0) =
   existT (fun B : Type => B) (t n') (M n' 1) -> True.
Proof.
  intros.
  discriminate H || exact I.
Qed.


(** *** Going into the opposite direction of [UniMath.Bicategories.Core.Examples.BicategoryFromWhiskeredMonoidal] *)
(** We fix a bicategory and an object of it and construct the (whiskered) monoidal category of endomorphisms.

Written by Ralph Matthes in 2019, adapted in 2022.

 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Unitors.

Local Open Scope cat.

Section Monoidal_Cat_From_Bicat.

Local Open Scope bicategory_scope.
Import Bicat.Notations.
Import MonoidalNotations.

Context {C : bicat}.
Context (c0: ob C).

Definition precategory_data_from_bicat_and_ob: precategory_data.
Proof.
  use make_precategory_data.
  - use make_precategory_ob_mor.
    + exact (C⟦c0,c0⟧).
    + apply prebicat_cells.
  - intro c; apply id2.
  - intros a b c; apply vcomp2.
Defined.

Lemma is_precategory_data_from_prebicat_and_ob: is_precategory precategory_data_from_bicat_and_ob.
Proof.
  use make_is_precategory.
  - intros a b f; apply id2_left.
  - intros a b f; apply id2_right.
  - intros a b c d f g h; apply vassocr.
  - intros a b c d f g h; apply pathsinv0; apply vassocr.
Qed.

Definition precategory_from_bicat_and_ob: precategory := _,, is_precategory_data_from_prebicat_and_ob.

Lemma has_homsets_precategory_from_bicat_and_ob: has_homsets precategory_from_bicat_and_ob.
Proof.
  red. intros.
  apply (cellset_property(C:=C)).
Qed.

Definition category_from_bicat_and_ob: category := precategory_from_bicat_and_ob ,, has_homsets_precategory_from_bicat_and_ob.

Local Notation EndC := category_from_bicat_and_ob.

Definition tensor_data_from_bicat_and_ob: bifunctor_data category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob.
Proof.
  use make_bifunctor_data.
  - intros a b. exact (a · b).
  - intros a b1 b2 β. exact (lwhisker _ β).
  - intros b a1 a2 α. exact (rwhisker _ α).
Defined.

(** we explicitly do not opacify the following definition: *)
Definition tensor_laws_from_bicat_and_ob: is_bifunctor tensor_data_from_bicat_and_ob.
Proof.
  red; repeat split; red; cbn.
  - apply lwhisker_id2.
  - intros; apply id2_rwhisker.
  - intros; apply pathsinv0, lwhisker_vcomp.
  - intros; apply pathsinv0, rwhisker_vcomp.
  - intros; apply vcomp_whisker.
Defined.

Definition tensor_from_bicat_and_ob
  : bifunctor category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob
  := make_bifunctor tensor_data_from_bicat_and_ob tensor_laws_from_bicat_and_ob.

Definition monoidal_data_from_bicat_and_ob: monoidal_data category_from_bicat_and_ob.
Proof.
  use make_monoidal_data.
  - exact tensor_data_from_bicat_and_ob.
  - exact (id₁ c0).
  - red; intros; apply lunitor.
  - red; intros; apply linvunitor.
  - red; intros; apply runitor.
  - red; intros; apply rinvunitor.
  - red; intros; apply rassociator.
  - red; intros; apply lassociator.
Defined.

Local Definition MD := monoidal_data_from_bicat_and_ob.

Local Lemma leftunitor_law_from_bicat_and_ob: leftunitor_law lu_{MD} luinv_{MD}.
Proof.
  split; red; cbn.
  - apply vcomp_lunitor.
  - apply is_invertible_2cell_lunitor.
Qed.

Local Lemma rightunitor_law_from_bicat_and_ob: rightunitor_law ru_{MD} ruinv_{MD}.
Proof.
  split; red; cbn.
  - apply vcomp_runitor.
  - apply is_invertible_2cell_runitor.
Qed.

Local Lemma associator_law_from_bicat_and_ob: associator_law α_{MD} αinv_{MD}.
Proof.
  repeat split; try red; cbn.
  - apply lwhisker_lwhisker_rassociator.
  - intros; apply pathsinv0, rwhisker_rwhisker_alt.
  - apply rwhisker_lwhisker_rassociator.
  - apply is_invertible_2cell_rassociator.
  - apply is_invertible_2cell_rassociator.
Qed.

Local Lemma triangle_identity_from_bicat_and_ob: triangle_identity lu_{MD} ru_{MD} α_{MD}.
Proof.
  red; cbn. apply lunitor_lwhisker.
Qed.

(** the next two lemmas only for illustration that the extra triangle laws are already available in bicategories *)
Local Lemma triangle_identity'_from_bicat_and_ob: triangle_identity' lu_{MD} α_{MD}.
Proof.
  red; intros x y; cbn. rewrite <- lunitor_triangle. rewrite vassocr. rewrite rassociator_lassociator. apply id2_left.
Qed.

Local Lemma triangle_identity''_from_bicat_and_ob: triangle_identity'' ru_{MD} α_{MD}.
Proof.
  red; intros x y; cbn. apply runitor_triangle.
Qed.

Local Lemma pentagon_identity_from_bicat_and_ob: pentagon_identity α_{MD}.
Proof.
  red; cbn. apply rassociator_rassociator.
Qed.

Definition monoidal_from_bicat_and_ob: monoidal category_from_bicat_and_ob.
Proof.
  exists monoidal_data_from_bicat_and_ob.
  exists (pr2 (tensor_from_bicat_and_ob)).
  exists leftunitor_law_from_bicat_and_ob.
  exists rightunitor_law_from_bicat_and_ob.
  exists associator_law_from_bicat_and_ob.
  exists triangle_identity_from_bicat_and_ob.
  exact pentagon_identity_from_bicat_and_ob.
Defined.

End Monoidal_Cat_From_Bicat.


Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.

Set Implicit Arguments.

Variant sim_global (gl_src gl_tgt: Global.t): Prop :=
| sim_global_intro
    (SC: TimeMap.le (Global.sc gl_src) (Global.sc gl_tgt))
    (PROMISES: Global.promises gl_src = Global.promises gl_tgt)
    (MEMORY: sim_memory (Global.memory gl_src) (Global.memory gl_tgt))
.
#[export] Hint Constructors sim_global: core.

Global Program Instance sim_global_PreOrder: PreOrder sim_global.
Next Obligation.
  ii. destruct x. econs; refl.
Qed.
Next Obligation.
  ii. destruct x, y, z. inv H. inv H0. ss. subst.
  econs; ss; etrans; eauto.
Qed.

Lemma init_sim_global: sim_global Global.init Global.init.
Proof. refl. Qed.

Lemma sim_global_cap gl_src gl_tgt
      (GL: sim_global gl_src gl_tgt)
      (GL_WF_SRC: Global.wf gl_src)
      (GL_WF_TGT: Global.wf gl_tgt)
  :
  sim_global (Global.cap_of gl_src) (Global.cap_of gl_tgt).
Proof.
  inv GL. econs; eauto. ss.
  eapply sim_memory_cap; eauto.
  { eapply Memory.cap_of_cap. }
  { eapply Memory.cap_of_cap. }
  { eapply GL_WF_SRC. }
  { eapply GL_WF_TGT. }
Qed.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.

Require Import MirrorCharge.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.SetoidRewrite.Base.
Require Import MirrorCharge.SetoidRewrite.ILSetoidRewrite.
Require Import MirrorCharge.PullConjunct.ILPullConjunct.

Require Import Charge.Logics.ILogic.

Set Implicit Arguments.
Set Strict Implicit.

Section PullConjunct.
  Context (typ func : Type).
  Context {HIL : ILogicFunc typ func} {HB : BaseFunc typ func}.
  Context {RelDec_func : RelDec (@eq (expr typ func))}.
  Context {target : expr typ func -> bool}.
  Context {RType_typ : RType typ}.
  Context {Typ2_typ : Typ2 RType_typ Fun}.
  Context {Typ0_typ : Typ0 RType_typ Prop}.
  Context {RSym_func : RSym func}.
  Context {ilogic : forall t : typ, option (ILogicOps (typD t))}.
Check setoid_rewrite.
  Definition pull_conjunct vars :=
	setoid_rewrite vars _ fEntails rw_fail (il_rewrite_respects typ func ilogic) (il_pull_conjunct target).

  Definition PULLCONJUNCTL : rtac typ (expr typ func) :=
    fun tus tvs lus lvs c s e =>
      match e with
        | App (App f L) R =>
          match ilogicS f with
	        | Some (ilf_entails l) =>
	        	match pull_conjunct (getVars c) l L with
	        	  | Some (e', _) => More s (GGoal (mkEntails l e' R))
	        	  | _ => More s (GGoal e)
	        	end
	        | _ => More s (GGoal e)
	      end
        | _ => More s (GGoal e)
      end.

End PullConjunct.

Implicit Arguments PULLCONJUNCTL [[HIL] [HB] [RelDec_func] [RType_typ] [Typ2_typ] [Typ0_typ] [RSym_func]].


Require Export Unicode.Utf8_core.
Require Export Coq.Program.Program.
Require Import Relations RelationClasses Setoid.

Implicit Arguments projT1 [[A] [P]].
Implicit Arguments projT2 [[A] [P]].
Implicit Arguments existT [[A] [P]].

Definition prodT (A B : Type) := @sigT A (fun _ => B).
Definition pairT {A B : Type} : A -> B -> prodT A B := @existT A (fun _ => B).

Inductive prop_eq (P : Prop) (p : P) : P -> Prop :=
  prop_eq_refl : prop_eq P p p.

Implicit Arguments pairT [[A] [B]].

Definition conv_annot {T U : Type} (M : U) : U := M.
Definition app_annot {T} {U : T -> Type} {N : T} (V : U N) : U N := V.

Lemma equal_existT {A} {P : A -> Type} {p : A} {x y : P p} : x = y -> (existT p x = existT p y).
Proof. now intros ->. Defined.

Implicit Arguments exist [[A] [P]].

Lemma equal_exist {A} {P : A -> Prop} {p : A} {x y : P p} : exist p x = exist p y.
Proof. now intros. Defined.

Lemma exist_eq {A : Type} {P : A -> Prop} (x y : A) (p : P x) (q : P y) :
  x = y -> exist x p = exist y q.
Proof. intros; subst; reflexivity. Qed.

Lemma equal_f {A B : Type} {f g : A -> B} : f = g -> forall x : A, f x = g x.
Proof. now intros ->. Qed.

Lemma equal_dep_f {A} {B : A -> Type} {f g : ∀ x : A, B x} : f = g -> forall x : A, f x = g x.
Proof. now intros ->. Qed.

(* To control backtracking during proof search *)
Class Tried (P : Prop).

Ltac not_tried p :=
  match goal with
    | [ H : Tried ?Q |- _ ] =>
      match Q with
        p => fail 2
      end
    | _ => idtac
  end.

Notation " '{Σ' x , y } " := (exist x y).
Notation " '(Σ' x , y ) " := (existT x y).

(** Basic definitions for forcing *)

(** Forcing conditions come with a preorder *)

Module Type Condition.
  Parameter P : Type.
  Parameter le : relation P.
  Declare Instance le_pre : PreOrder le.

  Delimit Scope forcing_scope with forcing.
  Notation " x <= y " := (le x y) : forcing_scope.

End Condition.

Inductive prop_or_type := is_prop | is_type.

Class ForcingOp {A : Type} (a : A) (p : prop_or_type) := {
  forcing_traduction_type : Type;
  forcing_traduction : forcing_traduction_type
}.

Implicit Arguments forcing_traduction [[A] [ForcingOp]].

Class ForcingLemma {P : Prop} (p : P) := {
  forcing_traduction_prop : Prop;
  forcing_traduction_proof : forcing_traduction_prop
}.

Require Import Le.
Module NatCondition <: Condition.
  Definition P := nat.

  Definition le := Peano.le.

  Instance le_pre : PreOrder le.
  Proof. split; red; intros. apply le_n. eapply le_trans; eauto. Qed.

  Delimit Scope forcing_scope with forcing.
  Notation " x <= y " := (le x y) : forcing_scope.

End NatCondition.

Module Forcing(F : Condition).
  Import F.

  Local Open Scope forcing_scope.

  Definition Psub (p : P) := fun q : P => q <= p.

  Definition subp (p : P) := sig (Psub p).

  Definition subp_proj {p : P} (q : subp p) : P := ` q.
  Global Coercion subp_proj : subp >-> P.

  Definition ssubp {p} (q : subp p) := subp (subp_proj q).

  (** [subp] also forms valid forcing conditions *)

  Program Definition subp_intro {p : P} (q : P) (prf : q <= p) : subp p := q.

  Lemma subp_proof {p} (q : subp p) : (subp_proj q) <= p.
  Proof. apply (proj2_sig q). Defined.
  Hint Resolve subp_proof : forcing.

  Program Definition embed (p : P) : subp p := p.
  Next Obligation. red; reflexivity. Qed.

  (** We define an overloaded [ι] operator to infer canonical
     coercions of conditions into larger subsets. *)

  Class Iota p (x : subp p) q := { iota : subp q ;
    iota_identity : @eq P x iota
  }.

  Global Implicit Arguments iota [[p] [q] [Iota]].

  Notation ι r := (iota r).

  (*Hint Extern 4 => progress (unfold le in * ) : forcing.*)

  Lemma subp_proof2 p (q : subp p) : ` q <= p.
  Proof. apply subp_proof. Defined.
  Hint Resolve subp_proof2 : forcing.

  Ltac forcing_le :=
    match goal with
      | |- le (@proj1_sig _ _ ?y) ?x =>
          apply (proj2_sig y)
      | |- ` ?x <= ?y =>
          match type of x with
              subp ?r => transitivity r
          end
      | |- le (@subp_proj ?x ?y) ?x =>
          apply (proj2_sig y)
      | |- subp_proj ?x <= ?y =>
          match type of x with
              subp ?r => transitivity r
          end
    end.

  Hint Extern 2 (_ <= _) => forcing_le : forcing.
  Hint Extern 0 (_ <= _) => apply reflexivity : forcing.
  Hint Extern 0 (_ = _) => try f_equal ; reflexivity : forcing.

  Ltac forcing :=
    try solve [simpl; unfold Psub in *; auto with arith forcing].
  Obligation Tactic := program_simpl; forcing.

  (** The identity, in case no coercion was needed in fact *)
  Global Program Instance iota_reflexive p (q : subp p) : Iota p q p := { iota := (q : P) }.

  (** Self-indexing [q : P p] then [q : P q] *)
  Global Program Instance iota_lift p (q : subp p) : Iota p q q := { iota := (q : P) }.

  (** [q : P p] so forall [r : P q] [r : P p] as well *)
  Global Program Instance iota_pi {p} (q : subp p) : Iota q (iota q) p :=
    { iota := (q : P) }.

  (** [q : P p] so forall [r : P q] [r : P p] as well *)
  Global Program Instance iota_pi_inv {p} (q : subp p) (r : subp q) : Iota q r p :=
    { iota := (r : P) }.

  (** Iotas compose *)
  Program Definition iota_compose {p sp q r} (pq : Iota p sp q) (qr : Iota q (iota sp) r) : Iota p sp r :=
    {| iota := iota (iota sp) |}.

  Next Obligation. now repeat rewrite <- iota_identity. Defined.

  (**  In case [iota] does not change the type, it's the identity *)
  Lemma iota_iota_refl {p} (q : subp p) : iota (iota q) = q.
  Proof. now destruct q. Qed.

  Lemma iota_irrel {p} (q : subp p) {r} (X Y : Iota p q r) : iota (Iota:=X) q = iota (Iota:=Y) q.
  Proof. destruct X, Y. unfold iota; simpl. destruct iota0, iota1. simpl in *. subst. reflexivity. Qed.

  CoInductive iota_trans : P -> P -> Prop := .

  (** [iota_compose] is always applicable, restrict it to cases where both [p] and [r]
     are ground and check for loops. *)
  Ltac apply_iota_compose p sp q :=
    progress (is_evar p || is_evar q ||
                      (try (not_tried (iota_trans p q) ;
                            let foo := fresh "tried" in
                              set(foo:=Build_Tried (iota_trans p q)) ;
                            eapply iota_compose))).

  Hint Extern 3 (Iota ?p ?sp ?q) => apply_iota_compose p sp q : typeclass_instances.

  Ltac test_iota_compose :=
    match goal with
      |- Iota ?p ?sp ?q => apply_iota_compose p sp q
    end.

  Goal forall p sp q r (iop : Iota p sp q), Iota q (iota sp) r -> Iota p sp r.
  Proof. intros. typeclasses eauto. Qed.

  Goal forall p sp q r, Iota p sp q -> Iota p sp r.
  Proof. intros.
    Fail typeclasses eauto. admit. Qed.

  Example one_trans p (q : subp p) (r : subp q) (s : subp r) : subp q.
  Proof. exact (iota s). Defined.

  Example two_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) : subp q.
  Proof. exact (iota t). Defined.

  Example three_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) : subp q.
  Proof. exact (iota u). Defined.

    (* Maybe use those instances more? *)
  Global Instance one_trans_inst p (q : subp p) (r : subp q) (s : subp r) : Iota _ s q := { iota := iota s }.
  Proof. reflexivity. Defined.

  Global Instance two_trans_inst p (q : subp p) (r : subp q) (s : subp r) (t : subp s) : Iota _ t q := { iota := iota t }.
  Proof. reflexivity. Defined.

  Global Instance three_trans_inst p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) : Iota _ u q := {iota := iota u}.
  Proof. reflexivity. Defined.

  Example four_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) (v : subp u)
  : subp q.
  Proof. exact (iota v). Defined.

  Section Translation.

    Definition transport {p} (f : subp p → Type) :=
      forall q : subp p, forall r : subp q, arrow (f q) (f (iota r)).

    Section Sheaf.
      Context {p} {f : subp p -> Type}.

      Definition refl (Θ : transport f) := Eval simpl in
        forall q : subp p, forall x : f q,
          Θ q (iota q) x = x.

      Definition trans (Θ : transport f) := Eval simpl in
        forall q : subp p, forall r : subp q, forall s : subp r,
          forall x, ((Θ (iota r) s) ∘ (Θ q r)) x = Θ q (iota s) x.

      Definition trans_prop (Θ : transport f) :=
        refl Θ /\ trans Θ.

    End Sheaf.

    Definition sheaf (p : P) :=
      { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) }.

    Definition sheaf_f {p : P} (s : sheaf p) : subp p -> Type :=
      projT1 s.

    Program Definition Θ {p : P} (s : sheaf p) : transport (sheaf_f s) :=
      projT2 s.

    Definition sheaf_refl {p} (s : sheaf p) : refl (Θ s).
    Proof. unfold Θ. destruct s. destruct s. destruct t. simpl. assumption. Defined.

    Definition sheaf_trans {p} (s : sheaf p) : trans (Θ s).
    Proof. unfold Θ. destruct s. destruct s. destruct t. simpl. assumption. Defined.

    Program Definition sheafC (p : P) (q : subp p) (r : subp q)
      (f : sheaf q) : sheaf r :=
        existT (fun s => sheaf_f f (iota s))
        (λ s : subp r, λ t : subp s, λ x : sheaf_f f (iota s),
          (Θ f (iota s) t x)).

    Notation " '{Σ'  x } " := (exist x _).

    Next Obligation. split; red. intros.
      simpl.
      destruct q0. simpl.
      destruct f. simpl in *.
      destruct s as [θ [Hr Ht]].
      red in Hr. pose (Hr _ x). simpl in *.
      rewrite <- e at 2. unfold Θ. simpl. reflexivity.

      (* Trans *)
      pose proof (sheaf_trans f).
      intros. unfold compose. destruct f; simpl in *.
      destruct s0 as [θ [Hr Ht]].
      red in Ht. pose (Ht (iota q0) r0 s x). unfold compose in *. simpl in *.
      unfold Θ. simpl in *. rewrite <- e. destruct r0; reflexivity.
    Qed.

    Lemma sheafC_trans (p : P) : trans_prop (sheafC p).
    Proof.
      red. split; red; intros.
      (* BUG with reflexivity only: eta for records probably *)
      destruct x as [sh [tr Htr]]; simpl. unfold sheafC. simpl.
      unfold Θ. simpl. reflexivity.
      destruct x as [sh [tr Htr]]; simpl. unfold compose, sheafC. simpl. apply f_equal.
      unfold Θ. simpl. reflexivity.
    Qed.

    Program Definition sheafC_sheaf (p : P) :
              { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) } :=
              existT sheaf (exist (sheafC p) (sheafC_trans p)).

  End Translation.

  Section TranslationProp.

    Definition prop_transport {p} (f : subp p → Prop) :=
      forall q : subp p, forall r : subp q, f q -> f (iota r).

    Definition prop_sheaf (p : P) :=
      { sheaf_f : subp p -> Prop | prop_transport sheaf_f }.

    Definition prop_sheaf_f {p : P} (s : prop_sheaf p) : subp p -> Prop :=
      proj1_sig s.

    Program Definition prop_Θ {p : P} (s : prop_sheaf p) : prop_transport (prop_sheaf_f s) :=
      proj2_sig s.

    Program Definition prop_sheafC (p : P) (q : subp p) (r : subp q)
      (f : prop_sheaf q) : prop_sheaf r :=
        exist (fun s => prop_sheaf_f f (iota s)) _.

    Next Obligation. red. intros.
      destruct f.
      simpl in *.
      specialize (p0 _ (iota r0) H). apply p0.
    Qed.

    Program Definition prop_sheafC_sheaf (p : P) :
              { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) } :=
              existT prop_sheaf (prop_sheafC p).
    Next Obligation.
      red. split; red; intros.
      destruct x as [sh tr]; simpl. unfold prop_sheafC. simpl. reflexivity.
      destruct x as [sh tr]; simpl. unfold compose, prop_sheafC. simpl.
      reflexivity.
    Qed.

  End TranslationProp.

End Forcing.

Module NatForcing := Forcing(NatCondition).

Declare ML Module "forcing_plugin".


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Div2.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists t':term, (infix_mnmngt t
  t')) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible(t:term): Prop := forall (t':term), ~ (infix_mnmngt t
  t').

Axiom irreducible_is_value : forall (t:term), (irreducible t) <->
  (is_value t).

(* Why3 assumption *)
Inductive only_K : term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Axiom only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR t
  v) /\ ((is_value v) /\ (only_K v)).

(* Why3 assumption *)
Fixpoint size(t:term) {struct t}: Z :=
  match t with
  | (K|S) => 0%Z
  | (App t1 t2) => ((1%Z + (size t1))%Z + (size t2))%Z
  end.

Axiom size_nonneg : forall (t:term), (0%Z <= (size t))%Z.

Parameter ks: Z -> term.

Axiom ksO : ((ks 0%Z) = K).

Axiom ksS : forall (n:Z), (0%Z <= n)%Z -> ((ks (n + 1%Z)%Z) = (App (ks n)
  K)).

Axiom ks1 : ((ks 1%Z) = (App K K)).

Axiom only_K_ks : forall (n:Z), (0%Z <= n)%Z -> (only_K (ks n)).

Axiom ks_inversion : forall (n:Z), (0%Z <= n)%Z -> ((n = 0%Z) \/
  ((0%Z < n)%Z /\ ((ks n) = (App (ks (n - 1%Z)%Z) K)))).

Axiom ks_injective : forall (n1:Z) (n2:Z), (0%Z <= n1)%Z -> ((0%Z <= n2)%Z ->
  (((ks n1) = (ks n2)) -> (n1 = n2))).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 10.

(* Why3 goal *)
Theorem WP_parameter_reduction3 : forall (t:term), (exists n:Z,
  (0%Z <= n)%Z /\ (t = (ks n))) ->
  match t with
  | S => True
  | K => True
  | (App t1 t2) => (exists n:Z, (0%Z <= n)%Z /\ (t1 = (ks n))) ->
      forall (result:term), ((is_value result) /\ forall (n:Z),
      (0%Z <= n)%Z -> (((t1 = (ks (2%Z * n)%Z)) -> (result = K)) /\
      ((t1 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (result = (App K K))))) ->
      match result with
      | K => True
      | S => True
      | (App K v1) => True
      | (App S v1) => True
      | (App (App S v1) v2) => (exists n:Z, (0%Z <= n)%Z /\ (t2 = (ks n))) ->
          forall (v3:term), ((is_value v3) /\ forall (n:Z), (0%Z <= n)%Z ->
          (((t2 = (ks (2%Z * n)%Z)) -> (v3 = K)) /\
          ((t2 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (v3 = (App K K))))) ->
          exists n:Z, (0%Z <= n)%Z /\ ((App (App v1 v3) (App v2
          v3)) = (ks n))
      | _ => True
      end
  end.
intros t (n, (h1, h2)).
destruct t; auto.
intros (n1, (h3, h4)).
destruct result; auto.
intros (_, ht1).
destruct result1; auto.
elimtype False.
destruct (Div2.div2 n1).
ae.
Qed.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2019                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(* [Require Import SMTCoq.SMTCoq.] loads the SMTCoq library.
   If you are using native-coq instead of Coq 8.11, replace it with:
     Require Import SMTCoq.
   *)

Require Import SMTCoq.SMTCoq.
Require Import Bool.

Require Import ZArith.

Import BVList.BITVECTOR_LIST.
Local Open Scope bv_scope.

Import FArray.
Local Open Scope farray_scope.

(* Examples that check ZChaff certificates *)

Local Open Scope int63_scope.

Zchaff_Checker "sat.cnf" "sat.log".
Zchaff_Theorem sat "sat.cnf" "sat.log".
Check sat.

Zchaff_Checker "hole4.cnf" "hole4.log".

(* Example that checks a VeriT certificate, for logic QF_UFLIA *)

Section Verit.
  Verit_Checker "lia.smt2" "lia.vtlog".
End Verit.

(* Example that checks a LFSC certificate, for logic QF_UFLIA *)

Section Lfsc.
  Lfsc_Checker "lia.smt2" "lia.lfsc".
End Lfsc.

(********************** Examples for Comp Reports **********************)
Theorem orIntroL : forall (a b: Prop), a -> a \/ b.
Proof.
  intros a b Ha.
  left. apply Ha.
Qed.

Theorem LEMProp : forall (a : Prop), a \/ ~a.
Proof.
  intros a.
Abort.

Theorem LEMBool : forall a : bool, a || (negb a) = true.
Proof.
  intros a. destruct a.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Theorem LEMBool' : forall a : bool, a || (negb a) = true.
Proof.
  smt.
Qed.

Theorem Z_congBool : forall (a b : Z) (f : Z -> Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = true).
Proof.
  intros.
  smt.
Qed.

Theorem Z_congBool : forall (a b : Z) (f : Z -> Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = true).
Proof.
  intros.
  smt.
Qed.

Theorem Z_congProp : forall (a b : Z) (f : Z -> Z), a = b -> f a = f b.
Proof.
  smt.
Qed.

Theorem BV_ulteZeroBool : forall (b : bitvector 4),
	bv_ult #b|0|0|0|0| b = true \/ bv_eq b #b|0|0|0|0| = true.
Proof.
  smt.
Qed.

Theorem BV_ulteZeroProp : forall (b : bitvector 4),
	bv_ultP #b|0|0|0|0| b \/ b = #b|0|0|0|0|.
Proof.
  smt.
Qed.

Theorem LEM_Z : forall (i : Z), i = 0%Z \/ ~(i = 0%Z).
Proof.
  smt.
Qed.

Theorem LEMBV : forall (b : bitvector 4),
  b = #b|0|0|0|0| \/ ~(b = #b|0|0|0|0|).
Proof.
  smt.
Qed.
(*************************************************************************)

(* CVC4 doesn't have a shl bit-blasting rule *)
Theorem BV_shl : forall (b : bitvector 4),
  bv_shl b #b|0|0|0|0| = b.
Proof.
  smt.
Abort.

(**************** Passing recursive functions to SMT solver ****************)

Definition f' (x : Z) : Prop := True.
Fixpoint evenP (x : nat) : Prop :=
  match x with
  | O => True
  | S n => evenP (n-1)
  end.

Definition f (x : Z) : Z := 1.
Theorem Z_congBool' : forall (a b : Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = false).
Proof.
  (*smt.*)
Abort.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS (n : nat) (H : ev n) : ev (S (S n)).

Theorem testPropFun : forall (a b : Z) (f : Z -> Prop), (Z.eqb a b) = true ->
  f a.
Proof.
  (*smt.*)
Abort.

(***************************** Example from Report *****************************)
Theorem F : forall (a b c : bool), (b && negb c) || (a && negb b) || negb a || c.
Proof.
  smt.
Qed.

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

Goal forall a b c,
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof.
  zchaff.
Qed.

Goal forall (i j k : Z),
    let a := Z.eqb i j in
    let b := Z.eqb j k in
    let c := Z.eqb k i in
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof.
  zchaff.
Qed.

(* Examples of the verit tactics (requires verit in your PATH environment
   variable), which handle
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - universally quantified hypotheses *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  verit_bool.
Qed.

Local Open Scope Z_scope.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  verit_bool.
Qed.

Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  verit_bool.
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  verit.
Qed.

Check (1 =? 2).

(*Some examples of using verit with lemmas. Use <verit H1 .. Hn>
  to temporarily add the lemmas H1 .. Hn to the verit environment. *)

Lemma const_fun_is_eq_val_0 :
  forall f : Z -> Z,
    (forall a b, f a =? f b = true) ->
    forall x, f x =? f 0 = true.
Proof.
  intros f Hf.
  verit Hf.
Qed.

Section With_lemmas.
  Variable f : Z -> Z.
  Variable k : Z.
  Hypothesis f_k_linear : forall x, f (x + 1) =? f x + k.

  Lemma fSS2:
    forall x, f (x + 2) =? f x + 2 * k.
  Proof. verit_no_check f_k_linear. Qed.
End With_lemmas.

(* Instantiating a lemma with multiple quantifiers *)
Section NonLinear.
  Lemma distr_right_inst a b (mult : Z -> Z -> Z) :
    (forall x y z, mult (x + y)  z =? mult x z + mult y z) ->
    (mult (3 + a) b =? mult 3 b + mult a b).
  Proof.
    intro H.
    verit H.
  Qed.
End NonLinear.

(* You can use <Add_lemmas H1 .. Hn> to permanently add the lemmas H1 .. Hn to
   the environment. If you did so in a section then, at the end of the section,
   you should use <Clear_lemmas> to empty the globally added lemmas because
   those lemmas won't be available outside of the section. *)

Section mult3.
  Variable mult3 : Z -> Z.
  Hypothesis mult3_0 : mult3 0 =? 0.
  Hypothesis mult3_Sn : forall n, mult3 (n+1) =? mult3 n + 3.
  Add_lemmas mult3_0 mult3_Sn.

  Lemma mult_3_4_12 : mult3 4 =? 12.
  Proof. verit. Qed.

  Clear_lemmas.
End mult3.

(* Examples of the smt tactic (requires verit and cvc4 in your PATH environment
   variable):
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - theory of fixed-sized bit-vectors
   - theory of arrays *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  smt.
Qed.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  smt.
Qed.
Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  smt.
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  smt.
Qed.

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt.
Qed.

(* All tactics have a "no_check" variant that is faster but, in case of
  failure, it will only fail at Qed *)

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt_no_check.
Qed.

(* From cvc4_bool : Uncaught exception Not_found *)
(* Goal forall (a b c d: farray Z Z), *)
(*     b[0 <- 4] = c  -> *)
(*     d = b[0 <- 4][1 <- 4]  -> *)
(*     a = d[1 <- b[1]]  -> *)
(*     a = c. *)
(* Proof. *)
(*   smt. *)
(* Qed. *)

Goal forall (a b: farray Z Z) (v w x y z t: Z)
            (r s: bitvector 4)
            (f: Z -> Z)
            (g: farray Z Z -> Z)
            (h: bitvector 4 -> Z),
    a[x <- v] = b /\ a[y <- w] = b ->
    a[z <- w] = b /\ a[t <- v] = b ->
    r = s -> v < x + 10 /\ v > x - 5 ->
    ~ (g a = g b) \/ f (h r) = f (h s).
Proof.
  smt.
Qed.

(** SMTCoq also provides conversion tactics, to inject various integer
    types into the type Z supported by SMTCoq. They can be called before
    the standard SMTCoq tactics. **)

Local Open Scope positive_scope.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((f (x + 3)) <=? (f y))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((3 <? y) && ((f (x + 3)) <=? (f y)))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Local Close Scope positive_scope.

Local Open Scope N_scope.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Local Close Scope N_scope.

Require Import NPeano.
Local Open Scope nat_scope.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Local Close Scope nat_scope.

(* An example with all 3 types and a binary function *)
Goal forall f : positive -> nat -> N, forall (x : positive) (y : nat),
  implb (x =? 3)%positive
    (implb (Nat.eqb y 7)
      (implb (f 3%positive 7%nat =? 12)%N
        (f x y =? 12)%N)) = true.
  pos_convert.
  nat_convert.
  N_convert.
  verit.
Qed.

Open Scope Z_scope.

(** Now more insightful examples. The first one automatically proves
    properties in group theory. **)

Section group.
  Variable op : Z -> Z -> Z.
  Variable inv : Z -> Z.
  Variable e : Z.

  (* We can prove automatically that we have a group if we only have the
     "left" versions of the axioms of a group *)
  Hypothesis associative :
    forall a b c : Z, op a (op b c) =? op (op a b) c.
  Hypothesis inverse :
    forall a : Z, (op (inv a) a =? e).
  Hypothesis identity :
    forall a : Z, (op e a =? a).
  Add_lemmas associative identity inverse.

  (* The "right" version of inverse *)
  Lemma inverse' :
    forall a : Z, (op a (inv a) =? e).
  Proof. smt. Qed.

  (* The "right" version of identity *)
  Lemma identity' :
    forall a : Z, (op a e =? a).
  Proof. smt inverse'. Qed.

  (* Some other interesting facts about groups *)
  Lemma unique_identity e':
    (forall z, op e' z =? z) -> e' =? e.
  Proof. intros pe'; smt pe'. Qed.

  Lemma simplification_right x1 x2 y:
      op x1 y =? op x2 y -> x1 =? x2.
  Proof. intro H. smt_no_check H inverse'. Qed.

  Lemma simplification_left x1 x2 y:
      op y x1 =? op y x2 -> x1 =? x2.
  Proof. intro H. smt_no_check H inverse'. Qed.

  Clear_lemmas.
End group.

(* A full example coming from CompCert, slightly revisited.
   See: https://hal.inria.fr/inria-00289542
        https://xavierleroy.org/memory-model/doc/Memory.html (Section 3)
 *)
Section CompCert.

  Definition block := Z.
  Variable mem: Set.
  Variable dec_mem : CompDec mem.
  Variable alloc_block: mem -> Z -> Z -> block.
  Variable alloc_mem: mem -> Z -> Z -> mem.
  Variable valid_block: mem -> block -> bool.

  Hypothesis alloc_valid_block_1:
    forall m lo hi b,
      valid_block (alloc_mem m lo hi) b ---> ((b =? (alloc_block m lo hi)) || valid_block m b).

  Hypothesis alloc_valid_block_2:
    forall m lo hi b,
      ((b =? (alloc_block m lo hi)) || valid_block m b) ---> valid_block (alloc_mem m lo hi) b.

  Hypothesis alloc_not_valid_block:
    forall m lo hi,
       negb (valid_block m (alloc_block m lo hi)).

  Lemma alloc_valid_block_inv m lo hi b :
    valid_block m b -> valid_block (alloc_mem m lo hi) b.
  Proof.
    intro H. unfold block in *. verit alloc_valid_block_2 H.
  Qed.

  Lemma alloc_not_valid_block_2 m lo hi b' :
    valid_block m b' -> b' =? (alloc_block m lo hi) = false.
  Proof.
    intro H. unfold block in *. verit alloc_not_valid_block H.
  Qed.

End CompCert.


(** This file develops [Isomorphic], [≅]. See ua_homomorphism.v for
    [IsHomomorphism] and [IsIsomorphism]. *)

Require Export HoTT.Classes.theory.ua_homomorphism.

Require Import
  HoTT.Types
  HoTT.Tactics.

(** Two algebras [A B : Algebra σ] are isomorphic if there is an
    isomorphism [∀ s, A s → B s]. *)

Record Isomorphic {σ : Signature} (A B : Algebra σ) := BuildIsomorphic
  { def_isomorphic : ∀ s, A s → B s
  ; is_homomorphism_isomorphic : IsHomomorphism def_isomorphic
  ; is_isomorphism_isomorphic : IsIsomorphism def_isomorphic }.

Arguments BuildIsomorphic {σ A B} def_isomorphic
            {is_homomorphism_isomorphic} {is_isomorphism_isomorphic}.

Arguments def_isomorphic {σ A B}.
Arguments is_homomorphism_isomorphic {σ A B}.
Arguments is_isomorphism_isomorphic {σ A B}.

Global Existing Instance is_homomorphism_isomorphic.
Global Existing Instance is_isomorphism_isomorphic.

Module isomorphic_notations.
  Global Notation "A ≅ B" := (Isomorphic A B) : Algebra_scope.
End isomorphic_notations.

Import isomorphic_notations.

Definition SigIsomorphic {σ : Signature} (A B : Algebra σ) :=
  { def_iso : ∀ s, A s → B s
  | { _ : IsHomomorphism def_iso | IsIsomorphism def_iso }}.

Lemma issig_isomorphic {σ : Signature} (A B : Algebra σ)
  : SigIsomorphic A B <~> A ≅ B.
Proof.
  issig.
Defined.

(** Isomorphic algebras can be identified [A ≅ B → A = B]. *)

Corollary id_isomorphic `{Univalence} {σ} {A B : Algebra σ} (e : A ≅ B)
  : A = B.
Proof.
  exact (path_isomorphism (def_isomorphic e)).
Defined.

(** Identified algebras are isomorophic [A = B → A ≅ B] *)

Lemma isomorphic_id {σ} {A B : Algebra σ} (p : A = B) : A ≅ B.
Proof.
  destruct p. exact (BuildIsomorphic (hom_id A)).
Defined.

(** To find a path between two witnesses [F G : A ≅ B], it suffices
    to find a path between the defining families of functions and
    the [is_homomorphism_hom] witnesses. *)

Lemma path_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ}
  (F G : A ≅ B) (a : def_isomorphic F = def_isomorphic G)
  (b : a#(is_homomorphism_isomorphic F) = is_homomorphism_isomorphic G)
  : F = G.
Proof.
  apply (ap (issig_isomorphic A B)^-1)^-1.
  srapply path_sigma.
  - exact a.
  - apply path_sigma_hprop.
    refine (ap _ (transport_sigma _ _) @ _).
    apply b.
Defined.

(** Suppose [IsHSetAlgebra B]. To find a path between two isomorphic
    witnesses [F G : A ≅ B], it suffices to find a path between the
    defining families of functions. *)

Lemma path_hset_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ}
  `{IsHSetAlgebra B} (F G : A ≅ B)
  (a : def_isomorphic F = def_isomorphic G)
  : F = G.
Proof.
  apply (path_isomorphic F G a). apply path_ishprop.
Defined.

Section path_def_isomorphic_id_transport.
  Context {σ : Signature} {A B : Algebra σ}.

  Lemma path_def_isomorphic_id_transport_dom (p : A = B)
    : def_isomorphic (isomorphic_id p)
      = transport (λ C, ∀ s, C s → B s) (ap carriers p)^ (hom_id B).
  Proof.
    by path_induction.
  Defined.

  Lemma path_def_isomorphic_id_transport_cod (p : A = B)
    : def_isomorphic (isomorphic_id p)
      = transport (λ C, ∀ s, A s → C s) (ap carriers p) (hom_id A).
  Proof.
    by path_induction.
  Defined.
End path_def_isomorphic_id_transport.

(** If [IsHSetAlgebra A], then [path_isomorphism] maps the identity
    homomorphism of [A] to the identity path. *)

(* I suspect that the following lemma holds even when [A] is not a set
   algebra. To show this, [path_isomorphism] and [path_operations_equiv]
   should be made transparent, which they are not at the moment. *)

Lemma path_path_isomorphism_hom_id_hset `{Univalence} {σ : Signature}
  (A : Algebra σ) `{IsHSetAlgebra A}
  : path_isomorphism (hom_id A) = idpath.
Proof.
  apply path_path_hset_algebra.
  rewrite path_ap_carriers_path_algebra.
  apply (paths_ind (λ s, idpath) (λ f _, path_forall A A f = idpath)).
  - apply path_forall_1.
  - intros.
    funext s.
    symmetry.
    rewrite (path_ishprop _ (isequiv_idmap (A s))).
    apply path_universe_1.
Qed.

(** The following section shows that [isomorphic_id] is an equivalence
    with inverse [id_isomorphic]. *)

Section isequiv_isomorphic_id.
  Context `{Univalence} {σ} (A B : Algebra σ) `{IsHSetAlgebra B}.

  Lemma sect_id_isomorphic : (@isomorphic_id σ A B) o id_isomorphic == idmap.
  Proof.
    intro F.
    apply path_hset_isomorphic.
    rewrite path_def_isomorphic_id_transport_cod.
    funext s x.
    rewrite !transport_forall_constant.
    rewrite path_ap_carriers_path_algebra.
    transport_path_forall_hammer.
    apply transport_path_universe.
  Qed.

  Lemma sect_isomorphic_id : id_isomorphic o (@isomorphic_id σ A B) == idmap.
  Proof.
    intro p.
    destruct p.
    apply path_path_isomorphism_hom_id_hset.
    exact _.
  Qed.

  Global Instance isequiv_isomorphic_id : IsEquiv (@isomorphic_id σ A B)
    := isequiv_adjointify
          isomorphic_id
          id_isomorphic
          sect_id_isomorphic
          sect_isomorphic_id.

End isequiv_isomorphic_id.


(*
 * Section 2 Example from the ITP 2019 paper.
 *
 * NOTE: This has changed a lot since the ITP paper! I have updated this file
 * to reflect the latest automation. To see the original ITP version,
 * take a look at the state of this file in the ITP release.
 *)

Add LoadPath "coq/examples".
Require Import Vector.
Require Import List.
Require Import Ornamental.Ornaments.

From Coq Require Import ssreflect ssrbool ssrfun Arith.

Import EqNotations.

(* syntax to match paper *)
Notation vector := Vector.t.
Notation consV n t v := (Vector.cons _ t n v).
Notation nilV := Vector.nil.

(*
 * Here is our library that we will lift.
 *)
Module hs_to_coq'.

(* From:
 * https://github.com/antalsz/hs-to-coq/blob/master/base/GHC/List.v
 *)
Definition zip {a} {b} : list a -> list b -> list (a * b)%type :=
  fix zip arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | nil, _bs => nil
           | _as, nil => nil
           | cons a as_, cons b bs => cons (pair a b) (zip as_ bs)
  end.

(* From:
 * https://github.com/antalsz/hs-to-coq/blob/master/core-semantics-no-values/semantics.v
 *)
Fixpoint zip_with {A} {B} {C} (f : A -> B -> C) (s : list A) (t : list B) : list C :=
  match s , t with
    | a :: s' , b :: t' => f a b :: zip_with f s' t'
    | _       , _       => nil
  end.

Theorem zip_with_is_zip {A} {B} :
  forall l1 l2, zip_with (@pair A B) l1 l2 = zip l1 l2.
Proof. by elim => [|a s IH] [|b t] //=; rewrite IH. Qed.

End hs_to_coq'.

(* --- Preprocess --- *)

(*
 * We define our terms using match statements, so we first need to preprocess.
 * Sometimes we can get away without this when we write terms ourselves, as is
 * true later in this file.
 *)

Preprocess Module hs_to_coq' as hs_to_coq { opaque list_ind list_rect Coq.Init.Logic }.

(* --- Search and Lift --- *)

(*
 * You can omit these lines if you'd like, since Lift does not need them,
 * but enabling these options shows that search behaves correctly:
 *)
Set DEVOID search prove coherence.
Set DEVOID search prove equivalence.

(*
 * You can omit this as well, but it makes the types look nicer:
 *)
Set DEVOID lift type.

(*
 * This option tells DEVOID to generate an induction principle that
 * will be useful later:
 *)
Set DEVOID search smart eliminators.

(*
 * We can then repair our entire module (search runs automatically):
 *)
Repair Module list vector in hs_to_coq as hs_to_coqV_p { hint "auto" }.
(*
 * This also prints suggested proofs for section and retraction.
 * The suggested proof for section is the same as the paper draft version up to renaming.
 * The suggested proof for retraction has an additional "intros" that we remove when
 * we modify the suggestion in the paper.
 *)

(*
 * That gives us these terms:
 *)
Definition zipV_p := hs_to_coqV_p.zip.
Definition zip_withV_p := hs_to_coqV_p.zip_with.
Definition zip_with_is_zipV_p := hs_to_coqV_p.zip_with_is_zip.
(*
 * Tactics from tweaked tactic suggestions "Repair" outputs
 * are at the bottom of this file.
 *)

(* Here are our lifted types: *)
Check zipV_p.
Check zip_withV_p.
Check zip_with_is_zipV_p.
(*
 * This gets us to vectors of _some_ length. Next, we'll see how with additional
 * user input, we can get vectors of a _particular_ length.
 *)

(* --- Unpack --- *)

(*
 * Now we have proofs about sigT (vector T), but we want proofs about
 * vector T n. So now we can use a methodology to get from lists to
 * these proofs.
 *
 * The intuition for this methodology is that while list T is equivalent to sigT (vector T),
 * for any n, { l : list T & length l = n } lifts to equivalent
 * { s : sigT (vector T) & projT1 s = n}, which is equivalent to vector T n.
 * Thus, we write proofs about { l : list T & length l = n },
 * lift those from list to vector, and then lift those again
 * from { s : sigT (vector T) & projT1 s = n} to vector.
 *
 * However, writing proofs about { l : list T & length l = n } isn't
 * in itself straightforward, so we break this up into parts and use
 * a nice custom eliminator to make this easier.
 *
 * Let's start by proving the length invariants
 * (these were also proven by the human for ITP 2019):
 *)
Module hs_to_coq_lengths'.

Lemma zip_length:
  forall a b (l1 : list a) (l2 : list b),
    length l1 = length l2 ->
    length (hs_to_coq.zip a b l1 l2) = length l1.
Proof.
  induction l1, l2; intros; auto.
  simpl. f_equal. rewrite IHl1; auto.
Defined.

Lemma zip_length_n:
  forall a b (n : nat) (l1 : list a) (l2 : list b),
    length l1 = n ->
    length l2 = n ->
    length (hs_to_coq.zip a b l1 l2) = n.
Proof.
  intros. rewrite <- H. apply zip_length. eapply eq_trans; eauto.
Defined.

Lemma zip_with_length:
  forall A B C f (l1 : list A) (l2 : list B),
    length l1 = length l2 ->
    length (hs_to_coq.zip_with A B C f l1 l2) = length l1.
Proof.
  induction l1, l2; intros; auto.
  simpl. f_equal. rewrite IHl1; auto.
Defined.

Lemma zip_with_length_n:
  forall A B C f (n : nat) (l1 : list A) (l2 : list B),
    length l1 = n ->
    length l2 = n ->
    length (hs_to_coq.zip_with A B C f l1 l2) = n.
Proof.
  intros. rewrite <- H. apply zip_with_length. eapply eq_trans; eauto.
Defined.

End hs_to_coq_lengths'.

Preprocess Module hs_to_coq_lengths' as hs_to_coq_lengths { opaque Datatypes Logic Coq.Init.Nat.pred Coq.Init.Peano.eq_add_S hs_to_coq.zip hs_to_coq.zip_with list_ind list_rect eq_trans eq_sym }.

(*
 * Once we have the length proofs, we write the proofs
 * about { l : list T & length l = n }. To do this,
 * it's useful to have a nice induction principle,
 * which DEVOID generated since we set the "smart elims" option (new since ITP 2019)
 * (the name of this will always be the name of your promote function
 * followed by _rect):
 *)
Definition packed_list_rect := hs_to_coqV_p.list_to_t_rect.
Check packed_list_rect.
(*
 * TECHNICAL NOTE: DEVOID for now makes some assumptions
 * about the format here. Try not to run "induction" on terms of type
 * { l : list T & length l = n } directly, and instead try to
 * use this induction principle. I'm working on relaxing this
 * assumption. It has to do with preserving definitional equalities
 * when we lift (more specifically, incompleteness of matching against Eta and Iota).
 *)

(*
 * Regression bug after updating to 8.9.1: For some reason we now need to lift this
 * explicitly. Should investigate, as it may point to a regression bug elsewhere.
 *)
Lift list vector in packed_list_rect as packed_vector_rect.

(*
 * Then we can write our proofs. Now note how everything here
 * follows a nice and easy formula:
 *)
Module packed_list.

Definition zip_length := hs_to_coq_lengths.zip_length_n.
Definition zip_with_length := hs_to_coq_lengths.zip_with_length_n.

Program Definition zip:
  forall a b n,
    { l1 : list a & length l1 = n } ->
    { l2 : list b & length l2 = n } ->
    { l3 : list (a * b) & length l3 = n }.
Proof.
  intros a b n pl1. apply packed_list_rect with (P := fun (pl1 : { l1 : list a & length l1 = n }) => { l2 : list b & length l2 = n } -> { l3 : list (a * b) & length l3 = n }).
  - intros l H pl2.
    (* list function: *)
    exists (hs_to_coq.zip a b l (projT1 pl2)).
    (* length invariant: *)
    apply zip_length; auto. apply (projT2 pl2).
  - apply pl1.
Defined.

Program Definition zip_with:
  forall A B C (f : A -> B -> C) n,
    { l1 : list A & length l1 = n } ->
    { l2 : list B & length l2 = n } ->
    { l3 : list C & length l3 = n }.
Proof.
  intros A B C f n pl1. apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => {l2 : list B & length l2 = n} -> {l3 : list C & length l3 = n}).
  - intros l H pl2.
    (* list function: *)
    exists (hs_to_coq.zip_with A B C f l (projT1 pl2)).
    (* length invariant: *)
    apply zip_with_length; auto. apply (projT2 pl2).
  - apply pl1.
Defined.
(*
 * It is cleaner for lifting to separate this out (not necessary though),
 * since Preprocess doesn't handle eq_existT_uncurried nicely:
 *)
Definition eq_existT_uncurried (T : Type) (n : nat) (l1 l2 : list T) (H1 : length l1 = n) (H2 : length l2 = n) (H : {p : l1 = l2 & rew [fun l : list T => length l = n] p in H1 = H2}) :=
@eq_existT_uncurried (list T) (fun (l : list T) => length l = n) l1 l2 H1 H2 H.

(*
 * The length invariant here relates our _proofs_ of the
 * above length invariants. Ouch! Luckily, for lists,
 * we can just use UIP, since equality over natural numbers
 * is decidable:
 *)
Lemma zip_with_is_zip :
  forall A B n (pl1 : { l1 : list A & length l1 = n }) (pl2 : { l2 : list B & length l2 = n }),
    zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2.
Proof.
  intros A B n pl1.
  apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => forall pl2 : {l2 : list B & length l2 = n}, zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2).
  intros l H pl2.
  unfold zip_with, zip, packed_list_rect, hs_to_coqV_p.list_to_t_rect, packed_rect. simpl.
  apply eq_existT_uncurried.
  (* list proof: *)
  exists (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)).
  (* length invariant: *)
  apply (Eqdep_dec.UIP_dec Nat.eq_dec).
Defined.
(*
 * TECHNICAL NOTE: In general, we may be able to avoid using UIP over the index
 * using adjunction and coherence together to show that we do not duplicate equalities (credit to Jason Gross).
 * There is also a coq-club thread about this with an alternative approach.
 * This should hopefully work for any algebraic ornament.
 * For now, if you do not have UIP on your index, you still run into
 * the equalities of equalities problem at some point.
 *
 * I will update this file when we solve this problem.
 *)
End packed_list.

(*
 * Now we can get from that to { s : sigT (vector T) & projT1 s = n} by lifting from
 * lists to vectors (new since ITP 2019).
 *
 * Rather than preprocess here, we just set terms that use pattern matching to
 * opaque for efficiency. We use Lift intead of Repair when tactics don't matter.
 *)
Lift Module list vector in hs_to_coq_lengths as hs_to_coq_projT1s.
Lift Module list vector in packed_list as packed_vector { opaque eq_existT_uncurried Eqdep_dec.UIP_dec Nat.eq_dec }.

(* We don't need tactics for these since they're just intermediate terms: *)
Check packed_vector.zip.
Check packed_vector.zip_with.
Check packed_vector.zip_with_is_zip.

(*
 * Finally, we can get from { s : sigT (vector T) & projT1 s = n} to unpacked vectors
 * at the index we want very easily.
 *
 * First we define a constant for { s : sigT (vector T) & projT1 s = n}, since DEVOID needs
 * this for caching.
 *)
Definition packed T n := { s : sigT (vector T) & projT1 s = n}.

(*
 * We can get away without preprocessing here, though we must set some terms to opaque to do that:
 *)
Configure Lift packed vector { opaque Eqdep_dec.UIP_dec Nat.eq_dec }.

(*
 * Then we repair (lifting hs_to_coqV_p first makes this faster and makes the result prettier):
 *)
Lift Module packed vector in hs_to_coqV_p as hs_to_coqV_u.
Repair Module packed vector in packed_vector as uf.

(* We are done. Here are our final types: *)
Check uf.zip.
Check uf.zip_with.
Check uf.zip_with_is_zip.

(*
 * TECHNICAL NOTE: For this particular example, interestingly, doing these by hand
 * without DEVOID, it's possible to construct functions such that the proof
 * of uf.zip_with_is_zipV goes through by reflexivity. However, these
 * are not the analogues of the functions included in the hs_to_coq module
 * (note that the proof using reflexivity does not work for them either).
 *)

(* --- Interface --- *)

(* Client code can then call our functions and proofs, for example: *)
Definition BVand' {n : nat} (v1 : vector bool n) (v2 : vector bool n) : vector bool n :=
  uf.zip_with bool bool bool andb n v1 v2.

(* --- Tactics --- *)

(*
 * We now have working functions and proofs over unpacked vectors.
 * We can use suggested tactics to get tactic scripts, but (as noted)
 * since they struggle with dependent types, we need to do a _lot_ of tweaking
 * right now. Still, let's do it using the suggested tactics and the terms
 * DEVOID has generated. These won't give exactly the same proof terms,
 * but we're OK with that.
 *
 * For zip:
 *)
Lemma zip_length:
  forall (a b : Type) (n : nat) (l1 : {H : nat & vector a H}) (l2 : {H : nat & vector b H}),
    projT1 l1 = n ->
    projT1 l2 = n ->
    projT1 (hs_to_coqV_p.zip a b (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))) = n.
Proof.
  intros a b n l1 l2 H.
  generalize dependent (projT2 l2). generalize dependent (projT1 l2).
  generalize dependent (projT2 l1). generalize dependent (projT1 l1).
  intros n1 H v1. rewrite <- H.
  revert H. revert n. induction v1 as [|h n0 t]; auto.
  intros n H n2 v2. revert H. revert n.
  induction v2 as [|h0 n1 t0]; auto.
  intros n H H2.
  simpl. f_equal. apply (IHt n0); auto.
Qed.

Program Definition zip:
  forall (a b : Type) (n : nat),
    vector a n -> vector b n -> vector (a * b) n.
Proof.
  intros a b n v1 v2.
  rewrite <- (zip_length _ _ _ (existT _ n v1) (existT _ n v2)); auto.
  apply (projT2 (hs_to_coqV_p.zip _ _ (existT _ n v1) (existT _ n v2))).
Defined.

(*
 * Note that this doesn't simplify away hs_to_coqV_p.zip.
 * There is no real point to doing so since we need both projections anyways.
 * Similarly, for zip_with:
 *)
Lemma zip_with_length:
  forall (A B C : Type) (f : A -> B -> C) (n : nat) (l1 : {H : nat & vector A H}) (l2 : {H : nat & vector B H}),
    projT1 l1 = n ->
    projT1 l2 = n ->
    projT1 (hs_to_coqV_p.zip_with A B C f (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))) = n.
Proof.
  intros A B C f n l1 l2 H.
  generalize dependent (projT2 l2). generalize dependent (projT1 l2).
  generalize dependent (projT2 l1). generalize dependent (projT1 l1).
  intros n1 H v1. rewrite <- H.
  revert H. revert n. induction v1 as [|h n0 t]; auto.
  intros n H n2 v2. revert H. revert n.
  induction v2 as [|h0 n1 t0]; auto.
  intros n H3 H4.
  simpl. f_equal. apply (IHt n0); auto.
Qed.

Program Definition zip_with:
  forall A B C : Type, (A -> B -> C) ->
    forall n : nat, vector A n -> vector B n -> vector C n.
Proof.
  intros A B C f n v1 v2.
  rewrite <- (zip_with_length _ _ _ f _ (existT _ n v1) (existT _ n v2)); auto.
  apply (projT2 (hs_to_coqV_p.zip_with _ _ _ f (existT _ n v1) (existT _ n v2))).
Defined.

(*
 * Finally:
 *)
Lemma zip_with_is_zipV_p_tactics :
  forall (A B : Type) (l1 : {H : nat & vector A H}) (l2 : {H : nat & vector B H}),
    zip_withV_p A B (A * B) pair (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))  =
    zipV_p A B (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2)).
Proof.
  intros A B l1. induction (projT2 l1) as [|h n t].
  - intros l2. induction (projT2 l2) as [|h n t]; auto.
  - intros l2. induction (projT2 l2) as [|h0 n0 t0].
    + auto.
    + specialize (IHt (existT _ n0 t0)).
      replace (existT _ (projT1 (existT [eta vector B] n0 t0)) (projT2 (existT [eta vector B] n0 t0)))
      with (existT _ n0 t0) in IHt by auto.
      replace (zip_withV_p _ _ _ pair (existT _ (S n) (consV n h t)) (existT _ (S n0) (consV n0 h0 t0)))
      with
      (existT _
        (S (projT1 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0))))
        (consV
          (projT1 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0)))
          (h, h0)
          (projT2 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0))))) by auto.
    rewrite IHt. auto.
Qed.

Lemma zip_with_is_zip:
  forall (A B : Type) (n : nat) (pl1 : vector A n) (pl2 : vector B n),
    zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2.
Proof.
  intros A B n pl1 pl2.
  apply uf.eq_existT_uncurried.
  exists (zip_with_is_zipV_p A B (existT [eta vector A] n pl1) (existT [eta vector B] n pl2)).
  apply (Eqdep_dec.UIP_dec Nat.eq_dec).
Qed.