From ITree Require Import
     ITree
     Eq.Eq.

From Vellvm Require Import
     Util
     UndefinedBehaviour
     DynamicValues
     MemoryAddress
     LLVMEvents
     LLVMAst
     Environment
     Handlers.Stack.

From Coq Require Import Relations.

Module Make(A:MemoryAddress.ADDRESS)(LLVMIO: LLVM_INTERACTIONS(A))(ENV: Environment).

Import LLVMIO.
Import LLVMIO.DV.
Import ENV.

(* Refinement relation for uvalues *)
Inductive refine_uvalue: uvalue -> uvalue -> Prop :=
| UndefPoison: forall t, refine_uvalue (UVALUE_Undef t) UVALUE_Poison (* CB / YZ: TODO, type for poison? *)
| RefineConcrete: forall uv1 uv2, (forall dv, concretize uv1 dv -> concretize uv2 dv) -> refine_uvalue uv1 uv2
.

Definition prod_rel {A B} (RA : relation A) (RB : relation B) : relation (A * B)
  := fun '(a,b) '(a', b') => RA a a' /\ RB b b'.

Infix "×" := prod_rel (at level 90, left associativity).

Definition TT {A} : relation A := fun _ _ => True.

(* Refinement of uninterpreted mcfg *)
Definition refine_L0: relation (itree L0 uvalue) := eutt refine_uvalue.

(* Refinement of mcfg after globals *)
Definition refine_res1 : relation (global_env * uvalue)
  := TT × refine_uvalue.

Definition refine_L1 : relation (itree L1 (global_env * uvalue))
  := eutt refine_res1.

(* Refinement of mcfg after locals *)
Definition refine_res2 : relation (local_env * stack * (global_env * uvalue))
  := TT × refine_res1.

Definition refine_L2 : relation (itree L2 (local_env * stack * (global_env * uvalue)))
  := eutt refine_res2.

(* For multiple CFG, after interpreting [LocalE] and [MemoryE] and [IntrinsicE] that are memory intrinsics *)
Definition refine_res3 : relation (memory * (local_env * stack * (global_env * uvalue)))
  := TT × refine_res2.

Definition refine_L3 : relation (itree L3 (memory * (local_env * stack * (global_env * uvalue))))
  := eutt refine_res3.

(* Refinement for after interpreting pick. *)
Definition refine_L4 : relation ((itree L4 (memory * (local_env * stack * (global_env * uvalue)))) -> Prop)
  := fun ts ts' => forall t, ts t -> exists t', ts' t' /\ eutt refine_res3 t t'.

End Make.


Set Implicit Arguments.
Set Automatic Coercions Import.
Require Import Coq.Relations.Relation_Operators.
Require Import Functor SPFunctor paco.

Inductive less_ones X (R : X -> X -> Prop) y : Type :=
| w_ord x (ORD: R x y) : less_ones R y.
Arguments less_ones {X} {R}.
Arguments w_ord {X} {R} {y} x ORD.

Arguments clos_trans_n1 {A} R.

Inductive bsm_gen PF `{SPFunctor PF} (fcofix : Type) (Fcofix : PF fcofix -> fcofix)
          bsm : fcofix -> fcofix -> Prop :=
| _bsm_gen : forall (x1 x2 : PF fcofix) (R: rel bsm x1 x2),
    bsm_gen Fcofix bsm (Fcofix x1) (Fcofix x2).

Module Type INDUCTIVE.

  Variable ffix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, Type. (* inductive type *)

  Variable Ffix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, PF ffix -> ffix. (* constructor *)

  Variable ffix_des : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, ffix -> PF ffix. (* destructor *)

  Hypothesis Ffix_inj : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x1 x2 (EQ: Ffix x1 = Ffix x2), x1 = x2.
  (* constructors are injective *)

  Hypothesis des_correct1 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x, Ffix (ffix_des x) = x.

  Hypothesis des_correct2 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x, ffix_des (Ffix x) = x.
  (* these say that destructors are the inverse of constructors *)

(* order and induction principle *)

  Variable ffix_ord : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, ffix -> ffix -> Prop. (* order on ffix *)

  Hypothesis ord_correct : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall m x, mem m x <-> ffix_ord x (Ffix m).
  (* membership relations in SPFunctor became order on ffix *)

  Variable ord_transtive : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x y z (Rxy: clos_trans_n1 (@ffix_ord PF _ _ _) x y) (Ryz: clos_trans_n1 (@ffix_ord PF _ _ _) y z),
      clos_trans_n1 (@ffix_ord PF _ _ _) x z.

  Hypothesis ffix_ord_wf: forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, well_founded (@ffix_ord PF _ _ _).

  Hypothesis ffix_ord_c_wf : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, well_founded (clos_trans_n1 (@ffix_ord PF _ _ _)).
  (* well order *)

  Hypothesis ffix_des_ord : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (x: ffix), PF (@less_ones _ (clos_trans_n1 (@ffix_ord PF _ _ _)) x).
  (* destruct with order *)

  Variable order_part : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall m x, mem m x -> (clos_trans_n1 (@ffix_ord PF _ _ _)) x (Ffix m).
  (* users don't need to know this *)

  Hypothesis des_ord_correct : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (m : PF ffix),
      ffix_des_ord (Ffix m) = map_dep m (fun x r => w_ord _ (order_part m x r)).

(* induction principles with different forms *)

  Hypothesis ffix_ord_induction : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x (P: ffix -> Prop)
        (STEP: forall y, (forall x, ffix_ord x y -> P x) -> P y),
    P x.

  Hypothesis ffix_str_induction : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x (P: ffix -> Prop)
        (STEP: forall y, (forall x, (clos_trans_n1 (@ffix_ord PF _ _ _)) x y -> P x) -> P y),
    P x.
    (* strong induction *)

  Hypothesis ffix_mem_induction : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x (P: ffix -> Prop)
        (STEP: forall m (IND: forall y, mem m y -> P y), P (Ffix m)),
    P x.

(* recursive function *)

  Variable frec : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall T (FIX: forall m (FN: forall y, (clos_trans_n1 (@ffix_ord PF _ _ _)) y m -> T), T),
      ffix -> T.

  Variable frec_d: forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (P: ffix -> Type)
                          (FIX: forall m (FN: forall y, (clos_trans_n1 (@ffix_ord PF _ _ _)) y m -> P y), P m),
      forall x : ffix, P x.
  (* dependent functions *)

  Variable frec_p : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall T (f: PF T -> T),
      ffix -> T.
  (* primitive recursion : simple but not general *)

(* reduction rules for recursive functions *)

  Hypothesis frec_red : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall T
      (FIX: forall m (FN: forall y, (clos_trans_n1 (@ffix_ord PF _ _ _)) y m -> T), T) x,
    frec FIX (Ffix x) = FIX (Ffix x) (fun y _ => frec FIX y).

  Hypothesis frec_d_red : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (P: ffix -> Type)
      (FIX: forall m (FN: forall y, (clos_trans_n1 (@ffix_ord PF _ _ _)) y m -> P y), P m) x,
    frec_d P FIX (Ffix x) = FIX (Ffix x) (fun y _ => frec_d P FIX y).

  Hypothesis frec_p_red : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall T (f: PF T -> T) m,
    frec_p f (Ffix m) = f (map (frec_p f) m).

End INDUCTIVE.

Module Type COINDUCTIVE.

(* constructor and destructor *)

  Variable fcofix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, Type. (* coinductive type *)

  Variable Fcofix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, PF fcofix -> fcofix. (* constructor *)

  Variable fcofix_des : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, fcofix ->  PF fcofix. (* destructor *)

  Hypothesis Fcofix_inj : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x1 x2 (EQ: Fcofix x1 = Fcofix x2), x1 = x2.
  (* constructors are injective *)

  Hypothesis c_des_correct1 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x, Fcofix (fcofix_des x) = x.

  Hypothesis c_des_correct2 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall x, fcofix_des (Fcofix x) = x.
  (* these say that destructors are the inverse of constructors *)

(* for corecursive functions *)
(* we use mendler style corecursion *)

  Variable grd_fcofix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, Type -> Type.

  Variable val : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (A : Type), fcofix -> grd_fcofix A.

  Variable grd : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (A : Type), PF (sum A (grd_fcofix A)) -> grd_fcofix A.
  (* constructors for grd_fcofix *)

  Variable grd_fcofix_des : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (A: Type),
      grd_fcofix A -> fcofix + (PF (sum A (grd_fcofix A))).
  (* destructors for grd_fcofix *)

  Hypothesis val_des_correct : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (x: fcofix),
      grd_fcofix_des (val A x) = inl x.

  Hypothesis grd_des_correct : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: PF (sum A (grd_fcofix A))),
      grd_fcofix_des (grd A f) = inr f.
  (* destructros are the inverse of constructors *)

  Variable to_fcofix : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A, (A -> grd_fcofix A) ->
                                 (sum A (grd_fcofix A)) -> fcofix.
  (* users don't need to know this function *)

  Variable fcorec : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A, (A -> grd_fcofix A) -> (A -> fcofix).
  (* corecursive function!!! *)

  Variable fcorec_p : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> PF A), A -> fcofix.
  (* primitive corecursion *)

(* reduction rules for corecursive functions *)

  Hypothesis fcorec_red : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> grd_fcofix A) (a: A),
      fcofix_des (fcorec f a) = match (grd_fcofix_des (f a)) with
                                | inl x => fcofix_des x
                                | inr m => map (to_fcofix f) m end.

  Hypothesis to_fcofix_correct1 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> grd_fcofix A) a,
    to_fcofix f (inl a) = fcorec f a.

  Hypothesis to_fcofix_correct2 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> grd_fcofix A) x,
    to_fcofix f (inr (val A x)) = x.

  Hypothesis to_fcofix_correct3 : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> grd_fcofix A) m,
    to_fcofix f (inr (grd A m)) = Fcofix (map (to_fcofix f) m).

  Variable fcorec_p_red : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall A (f: A -> PF A) a,
    fcofix_des (fcorec_p f a) = map (fcorec_p f) (f a).

(* bisimilarity *)

  Hypothesis bsm_gen_mon : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, monotone2 (bsm_gen (@Fcofix PF _ _ _)).
  Hint Resolve bsm_gen_mon : paco.

  Definition bsm PF `{SPFunctor PF} x1 x2 := paco2 (bsm_gen (@Fcofix PF _ _ _)) bot2 x1 x2.

  Hypothesis bsm_eq : forall PF `{H : FunctorData PF} `{H0 : @SFunctorData PF _} `{SPF : @SPFunctor PF _ _}, forall (x1 x2 : fcofix), bsm x1 x2 <-> x1 = x2.
  (* bisimilarity axiom.
     its proof relies on the bisimilarity axiom of universal functors *)

(* tactics for reduction *)

End COINDUCTIVE.


(* ******************************************************************************* *)
(** * Strict pseudofunctors on bicategories
 ********************************************************************************* *)

(** * Strict pseudo functors. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictIdentitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictCompositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat.

Local Open Scope bicategory_scope.
Local Open Scope cat.

(* ----------------------------------------------------------------------------------- *)
(** ** Strict pseudo-functors                                                                 *)
(* ----------------------------------------------------------------------------------- *)

Definition strict_psfunctor
           (C D : bicat)
  : UU
  := strict_psfunctor_bicat C D.

Definition make_strict_psfunctor_data
           {C D : bicat}
           (F₀ : C → D)
           (F₁ : ∏ {a b : C}, C⟦a,b⟧ → D⟦F₀ a, F₀ b⟧)
           (F₂ : ∏ {a b : C} {f g : C⟦a,b⟧}, f ==> g → F₁ f ==> F₁ g)
           (Fid : ∏ (a : C), identity (F₀ a) = F₁ (identity a))
           (Fcomp : (∏ (a b c : C) (f : a --> b) (g : b --> c),
                     F₁ f · F₁ g = F₁ (f · g)))
  : strict_psfunctor_data C D.
Proof.
  exact ((F₀ ,, F₁) ,, (F₂ ,, Fid ,, Fcomp)).
Defined.

Definition make_strict_psfunctor
           {C D : bicat}
           (F : strict_psfunctor_data C D)
           (HF : is_strict_psfunctor F)
  : strict_psfunctor C D
  := (F ,, HF).

Coercion strict_psfunctor_to_strict_psfunctor_data
         {C D : bicat}
         (F : strict_psfunctor C D)
  : strict_psfunctor_data C D
  := pr1 F.

Definition strict_psfunctor_on_cells
           {C D : bicat}
           (F : strict_psfunctor C D)
           {a b : C}
           {f g : a --> b}
           (x : f ==> g)
  : #F f ==> #F g
  := pr12 (pr1 F) a b f g x.

Definition strict_psfunctor_id
           {C D : bicat}
           (F : strict_psfunctor C D)
           (a : C)
  : identity (F a) = #F (identity a)
  := pr1 (pr221 F) a.

Definition strict_psfunctor_comp
           {C D : bicat}
           (F : strict_psfunctor C D)
           {a b c : C}
           (f : a --> b)
           (g : b --> c)
  : #F f · #F g = #F (f · g)
  := pr2 (pr221 F) _ _ _ f g.

Definition strict_psfunctor_id_cell
           {C D : bicat}
           (F : strict_psfunctor C D)
           (a : C)
  : invertible_2cell (identity (F a)) (#F (identity a))
  := idtoiso_2_1 _ _ (strict_psfunctor_id F a).

Definition strict_psfunctor_comp_cell
           {C D : bicat}
           (F : strict_psfunctor C D)
           {a b c : C}
           (f : a --> b)
           (g : b --> c)
  : invertible_2cell (#F f · #F g) (#F (f · g))
  := idtoiso_2_1 _ _ (strict_psfunctor_comp F f g).

Local Notation "'##'" := (strict_psfunctor_on_cells).

Section StrictProjection.
  Context {C D : bicat}.
  Variable (F : strict_psfunctor C D).

  Definition strict_psfunctor_id2
    : ∏ {a b : C} (f : a --> b), ##F (id2 f) = id2 (#F f)
    := pr1(pr2 F).

  Definition strict_psfunctor_vcomp
    : ∏ {a b : C} {f g h : C⟦a, b⟧} (η : f ==> g) (φ : g ==> h),
      ##F (η • φ) = ##F η • ##F φ
    := pr12(pr2 F).

  Definition strict_psfunctor_lunitor
    : ∏ {a b : C} (f : C⟦a, b⟧),
      lunitor (#F f)
      =
      (strict_psfunctor_id_cell F a ▹ #F f)
        • strict_psfunctor_comp_cell F (identity a) f
        • ##F (lunitor f)
    := pr122(pr2 F).

  Definition strict_psfunctor_runitor
    : ∏ {a b : C} (f : C⟦a, b⟧),
      runitor (#F f)
      =
      (#F f ◃ strict_psfunctor_id_cell F b)
        • strict_psfunctor_comp_cell F f (identity b)
        • ##F (runitor f)
    := pr1(pr222(pr2 F)).

  Definition strict_psfunctor_lassociator
    : ∏ {a b c d : C} (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧) ,
      (#F f ◃ strict_psfunctor_comp_cell F g h)
        • strict_psfunctor_comp_cell F f (g · h)
        • ##F (lassociator f g h)
      =
      (lassociator (#F f) (#F g) (#F h))
        • (strict_psfunctor_comp_cell F f g ▹ #F h)
        • strict_psfunctor_comp_cell F (f · g) h
    := pr12(pr222(pr2 F)).

  Definition strict_psfunctor_lwhisker
    : ∏ {a b c : C} (f : C⟦a, b⟧) {g₁ g₂ : C⟦b, c⟧} (η : g₁ ==> g₂),
      strict_psfunctor_comp_cell F f g₁ • ##F (f ◃ η)
      =
      #F f ◃ ##F η • strict_psfunctor_comp_cell F f g₂
    := pr122(pr222(pr2 F)).

  Definition strict_psfunctor_rwhisker
    : ∏ {a b c : C} {f₁ f₂ : C⟦a, b⟧} (g : C⟦b, c⟧) (η : f₁ ==> f₂),
      strict_psfunctor_comp_cell F f₁ g • ##F (η ▹ g)
      =
      ##F η ▹ #F g • strict_psfunctor_comp_cell F f₂ g
    := pr222(pr222(pr2 F)).
End StrictProjection.

(** Isos are preserved *)
Definition strict_psfunctor_is_iso
           {C D : bicat}
           (F : strict_psfunctor C D)
           {a b : C}
           {f g : C⟦a,b⟧}
           (α : invertible_2cell f g)
  : is_invertible_2cell (##F α).
Proof.
  use tpair.
  - exact (##F (α^-1)).
  - split ; cbn
    ; rewrite <- strict_psfunctor_vcomp, <- strict_psfunctor_id2 ; apply maponpaths.
    + apply vcomp_rinv.
    + apply vcomp_linv.
Defined.

Section StrictPseudoFunctorDerivedLaws.
  Context {C D : bicat}.
  Variable (F : strict_psfunctor C D).

  Definition strict_psfunctor_linvunitor
             {a b : C}
             (f : C⟦a, b⟧)
    : ##F (linvunitor f)
      =
      (linvunitor (#F f))
        • ((strict_psfunctor_id_cell F a) ▹ #F f)
        • (strict_psfunctor_comp_cell F _ _).
  Proof.
    rewrite !vassocl.
    cbn.
    use vcomp_move_L_pM.
    { is_iso. }
    cbn.
    use vcomp_move_R_Mp.
    {
      refine (strict_psfunctor_is_iso F (linvunitor f ,, _)).
      is_iso.
    }
    cbn.
    rewrite strict_psfunctor_lunitor ; cbn.
    rewrite <- !vassocr.
    reflexivity.
  Qed.

  Definition strict_psfunctor_rinvunitor
             {a b : C}
             (f : C⟦a, b⟧)
    : ##F (rinvunitor f)
      =
      (rinvunitor (#F f))
        • (#F f ◃ strict_psfunctor_id_cell F b)
        • strict_psfunctor_comp_cell F _ _.
  Proof.
    rewrite !vassocl.
    use vcomp_move_L_pM.
    { is_iso. }
    cbn.
    use vcomp_move_R_Mp.
    {
      refine (strict_psfunctor_is_iso F (rinvunitor f ,, _)).
      is_iso.
    }
    cbn.
    rewrite strict_psfunctor_runitor ; cbn.
    rewrite <- !vassocr.
    reflexivity.
  Qed.

  Definition strict_psfunctor_rassociator
             {a b c d : C}
             (f : C⟦a, b⟧) (g : C⟦b, c⟧) (h : C⟦c, d⟧)
    : (strict_psfunctor_comp_cell F f g ▹ #F h)
        • strict_psfunctor_comp_cell F (f · g) h
        • ##F (rassociator f g h)
      =
      (rassociator (#F f) (#F g) (#F h))
        • (#F f ◃ strict_psfunctor_comp_cell F g h)
        • strict_psfunctor_comp_cell F f (g · h).
  Proof.
    rewrite !vassocl.
    use vcomp_move_L_pM.
    { is_iso. }
    cbn.
    rewrite !vassocr.
    use vcomp_move_R_Mp.
    { refine (strict_psfunctor_is_iso F (rassociator f g h ,, _)).
      is_iso.
    }
    cbn.
    symmetry.
    exact (strict_psfunctor_lassociator F f g h).
  Qed.

  Definition strict_psfunctor_comp_natural
             {a b c : C}
             {g₁ g₂ : C⟦b,c⟧} {f₁ f₂ : C⟦a,b⟧}
             (ηg : g₁ ==> g₂) (ηf : f₁ ==> f₂)
    : strict_psfunctor_comp_cell F f₁ g₁ • ##F (ηf ⋆ ηg)
      =
      (##F ηf) ⋆ (##F ηg) • strict_psfunctor_comp_cell F f₂ g₂.
  Proof.
    unfold hcomp.
    rewrite !strict_psfunctor_vcomp.
    rewrite !vassocr.
    rewrite !strict_psfunctor_rwhisker.
    rewrite !vassocl.
    rewrite strict_psfunctor_lwhisker.
    reflexivity.
  Qed.

  Definition strict_psfunctor_F_lunitor
             {a b : C}
             (f : C⟦a, b⟧)
    : ##F (lunitor f)
      =
      ((strict_psfunctor_comp_cell F (identity a) f)^-1)
        • ((strict_psfunctor_id_cell F a)^-1 ▹ #F f)
        • lunitor (#F f).
  Proof.
    rewrite !vassocl.
    use vcomp_move_L_pM.
    { is_iso. }
    use vcomp_move_L_pM.
    { is_iso. }
    cbn.
    rewrite !vassocr.
    exact (!(strict_psfunctor_lunitor F f)).
  Qed.

  Definition strict_psfunctor_F_runitor
             {a b : C}
             (f : C⟦a,b⟧)
    : ##F (runitor f)
      =
      ((strict_psfunctor_comp_cell F f (identity b))^-1)
        • (#F f ◃ (strict_psfunctor_id_cell F b)^-1)
        • runitor (#F f).
  Proof.
    rewrite !vassocl.
    use vcomp_move_L_pM.
    { is_iso. }
    use vcomp_move_L_pM.
    { is_iso. }
    cbn.
    rewrite !vassocr.
    exact (!(strict_psfunctor_runitor F f)).
  Qed.
End StrictPseudoFunctorDerivedLaws.

Definition strict_pstrans_data
           {C D : bicat}
           (F G : strict_psfunctor C D)
  : UU.
Proof.
  refine (map1cells C D⟦_,_⟧).
  - apply F.
  - apply G.
Defined.

Definition is_strict_pstrans
           {C D : bicat}
           {F G : strict_psfunctor C D}
           (η : strict_pstrans_data F G)
  : UU
  := (∏ (X Y : C) (f g : X --> Y) (α : f ==> g),
      (pr1 η X ◃ ##G α)
        • pr2 η _ _ g
      =
      (pr2 η _ _ f)
        • (##F α ▹ pr1 η Y))
       ×
       (∏ (X : C),
        (pr1 η X ◃ strict_psfunctor_id_cell G X)
          • pr2 η _ _ (id₁ X)
        =
        (runitor (pr1 η X))
          • linvunitor (pr1 η X)
          • (strict_psfunctor_id_cell F X ▹ pr1 η X))
       ×
       (∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z),
        (pr1 η X ◃ strict_psfunctor_comp_cell G f g)
          • pr2 η _ _ (f · g)
        =
        (lassociator (pr1 η X) (#G f) (#G g))
          • (pr2 η _ _ f ▹ (#G g))
          • rassociator (#F f) (pr1 η Y) (#G g)
          • (#F f ◃ pr2 η _ _ g)
          • lassociator (#F f) (#F g) (pr1 η Z)
          • (strict_psfunctor_comp_cell F f g ▹ pr1 η Z)).

Definition make_strict_pstrans
           {C D : bicat}
           {F G : strict_psfunctor C D}
           (η : strict_pstrans_data F G)
           (Hη : is_strict_pstrans η)
  : F --> G.
Proof.
  refine ((η ,, _) ,, tt).
  repeat split ; cbn ; intros ; apply Hη.
Defined.

Definition strict_modification_eq
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           {m m' : σ ==> τ}
           (p : ∏ (X : B), pr111 m X = pr111 m' X)
  : m = m'.
Proof.
  use subtypePath.
  { intro. simpl.
    exact isapropunit.
  }
  use subtypePath.
  { intro. simpl.
    repeat (apply isapropdirprod) ; apply isapropunit.
  }
  use subtypePath.
  { intro. simpl.
    repeat (apply impred ; intro).
    apply B'.
  }
  use funextsec.
  exact p.
Qed.

Definition is_strict_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : ∏ (X : B), pr111 σ X ==> pr111 τ X)
  : UU
  := ∏ (X Y : B) (f : X --> Y),
     pr211 σ _ _ f • (m Y ▻ #F f)
     =
     #G f ◅ m X • pr211 τ _ _ f.

Definition make_strict_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : ∏ (X : B), pr111 σ X ==> pr111 τ X)
           (Hm : is_strict_modification m)
  : σ ==> τ
  := (((m ,, Hm) ,, (tt ,, tt ,, tt)),, tt).

Definition make_is_invertible_strict_modification_inv_is_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : σ ==> τ)
           (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X))
  : ∏ (X Y : B) (f : B ⟦ X, Y ⟧),
    (pr211 τ) X Y f • (# F f ◃ (Hm Y) ^-1) = ((Hm X) ^-1 ▹ # G f) • (pr211 σ) X Y f.
Proof.
  intros X Y f.
  simpl.
  use vcomp_move_R_Mp.
  { is_iso. }
  simpl.
  rewrite <- vassocr.
  use vcomp_move_L_pM.
  { is_iso. }
  symmetry.
  simpl.
  exact (pr211 m X Y f).
Qed.

Definition inv_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : σ ==> τ)
           (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X))
  : τ ==> σ.
Proof.
  use make_strict_modification.
  - exact (λ X, (Hm X)^-1).
  - exact (make_is_invertible_strict_modification_inv_is_modification m Hm).
Defined.

Definition modification_inv_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : σ ==> τ)
           (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X))
  : m • inv_modification m Hm = id₂ σ.
Proof.
  use strict_modification_eq.
  intro X.
  cbn.
  exact (vcomp_rinv (Hm X)).
Qed.

Definition inv_modification_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : σ ==> τ)
           (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X))
  : inv_modification m Hm • m = id₂ τ.
Proof.
  use strict_modification_eq.
  intro X.
  cbn.
  exact (vcomp_linv (Hm X)).
Qed.

Definition make_is_invertible_strict_modification
           {B B' : bicat}
           {F G : strict_psfunctor B B'}
           {σ τ : F --> G}
           (m : σ ==> τ)
           (Hm : ∏ (X : B), is_invertible_2cell (pr111 m X))
  : is_invertible_2cell m.
Proof.
  use make_is_invertible_2cell.
  - exact (inv_modification m Hm).
  - exact (modification_inv_modification m Hm).
  - exact (inv_modification_modification m Hm).
Defined.

Module Notations.
  Notation "'##'" := (strict_psfunctor_on_cells).
End Notations.


(** ElGamal encryption scheme.

  We show that DH security implies the security of ElGamal.

*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum
  eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb
  pkg_core_definition chUniverse pkg_composition pkg_rhl Package Prelude
  AsymScheme.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Theory.
Import Order.POrderTheory.

Local Open Scope ring_scope.
Import GroupScope GRing.Theory.

Import PackageNotation.

Module Type ElGamalParam.

  Parameter gT : finGroupType.
  Definition ζ : {set gT} := [set : gT].
  Parameter g :  gT.
  Parameter g_gen : ζ = <[g]>.
  Parameter prime_order : prime #[g].

End ElGamalParam.

Module ElGamal (EGP : ElGamalParam).

Import EGP.

Lemma cyclic_zeta: cyclic ζ.
Proof.
  apply /cyclicP. exists g. exact: g_gen.
Qed.

(* order of g *)
Definition q : nat := #[g].

Lemma group_prodC :
  ∀ x y : gT, x * y = y * x.
Proof.
  move => x y.
  have Hx: exists ix, x = g^+ix.
  { apply /cycleP. rewrite -g_gen.
    apply: in_setT. }
  have Hy: exists iy, y = g^+iy.
  { apply /cycleP. rewrite -g_gen.
    apply: in_setT. }
  destruct Hx as [ix Hx].
  destruct Hy as [iy Hy].
  subst.
  repeat rewrite -expgD addnC. reflexivity.
Qed.

Module MyParam <: AsymmetricSchemeParams.

  Definition SecurityParameter : choiceType := nat_choiceType.
  Definition Plain  : finType := FinGroup.arg_finType gT.
  Definition Cipher : finType :=
    prod_finType (FinGroup.arg_finType gT) (FinGroup.arg_finType gT).
  Definition PubKey : finType := FinGroup.arg_finType gT.
  Definition SecKey : finType := [finType of 'Z_q].

  Definition plain0 := g.
  Definition cipher0 := (g, g).
  Definition pub0 := g.
  Definition sec0 : SecKey := 0.

End MyParam.

Module MyAlg <: AsymmetricSchemeAlgorithms MyParam.

  Import MyParam.

  #[export] Instance positive_gT : Positive #|gT|.
  Proof.
    apply /card_gt0P. exists g. auto.
  Qed.

  #[export] Instance positive_SecKey : Positive #|SecKey|.
  Proof.
    apply /card_gt0P. exists sec0. auto.
  Qed.

  Definition Plain_pos : Positive #|Plain| := _.
  Definition PubKey_pos : Positive #|PubKey| := _.
  Definition SecKey_pos : Positive #|SecKey| := _.

  #[export] Instance Cipher_pos : Positive #|Cipher|.
  Proof.
    unfold Cipher. rewrite card_prod.
    exact _.
  Qed.

  Definition chPlain  : chUniverse := 'fin #|gT|.
  Definition chPubKey : chUniverse := 'fin #|gT|.
  Definition chCipher : chUniverse := 'fin #|Cipher|.
  Definition chSecKey : chUniverse := 'fin #|SecKey|.

  Definition counter_loc : Location := ('nat ; 0%N).
  Definition pk_loc : Location := (chPubKey ; 1%N).
  Definition sk_loc : Location := (chSecKey ; 2%N).
  Definition m_loc  : Location := (chPlain ; 3%N).
  Definition c_loc  : Location := (chCipher ; 4%N).

  Definition kg_id : nat := 5.
  Definition enc_id : nat := 6.
  Definition dec_id : nat := 7.
  Definition challenge_id : nat := 8. (*challenge for LR *)
  Definition challenge_id' : nat := 9. (*challenge for real rnd *)
  Definition getpk_id : nat := 42. (* routine to get the public key *)

  Definition i_plain := #|Plain|.
  Definition i_cipher := #|Cipher|.
  Definition i_pk := #|PubKey|.
  Definition i_sk := #|SecKey|.
  Definition i_bool := 2.

  (** Key Generation algorithm *)
  Definition KeyGen {L : {fset Location}} :
    code L [interface] (chPubKey × chSecKey) :=
    {code
      x ← sample uniform i_sk ;;
      let x := otf x in
      ret (fto (g^+x), fto x)
    }.

  (** Encryption algorithm *)
  Definition Enc {L : {fset Location}} (pk : chPubKey) (m : chPlain) :
    code L [interface] chCipher :=
    {code
      y ← sample uniform i_sk ;;
      let y := otf y in
      ret (fto (g^+y, (otf pk)^+y * (otf m)))
    }.

  (** Decryption algorithm *)
  Definition Dec_open {L : {fset Location}} (sk : chSecKey) (c : chCipher) :
    code L [interface] chPlain :=
    {code
      ret (fto ((fst (otf c)) * ((snd (otf c))^-(otf sk))))
    }.

  Notation " 'plain " :=
    chPlain
    (in custom pack_type at level 2).

  Notation " 'cipher " :=
    chCipher
    (in custom pack_type at level 2).

  Notation " 'pubkey " :=
    chPubKey
    (in custom pack_type at level 2).

End MyAlg.

Local Open Scope package_scope.

Module ElGamal_Scheme := AsymmetricScheme MyParam MyAlg.

Import MyParam MyAlg ElGamal_Scheme.

Lemma counter_loc_in :
  counter_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Lemma pk_loc_in :
  pk_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Lemma sk_loc_in :
  sk_loc \in (fset [:: counter_loc; pk_loc; sk_loc ]).
Proof.
  auto_in_fset.
Qed.

Definition DH_loc := fset [:: pk_loc ; sk_loc].

Definition DH_real :
  package DH_loc [interface]
    [interface val #[10] : 'unit → 'pubkey × 'cipher ] :=
    [package
      def #[10] (_ : 'unit) : 'pubkey × 'cipher
      {
        a ← sample uniform i_sk ;;
        let a := otf a in
        b ← sample uniform i_sk ;;
        let b := otf b in
        put pk_loc := fto (g^+a) ;;
        put sk_loc := fto a ;;
        ret (fto (g^+a), fto (g^+b, g^+(a * b)))
      }
    ].

Definition DH_rnd :
  package DH_loc [interface]
    [interface val #[10] : 'unit → 'pubkey × 'cipher ] :=
    [package
      def #[10] (_ : 'unit) : 'pubkey × 'cipher
      {
        a ← sample uniform i_sk ;;
        let a := otf a in
        b ← sample uniform i_sk ;;
        let b := otf b in
        c ← sample uniform i_sk ;;
        let c := otf c  in
        put pk_loc := fto (g^+a) ;;
        put sk_loc := fto a ;;
        ret (fto (g^+a), fto (g^+b, g^+c))
      }
    ].

Definition Aux :
  package (fset [:: counter_loc ; pk_loc ])
    [interface val #[10] : 'unit → 'pubkey × 'cipher]
    [interface
      val #[getpk_id] : 'unit → 'pubkey ;
      val #[challenge_id'] : 'plain → 'cipher
    ]
  :=
  [package
    def #[getpk_id] (_ : 'unit) : 'pubkey
    {
      pk ← get pk_loc ;;
      ret pk
    } ;

    def #[challenge_id'] (m : 'plain) : 'cipher
    {
      #import {sig #[10] : 'unit → 'pubkey × 'cipher } as query ;;
      count ← get counter_loc ;;
      put counter_loc := (count + 1)%N ;;
      #assert (count == 0)%N ;;
      '(pk, c) ← query Datatypes.tt ;;
      @ret chCipher (fto ((otf c).1 , (otf m) * ((otf c).2)))
    }
  ].

Lemma ots_real_vs_rnd_equiv_true :
  Aux ∘ DH_real ≈₀ ots_real_vs_rnd true.
Proof.
  (* We go to the relation logic using equality as invariant. *)
  eapply eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  all: ssprove_code_simpl.
  (* We are now in the realm of program logic *)
  - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
    move => [a1 h1] [a2 h2] [Heqa Heqh]. intuition auto.
  - ssprove_sync_eq. intro count.
    ssprove_sync_eq.
    ssprove_sync_eq. move => /eqP e. subst.
    ssprove_sync_eq. intro a.
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq.
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq.
    ssprove_sync_eq. intro b.
    rewrite !otf_fto. simpl.
    eapply r_ret. intuition eauto.
    f_equal. f_equal.
    rewrite group_prodC. f_equal.
    apply expgM.
Qed.

Lemma bijective_expgn :
  bijective (λ (a : 'Z_q), g ^+ a).
Proof.
  assert (hq : (1 < q)%N).
  { eapply prime_gt1. unfold q. apply prime_order. }
  unshelve eexists (λ x, (proj1_sig (@cyclePmin gT g x _) %% q)%:R).
  - rewrite -g_gen. unfold ζ. apply in_setT.
  - simpl. intros a.
    match goal with
    | |- context [ @cyclePmin _ _ _ ?hh ] =>
      set (h := hh)
    end.
    clearbody h. simpl in h.
    destruct cyclePmin as [n hn e]. simpl.
    move: e => /eqP e. rewrite eq_expg_mod_order in e.
    move: e => /eqP e.
    rewrite !modn_small in e. 2: auto.
    2:{
      eapply leq_trans. 1: eapply ltn_ord. fold q.
      unfold Zp_trunc.
      erewrite <- Lt.S_pred. 2:{ eapply Lt.lt_pred. apply /leP. eauto. }
      apply /leP.
      rewrite PeanoNat.Nat.succ_pred_pos.
      2:{ move: hq => /leP hq. auto with arith. }
      auto.
    }
    subst.
    rewrite modn_small. 2: auto.
    apply natr_Zp.
  - simpl. intro x.
    match goal with
    | |- context [ @cyclePmin _ _ _ ?hh ] =>
      set (h := hh)
    end.
    clearbody h. simpl in h.
    destruct cyclePmin as [n hn e]. simpl. subst.
    rewrite modn_small. 2: auto.
    f_equal. rewrite val_Zp_nat. 2: auto.
    apply modn_small. auto.
Qed.

#[local] Definition f m : 'Z_q * 'Z_q → gT * gT :=
  λ '(a,b), (g^+a, (otf m) * g^+b).

Lemma bijective_f : ∀ m, bijective (f m).
Proof.
  intro m.
  pose proof bijective_expgn as bij.
  destruct bij as [d hed hde].
  eexists (λ '(x,y), (d x, d ((otf m)^-1 * y))).
  - intros [? ?]. simpl. rewrite hed. f_equal.
    rewrite mulgA. rewrite mulVg. rewrite mul1g.
    apply hed.
  - intros [x y]. simpl. rewrite hde. f_equal.
    rewrite hde. rewrite mulgA. rewrite mulgV. rewrite mul1g.
    reflexivity.
Qed.

#[local] Definition f' (m : chPlain) :
  Arit (uniform (i_sk * i_sk)) → Arit (uniform i_cipher) :=
  λ x,
    let '(a, b) := ch2prod x in
    fto (f m (otf a, otf b)).

Lemma bijective_f' : ∀ m, bijective (f' m).
Proof.
  intro m.
  pose proof (bijective_f m) as bij. destruct bij as [g gf fg].
  unfold f'.
  exists (λ x, let '(a,b) := g (otf x) in prod2ch (fto a, fto b)).
  - cbn - [f]. intros x. rewrite -[RHS]prod2ch_ch2prod.
    set (y := ch2prod x). clearbody y. clear x.
    simpl in y. destruct y as [a b].
    rewrite otf_fto. rewrite gf.
    rewrite !fto_otf. reflexivity.
  - cbn - [f]. intro x.
    replace x with (fto (f m (g (otf x)))) at 2.
    2:{ rewrite fg. rewrite fto_otf. reflexivity. }
    set (y := g (otf x)). change (g (otf x)) with y. clearbody y. clear x.
    destruct y as [a b]. rewrite ch2prod_prod2ch. rewrite !otf_fto.
    reflexivity.
Qed.

Lemma ots_real_vs_rnd_equiv_false :
  ots_real_vs_rnd false ≈₀ Aux ∘ DH_rnd.
Proof.
  (* We go to the relation logic using equality as invariant. *)
  eapply eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  all: ssprove_code_simpl.
  (* We are now in the realm of program logic *)
  - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
    cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  - ssprove_sync_eq. intro count.
    ssprove_sync_eq.
    destruct count.
    2:{
      cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    }
    simpl.
    ssprove_sync_eq. intro a.
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq.
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq.
    eapply r_transR.
    1:{ eapply r_uniform_prod. intros x y. eapply rreflexivity_rule. }
    simpl.
    eapply rsymmetry.
    eapply @r_uniform_bij with (f := f' m). 1: apply bijective_f'.
    simpl. intros x.
    unfold f'. set (z := ch2prod x). clearbody z. clear x.
    destruct z as [x y]. simpl.
    eapply r_ret. intros s ? e. subst.
    intuition auto.
    rewrite !otf_fto. simpl.
    reflexivity.
Qed.

Theorem ElGamal_OT :
  ∀ LA A,
    ValidPackage LA [interface
      val #[getpk_id] : 'unit → 'pubkey ;
      val #[challenge_id'] : 'plain → 'cipher
    ] A_export A →
    fdisjoint LA (ots_real_vs_rnd true).(locs) →
    fdisjoint LA (ots_real_vs_rnd false).(locs) →
    Advantage ots_real_vs_rnd A <= AdvantageE DH_rnd DH_real (A ∘ Aux).
Proof.
  intros LA A vA hd₀ hd₁.
  simpl in hd₀, hd₁. clear hd₁. rename hd₀ into hd.
  rewrite Advantage_E.
  ssprove triangle (ots_real_vs_rnd false) [::
    Aux ∘ DH_rnd ;
    Aux ∘ DH_real
  ] (ots_real_vs_rnd true) A
  as ineq.
  eapply le_trans. 1: exact ineq.
  clear ineq.
  rewrite ots_real_vs_rnd_equiv_true. 3: auto.
  2:{
    rewrite fdisjointUr. apply/andP. split.
    - unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      rewrite fset_cons. apply fsetUS.
      rewrite !fset_cons -fset0E.
      apply fsetUS.
      apply fsub0set.
    - unfold DH_loc. unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      apply fsubsetUr.
  }
  rewrite ots_real_vs_rnd_equiv_false. 2: auto.
  2:{
    rewrite fdisjointUr. apply/andP. split.
    - unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      rewrite fset_cons. apply fsetUS.
      rewrite !fset_cons -fset0E.
      apply fsetUS.
      apply fsub0set.
    - unfold DH_loc. unfold L_locs_counter in hd.
      rewrite fdisjointC.
      eapply fdisjoint_trans. 2:{ rewrite fdisjointC. exact hd. }
      rewrite [X in fsubset _ X]fset_cons.
      apply fsubsetUr.
  }
  rewrite GRing.addr0. rewrite GRing.add0r.
  rewrite -Advantage_link. auto.
Qed.

End ElGamal.

Module EGP_Z3 <: ElGamalParam.

  Definition gT : finGroupType := Zp_finGroupType 2.
  Definition ζ : {set gT} := [set : gT].
  Definition g :  gT := Zp1.

  Lemma g_gen : ζ = <[g]>.
  Proof.
    unfold ζ, g. apply Zp_cycle.
  Qed.

  Lemma prime_order : prime #[g].
  Proof.
    unfold g.
    rewrite order_Zp1.
    reflexivity.
  Qed.

End EGP_Z3.

Module ElGamal_Z3 := ElGamal EGP_Z3.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q R S X Y : Universe, ((wd_ P X /\ (wd_ S X /\ (wd_ R Y /\ (wd_ S Y /\ (wd_ P R /\ (wd_ R S /\ (wd_ P S /\ (col_ S X Y /\ (col_ P Q R /\ (col_ R Y S /\ col_ P X S)))))))))) -> col_ P R S)).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import Coq.Logic.ClassicalFacts.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Def.
Require Import TraceCriterion.

Section Conjunction.

  Axiom prop_ext : prop_extensionality.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  (* the two relations and their conjunction *)
  Variable rel1 rel2 : trace__S -> trace__T -> Prop.
  Definition rel_cap : trace__S -> trace__T -> Prop :=
    fun s t => rel1 s t /\ rel2 s t.

  (* the induced connections *)
  Local Definition adjunction1 :=  induced_connection rel1.
  Local Definition adjunction2 :=  induced_connection rel2.

  Local Definition τ1 : prop__S -> prop__T := α adjunction1.
  Local Definition σ1 : prop__T -> prop__S := γ adjunction1.
  Local Definition τ2 : prop__S -> prop__T := α adjunction2.
  Local Definition σ2 : prop__T -> prop__S := γ adjunction2.

  Definition τ : prop__S -> prop__T := fun π__S => (fun t => τ1 π__S t /\ τ2 π__S t).

  Definition rel : trace__S -> trace__T -> Prop :=
    fun s t => (τ (fun x => x = s) t).

  Lemma rel_is_relcap : rel = rel_cap.
  Proof.
    apply: functional_extensionality => s.
    apply: functional_extensionality => t.
    apply: prop_ext.
    rewrite /rel /rel_cap /τ /τ1 /τ2 /α /= /low_rel. split.
    - move => [[s1 [Heq1 Hrel1]] [s2 [Heq2 Hrel2]]]. by subst.
    - by firstorder.
  Qed.

  (* Local Definition adjunction :=  induced_connection rel. *)

  (* Lemma τ_induced_by_rel : τ = α adjunction. *)
  (* Proof. *)
  (*   apply: functional_extensionality => π__S. *)
  (*   apply: functional_extensionality => t. *)
  (*   apply: prop_ext. *)
  (*   rewrite /α /τ  /τ1 /τ2 /= /low_rel. *)

  Local Definition CCtilde1 := rel_TC compilation_chain Source_Semantics Target_Semantics rel1.
  Local Definition τTP1     := τTP compilation_chain Source_Semantics Target_Semantics τ1.
  Local Definition trinity1 := rel_TC_τTP compilation_chain Source_Semantics Target_Semantics rel1.

  Local Definition CCtilde2 := rel_TC compilation_chain Source_Semantics Target_Semantics rel2.
  Local Definition τTP2     := τTP compilation_chain Source_Semantics Target_Semantics τ2.
  Local Definition trinity2 := rel_TC_τTP compilation_chain Source_Semantics Target_Semantics rel2.

  Local Definition CCtilde_cap := rel_TC compilation_chain Source_Semantics Target_Semantics rel_cap.
  Local Definition τTP        := τTP compilation_chain Source_Semantics Target_Semantics τ.

  (* Lemma CCtilde_cap_τTP : CCtilde_cap <-> τTP. *)
  (* Proof. *)
  (*   rewrite /CCtilde_cap -rel_is_relcap.  *)
  (*    setoid_rewrite contra_τTP. split. *)
  (*   - move => Htilde W π [t [Hsemt Hτ]]. *)
  (*     destruct (Htilde W t Hsemt) as [s [Hrel_s_t Hsems]]. *)
  (*     exists s. split; auto. move => s_in_π. apply: Hτ. *)
  (*     move: Hrel_s_t. rewrite /rel /τ /τ1 /τ2 /α /= /low_rel => Hrel. *)
  (*     move: Hrel => [[y1 [Heq1 Hrel1]] [y2 [Heq2 Hrel2]]]. subst.  *)
  (*     split; by exists s.  *)
  (*   - move => Hτ W t HsemWt. *)
  (*     have H : (forall s1 s2, sem__S W s1 -> sem__S W s2 -> rel1 s1 t -> rel2 s2 t -> s1 <> s2) \/ *)
  (*              (exists s1 s2, sem__S W s1 /\ sem__S W s2 /\ rel1 s1 t /\ rel2 s2 t /\ s1 = s2). *)
  (*     { case: (classic (forall s1 s2, sem__S W s1 -> sem__S W s2 -> rel1 s1 t -> rel2 s2 t -> s1 <> s2)); auto. *)
  (*       rewrite not_forall_ex_not. move => [s1 H]. move /not_forall_ex_not : H => [s2 H]. *)
  (*       right. exists s1, s2. *)
  (*       repeat (move /not_imp: H => [h H]; split; auto; clear h).  *)
  (*       by apply: NNPP. }  *)
  (*     case: H.  *)
  (*     move => H. exfalso. *)
  (*     have cc1 : CCtilde1. *)
  (*     { setoid_rewrite trinity1. setoid_rewrite contra_τTP. *)
  (*       move => Ws π__S [t0 [H1 H2]]. destruct (Hτ Ws π__S) as [s Hs].  *)
  (*       exists t0. split; auto. rewrite /τ. move => [Htau1 Htau2].   *)
  (*         by apply: H2. *)
  (*       exists s; auto. }             *)
  (*     have cc2 : CCtilde2. *)
  (*     { setoid_rewrite trinity2. setoid_rewrite contra_τTP. *)
  (*       move => Ws π__S [t0 [H1 H2]]. destruct (Hτ Ws π__S) as [s Hs].  *)
  (*       exists t0. split; auto. rewrite /τ. move => [Htau1 Htau2].   *)
  (*         by apply: H2. *)
  (*       exists s; auto. }            *)
  (*     destruct (cc1 W t HsemWt) as [s1 [HsemWs1 Hrel1]]. *)
  (*     destruct (cc2 W t HsemWt) as [s2 [HsemWs2 Hrel2]]. *)
  (*     have not_t : ~ (τ (fun s =>  rel s t )) t by admit.          *)
  (*     case: (Hτ W (fun s =>  rel s t )). *)
  (*     { exists t. split; auto. }  *)
  (*     move => s [HsemWs K].  move /de_morgan1: K. rewrite -dne. *)
  (*     rewrite rel_is_relcap /rel_cap. move  => [[k11 k12]| k2]; try now auto.  *)
  (*     by apply: (H s s).       *)
  (*     (* 2nd case *) *)
   (*    by firstorder.  *)
   (* Admitted.     *)

  Theorem TPtau_for_conjunction :
    CCtilde1 /\ CCtilde2 -> τTP.
  Proof.
    move => [H1 H2].
    have Hτ1 : τTP1 by move /trinity1 : H1.
    have Hτ2 : τTP2 by move /trinity2 : H2.
    move => W π__S sat_src. rewrite /τ. split.
      by apply: (Hτ1 W). by apply: (Hτ2 W).
  Qed.

  (* The problem is that τ does not coincide with the abstraction of
      the galois connection induced by ~ So that in general no involution in possible
        (see Lemma 2.9 in the paper)  *)

  (* Theorem conjunction_intersection : CCtilde1 /\ CCtilde2 <->  CCtilde_cap. *)
  (* Proof. *)
  (*   rewrite CCtilde_cap_τTP. split. *)
  (*   - exact TPtau_for_conjunction.   *)
  (*   - setoid_rewrite trinity1. setoid_rewrite trinity2. *)
  (*     by firstorder. *)
  (*  Qed.       *)

End Conjunction.


(** * Auto: More Automation *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

(** Up to now, we've used the more manual part of Coq's tactic
    facilities.  In this chapter, we'll learn more about some of Coq's
    powerful automation features: proof search via the [auto] tactic,
    automated forward reasoning via the [Ltac] hypothesis matching
    machinery, and deferred instantiation of existential variables
    using [eapply] and [eauto].  Using these features together with
    Ltac's scripting facilities will enable us to make our proofs
    startlingly short!  Used properly, they can also make proofs more
    maintainable and robust to changes in underlying definitions.  A
    deeper treatment of [auto] and [eauto] can be found in the
    [UseAuto] chapter in _Programming Language Foundations_.

    There's another major category of automation we haven't discussed
    much yet, namely built-in decision procedures for specific kinds
    of problems: [omega] is one example, but there are others.  This
    topic will be deferred for a while longer.

    Our motivating example will be this proof, repeated with just a
    few small changes from the [Imp] chapter.  We will simplify
    this proof in several stages. *)

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * The [auto] Tactic *)

(** Thus far, our proof scripts mostly apply relevant hypotheses or
    lemmas by name, and one at a time. *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

(** The [auto] tactic frees us from this drudgery by _searching_ for a
    sequence of applications that will prove the goal: *)

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros] and
     - [apply] (of hypotheses from the local context, by default). *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing. *)

(** Here is a more interesting example showing [auto]'s power: *)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** Proof search could, in principle, take an arbitrarily long time,
    so there are limits to how far [auto] will search by default. *)

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

(** When searching for potential proofs of the current goal,
    [auto] considers the hypotheses in the current context together
    with a _hint database_ of other lemmas and constructors.  Some
    common lemmas about equality and logical operators are installed
    in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] by writing "[auto using ...]". *)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

(** Of course, in any given development there will probably be
    some specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing

      Hint Resolve T.

    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write

      Hint Constructors c.

    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add

      Hint Unfold d.

    where [d] is a defined symbol, so that [auto] knows to expand uses
    of [d], thus enabling further possibilities for applying lemmas that
    it knows about. *)

(** It is also possible to define specialized hint databases that can
    be activated only when needed.  See the Coq reference manual for
    more. *)

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

(** Now let's take a first pass over [ceval_deterministic] to simplify
    the proof script.
 *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* ################################################################# *)
(** * Searching For Hypotheses *)

(** The proof has become simpler, but there is still an annoying
    amount of repetition. Let's start by tackling the contradiction
    cases. Each of them occurs in a situation where we have both

      H1: beval st b = false

    and

      H2: beval st b = true

    as hypotheses.  The contradiction is evident, but demonstrating it
    is a little complicated: we have to locate the two hypotheses [H1]
    and [H2] and do a [rewrite] following by an [inversion].  We'd
    like to automate this process.

    (In fact, Coq has a built-in tactic [congruence] that will do the
    job in this case.  But we'll ignore the existence of this tactic
    for now, in order to demonstrate how to build forward search
    tactics by hand.)

    As a first step, we can abstract out the piece of script in
    question by writing a little function in Coq's tactic programming
    language, Ltac. *)

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

(** That was is a bit better, but not much.  We really want Coq to
    discover the relevant hypotheses for us.  We can do this by using
    the [match goal] facility of Ltac. *)

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

(** The [match goal] tactic looks for two distinct hypotheses that
    have the form of equalities, with the same arbitrary expression
    [E] on the left and with conflicting boolean values on the right.
    If such hypotheses are found, it binds [H1] and [H2] to their
    names and applies the [rwinv] tactic to [H1] and [H2].

    Adding this tactic to the ones that we invoke in each case of the
    induction handles all of the contradictory cases. *)

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

(** Let's see about the remaining cases. Each of them involves
    applying a conditional hypothesis to extract an equality.
    Currently we have phrased these as assertions, so that we have to
    predict what the resulting equality will be (although we can then
    use [auto] to prove it).  An alternative is to pick the relevant
    hypotheses to use and then [rewrite] with them, as follows: *)

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

(** Now we can automate the task of finding the relevant hypotheses to
    rewrite with. *)

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

(** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of
    the form "for all [x], _some property of [x]_ implies _some
    equality_."  The property of [x] is bound to the pattern variable
    [P], and the left- and right-hand sides of the equality are bound
    to [L] and [R].  The name of this hypothesis is bound to [H1].
    Then the pattern [?P ?X] matches any hypothesis that provides
    evidence that [P] holds for some concrete [X].  If both patterns
    succeed, we apply the [rewrite] tactic (instantiating the
    quantified [x] with [X] and providing [H2] as the required
    evidence for [P X]) in all hypotheses and the goal.

    One problem remains: in general, there may be several pairs of
    hypotheses that have the right general form, and it seems tricky
    to pick out the ones we actually need.  A key trick is to realize
    that we can _try them all_!  Here's how this works:

    - each execution of [match goal] will keep trying to find a valid
      pair of hypotheses until the tactic on the RHS of the match
      succeeds; if there are no such pairs, it fails;
    - [rewrite] will fail given a trivial equation of the form [X = X];
    - we can wrap the whole thing in a [repeat], which will keep doing
      useful rewrites until only trivial ones are left. *)

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

(** The big payoff in this approach is that our proof script
    should be robust in the face of modest changes to our language.
    For example, we can add a [REPEAT] command to the language. *)

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

(** Our first attempt at the determinacy proof is disappointing: the
    [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't [find_rwinv] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwinv]. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

(** These examples just give a flavor of what "hyper-automation" can
    achieve in Coq.  The details of [match goal] are a bit tricky, and
    debugging scripts using it is, frankly, not very pleasant.  But it
    is well worth adding at least simple uses to your proofs, both to
    avoid tedium and to "future proof" them. *)

(* ----------------------------------------------------------------- *)
(** *** [eapply] and [eauto] *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers.  To
    motivate this feature, recall this example from the [Imp]
    chapter: *)

Example ceval_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with (t_update empty_state X 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** In the first step of the proof, we had to explicitly provide a
    longish expression to help Coq instantiate a "hidden" argument to
    the [E_Seq] constructor.  This was needed because the definition
    of [E_Seq]...

          E_Seq : forall c1 c2 st st' st'',
            c1 / st  \\ st' ->
            c2 / st' \\ st'' ->
            (c1 ;; c2) / st \\ st''

   is quantified over a variable, [st'], that does not appear in its
   conclusion, so unifying its conclusion with the goal state doesn't
   help Coq find a suitable value for this variable.  If we leave
   out the [with], this step fails ("Error: Unable to find an
   instance for the variable [st']").

   What's silly about this error is that the appropriate value for [st']
   will actually become obvious in the very next step, where we apply
   [E_Ass].  If Coq could just wait until we get to this step, there
   would be no need to give the value explicitly.  This is exactly what
   the [eapply] tactic gives us: *)

Example ceval'_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** The tactic [eapply H] tactic behaves just like [apply H] except
    that, after it finishes unifying the goal state with the
    conclusion of [H], it does not bother to check whether all the
    variables that were introduced in the process have been given
    concrete values during unification.

    If you step through the proof above, you'll see that the goal
    state at position [1] mentions the _existential variable_ [?st']
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?st'] with a concrete value.  This new
    value contains a new existential variable [?n], which is
    instantiated in its turn by the following [reflexivity] step,
    position [3].  When we start working on the second
    subgoal (position [4]), we observe that the occurrence of [?st']
    in this subgoal has been replaced by the value that it was given
    during the first subgoal. *)

(** Several of the tactics that we've seen so far, including [exists],
    [constructor], and [auto], have [e...] variants.  For example,
    here's a proof using [eauto]: *)

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := t_update (t_update empty_state X 1) Y 2.
Definition st21 := t_update (t_update empty_state X 2) Y 1.

Example auto_example_8 : exists s',
  (IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI) / st21 \\ s'.
Proof. eauto. Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply]. *)

(** $Date: 2017-07-15 16:03:20 -0400 (Sat, 15 Jul 2017) $ *)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition validate_realm_params_spec0  (adt: RData) : option Z64 :=
    when' _base == get_realm_params_par_base_spec  adt;
    rely is_int64 _base;
    when' _size == get_realm_params_par_size_spec  adt;
    rely is_int64 _size;
    rely is_int64 (_base mod 4096);
    if ((_base mod 4096) =? 0) then
      rely is_int64 (_size mod 4096);
      let _t'3 := ((_size mod 4096) =? 0) in
      if _t'3 then
        rely is_int64 (_base + _size);
        let _t'4 := ((_base + _size) >? _base) in
        if _t'4 then
          when' _t'6 == max_ipa_size_spec  adt;
          rely is_int64 _t'6;
          let _t'5 := ((_base + _size) <? _t'6) in
          if _t'5 then
            let _ret := 0 in
            Some (VZ64 _ret)
          else
            let _ret := 1 in
            Some (VZ64 _ret)
        else
          let _t'5 := 0 in
          let _ret := 1 in
          Some (VZ64 _ret)
      else
        let _t'4 := 0 in
        let _t'5 := 0 in
        let _ret := 1 in
        Some (VZ64 _ret)
    else
      let _t'3 := 0 in
      let _t'4 := 0 in
      let _t'5 := 0 in
      let _ret := 1 in
      Some (VZ64 _ret)
    .

End SpecLow.


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

 Contents:

  - Definition of a Category with Display maps from a Comprehension Category
      (assumption of saturatedness needed for pullbacks forming hprop)
*)

Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.OtherDefs.DM.

(** * Construction of Comprehension precategory from Display map precategory *)

Section TypeCat_to_DM.

Variable CC : category.
Variable H : is_univalent CC.
Variable C : typecat_structure CC.

Definition iso_to_dpr {Γ Γ'} (γ : Γ --> Γ') : UU
  := ∑ (A : C Γ') (f : z_iso (Γ'◂ A) Γ),
        dpr_typecat _ = f ;; γ .

Definition dm_sub_struct_of_TypeCat : dm_sub_struct CC.
Proof.
  unfold dm_sub_struct.
  intros Γ Γ' γ.
  exact (ishinh (iso_to_dpr γ)).
Defined.

Lemma dm_sub_closed_under_iso_of_TypeCat : dm_sub_closed_under_iso dm_sub_struct_of_TypeCat.
Proof.
  unfold dm_sub_closed_under_iso.
  intros Δ Γ γ Δ' δ h HT.
  unfold dm_sub_struct_of_TypeCat in γ.
  destruct γ as [γ A]. simpl in *. unfold DM_type in A.
  apply A.
  intro A'.
  apply hinhpr.
  clear A.
  destruct A' as [A [f TH]].
  unfold iso_to_dpr.
  exists A.
  set (T:= z_iso_comp f h).
  exists T.
  unfold T. simpl.
  rewrite TH; clear TH.
  rewrite <- assoc. apply maponpaths.
  sym. assumption.
Qed.

Definition pb_of_DM_of_TypeCat : pb_of_DM_struct dm_sub_struct_of_TypeCat.
Proof.
  unfold pb_of_DM_struct.
  intros Δ Γ γ Γ' f.
  destruct γ as [γ B]. simpl.
  match goal with | [ |- ?T ] => assert (X : isaprop T) end.
  { apply isofhleveltotal2.
    - apply isaprop_Pullback. assumption.
    - intros. apply isapropishinh.
  }
  unfold DM_type in B. simpl in *.
  unfold dm_sub_struct_of_TypeCat in B.
  set (T:= make_hProp _ X).
  set (T':= B T).
  apply T'.
  unfold T; simpl;
  clear X T T'.
  intro T.
  unfold iso_to_dpr in T.
  destruct T as [A [h e]].
  clear B.
  unshelve refine (tpair _ _ _ ).
  - unshelve refine (make_Pullback _ _).
    5: use postcomp_pb_with_z_iso.
    7: eapply is_symmetric_isPullback, reind_pb_typecat.
    + eassumption.
    + sym. assumption.
 - simpl.
    apply hinhpr.
    unfold iso_to_dpr.
    exists (A{{f}}).
    exists (identity_z_iso _ ).
    sym. apply id_left.
Defined.

Definition dm_sub_pb_of_TypeCat : dm_sub_pb CC.
Proof.
  exists dm_sub_struct_of_TypeCat.
  exact pb_of_DM_of_TypeCat.
Defined.

Definition DM_structure_of_TypeCat : DM_structure CC.
Proof.
  exists dm_sub_pb_of_TypeCat.
  exists dm_sub_closed_under_iso_of_TypeCat.
  intros. apply isapropishinh.
Defined.

End TypeCat_to_DM.


From Mtac2 Require Import Base Logic Datatypes List MTele.
Import M.notations.
Import Sorts.S.
Import ListNotations.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
Unset Universe Minimization ToSet.

Inductive mtpattern A (M : A -> Prop)  : Prop :=
| mtpbase : forall x : A, M x -> Unification -> mtpattern A M
| mtptele : forall {C}, (forall x : C, mtpattern A M) -> mtpattern A M
| mtpsort : (Sort -> mtpattern A M) -> mtpattern A M.

Arguments mtpbase {A M} _ _.
Arguments mtptele {A M C} _.
Arguments mtpsort {A M} _.

Local Notation MFA T := (MTele_val (MTele_C Typeₛ Propₛ M T)).

Fixpoint open_branch {A} {m} {T : forall x, MTele_Ty (m x)} {y : A} {a : ArgsOf (m y)}
         (p : mtpattern A (fun x => MFA (T x))) : M (apply_sort (T y) a) :=
  match p return M _ with
  | mtpbase x f u =>
    oeq <- M.unify x y u;
    match oeq return M (apply_sort (T y) a) with
    | mSome eq =>
      match eq in meq _ z return forall a : ArgsOf (m z), M (apply_sort (T z) a) with
      | meq_refl => apply_C Propₛ f
      end a
    | mNone => M.raise DoesNotMatch
    end
  | mtptele f => c <- M.evar _; open_branch (f c)
  | mtpsort f =>
    M.mtry'
      (open_branch (f Propₛ))
      (fun e =>
         oeq <- M.unify e DoesNotMatch UniMatchNoRed;
         match oeq with
         | mSome _ => open_branch (f Typeₛ)
         | mNone => M.raise e
         end
      )
  end
.

Definition mtmmatch' A m (T : forall x, MTele_Ty (m x)) (y : A)
           (ps : mlist (mtpattern A (fun x => MFA (T x)))) : selem_of (MFA (T y)) :=
  curry_C
    Propₛ
    (fun a : ArgsOf (m y) =>
       (fix mmatch' (ps : mlist (mtpattern A (fun x => MFA (T x)))) :=
          match ps with
          | [m:] => M.raise NoPatternMatches
          | p :m: ps' =>
            M.mtry' (open_branch p)
                    (fun e =>
                       mif M.unify e DoesNotMatch UniMatchNoRed then mmatch' ps' else M.raise e)
          end) ps
    ).

Module TestFin.
Require Fin.
Polymorphic Definition mt : nat -> MTele := fun n => mTele (fun _ : Fin.t n => mBase).
Definition T : forall n, MTele_Ty (mt n) := fun n _ => True.
Definition pO u : mtpattern nat _ := @mtpbase _ (fun x => MTele_ty M (n:=mt x) (T x)) 0 ((* ex_intro _ 0 *) (fun x => Fin.case0 (fun _ => M True) x)) u.
Definition p1 u : mtpattern nat _ := @mtpbase _ (fun x => MTele_ty M (n:=mt x) (T x)) 1 ((* ex_intro _ 1 *) (fun n => M.ret I)) u.
Definition pi u : mtpattern nat (fun x => MTele_ty M (n:=mt x) (T x)) :=
  mtptele (fun i : nat =>
             @mtpbase _ _  i ((* ex_intro _ i *) (fun n => M.ret I)) u
          ).

Program Example pbeta : mtpattern nat (fun x => MTele_ty M (n:=mt x) (T x)) :=
  mtptele (fun i : nat =>
            @mtpbase _ (* (fun x => MTele_ty M (mt x)) *) _ (i+1) ((* ex_intro _ (i + 1) *) (fun n : Fin.t (i + 1) => M.ret I)) UniCoq
         ).
End TestFin.


(****************************************************************)
(*                   DEDUCTION NATURELLE                        *)
(****************************************************************)

(****************************************************************)
(*    [A]     * implique_intro h :                              *)
(*    ...     * Si le but est de la forme A => B rajoute A aux  *)
(*     B      * hypotèses sous le nom h et remplace le but par  *)
(*  --------  * B.                                              *)
(*   A => B   *                                                 *)
(****************************************************************)

Ltac implique_intro h :=
	match goal with
	| |- _ -> _ => try intro h
	| |- ~ _  => try intro h
	| _ => idtac "Erreur: aucun implique dans le but courant."
	end
.

(****************************************************************)
(*             * implique_elim h :                              *)
(*             * Si h est de la forme A=>B et le but            *)
(*             * courant de la forme B remplace le but par A.   *)
(*             * Si h est de la forme A et le but courant de la *)
(*   A  A=>B   * forme A=>B remplace le but par A.              *)
(*  ---------  *                                                *)
(*      B      * implique_elim h i j :                          *)
(*             * Si h est de la forme A=>B et i de la forme A   *)
(*             * Cree une nouvelle hypothèse j contenant B.     *)
(*             *                                                *)
(****************************************************************)

Inductive ltac_No_arg : Set :=
  | ltac_no_arg : ltac_No_arg.

Ltac implique_elim_tac h i j :=
	match type of i with
	| ltac_No_arg => match goal with
					 | |- _ -> _ => try elim h
					 | |- ?X1 => try apply h
					 | _ => idtac "Erreur: l'hypotese n'est pas appliquable au but courant." end
	| _ => try pose ( j := h i )
	| _ => idtac "Erreur: impossible de creer le resolvant des deux hypoteses."
	end
.

Tactic Notation "implique_elim" constr(h) :=
  implique_elim_tac h ltac_no_arg ltac_no_arg.
Tactic Notation "implique_elim" constr(h) constr(i) ident(j) :=
  implique_elim_tac h i j.

(****************************************************************)
(*            * et_elim_1 h h_decomp:                           *)
(*   A /\ B   * Si h est de la forme A /\ B rajoute A aux       *)
(*  --------  * hypotèses sous le nom h_decomp.                 *)
(*     A      *                                                 *)
(*            *                                                 *)
(****************************************************************)

Ltac et_elim_1 h h_decomp :=
	match type of h with
	| _ /\ _ => try ( elim h; intros h_decomp Tmp ; clear Tmp )
	| _ => idtac "Erreur: l'hypotese n'est pas decomposable."
	end
.

(****************************************************************)
(*            * et_elim_1 h h_decomp:                           *)
(*   A /\ B   * Si h est de la forme A /\ B rajoute B aux       *)
(*  --------  * hypotèses sous le nom h_decomp.                 *)
(*     B      *                                                 *)
(*            *                                                 *)
(****************************************************************)

Ltac et_elim_2 h h_decomp :=
	match type of h with
	| _ /\ _ => try (elim h; intros Tmp h_decomp ; clear Tmp)
	| _ => idtac "Erreur: l'hypotese n'est pas decomposable."
	end
.

(****************************************************************)
(*            * et_intro :                                      *)
(*   A    B   * Si le but est de la forme A /\ B Decompose le   *)
(*  --------  * but courant en deux sous-but contenant A et B.  *)
(*   A /\ B   *                                                 *)
(*            *                                                 *)
(****************************************************************)

Ltac et_intro :=
	match goal with
	| |- _ /\ _ => try split
	| _ => idtac "Erreur: le but courant n'est pas décomposable."
	end
.

(****************************************************************)
(*            * ou_intro_1 :                                    *)
(*     A      * Si le but est de la forme A \/ B remplace le    *)
(*  --------  * but courant par A.                              *)
(*   A \/ B   *                                                 *)
(*            *                                                 *)
(****************************************************************)

Ltac ou_intro_1 :=
	match goal with
	| |- _ \/ _ => try left
	| _ => idtac "Erreur: introduction de l'hypotese impossible."
	end
.

(****************************************************************)
(*            * ou_intro_2 :                                    *)
(*     B      * Si le but est de la forme A \/ B remplace le    *)
(*  --------  * but courant par B.                              *)
(*   A \/ B   *                                                 *)
(*            *                                                 *)
(****************************************************************)

Ltac ou_intro_2 :=
	match goal with
	| |- _ \/ _ => try right
	| _ => idtac "Erreur: introduction de l'hypotese impossible."
	end
.

(****************************************************************)
(*                  * ou_elim h :                               *)
(*  A\/B A=>C B=>C  * Si h est de la forme A \/ B et le but     *)
(*  --------------  * courant de la forme C cree deux nouveaux  *)
(*        C         * buts A=>C et B=>C.                        *)
(*                  *                                           *)
(****************************************************************)

Ltac ou_elim h :=
	match type of h with
	| _ \/ _ => try elim h
	| _ => idtac "Erreur: forme de l'hypotese incorrecte."
	end
.

(****************************************************************)
(*           * efq :                                            *)
(*    _|_    * Remplace le but courant par False.               *)
(*  -------  *                                                  *)
(*     A     *                                                  *)
(*           *                                                  *)
(****************************************************************)

Ltac efq := try exfalso.

(****************************************************************)
(*           * raa :                                            *)
(*    ~~A    * Si le but est de la forme ~~A ou                 *)
(*  -------  * (A => False => False) le remplace par A.         *)
(*     A     *                                                  *)
(*           *                                                  *)
(****************************************************************)

Ltac raa :=
	match goal with
	| |- (~~ _ ) => let tmp := fresh in try (intro tmp ; apply tmp ; clear tmp)
	| |- ( _ -> False -> False) => let tmp := fresh in try (intro tmp ; apply tmp ; clear tmp)
	| _ => idtac "Erreur: reduction a l absurde impossible sur le but courant."
	end
.

(****************************************************************)
(*                      QUANTIFICATEURS                         *)
(****************************************************************)

(****************************************************************)
(*                 * pourtout_intro h :                         *)
(*        A        * Si le but est de la forme forall x, A      *)
(*  -------------  * le remplace par A et ajoute une instance   *)
(*   forall x, A   * de x comme hypothese. Cette nouvelle       *)
(*                 * hypothese est nommee h.                    *)
(****************************************************************)

Ltac pourtout_intro h :=
	match goal with
	| |- forall _ , _ => intro h
	| _ => idtac "Erreur: Aucun pour tout decomposable dans le but courant."
	end
.

(****************************************************************)
(*                 * pourtout_elim h i t :                      *)
(*   forall x, A   * Si h est de la forme forall x, A cree une  *)
(*  -------------  * nouvelle hypothese i qui est               *)
(*    A < x:=t >   * l'instantiation de h avec < x:=t >.        *)
(*                 *                                            *)
(****************************************************************)

Ltac pourtout_elim h i t :=
	match type of h with
	| forall _ , _ => pose ( i := h t )
	| _ => idtac "Erreur: Aucun pour tout decomposable dans l'hypothese."
	end
.

(****************************************************************)
(*                 * existe_intro t :                           *)
(*   A < x:=t >    * Si le but est de la forme exists x, A      *)
(*  -------------  * le remplace par A < x:=t >.                *)
(*   exists x, A   *                                            *)
(*                 *                                            *)
(****************************************************************)

Ltac existe_intro t :=
	match goal with
	| |- exists _ , _ => exists t
	| _ => idtac "Erreur: Le but courant ne contient pas de il existe decomposable."
	end
.

(****************************************************************)
(*                        * existe_elim h i :                   *)
(*   (exists x, A) A=>B   * Si le but est de la forme B et h de *)
(*  --------------------  * la forme (exists x, A) remplace le  *)
(*            B           * but courant par A=>B et ajout une   *)
(*                        * instance i de x dans les hypotheses *)
(****************************************************************)

Ltac existe_elim h i :=
	match type of h with
	| exists _ , _ => elim h ; intro i
	| _ => idtac "Erreur : l hypothese ne contient pas de il existe decomposable."
	end
.

(****************************************************************)
(*                          EGALITE                             *)
(****************************************************************)


Require Import FP.Data.Function.
Require Import FP.Structures.Proxy.
Require Import FP.Relations.Setoid.

Import ProperNotation.

Class EqvEnv :=
  { (* equivalence *)
    env_PER : Type -> Type
  ; env_eqv : forall {T} {p:Px (env_PER T)}, T -> T -> Prop
  ; (* eqv is a partial equivalence relation *)
    env_PER_WF : forall (T:Type) {p:Px (env_PER T)}, Type
  ; env_eqv_WF :>
      forall {T} {p:Px (env_PER T)} {pwf:Px (env_PER_WF T)},
      PER env_eqv
  }.
Arguments env_eqv {EqvEnv T p} _ _ : simpl never.

Class EqvEnvLogical {EqvEnv_:EqvEnv} :=
  { eqv_env_logical_P :>
      forall
        {A} {aP:Px (env_PER A)}
        {B} {bP:Px (env_PER B)},
      Px (env_PER (A -> B))
  ; eqv_env_logical_PE_WF :>
      forall
        {A} {aP:Px (env_PER A)} (aPWF:Px (env_PER_WF A))
        {B} {bP:Px (env_PER B)} (bPWF:Px (env_PER_WF B)),
      Px (env_PER_WF (A -> B))
  ; eqv_env_logical_intro :
      forall
        {A} {aPER:Px (env_PER A)}
        {B} {bPER:Px (env_PER B)}
        {f:A -> B} {g:A -> B},
      (env_eqv ==> env_eqv) f g -> env_eqv f g
  ; eqv_env_logical_elim :
      forall
        {A} {aPER:Px (env_PER A)}
        {B} {bPER:Px (env_PER B)}
        {f:A -> B} {g:A -> B},
      env_eqv f g -> (env_eqv ==> env_eqv) f g
  }.

(*
not sure if this is needed or not
Section EqvEnv.
  Context {EqvEnv_:EqvEnv}.
  Context {EqvEnvLogical_:EqvEnvLogical}.

  Global Instance eqv_env_logical_P' :
    forall
      {P}
      {A} {aP:Px (P A)}
      {B} {bP:Px (P B)}
      (e:P = env_PER),
    Px (P (A -> B)).
  Proof.
    intros.
    rewrite e in *.
    eauto with typeclass_instances.
  Qed.
End EqvEnv.
*)

Section EqvEnvLogical.
  Context {EqvEnv_:EqvEnv}.
  Context {EqvEnvWF_:EqvEnvLogical}.

  Section Proper_Elim.
    Context {A} {aER:Px (env_PER A)} {aER':Px (env_PER_WF A)}.
    Context {B} {bER:Px (env_PER B)} {bER':Px (env_PER_WF B)}.
    Context {f:A -> B} {fP:Proper env_eqv f}.
    Global Instance Proper_PE_R_elim1 : Proper (env_eqv ==> env_eqv) f :=
      eqv_env_logical_elim fP.

    Context {C} {cER:Px (env_PER C)} {cER':Px (env_PER_WF C)}.
    Context {g:A -> B -> C} {gP:Proper env_eqv g}.
    Global Instance Proper_PE_R_elim2 : Proper (env_eqv ==> env_eqv ==> env_eqv) g.
      unfold Proper,"==>" at 1 ; intros.
      repeat apply eqv_env_logical_elim ; auto.
    Qed.
  End Proper_Elim.

  Section Proper_App.
    Context {A} {aER:Px (env_PER A)} {aER':Px (env_PER_WF A)}.
    Context {B} {bER:Px (env_PER B)} {bER':Px (env_PER_WF B)}.
    Context (x:A) {xP:Proper env_eqv x}.
    Context (f:A -> B) {fP:Proper env_eqv f}.
    Global Instance Proper_PE_R_app : Proper env_eqv (f x) := Proper_PE_R_elim1 x x xP.
  End Proper_App.
End EqvEnvLogical.

Ltac logical_eqv_intro_once :=
  match goal with
  | [ |- ?R ?A ?B ] =>
      match type of A with
      | ?T -> ?U => apply eqv_env_logical_intro ; unfold "==>" at 1 ; intros
      | Fun ?T ?U => apply eqv_env_logical_intro ; unfold "==>" at 1 ; intros
      end
  end.

Ltac logical_eqv_intro := repeat logical_eqv_intro_once.
Ltac logical_eqv_elim_once :=
  match goal with
  | [ |- ?R (?f ?x) (?g ?y) ] => apply eqv_env_logical_elim
  end.
Ltac logical_eqv_elim := repeat logical_eqv_elim_once.

Create HintDb logical_eqv_db.

Ltac logical_eqv_once :=
  match goal with
  | [ |- env_eqv (?f ?x) (?g ?y) ] =>
      let g_type := type of g in
      match type of f with
      | g_type => logical_eqv_elim_once
      end
  | [ |- env_eqv (fun _ => _) _ ] =>
      logical_eqv_intro_once
  | [ |- env_eqv _ (fun _ => _) ] =>
      logical_eqv_intro_once
  end.
Ltac logical_eqv :=
  match goal with
  | [ |- Proper env_eqv ?x ] => unfold Proper
  | _ => idtac
  end ;
  repeat logical_eqv_once ;
  match goal with
  | [ |- env_eqv ?x ?x ] => change (env_eqv x x) with (Proper env_eqv x)
  | _ => idtac
  end ;
  eauto with logical_eqv_db typeclass_instances.

Section morph_proper.
  Context {EqvEnv_:EqvEnv}.
  Context {T:Type} {tPER:Px (env_PER T)} {tPER_WF:Px (env_PER_WF T)}.
  Context {x:T} {y:T}.
  Context (fP:env_eqv x y).
  Definition morph_proper_left : Proper env_eqv x.
  Proof.
    unfold Proper.
    transitivity y ; auto.
    symmetry ; auto.
  Qed.
  Definition morph_proper_right : Proper env_eqv y.
  Proof.
    unfold Proper.
    transitivity x ; auto.
    symmetry ; auto.
  Qed.
End morph_proper.
Hint Resolve morph_proper_left : logical_eqv_db.
Hint Resolve morph_proper_right : logical_eqv_db.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal20.

Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq bool (even (len (append (Nil) (Nil)))) (true)).
Admitted.
QuickChick lfind_hyp_test.


(*
 * Copyright (c) 2022 BedRock Systems, Inc.
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

From bedrock.lang.cpp.algebra Require Export cfrac.
From bedrock.lang.bi Require Import prelude split_andb split_frac.
Require Import iris.proofmode.proofmode.
Import ChargeNotation.

#[local] Set Printing Coercions.

(** * Splitting and combining const/mutable fractional things *)
(**
Overview:

- [cQpTC.IsConst], [cQpTC.Frac] normalizing projections from
const/mutable fractions

- [SplitCFrac], [CombineCFrac] split and combine terms of type [cQp.t]
*)

(**
Our rules are syntactic: All operations appearing in input positions
should be opaque for typeclass resolution.

Most rules key on [cQp.add] and [cQp.scale] which are opaque. Rule
[combine_frac.fold_add] keys on [Qp.add] and [andb]. The former is
opaque. (We choose not to touch the opacity of [andb]. See
../../bi/split_andb.v.)
*)

#[local] Notation Cut := TCNoBackTrack.

#[local] Open Scope cQp_scope.

(** ** Operations on const/mutable fractions *)
Module cQpTC.

  (** [IsConst q b] sets [b := cQp.is_const q] with simplifications. *)
  Class IsConst (q : cQp.t) (b : bool) : Prop := is_const : cQp.is_const q = b.
  #[global] Hint Mode IsConst + - : typeclass_instances.
  #[global] Arguments IsConst : simpl never.
  #[global] Arguments is_const _ {_ _} : assert.
  Notation IS_CONST q b := (Cut (IsConst q b)) (only parsing).

  (** [Frac cq q] sets [q := cQp.frac cq] with simplifications. *)
  Class Frac (cq : cQp.t) (q : Qp) : Prop := frac : cQp.frac cq = q.
  #[global] Hint Mode Frac + - : typeclass_instances.
  #[global] Arguments Frac : simpl never.
  #[global] Arguments frac _ {_ _} : assert.
  Notation FRAC q b := (Cut (Frac q b)) (only parsing).

  (** [IsConst] *)

  #[global] Instance is_const_mk c q : IsConst (cQp.mk c q) c | 10.
  Proof. done. Qed.

  #[global] Instance is_const_scale q cq c :
    IS_CONST cq c -> IsConst (cQp.scale q cq) c | 20.
  Proof.
    intros [?]. rewrite /IsConst.
    by rewrite cQp.is_const_scale is_const.
  Qed.

  #[global] Instance is_const_add cq1 cq2 c1 c2 c :
    IS_CONST cq1 c1 -> IS_CONST cq2 c2 -> CombineAndB c1 c2 c ->
    IsConst (cq1 + cq2) c | 20.
  Proof.
    intros [?] [?] ?. rewrite /IsConst.
    by rewrite cQp.is_const_add !is_const combine_andb.
  Qed.

  #[global] Instance is_const_var q : IsConst q (cQp.is_const q) | 50.
  Proof. done. Qed.

  (** [Frac] *)

  #[global] Instance frac_mk c q : Frac (cQp.mk c q) q | 10.
  Proof. done. Qed.

  #[global] Instance frac_scale q1 q2 q cq :
    FRAC cq q2 -> QpTC.MUL q1 q2 q ->
    Frac (cQp.scale q1 cq) q | 20.
  Proof.
    intros [?] [?]. rewrite /Frac.
    by rewrite cQp.frac_scale frac QpTC.mul.
  Qed.

  #[global] Instance frac_add cq1 cq2 q1 q2 q :
    FRAC cq1 q1 -> FRAC cq2 q2 -> QpTC.ADD q1 q2 q ->
    Frac (cq1 + cq2) q | 20.
  Proof.
    intros [?] [?] [?]. rewrite /Frac.
    by rewrite cQp.frac_add !frac QpTC.add.
  Qed.

  #[global] Instance frac_var cq : Frac cq (cQp.frac cq) | 50.
  Proof. done. Qed.

End cQpTC.

(** ** Splitting const/mutable fractions *)
(**
[SplitCFrac q q1 q2] splits [q : cQp.t] into [q1], [q2] s.t. [q = q1 +
q2], adjusting the outputs [q1], [q2] for readabilty.
*)
Class SplitCFrac (cv cv1 cv2 : cQp.t) : Prop := split_cfrac : cv = cv1 + cv2.
#[global] Hint Mode SplitCFrac + - - : typeclass_instances.
#[global] Arguments SplitCFrac : simpl never.
#[global] Arguments split_cfrac _ {_ _ _} : assert.

Module split_cfrac.

  (**
  We use this auxiliary judgment to [Cut] in [SplitCFrac].
  *)
  Class Split (q q1 q2 : cQp.t) : Prop := split : q = q1 + q2.
  #[global] Hint Mode Split + - - : typeclass_instances.
  #[global] Arguments Split : simpl never.
  #[global] Arguments split _ {_ _ _} : assert.
  Notation SPLIT q q1 q2 := (Cut (Split q q1 q2)) (only parsing).

  (** Splitting on [cQp.add] is immediate *)

  #[global] Instance split_add q1 q2 : Split (q1 + q2) q1 q2 | 10.
  Proof. done. Qed.

  Goal forall q1 q2, Split (q1 ⋅ q2) q1 q2.
  Proof. apply _. Abort.

  (** Splitting on [cQp.scale q] preserves the factor [q] *)

  #[global] Instance split_scale q cv cv1 cv2 :
    SPLIT cv cv1 cv2 ->
    Split (cQp.scale q cv) (cQp.scale q cv1) (cQp.scale q cv2) | 20.
  Proof.
    intros [?]. rewrite /Split.
    by rewrite (split cv) cQp.scale_add_r.
  Qed.

  (** Default: Split componentwise *)

  #[global] Instance split_parts cq c c1 c2 q q1 q2 :
    cQpTC.IS_CONST cq c -> cQpTC.FRAC cq q ->
    SplitAndB c c1 c2 -> SplitFrac q q1 q2 ->
    Split cq (cQp.mk c1 q1) (cQp.mk c2 q2) | 50.
  Proof.
    intros [?] [?] ??. rewrite /Split cQp.add_eq/=.
    rewrite (cQp.eta cq) cQpTC.is_const cQpTC.frac. by f_equal.
  Qed.

End split_cfrac.

#[global] Instance split_cfrac_split cv cv1 cv2 :
  split_cfrac.SPLIT cv cv1 cv2 -> SplitCFrac cv cv1 cv2 | 10.
Proof. by case. Qed.

(** ** Combining const/mutable fractions *)
(**
[CombineCFrac q1 q2 q] combine [q1, q2 : cQp.t] into [q = q1 + q2],
adjusting the output [q] for readability.
*)
Class CombineCFrac (q1 q2 q : cQp.t) : Prop := combine_cfrac : q1 + q2 = q.
#[global] Hint Mode CombineCFrac + + - : typeclass_instances.
#[global] Arguments CombineCFrac : simpl never.
#[global] Arguments combine_cfrac _ _ {_ _} : assert.

Module combine_cfrac.

  (**
  [Fold p q] folds occurrences of [cQp.add] and eliminates occurrences
  of eta-expanded [cQp.mk] in [p] to produce [q].
  *)
  Class Fold (p q : cQp.t) : Prop := fold : p = q.
  #[global] Hint Mode Fold + - : typeclass_instances.
  #[global] Arguments Fold : simpl never.
  #[global] Arguments fold _ {_ _} : assert.
  Notation FOLD p q := (Cut (Fold p q)) (only parsing).

  #[global] Instance fold_eta q :
    Fold (cQp.mk (cQp.is_const q) (cQp.frac q)) q | 10.
  Proof. done. Qed.

  (** Account for [Qp.Add]'s [q + q --> 2q] *)
  #[global] Instance fold_add_diag q :
    Fold (cQp.mk (cQp.is_const q) (2 * cQp.frac q)) (q + q) | 10.
  Proof.
    rewrite /Fold cQp.add_eq.
    by rewrite andb_diag Qp.add_diag.
  Qed.

  #[global] Instance fold_scale p q' q :
    FOLD q' q ->
    Fold (cQp.scale p q') (cQp.scale p q) | 20.
  Proof.
    intros [?]. rewrite /Fold. by rewrite (fold q').
  Qed.

  #[global] Instance fold_add p1 p2 q1 q2 :
    FOLD p1 q1 -> FOLD p2 q2 ->
    Fold (Reduce (cQp.add p1 p2)) (cQp.add q1 q2) | 20.
  Proof.
    intros [?] [?]. rewrite /Fold.
    by rewrite (fold p1) (fold p2).
  Qed.

  #[global] Instance fold_skip q : Fold q q | 50.
  Proof. done. Qed.

  (**
  We use this auxiliary judgment to [Cut] in [CombineCFrac].
  *)
  Class Combine (q1 q2 q : cQp.t) : Prop := combine : q1 + q2 = q.
  #[global] Hint Mode Combine + + - : typeclass_instances.
  #[global] Arguments Combine : simpl never.
  #[global] Arguments combine _ _ {_ _} : assert.
  Notation COMBINE q1 q2 q := (Cut (Combine q1 q2 q)) (only parsing).

  (** Combining terms of the form [cQp.scale p] preserves that structure *)

  #[global] Instance combine_scale p q1 q2 q :
    COMBINE q1 q2 q ->
    Combine (cQp.scale p q1) (cQp.scale p q2) (cQp.scale p q) | 20.
  Proof.
    intros [?]. rewrite /Combine.
    by rewrite -cQp.scale_add_r combine.
  Qed.

  (** Default: Combine componentwise *)

  #[global] Instance combine_parts cq1 cq2 cq c1 c2 c q1 q2 q :
    cQpTC.IS_CONST cq1 c1 -> cQpTC.FRAC cq1 q1 ->
    cQpTC.IS_CONST cq2 c2 -> cQpTC.FRAC cq2 q2 ->
    CombineAndB c1 c2 c -> CombineFrac q1 q2 q -> FOLD (cQp.mk c q) cq ->
    Combine cq1 cq2 cq | 50.
  Proof.
    intros [?] [?] [?] [?] ?? [<-]. rewrite /Combine cQp.add_eq.
    rewrite !cQpTC.is_const !cQpTC.frac. by f_equal.
  Qed.

End combine_cfrac.

#[global] Instance combine_cfrac_add q1 q2 q :
  combine_cfrac.COMBINE q1 q2 q -> CombineCFrac q1 q2 q | 10.
Proof. by case. Qed.