(* This file contains the specification of a lock module discussed
   in the section on the Fancy update modality and weakest precondition
   in the Iris Lecture Notes.
     Recall from loc. cit. that the point of this
   alternative lock specification is that it allows ones
   to allocate the lock before one knows what the resource
   of the invariant it is going to protect is.
*)

(* Contains definitions of the weakest precondition assertion, and its basic rules. *)
From iris.program_logic Require Export weakestpre.

(* Instantiation of Iris with the particular language. The notation file
   contains many shorthand notations for the programming language constructs, and
   the lang file contains the actual language syntax. *)
From iris.heap_lang Require Export notation lang.

(* Files related to the interactive proof mode. The first import includes the
   general tactics of the proof mode. The second provides some more specialized
   tactics particular to the instantiation of Iris to a particular programming
   language. *)
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode.

(* Definition of invariants and their rules (expressed using the fancy update
   modality). *)
From iris.base_logic.lib Require Export invariants.

(* The exclusive resource algebra *)
From iris.algebra Require Import excl.

Section lock_model.
(* In order to do the proof we need to assume certain things about the
   instantiation of Iris. The particular, even the heap is handled in an
   analogous way as other ghost state. This line states that we assume the Iris
   instantiation has sufficient structure to manipulate the heap, e.g., it
   allows us to use the points-to predicate, and that the ghost state includes
   the exclusive resource algebra over the singleton set (represented using the
   unitR type). *)

  Context `{heapGS Σ}.
  Context `{inG Σ (exclR unitR)}.

  (* We use a ghost name with a token to model whether the lock is locked or not.
     The the token is just exclusive ownerwhip of unit value. *)
  Definition locked γ := own γ (Excl ()).

  (* The name of a lock. *)
  Definition lockN (l : loc) := nroot .@ "lock" .@ l.

  (* The lock invariant *)
  Definition is_lock γ l P :=
    inv (lockN l) ((l ↦ (#false) ∗ P ∗ locked γ) ∨
                                l ↦ (#true))%I.

  (* The is_lock predicate is persistent *)
  Global Instance is_lock_persistent γ l Φ : Persistent (is_lock γ l Φ).
  Proof. apply _. Qed.

End lock_model.

Section lock_code.

  (* Here is the standard spin lock code *)

  Definition newlock : val := λ: <>, ref #false.
  Definition acquire : val :=
    rec: "acquire" "l" :=
      if: CAS "l" #false #true then #() else "acquire" "l".
  Definition release : val := λ: "l", "l" <- #false.

End lock_code.

Section lock_spec.
  Context `{heapGS Σ}.
  Context `{inG Σ (exclR unitR)}.

  (* Here is the interesting part of this example, namely the new specification
     for newlock, which allows one to get a post-condition which can be instantiated
     with the lock invariant at some point later, when it is known.
     See the discussion in Iris Lecture Notes.
     First we show the specs using triples, and afterwards using weakest preconditions.
  *)

  Lemma wp_newlock_t :
    {{{ True }}} newlock #() {{{v, RET v; ∃ (l: loc) γ, ⌜v = #l⌝ ∧ (∀ P E, P ={E}=∗ is_lock γ l P) }}}.
  Proof.
    iIntros (φ) "Hi Hcont".
    rewrite /newlock.
    wp_lam.
    wp_alloc l as "HPt".
    iApply "Hcont".
    iExists l.
    iMod (own_alloc (Excl ())) as (γ) "Hld"; first done.
    iExists γ.
    iModIntro. iSplit; first done.
    iIntros (P E) "HP".
    iMod (inv_alloc _ _
           ((l ↦ (#false) ∗ P ∗ locked γ) ∨ l ↦ (#true))%I with "[-]")
      as "Hinv"; last eauto.
    { iNext; iLeft; iFrame. }
  Qed.

  Lemma wp_acquire_t E γ l P :
    nclose (lockN l) ⊆ E →
    {{{ is_lock γ l P }}} acquire (#l) @ E {{{v, RET #v; P ∗ locked γ}}}.
  Proof.
    iIntros (HE φ) "#Hi Hcont"; rewrite /acquire.
    iLöb as "IH".
    wp_rec.
    wp_bind (CmpXchg _ _ _).
    iInv (lockN l) as "[(Hl & HP & Ht)|Hl]" "Hcl".
    - wp_cmpxchg_suc.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply "Hcont".
      by iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply ("IH" with "[$Hcont]").
  Qed.

  Lemma wp_release_t E γ l P :
    nclose (lockN l) ⊆ E →
    {{{ is_lock γ l P ∗ locked γ ∗ P }}} release (#l) @ E {{{RET #(); True}}}.
  Proof.
    iIntros (HE φ) "(#Hi & Hld & HP) Hcont"; rewrite /release.
    wp_lam.
    iInv (lockN l) as "[(Hl & HQ & >Ht)|Hl]" "Hcl".
    - iDestruct (own_valid_2 with "Hld Ht") as %Hv. done.
    - wp_store.
      iMod ("Hcl" with "[-Hcont]") as "_"; first by iNext; iLeft; iFrame.
      iApply "Hcont".
      done.
  Qed.

  (* Here are the specifications again, just written using weakest preconditions *)

  Lemma wp_newlock :
    True ⊢ WP newlock #() {{v, ∃ (l: loc) γ, ⌜v = #l⌝ ∧ (∀ P E, P ={E}=∗ is_lock γ l P) }}.
  Proof.
    iIntros "_".
    rewrite /newlock.
    wp_lam.
    wp_alloc l as "HPt".
    iExists l.
    iMod (own_alloc (Excl ())) as (γ) "Hld"; first done.
    iExists γ.
    iModIntro. iSplit; first done.
    iIntros (P E) "HP".
    iMod (inv_alloc _ _
           ((l ↦ (#false) ∗ P ∗ locked γ) ∨ l ↦ (#true))%I with "[-]")
      as "Hinv"; last eauto.
    { iNext; iLeft; iFrame. }
  Qed.

  Lemma wp_acquire E γ l P :
    nclose (lockN l) ⊆ E →
    is_lock γ l P ⊢ WP acquire (#l) @ E {{v, P ∗ locked γ}}.
  Proof.
    iIntros (HE) "#Hi"; rewrite /acquire.
    iLöb as "IH".
    wp_rec.
    wp_bind (CmpXchg _ _ _).
    iInv (lockN l) as "[(Hl & HP & Ht)|Hl]" "Hcl".
    - wp_cmpxchg_suc.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      by iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply "IH".
  Qed.

  Lemma wp_release E γ l P :
    nclose (lockN l) ⊆ E →
    is_lock γ l P ∗ locked γ ∗ P ⊢ WP release (#l) @ E {{v, True}}.
  Proof.
    iIntros (HE) "(#Hi & Hld & HP)"; rewrite /release.
    wp_lam.
    iInv (lockN l) as "[(Hl & HQ & >Ht)|Hl]" "Hcl".
    - iDestruct (own_valid_2 with "Hld Ht") as %Hv. done.
    - wp_store.
      iMod ("Hcl" with "[-]") as "_"; first by iNext; iLeft; iFrame.
      done.
  Qed.

  Global Opaque newlock release acquire.

  (* We now present a simple client of the lock which cannot be verified with the
     lock specification described in the Chapter on Invariants and Ghost State in the
     Iris Lecture Notes, but which can be specifed and verified with the current
     specification.
  *)
  Definition test : expr :=
    let: "l" := newlock #() in
    let: "r" := ref #0 in
    (λ: <>, acquire "l";; "r" <- !"r" + #1;; release "l").

  Lemma test_spec :
    {{{ True }}} test #() {{{ v, RET v; True }}}.
  Proof.
    iIntros (φ) "Hi HCont"; rewrite /test.
    wp_bind (newlock #())%E.
    iApply (wp_newlock_t); auto.
    iNext.
    iIntros (v) "Hs".
    wp_let.
    wp_bind (ref #0)%E.
    wp_alloc l as "Hl".
    wp_let.
    wp_seq.
    wp_bind (acquire v)%E.
    iDestruct "Hs" as (l' γ) "[% H2]".
    subst.
    iMod ("H2" $! (∃ (n : Z), l ↦ #n)%I with "[Hl]") as "#H3".
    { iExists 0; iFrame. }
    wp_apply (wp_acquire_t with "H3"); auto.
    iIntros (v) "(Hpt & Hlocked)".
    iDestruct "Hpt" as (u) "Hpt".
    wp_seq.
    wp_load.
    wp_op.
    wp_store.
    wp_apply (wp_release_t with "[-HCont]"); auto.
    iFrame "H3 Hlocked".
    iExists _; iFrame.
  Qed.
End lock_spec.

Typeclasses Opaque locked.
Global Opaque locked.
Typeclasses Opaque is_lock.
Global Opaque is_lock.


Require Import Arith.
Require Import PolSBase.

Section PolReplaceBase.

(* The set of the coefficient usually Z or better Q *)
Variable C : Set.

(* Usual operations *)
Variable Cplus : C -> C -> C.
Variable Cmul : C -> C -> C.
Variable Cop : C -> C.

(* Constant *)
Variable C0 : C.
Variable C1 : C.

(* Test to 1 *)
Variable isC1 : C -> bool.

(* Test to 0 *)
Variable isC0 : C -> bool.

(* Test if positive *)
Variable isPos : C -> bool.

(* Divisibility *)
Variable Cdivide : C -> C -> bool.

(* Division *)
Variable Cdiv : C -> C -> C.

Let mkMul := mkPEmul C Cmul Cop C0 isC1 isC0.
Let mkOpp := mkPEopp C Cop.
Let mkAdd := mkPEadd C Cplus Cmul Cop C0 isC1 isC0 isPos.
Let mkSub := mkPEsub C Cplus Cmul Cop C0 isC1 isC0 isPos.
Let mkAdd0 e1 e2 := if isP0 _ isC0 e1 then e2 else PEadd e1 e2.
Let mkSub0 e1 e2 := if isP0 _ isC0 e1 then PEopp e2 else PEsub e1 e2.

(* Test if the difference of two terms is zero *)
Definition is_replace_eq (x y : PExpr C) : bool :=
  let r :=
      simpl_minus C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEsub y x)
  in
  match r with
  | PEsub (PEc c) r1 => if isC0 c then true else false
  | _ => false
  end.

Definition replace_eq (x y z : PExpr C) : option (PExpr C) :=
  let r :=
      simpl_minus C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEsub y x)
  in
  match r with
  | PEsub (PEc c) r1 => if isC0 c then Some (mkAdd0 r1 z) else None
  | _ => None
  end.

(* Test if the sum of two term is zero *)

Definition is_replace_op (x y : PExpr C) : bool :=
  let r :=
      simpl_minus
        C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEsub (PEopp y) x)
  in
  match r with
  | PEsub (PEc c) r1 => if isC0 c then true else false
  | _ => false
  end.

Definition replace_op (x y z : PExpr C) : option (PExpr C) :=
  let r :=
      simpl_minus
        C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEsub (PEopp y) x)
  in
  match r with
  | PEsub (PEc c) r1 => if isC0 c then Some (mkSub0 r1 z) else None
  | _ => None
  end.

Definition is_replace_eq_or_op (x y : PExpr C) : bool :=
  match is_replace_eq x y with true => true | _ => is_replace_op x y end.

Definition replace_eq_or_op (x y z : PExpr C) : option (PExpr C) :=
  match replace_eq x y z with Some r => Some r | _ => replace_op x y z end.

Definition bool_nat (x : bool) : nat := match x with true => 1%nat | false => 0 %nat end.

(* Count the number of possible replacement *)
Fixpoint bcount_replace (b : bool) (e from : PExpr C) : nat :=
  let (b1, n) :=
      if b then (b, 0) else
        if is_replace_eq_or_op e from then (true, 1)
        else (true, 0)
  in
  n +
  match e with
  | PEadd e1 e2 => bcount_replace b1 e1 from + bcount_replace b1 e2 from
  | PEsub e1 e2 => bcount_replace b1 e1 from + bcount_replace b1 e2 from
  | PEopp e1 => bcount_replace b1 e1 from
  | PEmul e1 e2 => bcount_replace false e1 from + bcount_replace false e2 from
  | _ => 0
  end.

Definition count_replace := bcount_replace false.

(* Return the replaced term *)
Fixpoint replace_aux (b : bool) (l : list bool) (e from to : PExpr C)
  : list bool * PExpr C :=
  let v := replace_eq_or_op e from to in
  let b1 := if b then b else if v then true else false in
  let b2 := if b then false else if b1 then nth 0 l false else false in
  let ll := if b then l else if b1 then tail l else l in
  let el := match v with (Some v1) => v1 | None => e end in
  match e with
  | PEadd e1 e2 =>
    let (l1,e3) := replace_aux b1 ll e1 from to in
    let (l2,e4) := replace_aux b1 l1 e2 from to in
    (l2, if b2 then el else PEadd e3 e4)
  | PEsub e1 e2 =>
    let (l1,e3) := replace_aux b1 ll e1 from to in
    let (l2,e4) := replace_aux b1 l1 e2 from to in
    (l2, if b2 then el else PEsub e3 e4)
  | PEopp e1 =>
    let (l1,e3) := replace_aux b1 ll e1 from to in
    (l1, if b2 then el else PEopp e3)
  | PEmul e1 e2 =>
    let (l1,e3) := replace_aux false ll e1 from to in
    let (l2,e4) := replace_aux false l1 e2 from to in
    (l2, if b2 then el else PEmul e3 e4)
  | _ => (ll, if b2 then el else e)
  end.

Fixpoint make_all_const (b : bool) (n : nat) : list bool :=
  match n with 0 => nil | S n1 => b::make_all_const b n1 end.

Fixpoint make_one_true (n1 n2 : nat): list bool :=
  match n1, n2 with
  | O, _ => nil
  | S n3, O => true::make_all_const false n3
  | S n3, S n4 => false::make_one_true n3 n4
  end.

Definition replace (e from to : PExpr C) (n : Z) :=
  let c := count_replace e from in
  let l :=
      match n with
      | Z0 => make_all_const true c
      | Zpos n1 => make_one_true c (pred (nat_of_P n1))
      | Zneg n1 =>
        if Zlt_bool (Z_of_nat c) n
        then make_all_const false c
        else make_one_true c (c - (nat_of_P n1))%nat
      end
  in
  snd (replace_aux false l e from to).

End PolReplaceBase.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import Setoid.
Require Import Decidable.
Require Import List.
Require Import Refl.

Set Implicit Arguments.

Section CheckerMaker.

(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
Variable Formula : Type.

Variable Env : Type.

Variable eval : Env -> Formula -> Prop.

Variable Formula' : Type.

Variable eval' : Env -> Formula' -> Prop.

Variable normalise : Formula -> Formula'.

Variable negate : Formula -> Formula'.

Hypothesis normalise_sound :
  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).

Hypothesis negate_correct :
  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).

Variable Witness : Type.

Variable check_formulas' : list Formula' -> Witness -> bool.

Hypothesis check_formulas'_sound :
  forall (l : list Formula') (w : Witness),
    check_formulas' l w = true ->
      forall env : Env, make_impl (eval' env) l False.

Definition normalise_list : list Formula -> list Formula' := map normalise.
Definition negate_list : list Formula -> list Formula' := map negate.

Definition check_formulas (l : list Formula) (w : Witness) : bool :=
  check_formulas' (map normalise l) w.

(* Contraposition of normalise_sound for lists *)
Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
Proof.
intros env l; induction l as [| t l IH]; simpl in *.
trivial.
intros H1 H2. apply IH. apply H1. now apply normalise_sound.
Qed.

Theorem check_formulas_sound :
  forall (l : list Formula) (w : Witness),
    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
Proof.
unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
intro H1. apply normalise_sound in H1.
pose proof (check_formulas'_sound H env) as H2; simpl in H2.
apply H2 in H1. now apply normalise_sound_contr.
Qed.

(* In check_conj_formulas', t2 is supposed to be a list of negations of
formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
A1 /\ A2 -> B1 /\ B2. *)

Fixpoint check_conj_formulas'
  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
match t2 with
| nil => true
| t':: rt2 =>
  match wits with
  | nil => false
  | w :: rwits =>
    match check_formulas' (t':: t1) w with
    | true => check_conj_formulas' t1 rwits rt2
    | false => false
    end
  end
end.

(* checks whether the conjunction of t1 implies the conjunction of t2 *)

Definition check_conj_formulas
  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
    check_conj_formulas' (normalise_list t1) wits (negate_list t2).

Theorem check_conj_formulas_sound :
  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
    check_conj_formulas t1 wits t2 = true ->
      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
Proof.
intro t1; induction t2 as [| a2 t2' IH].
intros; apply make_impl_true.
intros wits H env.
unfold check_conj_formulas in H; simpl in H.
destruct wits as [| w ws]; simpl in H. discriminate.
case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
intro H1; rewrite H1 in H; [| discriminate].
assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
now apply check_formulas'_sound with (w := w). clear H1.
pose proof (IH ws H env) as H1. simpl in H2.
assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
by auto using normalise_sound_contr. clear H2.
rewrite <- make_conj_impl in *.
rewrite make_conj_cons. intro H2. split.
apply <- negate_correct. intro; now elim H3. exact (H1 H2).
Qed.

End CheckerMaker.


(************************************************************************************

 Fibers of slice bicategories

 Each of the variations of slice bicategories has a local isocleaving, and thus we
 can talk about fiber categories. The slice of each of them is some variation of
 the hom-category:
 - for the lax slice, it is the hom-category
 - for the oplax slice, it is the opposite of the hom-category
 - for the slice, it is the core of the hom-category
 In addition, we determine the functor arising from a morphism in the base and the
 global cleaving. In all of the different variations of the slice bicategory, this
 functor is equivalent to precomposition.

 Contents
 1. Fiber of lax slice
 2. Fiber functor of lax slice
 3. Fiber of oplax slice
 4. Fiber functor of oplax slice
 5. Fiber of slice
 6. Fiber functor of oplax slice

 ************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Core.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.LaxSlice.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory.
Require Import UniMath.Bicategories.DisplayedBicats.FiberCategory.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.SliceCleaving.
Require Import UniMath.Bicategories.DisplayedBicats.FiberBicategory.FunctorFromCleaving.

Local Open Scope cat.

(**
 1. Fiber of lax slice
 *)
Section LaxSliceFiber.
  Context {B : bicat}
          (c a : B).

  Let fib : category
    := discrete_fiber_category
         (lax_slice_disp_bicat B a)
         (lax_slice_disp_2cells_isaprop B a)
         (lax_slice_disp_univalent_2_1 B a)
         (lax_slice_local_iso_cleaving a)
         c.

  Let homc : category
    := hom c a.

  Definition hom_to_lax_slice_fib_data
    : functor_data homc fib.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - exact (λ f g α, α • linvunitor _).
  Defined.

  Definition hom_to_lax_slice_fib_is_functor
    : is_functor hom_to_lax_slice_fib_data.
  Proof.
    split.
    - intro f ; cbn.
      apply id2_left.
    - intros f g h α β ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply linvunitor_natural.
      }
      rewrite <- lwhisker_hcomp.
      apply maponpaths.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      refine (!(id2_right _) @ _).
      apply maponpaths.
      rewrite lunitor_runitor_identity.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      apply idpath.
  Qed.

  Definition hom_to_lax_slice_fib
    : homc ⟶ fib.
  Proof.
    use make_functor.
    - exact hom_to_lax_slice_fib_data.
    - exact hom_to_lax_slice_fib_is_functor.
  Defined.

  Definition lax_slice_fib_to_hom_data
    : functor_data fib homc.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - exact (λ f g α, α • lunitor _).
  Defined.

  Definition lax_slice_fib_to_hom_is_functor
    : is_functor lax_slice_fib_to_hom_data.
  Proof.
    split.
    - intros f ; cbn.
      apply linvunitor_lunitor.
    - intros f g h α β ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- vcomp_lunitor.
      rewrite !vassocl.
      apply maponpaths.
      apply lunitor_triangle.
  Qed.

  Definition lax_slice_fib_to_hom
    : fib ⟶ homc.
  Proof.
    use make_functor.
    - exact lax_slice_fib_to_hom_data.
    - exact lax_slice_fib_to_hom_is_functor.
  Defined.

  Definition equiv_lax_slice_fib_hom_unit
    : functor_identity fib
      ⟹
      lax_slice_fib_to_hom ∙ hom_to_lax_slice_fib.
  Proof.
    use make_nat_trans.
    - exact (λ f, linvunitor f).
    - abstract
        (intros f g α ; cbn ;
         do 2 apply maponpaths_2 ;
         rewrite !vassocl ;
         rewrite lunitor_linvunitor ;
         rewrite id2_right ;
         rewrite !lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         rewrite <- lwhisker_hcomp ;
         apply maponpaths ;
         rewrite linvunitor_assoc ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite lwhisker_hcomp, rwhisker_hcomp ;
         apply triangle_r_inv).
  Defined.

  Definition equiv_lax_slice_fib_hom_counit
    : hom_to_lax_slice_fib ∙ lax_slice_fib_to_hom
      ⟹
      functor_identity homc.
  Proof.
    use make_nat_trans.
    - exact (λ f, id₂ f).
    - abstract
        (intros f g α ; cbn ;
         rewrite id2_left, id2_right ;
         rewrite !vassocl ;
         rewrite linvunitor_lunitor ;
         apply id2_right).
  Defined.

  Definition equiv_lax_slice_fib_hom
    : equivalence_of_cats fib homc.
  Proof.
    use make_equivalence_of_cats.
    - use make_adjunction_data.
      + exact lax_slice_fib_to_hom.
      + exact hom_to_lax_slice_fib.
      + exact equiv_lax_slice_fib_hom_unit.
      + exact equiv_lax_slice_fib_hom_counit.
    - split.
      + intro f.
        apply is_z_iso_discrete_fiber.
        apply lax_slice_invertible_2cell_is_left_disp_adj_equiv.
        cbn.
        is_iso.
      + intro f ; cbn.
        apply is_inv2cell_to_is_z_iso.
        is_iso.
  Defined.

  Definition adj_equivalence_lax_slice_fib_to_hom
    : adj_equivalence_of_cats lax_slice_fib_to_hom
    := adjointificiation equiv_lax_slice_fib_hom.

  Definition adj_equiv_lax_slice_fib_hom
    : adj_equiv fib homc
    := _ ,, adj_equivalence_lax_slice_fib_to_hom.
End LaxSliceFiber.

(**
 2. Fiber functor of lax slice
 *)
Section LaxSliceSubFiber.
  Context {B : bicat}
          (a : B)
          {c₁ c₂ : B}
          (f : c₁ --> c₂).

  Let fib₁ : category
    := discrete_fiber_category
         (lax_slice_disp_bicat B a)
         (lax_slice_disp_2cells_isaprop B a)
         (lax_slice_disp_univalent_2_1 B a)
         (lax_slice_local_iso_cleaving a)
         c₁.

  Let fib₂ : category
    := discrete_fiber_category
         (lax_slice_disp_bicat B a)
         (lax_slice_disp_2cells_isaprop B a)
         (lax_slice_disp_univalent_2_1 B a)
         (lax_slice_local_iso_cleaving a)
         c₂.

  Definition functor_from_lax_slice_cleaving_nat_trans
    : functor_from_cleaving
        (lax_slice_disp_bicat B a)
        (lax_slice_disp_2cells_isaprop B a)
        (lax_slice_disp_univalent_2_1 B a)
        (lax_slice_global_cleaving a)
        (lax_slice_local_iso_cleaving a)
        f
      ⟹
      lax_slice_fib_to_hom _ _
      ∙ pre_comp a f
      ∙ hom_to_lax_slice_fib _ _.
  Proof.
    use make_nat_trans.
    - exact (λ g, linvunitor _).
    - abstract
        (intros g₁ g₂ α ; cbn in * ;
         rewrite lwhisker_id2 ;
         rewrite id2_left, id2_right ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocr ;
         do 3 apply maponpaths_2 ;
         rewrite !vassocl ;
         rewrite <- !rwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite runitor_rwhisker ;
         rewrite !vassocr ;
         rewrite lwhisker_vcomp ;
         rewrite <- vcomp_whisker ;
         rewrite linvunitor_assoc ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite <- lwhisker_lwhisker_rassociator ;
         rewrite !lwhisker_vcomp ;
         apply idpath).
  Defined.

  Definition functor_from_lax_slice_cleaving_nat_z_iso
    : nat_z_iso
        (functor_from_cleaving
           (lax_slice_disp_bicat B a)
           (lax_slice_disp_2cells_isaprop B a)
           (lax_slice_disp_univalent_2_1 B a)
           (lax_slice_global_cleaving a)
           (lax_slice_local_iso_cleaving a)
           f)
        (lax_slice_fib_to_hom _ _
         ∙ pre_comp a f
         ∙ hom_to_lax_slice_fib _ _).
  Proof.
    use make_nat_z_iso.
    - exact functor_from_lax_slice_cleaving_nat_trans.
    - intro g.
      apply is_z_iso_discrete_fiber.
      apply lax_slice_invertible_2cell_is_left_disp_adj_equiv.
      cbn.
      is_iso.
  Defined.
End LaxSliceSubFiber.

(**
 3. Fiber of oplax slice
 *)
Section OplaxSliceFiber.
  Context {B : bicat}
          (c a : B).

  Let fib : category
    := discrete_fiber_category
         (oplax_slice_disp_bicat B a)
         (oplax_slice_disp_2cells_isaprop B a)
         (oplax_slice_disp_univalent_2_1 B a)
         (oplax_slice_local_iso_cleaving a)
         c.

  Let homc : category
    := (hom c a)^op.

  Definition hom_to_oplax_slice_fib_data
    : functor_data homc fib.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - exact (λ f g α, lunitor _ • α).
  Defined.

  Definition hom_to_oplax_slice_fib_is_functor
    : is_functor hom_to_oplax_slice_fib_data.
  Proof.
    split.
    - intro f ; cbn.
      apply id2_right.
    - intros f g h α β ; cbn.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite vcomp_lunitor.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
  Qed.

  Definition hom_to_oplax_slice_fib
    : homc ⟶ fib.
  Proof.
    use make_functor.
    - exact hom_to_oplax_slice_fib_data.
    - exact hom_to_oplax_slice_fib_is_functor.
  Defined.

  Definition oplax_slice_fib_to_hom_data
    : functor_data fib homc.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - exact (λ f g α, linvunitor _ • α).
  Defined.

  Definition oplax_slice_fib_to_hom_is_functor
    : is_functor oplax_slice_fib_to_hom_data.
  Proof.
    split.
    - intros f ; cbn.
      apply linvunitor_lunitor.
    - intros f g h α β ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      apply maponpaths_2.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite vcomp_lunitor.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      use maponpaths_2.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      apply id2_left.
  Qed.

  Definition oplax_slice_fib_to_hom
    : fib ⟶ homc.
  Proof.
    use make_functor.
    - exact oplax_slice_fib_to_hom_data.
    - exact oplax_slice_fib_to_hom_is_functor.
  Defined.

  Definition equiv_oplax_slice_fib_hom_unit
    : functor_identity fib
      ⟹
      oplax_slice_fib_to_hom ∙ hom_to_oplax_slice_fib.
  Proof.
    use make_nat_trans.
    - exact (λ f, lunitor f).
    - abstract
        (intros f g α ; cbn ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocl ;
         do 3 apply maponpaths ;
         rewrite !vassocr ;
         rewrite !lwhisker_vcomp ;
         rewrite vcomp_lunitor ;
         rewrite !vassocr ;
         rewrite lunitor_linvunitor ;
         rewrite id2_left ;
         apply idpath).
  Defined.

  Definition equiv_oplax_slice_fib_hom_counit
    : hom_to_oplax_slice_fib ∙ oplax_slice_fib_to_hom
      ⟹
      functor_identity homc.
  Proof.
    use make_nat_trans.
    - exact (λ f, id₂ f).
    - abstract
        (intros f g α ; cbn ;
         rewrite id2_left, id2_right ;
         rewrite !vassocr ;
         rewrite linvunitor_lunitor ;
         apply id2_left).
  Defined.

  Definition equiv_oplax_slice_fib_hom
    : equivalence_of_cats fib homc.
  Proof.
    use make_equivalence_of_cats.
    - use make_adjunction_data.
      + exact oplax_slice_fib_to_hom.
      + exact hom_to_oplax_slice_fib.
      + exact equiv_oplax_slice_fib_hom_unit.
      + exact equiv_oplax_slice_fib_hom_counit.
    - split.
      + intro f.
        apply is_z_iso_discrete_fiber.
        apply oplax_slice_invertible_2cell_is_left_disp_adj_equiv.
        cbn.
        is_iso.
      + intro f.
        apply opp_is_z_isomorphism.
        apply is_inv2cell_to_is_z_iso ; cbn.
        is_iso.
  Defined.

  Definition adj_equivalence_oplax_slice_fib_to_hom
    : adj_equivalence_of_cats oplax_slice_fib_to_hom
    := adjointificiation equiv_oplax_slice_fib_hom.

  Definition adj_equiv_oplax_slice_fib_hom
    : adj_equiv fib homc
    := _ ,, adj_equivalence_oplax_slice_fib_to_hom.
End OplaxSliceFiber.

(**
 4. Fiber functor of oplax slice
 *)
Section OplaxSliceSubFiber.
  Context {B : bicat}
          (a : B)
          {c₁ c₂ : B}
          (f : c₁ --> c₂).

  Let fib₁ : category
    := discrete_fiber_category
         (oplax_slice_disp_bicat B a)
         (oplax_slice_disp_2cells_isaprop B a)
         (oplax_slice_disp_univalent_2_1 B a)
         (oplax_slice_local_iso_cleaving a)
         c₁.

  Let fib₂ : category
    := discrete_fiber_category
         (oplax_slice_disp_bicat B a)
         (oplax_slice_disp_2cells_isaprop B a)
         (oplax_slice_disp_univalent_2_1 B a)
         (oplax_slice_local_iso_cleaving a)
         c₂.

  Definition functor_from_oplax_slice_cleaving_nat_trans
    : functor_from_cleaving
        (oplax_slice_disp_bicat B a)
        (oplax_slice_disp_2cells_isaprop B a)
        (oplax_slice_disp_univalent_2_1 B a)
        (oplax_slice_global_cleaving a)
        (oplax_slice_local_iso_cleaving a)
        f
      ⟹
      oplax_slice_fib_to_hom _ _
      ∙ functor_opp (pre_comp a f)
      ∙ hom_to_oplax_slice_fib _ _.
  Proof.
    use make_nat_trans.
    - exact (λ g, lunitor _).
    - abstract
        (intros g₁ g₂ α ; cbn in * ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite lwhisker_id2, id2_left, id2_right ;
         do 3 apply maponpaths ;
         rewrite vcomp_lunitor ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite <- lunitor_triangle ;
         rewrite !vassocr ;
         rewrite lwhisker_lwhisker ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite <-vcomp_whisker ;
         rewrite <- !rwhisker_vcomp ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite rwhisker_hcomp, lwhisker_hcomp ;
         rewrite triangle_r_inv ;
         apply idpath).
  Defined.

  Definition functor_from_oplax_slice_cleaving_nat_z_iso
    : nat_z_iso
        (functor_from_cleaving
           (oplax_slice_disp_bicat B a)
           (oplax_slice_disp_2cells_isaprop B a)
           (oplax_slice_disp_univalent_2_1 B a)
           (oplax_slice_global_cleaving a)
           (oplax_slice_local_iso_cleaving a)
           f)
        (oplax_slice_fib_to_hom _ _
         ∙ functor_opp (pre_comp a f)
         ∙ hom_to_oplax_slice_fib _ _).
  Proof.
    use make_nat_z_iso.
    - exact functor_from_oplax_slice_cleaving_nat_trans.
    - intro g.
      apply is_z_iso_discrete_fiber.
      apply oplax_slice_invertible_2cell_is_left_disp_adj_equiv.
      cbn.
      is_iso.
  Defined.
End OplaxSliceSubFiber.

(**
 5. Fiber of slice
 *)
Section SliceFiber.
  Context {B : bicat}
          (c a : B).

  Let fib : category
    := discrete_fiber_category
         (slice_disp_bicat a)
         (disp_2cells_isaprop_slice a)
         (disp_univalent_2_1_slice a)
         (slice_local_iso_cleaving a)
         c.

  Let homc : category
    := core (hom c a).

  Definition hom_to_slice_fib_data
    : functor_data homc fib.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - exact (λ f g α,
             comp_of_invertible_2cell
               (z_iso_to_inv2cell α)
               (linvunitor_invertible_2cell _)).
  Defined.

  Definition hom_to_slice_fib_is_functor
    : is_functor hom_to_slice_fib_data.
  Proof.
    split.
    - intro f.
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      apply id2_left.
    - intros f g h α β.
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply linvunitor_natural.
      }
      rewrite <- lwhisker_hcomp.
      apply maponpaths.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      refine (!(id2_right _) @ _).
      apply maponpaths.
      rewrite lunitor_runitor_identity.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      apply idpath.
  Qed.

  Definition hom_to_slice_fib
    : homc ⟶ fib.
  Proof.
    use make_functor.
    - exact hom_to_slice_fib_data.
    - exact hom_to_slice_fib_is_functor.
  Defined.

  Definition slice_fib_to_hom_data
    : functor_data fib homc.
  Proof.
    use make_functor_data.
    - exact (λ f, f).
    - intros f g α.
      simple refine (_ ,, _).
      + exact (pr1 α • lunitor _).
      + use is_inv2cell_to_is_z_iso.
        is_iso.
        apply property_from_invertible_2cell.
  Defined.

  Definition slice_fib_to_hom_is_functor
    : is_functor slice_fib_to_hom_data.
  Proof.
    split.
    - intros f.
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      apply linvunitor_lunitor.
    - intros f g h α β.
      use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- vcomp_lunitor.
      rewrite !vassocl.
      apply maponpaths.
      apply lunitor_triangle.
  Qed.

  Definition slice_fib_to_hom
    : fib ⟶ homc.
  Proof.
    use make_functor.
    - exact slice_fib_to_hom_data.
    - exact slice_fib_to_hom_is_functor.
  Defined.

  Definition equiv_slice_fib_hom_unit
    : functor_identity fib
      ⟹
      slice_fib_to_hom ∙ hom_to_slice_fib.
  Proof.
    use make_nat_trans.
    - exact (λ f, linvunitor_invertible_2cell f).
    - abstract
        (intros f g α ;
         use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ;
         rewrite !vassocr ;
         do 2 apply maponpaths_2 ;
         rewrite !vassocl ;
         rewrite lunitor_linvunitor ;
         rewrite id2_right ;
         rewrite !lwhisker_hcomp ;
         rewrite <- linvunitor_natural ;
         rewrite <- lwhisker_hcomp ;
         apply maponpaths ;
         rewrite linvunitor_assoc ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite lwhisker_hcomp, rwhisker_hcomp ;
         apply triangle_r_inv).
  Defined.

  Definition equiv_slice_fib_hom_counit
    : hom_to_slice_fib ∙ slice_fib_to_hom
      ⟹
      functor_identity homc.
  Proof.
    use make_nat_trans.
    - exact (λ f, identity_z_iso f).
    - abstract
        (intros f g α ;
         use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn ;
         rewrite id2_left, id2_right ;
         rewrite !vassocl ;
         rewrite linvunitor_lunitor ;
         apply id2_right).
  Defined.

  Definition equiv_slice_fib_hom
    : equivalence_of_cats fib homc.
  Proof.
    use make_equivalence_of_cats.
    - use make_adjunction_data.
      + exact slice_fib_to_hom.
      + exact hom_to_slice_fib.
      + exact equiv_slice_fib_hom_unit.
      + exact equiv_slice_fib_hom_counit.
    - split.
      + intro f.
        apply is_z_iso_discrete_fiber.
        apply slice_is_inv2cell_to_is_disp_adj_equiv.
      + intro f ; cbn.
        apply is_z_iso_core.
  Defined.

  Definition adj_equivalence_slice_fib_to_hom
    : adj_equivalence_of_cats slice_fib_to_hom
    := adjointificiation equiv_slice_fib_hom.

  Definition adj_equiv_slice_fib_hom
    : adj_equiv fib homc
    := _ ,, adj_equivalence_slice_fib_to_hom.
End SliceFiber.

(**
 6. Fiber functor of oplax slice
 *)
Section SliceSubFiber.
  Context {B : bicat}
          (a : B)
          {c₁ c₂ : B}
          (f : c₁ --> c₂).

  Let fib₁ : category
    := discrete_fiber_category
         (slice_disp_bicat a)
         (disp_2cells_isaprop_slice a)
         (disp_univalent_2_1_slice a)
         (slice_local_iso_cleaving a)
         c₁.

  Let fib₂ : category
    := discrete_fiber_category
         (slice_disp_bicat a)
         (disp_2cells_isaprop_slice a)
         (disp_univalent_2_1_slice a)
         (slice_local_iso_cleaving a)
         c₂.

  Definition functor_from_slice_cleaving_nat_trans
    : functor_from_cleaving
        (slice_disp_bicat a)
        (disp_2cells_isaprop_slice a)
        (disp_univalent_2_1_slice a)
        (slice_global_cleaving a)
        (slice_local_iso_cleaving a)
        f
      ⟹
      slice_fib_to_hom _ _
      ∙ core_functor (pre_comp a f)
      ∙ hom_to_slice_fib _ _.
  Proof.
    use make_nat_trans.
    - exact (λ g, linvunitor_invertible_2cell _).
    - abstract
        (intros g₁ g₂ α ;
         use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ; cbn in * ;
         rewrite lwhisker_id2 ;
         rewrite id2_left, id2_right ;
         rewrite <- !lwhisker_vcomp ;
         rewrite !vassocr ;
         do 3 apply maponpaths_2 ;
         rewrite !vassocl ;
         rewrite <- !rwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
         rewrite runitor_rwhisker ;
         rewrite !vassocr ;
         rewrite lwhisker_vcomp ;
         rewrite <- vcomp_whisker ;
         rewrite linvunitor_assoc ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite <- lwhisker_lwhisker_rassociator ;
         rewrite !lwhisker_vcomp ;
         apply idpath).
  Defined.

  Definition functor_from_slice_cleaving_nat_z_iso
    : nat_z_iso
        (functor_from_cleaving
           (slice_disp_bicat a)
           (disp_2cells_isaprop_slice a)
           (disp_univalent_2_1_slice a)
           (slice_global_cleaving a)
           (slice_local_iso_cleaving a)
           f)
        (slice_fib_to_hom _ _
         ∙ core_functor (pre_comp a f)
         ∙ hom_to_slice_fib _ _).
  Proof.
    use make_nat_z_iso.
    - exact functor_from_slice_cleaving_nat_trans.
    - intro g.
      apply is_z_iso_discrete_fiber.
      apply slice_is_inv2cell_to_is_disp_adj_equiv.
  Defined.
End SliceSubFiber.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e224m2e96p1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m189_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


From Coq Require Import Setoid Morphisms.
Set Primitive Projections.

Record a : Type := { f : nat }.

Parameter aa : a -> a -> Prop.
Parameter nn : nat -> nat -> Prop.

#[export] Declare Instance eqv_aa : Equivalence aa.
#[export] Declare Instance eqv_nn : Equivalence nn.

#[export] Instance Proper_f : Proper (aa ==> nn) f.
Admitted.

Lemma w : forall x y : a, aa x y -> nn (f x) (f y).
Proof.
  intros x y H.
  Fail rewrite H.
  (* Tactic failure: Nothing to rewrite. *)
Restart.
  intros x y H.
  change (nn ((fun x => f x) x) ((fun y => f y) y)).
  rewrite H.
Abort.

Definition f' (x : a) : nat := f x.

#[export] Instance Proper_f' : Proper (aa ==> nn) f'.
Admitted.

Lemma w : forall x y : a, aa x y -> nn (f' x) (f' y).
Proof.
  intros x y H.
  rewrite H.
  (* Tactic failure: setoid rewrite failed: Unable to satisfy the following constraints: *)
Abort.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e206m5_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e480m2e240m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Program List String.
Require Import PFDS.common.Result.
Open Scope string_scope.
Open Scope list_scope.

Definition pair_size {A B : Set} size1 size2 (pair: A*B) :=
  let '(x, y) := pair in
  size1 x + size2 y.

Definition pipeline {A B: Type} (x: A) (f: A -> B) := f x.
Infix "|>" := pipeline (at level 100).
Hint Transparent pipeline.

(* f x y = f y x でかつ f (f x y) z = f x (f y z) であるfに限る *)
Definition reduce_right {A: Type} (f: A -> A -> A) (xs: list A) : Result A :=
  match xs with
  | [] => Error "empty"
  | x :: xs => Ok (List.fold_right f x xs)
  end.

Definition reduce_left {A: Type} (f: A -> A -> A) (xs: list A) : Result A :=
  match xs with
  | [] => Error "empty"
  | x :: xs => Ok (List.fold_left f xs x)
  end.

Definition reduce {A: Type} := @reduce_right A.

 (** proved by chiguri : https://gist.github.com/chiguri/c10948810668490787c5f985f42955bd *)
Lemma fold_right_tail : forall (A B: Type) (f: A -> B -> B) xs x b0,
  List.fold_right f b0 (xs ++ [x]) = List.fold_right f (f x b0) xs.
Proof.
 intros.
 apply List.fold_right_app.
Qed.

(** proved by erutuf : https://gist.github.com/erutuf/123da543af0d6b19ae53bb7e8ccf8b81*)
Lemma fold_right_ext : forall (A : Type)(f g : A -> A -> A) xs x0,
  (forall x y, f x y = g x y) ->
  fold_right f x0 xs = fold_right g x0 xs.
Proof with simpl in *.
  intros.
  induction xs; [auto|]...
  rewrite H.
  rewrite IHxs.
  reflexivity.
Qed.

(** proved by erutuf : https://gist.github.com/erutuf/123da543af0d6b19ae53bb7e8ccf8b81*)
Lemma fold_right_rev : forall (A: Type) (f: A -> A -> A) xs x0,
  (forall x y z, f x (f y z) = f (f x y) z) ->
  (forall x y, f x y = f y x) ->
List.fold_right f x0 xs = List.fold_right f x0 (List.rev xs).
Proof.
  intros.
  rewrite (fold_right_ext _ f (fun x y => f y x)) by auto.
  rewrite <- fold_symmetric; [|auto..].
  rewrite fold_left_rev_right.
  reflexivity.
Qed.

Lemma fold_right_cons_tail : forall (A:Type) (f: A -> A -> A) x xs y ys,
  (forall x y z, f x (f y z) = f (f x y) z) ->
  (forall x y, f x y = f y x) ->
  x :: xs = ys ++ [y] ->
  fold_right f x xs = fold_right f y ys.
Proof.
 intros A f x xs y ys Hassoc Hcomm Heq. destruct xs as [|x1 xs'].
 - destruct ys; [|destruct ys; discriminate Heq]. simpl in Heq. now inversion Heq.
 - destruct ys as [|y1 ys']; [discriminate|].
   inversion Heq. rewrite H1.
   rewrite fold_right_tail. rewrite Hcomm.
   rewrite fold_right_rev at 1; [|assumption|assumption].
   rewrite <- fold_right_tail.
   rewrite fold_right_rev at 1; [|assumption|assumption].
   rewrite rev_unit. now rewrite rev_involutive.
Qed.


Require Import Grammar.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Datatypes.
Require Import PeanoNat.
Import ListNotations.

Inductive Tree : Type :=
  | Leaf : symbol -> Tree
  | Node : symbol -> list Tree -> Tree.

(* This is the derivation tree for the smallest string in the
 * language `simple_grammar`, a. *)
Check Node (N "S") (Leaf (T "a") :: nil).

Inductive item : Type :=
  | I : nat -> symbol -> list symbol -> list symbol -> nat -> list Tree -> item.

Notation "'{' i ',' b '==>' s '*' ss ',' j '}'" := (I i b s ss j []) (at level 60).

Definition trees (i : item) : list Tree :=
  match i with
  | I _ _ _ _ _ t => t
  end.

Definition axioms (g : list Rule) : list item :=
  match start_symbol g with
  | Some s => [I 0 (D "S'") [] [s] 0 []]
  | None => []
  end.

Compute axioms simple_grammar.

(* TODO: Fix goal *)
Definition goal (g : list Rule) (s : list id) (i : item) : Prop :=
  match i with
  | I i symbol symbols symbols' k trees => i = 0 /\ dummy symbol /\ symbols' = []
  end.

Definition beq_s_r (s : symbol) (r : Rule) :=
  beq_symbol s (lhs r).

(* The `scan` rule for our Earley parser has the form:
 *
 *   i, A → α • wjβ, j
 * ----------------------
 * i, A → αwj • β, j + 1
 *)
Definition scan (tokens : list id) (trigger : item) : list item :=
  match trigger with
  | I i a alpha [] j ts => []
  | I i a alpha (symbol :: b) j ts =>
    if (Nat.ltb (Datatypes.length tokens) j)
    then []
    else (
        if beq_symbol symbol (Terminal (nth j tokens (Id "")))
        then [I i a (alpha ++ [symbol]) b (j+1) (ts ++ [Leaf (Terminal (nth j tokens (Id "")))])]
        else []
      )
  end.

(* The `predict` rule for our Earley parser has the form:
 *
 * i, A → α • B
 * ------------- β, j
 * j, B → •γ, j
 *
 *)
Definition predict_item (j : nat) (r : Rule) : item :=
  match r with
  | R b gamma => I j b [] gamma j []
  end.

Definition predict (g : list Rule) (trigger : item) : list item :=
  match trigger with
  | I i a alpha [] j ts => []
  | I i a alpha (symbol :: b) j ts =>
    map (predict_item j) (filter (beq_s_r symbol) g)
  end.

(* The `complete` rule for our Earley parser has the form:
 *
 * i, A → α • Bβ, k k, B → γ•, j
 * -------------------------------
 *       i, A → αB • β, j
 *)
Definition complete (trigger : item) (stored : list item) : list item :=
  match trigger with
  | I i a alpha ((N x) :: b) k ts => []
  | I k (N x) gamma [] j ts => []
  | _ => []
  end.

Definition consequences
           (grammar : list Rule) (tokens : list id)
           (trigger : item) (stored : list item) : list item :=
  (scan tokens trigger) ++ (predict grammar trigger) ++ (complete trigger stored).

Definition initial_store (g : list Rule) : (list item * list item) :=
  ([], axioms g).

Fixpoint exhaust_agenda (g : list Rule) (tokens : list id) (store : list item * list item) : (list item * list item) :=
  match store with
  | (chart, []) => (chart, [])
  | (chart, trigger :: rest) =>
    exhaust_agenda g tokens
                   (
                     chart ++ [trigger],
                     rest ++ (consequences g tokens trigger chart)
                   )
  end.


(** * Term definition for PTS and de Bruijn manipulation . *)
(** * Usual Term syntax .*)
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt.
Require Import Le.
Require Import Gt.
Require Import Plus.
Require Import Minus.
Require Import Bool.
Require Import PTS_base.

Module Type ut_term_mod (X: term_sig).
  Import X.
(** Term syntax:*)
Inductive Term : Set:=
 | Var : Vars -> Term
 | Sort : Sorts -> Term
 | App : Term -> Term -> Term
 | Pi : Term -> Term -> Term
 | La :Term -> Term -> Term
.

Notation "x · y" := (App x y) (at level 15, left associativity) : UT_scope.
Notation "! s" := (Sort s) (at level 1) : UT_scope.
Notation "# v" := (Var v) (at level 1) : UT_scope.
Notation "'Π' ( U ) , V " := (Pi U V) (at level 20, U, V at level 30) : UT_scope.
Notation "'λ' [ U ] , v " := (La U v) (at level 20, U , v at level 30) : UT_scope.

Reserved Notation " t ↑ x # n " (at level 5, x at level 0, left associativity).

Delimit Scope UT_scope with UT.

Open Scope UT_scope.

(** In order to deal with variable bindings and captures, we need a lift
function to deal with free and bounded variables.

   [M ↑ n # m] recursivly add [n] to all variables that are
   above [m] in [M]. *)
Fixpoint lift_rec (n:nat) (k:nat) (T:Term) {struct T} := match T with
   | # x =>  if le_gt_dec k x then Var (n+x) else Var x
   | ! s => Sort s
   | M · N =>  App (M ↑ n # k) (N ↑ n # k)
   | Π ( A ), B => Π (A ↑ n # k), (B ↑ n # (S k))
   | λ [ A ], M => λ [A ↑ n # k], (M ↑ n # (S k))
 end
   where "t ↑ n # k" := (lift_rec n k t) : UT_scope.

Notation " t ↑ n " := (lift_rec n 0 t) (at level 5, n at level 0, left associativity) : UT_scope.

(** Some basic properties of the lift function. That is everything we will
ever need to handle de Bruijn indexes *)

Lemma inv_lift : forall M N n m , M ↑ n # m = N ↑ n # m -> M = N.
intros M; induction M; destruct N; intros;
simpl in *; try (discriminate || intuition); (try (destruct (le_gt_dec m v) ; discriminate)).
destruct (le_gt_dec m v); destruct (le_gt_dec m v0) ; injection H; intros; subst; intuition.
apply plus_reg_l in H0; rewrite H0; trivial.
elim (lt_irrefl m). apply le_lt_trans with v. trivial. induction n; intuition.
elim (lt_irrefl v0). apply lt_le_trans with m. induction n; intuition. trivial.
injection H; intros; rewrite (IHM1 N1 n m H1); rewrite (IHM2 N2 n m H0); reflexivity.
injection H; intros; rewrite (IHM1 N1 n m H1); rewrite (IHM2 N2 n (S m) H0); reflexivity.
injection H; intros; rewrite (IHM1 N1 n m H1); rewrite (IHM2 N2 n (S m) H0); reflexivity.
Qed.

Lemma lift_rec0 : forall M n, M ↑ 0 # n = M.
induction M; intros; simpl.
destruct (le_gt_dec n v); reflexivity.
reflexivity.
rewrite IHM1; rewrite IHM2; reflexivity.
rewrite IHM1; rewrite IHM2; reflexivity.
rewrite IHM1; rewrite IHM2; reflexivity.
Qed.

Lemma lift0 : forall M, M ↑ 0 = M .
intros; apply lift_rec0.
Qed.

Lemma liftP1 : forall M i j  k, (M ↑ j # i) ↑ k # (j+i) = M ↑ (j+k) # i.
intros M; induction M; intros;simpl.
destruct (le_gt_dec i v); simpl.
destruct (le_gt_dec (j+i) (j+v)); simpl.
rewrite plus_assoc. replace (k+j) with (j+k) by (apply plus_comm).  trivial.
apply plus_gt_reg_l in g. elim (lt_irrefl v).
apply lt_le_trans with i; intuition.
simpl; destruct (le_gt_dec (j+i)); intuition.
elim (lt_irrefl v).
apply lt_le_trans with i; intuition. induction j; intuition.
reflexivity.
rewrite IHM1;rewrite IHM2;reflexivity.
rewrite IHM1; rewrite <-IHM2 ;replace (j+S i) with (S(j+i)) by intuition; reflexivity.
rewrite IHM1; rewrite <- IHM2 ;replace (j+S i) with (S(j+i)) by intuition; reflexivity.
Qed.

Lemma liftP2: forall M i j k n, i <= n ->
  (M ↑ j # i) ↑ k # (j+n) = (M ↑ k # n) ↑ j # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); destruct (le_gt_dec n v).
simpl.
destruct le_gt_dec. destruct le_gt_dec.
rewrite 2! plus_assoc. replace (k+j) with (j+k) by (apply plus_comm).  trivial.
elim (lt_irrefl v). apply lt_le_trans with i. induction k; intuition. trivial.
apply plus_gt_reg_l in g. elim (lt_irrefl v).
apply lt_le_trans with n; intuition.
simpl.
destruct le_gt_dec. apply plus_le_reg_l in l0. elim (lt_irrefl v).
apply lt_le_trans with n; intuition. destruct le_gt_dec. trivial.
elim (lt_irrefl v). apply lt_le_trans with i; intuition.
simpl. destruct le_gt_dec. elim (lt_irrefl n). apply lt_le_trans with i.
apply le_lt_trans with v; intuition. trivial. elim (lt_irrefl v).
apply lt_le_trans with n. apply lt_le_trans with i; intuition. trivial.
simpl. destruct le_gt_dec. elim (lt_irrefl v). apply lt_le_trans with n.
intuition. induction j; intuition. destruct le_gt_dec. elim (lt_irrefl i).
apply le_lt_trans with v; intuition. trivial.
trivial.

rewrite IHM1; intuition;  rewrite IHM2; intuition;  reflexivity.
rewrite IHM1; intuition.
replace (S(j+n)) with (j+S n) by intuition.
rewrite (IHM2 (S i) j k (S n)); intuition.
rewrite IHM1; intuition.
replace (S(j+n)) with (j+S n) by intuition.
rewrite (IHM2 (S i) j k (S n) ); intuition.
Qed.

Lemma liftP3 : forall M i k j n , i <= k -> k <= (i+n) ->
  (M ↑ n # i) ↑ j # k = M ↑ (j+n) # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); simpl.
destruct (le_gt_dec k (n+v)); intuition.
elim (lt_irrefl (i+n)). apply lt_le_trans with k.
apply le_lt_trans with (n+v). rewrite plus_comm. intuition. intuition. trivial.
destruct (le_gt_dec k v); intuition. elim (lt_irrefl k).
apply lt_le_trans with i.  apply le_lt_trans with v. trivial. intuition. trivial.
reflexivity.
rewrite IHM1; intuition;rewrite IHM2; intuition.
rewrite IHM1; intuition;rewrite IHM2; intuition. change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition; rewrite IHM2; intuition. change (S i + n) with (S (i+n)). intuition.
Qed.

Lemma lift_lift : forall M n m, (M ↑ m) ↑ n  = M↑ (n+m).
intros.
apply liftP3; intuition.
Qed.

(** We will consider the usual implicit substitution without variable capture
(this is where the lift operator comes in handy).
  [ M [ n ← N ] ] replace the variable [n] in [M] by the term [N].
  *)
Reserved Notation "t [ x ← u ]" (at level 5, x at level 0, left associativity).

Fixpoint subst_rec U T n {struct T} :=
 match T with
  | # x => match (lt_eq_lt_dec x n) with
      | inleft (left _) => # x (* v < n *)
      | inleft (right _) => U ↑ n  (* v = n *)
      | inright _ => # (x - 1) (* v > n *)
      end
  | ! s => ! s
  | M · N => (M [ n ← U ]) · ( N [ n ← U ])
  | Π ( A ), B => Π ( A [ n ← U ] ), (B [ S n ← U ])
  | λ [ A ], M => λ [ A [ n ← U ] ], (M [ S n ← U ])
end
    where " t [ n ← w ] " := (subst_rec w t n) : UT_scope.

Notation " t [ ← w ] " := (subst_rec w t 0) (at level 5) : UT_scope.

(** Some basic properties of the substitution function. Again, we will only need
a few functions to deal with indexes. *)

Lemma substP1: forall M N i j k ,
  ( M [ j ← N] ) ↑ k # (j+i) = (M ↑ k # (S (j+i))) [ j ← (N ↑ k # i ) ].
intros M; induction M; intros.
simpl (#v [j ← N] ↑ k # (j+i)).
change (#v ↑ k # (S (j+i))) with  (if le_gt_dec (S (j+i)) v then #(k+v) else #v).
destruct (lt_eq_lt_dec v j) as [[] | ].
destruct (le_gt_dec (S (j+i)) v).
elim (lt_irrefl v). apply lt_le_trans with j; intuition.
apply le_trans with (S (j+i)); intuition.
simpl.
destruct (le_gt_dec (j+i) v).
elim (lt_irrefl v). apply lt_le_trans with j; intuition. apply le_trans with (j+i); intuition.
destruct (lt_eq_lt_dec v j) as [[] | ]. trivial.
subst. elim (lt_irrefl j);trivial.
elim (lt_irrefl j); apply lt_trans with v; trivial.
destruct (le_gt_dec (S(j+i)) v). subst.
elim (lt_irrefl j). apply lt_le_trans with (S (j+i)). intuition. trivial.
simpl. destruct (lt_eq_lt_dec v j) as [[] | ].
subst. elim (lt_irrefl j); trivial.
apply liftP2; intuition.
subst. elim (lt_irrefl j); trivial.
destruct (le_gt_dec (S (j+i)) v).
simpl.
destruct (le_gt_dec (j+i) (v-1)). destruct (lt_eq_lt_dec (k+v) j) as [[] | ].
elim (lt_irrefl j). apply lt_le_trans with v. trivial. induction k; intuition.
subst. elim (lt_irrefl v). apply lt_le_trans with (S(k+v+i)). intuition. trivial.
destruct v. apply lt_n_O in l; elim l. rewrite <- 2! pred_of_minus. replace (k+ S v) with (S (k+v)) by intuition.
simpl. trivial.
elim (lt_irrefl v). apply lt_le_trans with (S (j+i)). destruct v. apply lt_n_O in l; elim l.
rewrite <- pred_of_minus in g. simpl in g. intuition. trivial.
simpl.
destruct (le_gt_dec (j+i) (v-1)). destruct (lt_eq_lt_dec v j) as [[] | ].
elim (lt_irrefl j); apply lt_trans with v; trivial.
subst. elim (lt_irrefl j); trivial.
elim (lt_irrefl v). apply lt_le_trans with (S (j+i)). intuition.
destruct v. apply lt_n_O in l; elim l. rewrite <- pred_of_minus in l0. simpl in l0. intuition.
destruct (lt_eq_lt_dec) as [[] | ]. elim (lt_irrefl j); apply lt_trans with v; trivial.
subst. elim (lt_irrefl j); trivial. trivial.
simpl; trivial.
simpl; rewrite IHM1; intuition; rewrite IHM2; intuition.
simpl; rewrite IHM1; intuition.
replace (S(S(j+i))) with (S((S j)+i)) by intuition.
rewrite <- (IHM2 N i (S j)  k ); intuition.
simpl; rewrite IHM1; intuition.
replace (S(S(j+i))) with ((S ((S j)+i))) by intuition.
rewrite <- (IHM2 N i (S j)  k ); intuition.
Qed.

Lemma substP2: forall M N i j n, i <= n ->
  (M ↑ j # i ) [ j+n ← N ] = ( M [ n ← N]) ↑ j # i .
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); destruct (lt_eq_lt_dec v n) as [[] | ].
simpl.
destruct (le_gt_dec i v).  destruct (lt_eq_lt_dec (j+v) (j+n)) as [[] | ].
reflexivity.
apply plus_reg_l in e. subst. elim (lt_irrefl n); trivial.
apply plus_lt_reg_l in l2. elim (lt_asym v n); trivial.
elim (lt_irrefl i). apply le_lt_trans with v; intuition. subst.
simpl.
destruct (lt_eq_lt_dec (j+n) (j+n)) as [[] | ].
apply lt_irrefl in l0; elim l0.
symmetry.
apply liftP3; intuition.
apply lt_irrefl in l0; elim l0.
simpl.
destruct (le_gt_dec i (v-1)). destruct (lt_eq_lt_dec (j+v) (j+n))as [[] | ].
apply plus_lt_reg_l in l2. elim (lt_asym  v n ); trivial.
apply plus_reg_l in e; subst. elim (lt_irrefl n); trivial.
destruct v. apply lt_n_O in l0; elim l0. rewrite <- 2! pred_of_minus. replace (j+ S v) with (S (j+v)) by intuition.
simpl. trivial.
unfold gt in g. unfold lt in g. rewrite <- pred_of_minus in g.
rewrite <- (S_pred  v n l0) in g.
elim (lt_irrefl n). apply lt_le_trans with v; trivial. apply le_trans with i; trivial.
simpl.
destruct (le_gt_dec i v).  elim (lt_irrefl i). apply le_lt_trans with v; trivial.
destruct (lt_eq_lt_dec v (j+n)) as [[] | ]. reflexivity.
subst. elim (lt_irrefl n). apply le_lt_trans with (j+n); intuition.
elim (lt_irrefl n). apply lt_trans with v.  apply le_lt_trans with (j+n); intuition. trivial.
simpl. subst.
elim (lt_irrefl n). apply lt_le_trans with i; intuition.
simpl. elim (lt_irrefl n). apply lt_le_trans with v; intuition.
apply le_trans with i; intuition.
trivial.

rewrite IHM1; intuition;rewrite IHM2; intuition.
rewrite IHM1; intuition;
rewrite <- (IHM2 N (S i) j (S n)); intuition.
replace (S(j+n)) with (j+(S n)) by intuition.
reflexivity.
rewrite IHM1; intuition;
rewrite <- (IHM2 N (S i) j (S n)); intuition.
replace (S(j+n)) with (j+(S n)) by intuition.
reflexivity.
Qed.

Lemma substP3: forall M N i  k n, i <= k -> k <= i+n ->
  (M↑ (S n) # i) [ k← N] = M ↑ n # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v).
unfold subst_rec.
destruct (lt_eq_lt_dec (S(n+v)) k) as [[] | ].
elim (lt_irrefl (i+n)). apply lt_le_trans with k; intuition.
apply le_lt_trans with (v+n). intuition. rewrite plus_comm; intuition.
subst. replace (i+n) with (n+i) in H0 by (apply plus_comm) . replace (S (n+v)) with (n + S v) in H0 by intuition.
apply plus_le_reg_l in H0. elim (lt_irrefl i). apply le_lt_trans with v; intuition.
simpl. rewrite <- minus_n_O. trivial.
simpl. destruct (lt_eq_lt_dec v k) as [[] | ].
reflexivity. subst. elim (lt_irrefl i). apply le_lt_trans with k; intuition.
elim (lt_irrefl k). apply lt_trans with v; trivial. apply lt_le_trans with i; intuition.

reflexivity.
rewrite IHM1; intuition;rewrite IHM2; intuition.
rewrite IHM1; intuition; rewrite <- (IHM2 N (S i) (S k) n); intuition.
change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition; rewrite <- (IHM2 N (S i) (S k) n); intuition.
change (S i + n) with (S (i+n)). intuition.
Qed.

Lemma substP4: forall M N P i j,
   (M [ i← N]) [i+j ← P] = (M [S(i+j) ← P]) [i← N[j← P]].
intro M; induction M; intros; simpl.
destruct (lt_eq_lt_dec v i) as [[] | ] ; destruct (lt_eq_lt_dec v (S(i+j))) as [[] | ].
simpl.
destruct (lt_eq_lt_dec v (i+j)) as [[] | ]. destruct (lt_eq_lt_dec v i) as [[] | ].
trivial.
subst. apply lt_irrefl in l; elim l. elim ( lt_asym v i); trivial.
subst. rewrite plus_comm in l. elim (lt_irrefl i). induction j; simpl in *; intuition.
elim (lt_irrefl i). apply le_lt_trans with v;intuition. rewrite plus_comm in l1; intuition.  induction j; simpl in *; intuition.
subst. elim (lt_irrefl i). apply lt_trans with (S (i+j)); intuition.
elim (lt_irrefl i). apply lt_trans with (S (i+j)); intuition. apply lt_trans with v; trivial.
simpl. subst. destruct (lt_eq_lt_dec i i) as [[] | ].
elim (lt_irrefl i); trivial. apply substP2; intuition.
elim (lt_irrefl i); trivial.
subst. rewrite plus_comm in e0. apply succ_plus_discr in e0. elim e0.
subst. elim (lt_irrefl i). apply le_lt_trans with (i+j); intuition.
simpl.
destruct (lt_eq_lt_dec (v-1) (i+j)) as  [[] | ]. destruct (lt_eq_lt_dec v i) as [[] | ].
elim (lt_asym v i); trivial. subst. elim (lt_irrefl i); trivial.
trivial. rewrite <- e in l0. rewrite <- pred_of_minus in l0.
rewrite <- (S_pred  v i l) in l0. elim (lt_irrefl v); trivial.
apply lt_n_S in l1. elim (lt_irrefl v).
apply lt_trans with (S(i+j)); trivial.
rewrite <- pred_of_minus in l1. rewrite <- (S_pred  v i l) in l1. trivial.
subst. simpl. rewrite <- minus_n_O.
destruct (lt_eq_lt_dec (i+j) (i+j)) as [[] | ].
elim (lt_irrefl (i+j)) ; trivial.
symmetry. apply substP3; intuition.
elim (lt_irrefl (i+j)) ; trivial.
simpl.
destruct (lt_eq_lt_dec (v-1) (i+j)) as  [[] | ].
elim (lt_irrefl v). apply lt_trans with (S (i+j)) ;trivial.
apply lt_n_S in l1. rewrite <- pred_of_minus in l1. rewrite <- (S_pred v i l) in l1. trivial.
apply eq_S in e. rewrite <- pred_of_minus in e. rewrite <- (S_pred v i l) in e.
subst. elim (lt_irrefl (S(i+j))); trivial.
destruct (lt_eq_lt_dec (v-1) i) as [[] | ].
elim (lt_irrefl v). apply le_lt_trans with i; trivial. destruct v. apply lt_n_O in l; elim l.
rewrite <- pred_of_minus in l2. simpl in l2. trivial.
destruct v. elim (lt_n_O i); trivial. rewrite <- pred_of_minus in e. simpl in e. subst.
rewrite <- pred_of_minus in l1. simpl in l1. elim (lt_irrefl i).
apply le_lt_trans with (i+j); intuition.
trivial.
trivial.
rewrite IHM1; rewrite IHM2; intuition.
rewrite IHM1; replace (S(S(i+j))) with (S((S i)+ j)) by intuition;
  rewrite <- (IHM2 N P (S i)); replace (S(i+j)) with ((S i)+ j) by intuition; intuition.
rewrite IHM1; replace (S(S(i+j))) with (S((S i)+j)) by intuition;
  rewrite <- (IHM2 N P (S i)); replace (S(i+j)) with ((S i)+ j) by intuition; intuition.
Qed.

Lemma subst_travers :
 forall  M N P n, (M [← N]) [n ← P] = (M [n+1 ← P])[← N[n← P]].
intros.
rewrite plus_comm. change n with (O+n). apply substP4.
Qed.

(** Tool function usefull when eta-conversion is used, but this is not the case
here. *)
Lemma expand_term_with_subst : forall M n, (M ↑ 1 # (S n)) [ n ← #0 ] = M.
induction M; intros.
unfold lift_rec.
destruct (le_gt_dec (S n) v). unfold subst_rec.
destruct (lt_eq_lt_dec (1+v) n) as [[] | ].
apply le_not_lt in l. elim l. intuition.
elim (lt_irrefl v). apply lt_le_trans with (S (S v)). intuition. subst; trivial.
change (1+v) with (S v). destruct v; simpl; trivial.
simpl.
destruct (lt_eq_lt_dec v n) as [[] | ].
trivial.
simpl; subst; trivial.
rewrite <- plus_n_O. trivial.
elim (lt_irrefl n). apply lt_le_trans with v; intuition.
simpl; trivial.
simpl. rewrite IHM1. rewrite IHM2. reflexivity.
simpl. rewrite IHM1. rewrite IHM2. reflexivity.
simpl. rewrite IHM1. rewrite IHM2. reflexivity.
Qed.

End ut_term_mod.


(** * The conditional probabilistic guarded command language (cpGCL) syntax. *)

From Coq Require Import
  Basics
  QArith
  String.

Local Open Scope program_scope.

Declare Scope cpGCL_scope.

From zar Require Import cpo misc order.

(** Values are bools, nats, ints, or rationals. *)
Variant val : Type :=
| vbool : bool -> val
| vnat : nat -> val
| vint : Z -> val
| vrat : Q -> val.

(** A program state is a map from identifiers (nat for now) to values. *)
Definition St : Set := string -> val.
Definition empty : St := fun _ => vbool false.
Definition upd (x : string) (v : val) (st : St) : St :=
  fun y => if String.eqb y x then v else st y.

#[global]
  Instance Inhabited_St : Inhabited St :=
  {| el := empty |}.

(** An expression is a function from program states to values. *)
Definition expr := St -> val.

Definition is_bool (v : val) : bool :=
  match v with
  | vbool _ => true
  | _ => false
  end.

Definition is_nat (v : val) : bool :=
  match v with
  | vnat _ => true
  | _ => false
  end.

Definition is_int (v : val) : bool :=
  match v with
  | vint _ => true
  | _ => false
  end.

Definition is_rat (v : val) : bool :=
  match v with
  | vrat _ => true
  | _ => false
  end.

Definition as_bool (v : val) : bool :=
  match v with
  | vbool b => b
  | _ => false
  end.

Definition as_nat (v : val) : nat :=
  match v with
  | vnat n => n
  | _ => O
  end.

Definition as_int (v : val) : Z :=
  match v with
  | vint n => n
  | _ => Z0
  end.

Definition as_rat (v : val) : Q :=
  match v with
  | vrat q => q
  | _ => 0
  end.

Inductive cpGCL : Type :=
| CSkip : cpGCL
| CAbort : cpGCL
| CAssign : string -> expr -> cpGCL
| CSeq : cpGCL -> cpGCL -> cpGCL
| CIte : (St -> bool) -> cpGCL -> cpGCL -> cpGCL
| CChoice : (St -> Q) -> (bool -> cpGCL) -> cpGCL
| CUniform : (St -> nat) -> (nat -> cpGCL) -> cpGCL
| CWhile : (St -> bool) -> cpGCL -> cpGCL
| CObserve : (St -> bool) -> cpGCL.

Definition CScore (e : St -> Q) : cpGCL :=
  CChoice e (fun b => if b then CSkip else CObserve (const false)).

Definition unroll_while (e : St -> bool) (c : cpGCL) : cpGCL :=
  CIte e (CSeq c (CWhile e c)) CSkip.

Definition const_val : val -> expr := const.

Coercion vbool : bool >-> val.
Coercion vnat : nat >-> val.
Coercion vint : Z >-> val.
Coercion vrat : Q >-> val.
Coercion const_val : val >-> expr.

(* Coercion as_bool : val >-> bool. *)

Notation "'skip'" :=
  CSkip (at level 0) : cpGCL_scope.
Notation "'abort'" :=
  CAbort (at level 0) : cpGCL_scope.
Notation "x <-- e" :=
  (CAssign x e)
    (at level 0, e at level 85, no associativity) : cpGCL_scope.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 90, right associativity) : cpGCL_scope.
Notation "'if' e 'then' c1 'else' c2 'end'" :=
  (CIte e c1 c2) (at level 89, e at level 99,
      c1 at level 99, c2 at level 99) : cpGCL_scope.
(* Notation "{ c1 } [ p ] { c2 }" := *)
(*   (CChoice p c1 c2) (at level 89, p at level 99, *)
(*       c1 at level 99, c2 at level 99) : cpGCL_scope. *)
(* Notation "'while' e { c }" := *)
(*   (CWhile e c) (at level 89, e at level 99, c at level 99) : cpGCL_scope. *)
Notation "'while' e 'do' c 'end'" :=
  (CWhile e c) (at level 89, e at level 99, c at level 99) : cpGCL_scope.
Notation "'obs' e" :=
  (CObserve e) (at level 0, e at level 85, no associativity) : cpGCL_scope.
(* Notation "{ c1 } [ p ] { c2 }" := *)
(*   (CChoice p c1 c2) (at level 89, p at level 99, *)
(*       c1 at level 99, c2 at level 99) : cpGCL_scope. *)

(* Notation "'unif' e f" := *)
(*   (CUniform e f) (at level 0, e at level 85, f at level 85, no associativity) : cpGCL_scope. *)

(** A cpGCL command is well-formed when all p values in choice
    commands are valid probabilities in all states. *)
(* Could refine to only being valid probabilities in reachable states. *)
Inductive wf_cpGCL : cpGCL -> Type :=
| wf_skip : wf_cpGCL CSkip
| wf_abort : wf_cpGCL CAbort
| wf_assign : forall x e, wf_cpGCL (CAssign x e)
| wf_seq : forall c1 c2,
    wf_cpGCL c1 -> wf_cpGCL c2 -> wf_cpGCL (CSeq c1 c2)
| wf_ite : forall e c1 c2,
    wf_cpGCL c1 -> wf_cpGCL c2 -> wf_cpGCL (CIte e c1 c2)
| wf_choice : forall (e : St -> Q) f,
    (forall s, (0 <= e s <= 1)%Q) ->
    (forall b, wf_cpGCL (f b)) ->
    wf_cpGCL (CChoice e f)
| wf_uniform : forall (e : St -> nat) f,
    (forall s, (0 < e s)%nat) ->
    (forall n, wf_cpGCL (f n)) ->
    wf_cpGCL (CUniform e f)
| wf_while : forall e body, wf_cpGCL body -> wf_cpGCL (CWhile e body)
| wf_observe : forall e, wf_cpGCL (CObserve e).


(** Coq coding by choukh, May 2022 **)

From ZF Require Export Meta.

(** ZF模型的定义 **)

Class ZF结构 := {
  集 : Type;
  属 : 集 → 集 → Prop;
  空 : 集;
  并 : 集 → 集;
  幂 : 集 → 集;
  替 : (集 → 集 → Prop) → 集 → 集
}.

Coercion 集 : ZF结构 >-> Sortclass.

Declare Scope zf_scope.
Delimit Scope zf_scope with zf.
Open Scope zf_scope.

Notation "x ∈ y" := (  属 x y) (at level 70) : zf_scope.
Notation "x ∉ y" := (¬ 属 x y) (at level 70) : zf_scope.

Notation "∀ x .. y ∈ A , P" :=
  (∀ x, x ∈ A → (.. (∀ y, y ∈ A → P) ..))
  (only parsing, at level 200, x binder, right associativity) : zf_scope.

Notation "∃ x .. y ∈ A , P" :=
  (∃ x, x ∈ A ∧ (.. (∃ y, y ∈ A ∧ P) ..))
  (only parsing, at level 200, x binder, right associativity) : zf_scope.

Definition 包含关系 {𝓜 : ZF结构} (A B : 𝓜) := ∀ x, x ∈ A → x ∈ B.
Notation "A ⊆ B" := (  包含关系 A B) (at level 70) : zf_scope.
Notation "A ⊈ B" := (¬ 包含关系 A B) (at level 70) : zf_scope.
Notation "p ⊂ q" := (p ⊆ q ∧ q ⊈ p) (at level 70) : zf_scope.

Notation "∅" := 空 : zf_scope.
Notation "⋃ A" := (并 A) (at level 8, right associativity, format "⋃  A") : zf_scope.
Notation "'𝒫' A" := (幂 A) (at level 9, right associativity, format "'𝒫'  A") : zf_scope.
Notation "R @ A" := (替 R A) (at level 60) : zf_scope.

Inductive 良基 {𝓜 : ZF结构} (A : 𝓜) : Prop :=
  | 良基I : (∀ x ∈ A, 良基 x) → 良基 A.

Class ZF := {
  结构 :> ZF结构;
  外延 : ∀ x y, x ⊆ y → y ⊆ x → x = y;
  空集 : ∀ x, x ∉ ∅;
  并集 : ∀ x A, x ∈ ⋃ A ↔ ∃ y, x ∈ y ∧ y ∈ A;
  幂集 : ∀ x A, x ∈ 𝒫 A ↔ x ⊆ A;
  替代 : ∀ R A, 函数性 R → ∀ y, y ∈ R @ A ↔ ∃ x ∈ A, R x y;
  正则 : ∀ x, 良基 x
}.

Coercion 结构 : ZF >-> ZF结构.
Arguments 正则 {_} _.

(** 涉及类的记法 **)

Notation "x ∈ₚ P" := (P x) (only parsing, at level 70) : zf_scope.
Notation "x ∉ₚ P" := (¬ P x) (only parsing, at level 70) : zf_scope.
Notation "P ⊑ Q" := (∀ x, x ∈ₚ P → x ∈ₚ Q) (at level 70) : zf_scope.
Notation "P ⋢ Q" := (¬ ∀ x, x ∈ₚ P → x ∈ₚ Q) (at level 70) : zf_scope.
Notation "P ⊓ Q" := (λ x, x ∈ₚ P ∧ x ∈ₚ Q) (at level 60) : zf_scope.
Notation "A '⊆ₚ' P" := (∀ x, x ∈ A → x ∈ₚ P) (at level 70) : zf_scope.
Notation "P '⊆ₛ' A" := (∀ x, x ∈ₚ P → x ∈ A) (at level 70) : zf_scope.
Notation "A =ₚ P" := (∀ x, x ∈ A ↔ x ∈ₚ P) (at level 70) : zf_scope.
Notation "'setLike' P" := (∃ A, A =ₚ P) (only parsing, at level 10) : zf_scope.

Notation "∀ x .. y ∈ₚ A , P" :=
  (∀ x, x ∈ₚ A → (.. (∀ y, y ∈ₚ A → P) ..))
  (only parsing, at level 200, x binder, right associativity) : zf_scope.

Notation "∃ x .. y ∈ₚ A , P" :=
  (∃ x, x ∈ₚ A ∧ (.. (∃ y, y ∈ₚ A ∧ P) ..))
  (only parsing, at level 200, x binder, right associativity) : zf_scope.

(** 封闭性 **)
Section Closure.
Context {𝓜 : ZF}.
Implicit Type A a b x y : 𝓜.
Implicit Type P : 𝓜 → Prop.

Definition 传递 x := ∀ y z, y ∈ z → z ∈ x → y ∈ x.
Definition 膨胀 x := ∀ y z, y ⊆ z → z ∈ x → y ∈ x.

Definition 传递类 P := ∀ x y, x ∈ y → y ∈ₚ P → x ∈ₚ P.
Definition 膨胀类 P := ∀ x y, x ⊆ y → y ∈ₚ P → x ∈ₚ P.

Definition 空集封闭 x := ∅ ∈ x.
Definition 并集封闭 x := ∀ y ∈ x, ⋃ y ∈ x.
Definition 幂集封闭 x := ∀ y ∈ x, 𝒫 y ∈ x.

Definition 替代封闭 x := ∀ R y, 函数性 R → (∀ a b, R a b → a ∈ y → b ∈ x) → y ∈ x → R @ y ∈ x.
Definition 替代封闭' x := ∀ R y, 函数性 R → R @ y ⊆ x → y ∈ x → R @ y ∈ x.

Fact 替代封闭_等价表述 x : 替代封闭 x ↔ 替代封闭' x.
Proof.
  split; intros C R A FR H1 H2; apply C; auto.
  - intros a b Rab aA. apply H1.
    apply 替代. auto. now exists a.
  - intros z [y [yA Ryz]]%替代; auto. eapply H1; eauto.
Qed.

Class 封闭类 P : Prop := {
  成员封闭类 : 传递类 P;
  空集封闭类 : ∅ ∈ₚ P;
  并集封闭类 x : x ∈ₚ P → ⋃ x ∈ₚ P;
  幂集封闭类 x : x ∈ₚ P → 𝒫 x ∈ₚ P;
  替代封闭类 R A : 函数性 R →
    (∀ x y, R x y → x ∈ A → y ∈ₚ P) → A ∈ₚ P → R @ A ∈ₚ P
}.

End Closure.

(* 构造化无穷公理 *)
Class Infʷ {𝓜 : ZF} := {
  嵌入 : nat → 𝓜;
  嵌入单射 : ∀ m n, 嵌入 m = 嵌入 n → m = n;
  有穷序数 x := ∃ n, x = 嵌入 n;
  ω : 𝓜;
  无穷 : ω =ₚ 有穷序数
}.

(** 自动化设置 **)

Create HintDb zf discriminated.
Global Hint Constants Transparent : zf.
Global Hint Variables Transparent : zf.

Tactic Notation "zf" := auto with zf.
Tactic Notation "ezf" := eauto with zf.

Global Hint Unfold 包含关系 : zf.
Global Hint Unfold 函数性 : zf.

Global Hint Extern 4 =>
match goal with
  | [ H : _ ∈ ∅ |- _ ] => exfalso; eapply (空集 H)
end : zf.


From iris_examples.logrel.stlc Require Export logrel.
From iris.proofmode Require Import tactics.
From iris_examples.logrel.stlc Require Import rules.
From iris.program_logic Require Import lifting.

Section typed_interp.
  Context `{irisG stlc_lang Σ}.

  Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) constr(Hp) :=
    iApply (wp_bind (fill [ctx]));
    iApply (wp_wand with "[-]"); [iApply Hp; trivial|]; cbn;
    iIntros (v) Hv.

  Theorem fundamental Γ vs e τ :
    Γ ⊢ₜ e : τ → ⟦ Γ ⟧* vs ⊢ ⟦ τ ⟧ₑ e.[env_subst vs].
  Proof.
    intros Htyped; revert vs.
    induction Htyped; iIntros (vs) "#Hctx /=".
    - (* var *)
      iDestruct (interp_env_Some_l with "[]") as (v) "[#H1 #H2]"; eauto;
        iDestruct "H1" as %Heq. erewrite env_subst_lookup; eauto.
      by iApply wp_value.
    - (* unit *) by iApply wp_value.
    - (* pair *)
      smart_wp_bind (PairLCtx e2.[env_subst vs]) v "# Hv" IHHtyped1.
      smart_wp_bind (PairRCtx v) v' "# Hv'" IHHtyped2.
      iApply wp_value; eauto 10.
    - (* fst *)
      smart_wp_bind (FstCtx) v "# Hv" IHHtyped; cbn.
      iDestruct "Hv" as (w1 w2) "#[% [H2 H3]]"; subst.
      iApply wp_pure_step_later; auto. by iApply wp_value.
    - (* snd *)
      smart_wp_bind (SndCtx) v "# Hv" IHHtyped; cbn.
      iDestruct "Hv" as (w1 w2) "#[% [H2 H3]]"; subst.
      iApply wp_pure_step_later; auto. by iApply wp_value.
    - (* injl *)
      smart_wp_bind (InjLCtx) v "# Hv" IHHtyped. by iApply wp_value; eauto.
    - (* injr *)
      smart_wp_bind (InjRCtx) v "# Hv" IHHtyped. by iApply wp_value; eauto.
    - (* case *)
      iDestruct (interp_env_length with "[]") as %Hlen; auto.
      smart_wp_bind (CaseCtx _ _) v "# Hv" IHHtyped1; cbn.
      iDestruct "Hv" as "[Hv|Hv]"; iDestruct "Hv" as (w) "[% Hw]"; subst.
      + simpl. iApply wp_pure_step_later; auto. asimpl.
        specialize (IHHtyped2 (w::vs)).
        iNext. iApply (IHHtyped2). iApply interp_env_cons; by iSplit.
      + simpl. iApply wp_pure_step_later; auto. asimpl.
        specialize (IHHtyped3 (w::vs)).
        iNext. iApply (IHHtyped3). iApply interp_env_cons; by iSplit.
    - (* lam *)
      iDestruct (interp_env_length with "[]") as %Hlen; auto.
      iApply wp_value. simpl. iAlways; iIntros (w) "#Hw".
      iApply wp_pure_step_later; auto.
      asimpl.
      iNext; iApply (IHHtyped (w :: vs)). iApply interp_env_cons; by iSplit.
    - (* app *)
      smart_wp_bind (AppLCtx (e2.[env_subst vs])) v "#Hv" IHHtyped1.
      smart_wp_bind (AppRCtx v) w "#Hw" IHHtyped2.
      iApply "Hv"; auto.
  Qed.
End typed_interp.


Require Import List paco2.
Require Import Util IL.
Require Import SmallStepRelations StateType.

Set Implicit Arguments.
Unset Printing Records.

(** * Non-parametric Definitions of Simulation and Bisimulation *)
(** ** Bisimulation *)
(** A characterization of bisimulation equivalence on states;
    works only for internally deterministic semantics. *)

CoInductive bisim {S} `{StateType S} {S'} `{StateType S'}  : S -> S' -> Prop :=
  | BisimSilent (σ1 σ1':S) (σ2 σ2':S') :
      plus2 step σ1 nil σ1'
      -> plus2 step σ2 nil σ2'
      -> bisim σ1' σ2'
      -> bisim σ1 σ2
  | BisimExtern (pσ1 σ1:S) (pσ2 σ2:S') :
      star2 step pσ1 nil σ1
      -> star2 step pσ2 nil σ2
      -> activated σ1
      -> activated σ2
      -> (forall evt σ1', step σ1 evt σ1' -> exists σ2', step σ2 evt σ2' /\ bisim σ1' σ2')
      -> (forall evt σ2', step σ2 evt σ2' -> exists σ1', step σ1 evt σ1' /\ bisim σ1' σ2')
      -> bisim pσ1 pσ2
  | BisimTerm (σ1 σ1':S) (σ2 σ2':S')
    : result σ1' = result σ2'
      -> star2 step σ1 nil σ1'
      -> star2 step σ2 nil σ2'
      -> normal2 step σ1'
      -> normal2 step σ2'
      -> bisim σ1 σ2.

Arguments bisim [S] {H} [S'] {H0} _ _.

(** *** Bisimulation is an reflexive and symmetric *)
Lemma bisim_refl {S} `{StateType S} (σ:S)
      : bisim σ σ.
Proof.
  revert σ. cofix.
  intros. destruct (step_dec σ) as [[[] []]|].
  - eapply BisimExtern; intros; eauto using star2_refl; eexists; eauto.
  - eapply BisimSilent; eauto using plus2O.
  - eapply BisimTerm; eauto using star2_refl.
Qed.

Lemma bisim_sym {S} `{StateType S} {S'} `{StateType S'} (σ:S) (σ':S')
      : bisim σ σ' -> bisim σ' σ.
Proof.
  revert σ σ'. cofix; intros.
  inv H1.
  - eapply BisimSilent; eauto.
  - eapply BisimExtern; eauto; intros.
    edestruct H7; eauto; dcr. eexists; eauto.
    edestruct H6; eauto; dcr. eexists; eauto.
  - eapply BisimTerm; eauto using star2_refl.
Qed.

(** ** Simulation *)

CoInductive sim {S} `{StateType S} {S'} `{StateType S'}  : S -> S' -> Prop :=
  | SimSilent (σ1 σ1':S) (σ2 σ2':S') :
      plus2 step σ1 nil σ1'
      -> plus2 step σ2 nil σ2'
      -> sim σ1' σ2'
      -> sim σ1 σ2
  | SimExtern (pσ1 σ1:S) (pσ2 σ2:S') :
      star2 step pσ1 nil σ1
      -> star2 step pσ2 nil σ2
      -> activated σ1
      -> activated σ2
      -> (forall evt σ2', step σ2 evt σ2' -> exists σ1', step σ1 evt σ1' /\ sim σ1' σ2')
      -> sim pσ1 pσ2
  | SimTerm (σ1 σ1':S) (σ2 σ2':S')
    : result σ1' = result σ2'
      -> star2 step σ1 nil σ1'
      -> star2 step σ2 nil σ2'
      -> normal2 step σ1'
      -> normal2 step σ2'
      -> sim σ1 σ2
  | SimErr (σ1 σ1':S) (σ2:S')
    : result σ1' = None
      -> star2 step σ1 nil σ1'
      -> normal2 step σ1'
      -> sim σ1 σ2.

Arguments bisim [S] {H} [S'] {H0} _ _.

(** *** Simulation is an reflexive *)

Lemma sim_refl {S} `{StateType S} (σ:S)
      : sim σ σ.
Proof.
  revert σ. cofix.
  intros. destruct (step_dec σ) as [[[] []]|].
  - eapply SimExtern; intros; eauto using star2_refl; eexists; eauto.
  - eapply SimSilent; eauto using plus2O.
  - eapply SimTerm; eauto using star2_refl.
Qed.

(** Receptive and determinate according to CompCertTSO (Sevcík 2013) *)

Definition same_call (e e':extern) := extern_fnc e = extern_fnc e' /\ extern_args e = extern_args e'.

Definition receptive S `{StateType S} :=
  forall σ σ' ext, step σ (EvtExtern ext) σ'
              -> forall ext', same_call ext ext' -> exists σ'', step σ (EvtExtern ext') σ''.

Arguments receptive S [H].

Definition determinate S `{StateType S} :=
  forall σ σ' σ'' ext ext', step σ (EvtExtern ext) σ'
              -> step σ (EvtExtern ext') σ'' -> same_call ext ext'.

Arguments determinate S [H].

Lemma bisimExternDet {S} `{StateType S} {S'} `{StateType S'} (pσ1:S) (pσ2:S') (σ1:S) (σ2:S')
      (RCPT:receptive S) (DET:determinate S')
: star2 step pσ1 nil σ1
  -> star2 step pσ2 nil σ2
  -> activated σ1
  -> (forall evt σ1', step σ1 evt σ1' -> exists σ2', step σ2 evt σ2' /\ bisim σ1' σ2')
  -> bisim pσ1 pσ2.
Proof.
  intros.
  econstructor 2; eauto.
  - inv H3. dcr. edestruct H4; eauto. firstorder.
  - intros. inv H3. dcr. exploit H4; eauto; dcr.
    destruct evt.
    + exploit DET. eauto. eapply H5.
      exploit RCPT; eauto. dcr.
      exploit H4. eapply H11. dcr.
      eexists; split. eapply H11.
      exploit step_externally_determined. Focus 3.
      instantiate (2:=σ2') in H8. rewrite H8. eapply H14.
      eauto. eauto.
    + exfalso. exploit step_internally_deterministic; eauto; dcr. congruence.
Qed.

Lemma bisim_expansion_closed {S} `{StateType S}
      (σ1 σ1':S) {S'} `{StateType S'} (σ2 σ2':S')
  : bisim σ1' σ2'
    -> star2 step σ1 nil σ1'
    -> star2 step σ2 nil σ2'
    -> bisim σ1 σ2.
Proof.
  intros SIM ? ?.
  inversion SIM; subst;
    eauto using bisim, star2_plus2_plus2_silent, star2_trans_silent.
Qed.

Lemma bisim_reduction_closed {S} `{StateType S}
      (σ1 σ1':S) {S'} `{StateType S'} (σ2:S')
  : bisim σ1 σ2
    -> star2 step σ1 nil σ1'
    -> bisim σ1' σ2.
Proof.
  intros Sim Star. eapply star2_star2n in Star. destruct Star as [n StarN].
  revert σ1 σ1' σ2 Sim StarN.
  size induction n.
  inv Sim.
  - invc StarN; eauto; relsimpl.
    eapply star2_star2n in H2. destruct H2 as [n' H2].
    edestruct (star2n_reach H9 H2); eauto. eapply H.
    + eapply bisim_expansion_closed; eauto using star2n_star2, plus2_star2.
    + eapply H1; try eapply H9. omega.
      eapply bisim_expansion_closed;
        eauto using star2n_star2, plus2_star2.
  - eapply star2n_star2 in StarN; relsimpl; eauto using bisim.
  - eapply star2n_star2 in StarN; relsimpl; eauto using bisim.
Qed.

Lemma bisim_reduction_closed_both {S} `{StateType S}
      (σ1 σ1':S) {S'} `{StateType S'} (σ2 σ2':S')
  : bisim σ1 σ2
    -> star2 step σ1 nil σ1'
    -> star2 step σ2 nil σ2'
    -> bisim σ1' σ2'.
Proof.
  intros. eapply bisim_reduction_closed; eauto.
  eapply bisim_sym. eapply bisim_reduction_closed; eauto.
  eapply bisim_sym. eauto.
Qed.

Lemma bisim_terminate {S1} `{StateType S1} (σ1 σ1':S1)
      {S2} `{StateType S2} (σ2:S2)
: star2 step σ1 nil σ1'
  -> normal2 step σ1'
  -> bisim σ1 σ2
  -> exists σ2', star2 step σ2 nil σ2' /\ normal2 step σ2' /\ result σ1' = result σ2'.
Proof.
  intros. general induction H1.
  - inv H3; subst.
    + exfalso. eapply H2. inv H1; do 2 eexists; eauto.
    + exfalso. eapply star2_normal in H1; eauto. subst.
      eapply (activated_normal _ H5); eauto.
    + eapply star2_normal in H4; eauto; subst.
      eexists; split; eauto.
  - destruct y; isabsurd. simpl.
    eapply IHstar2; eauto.
    eapply bisim_reduction_closed; eauto using star2, star2_silent.
Qed.

Lemma bisim_activated {S1} `{StateType S1} (σ1:S1)
      {S2} `{StateType S2} (σ2:S2)
: activated σ1
  -> bisim σ1 σ2
  -> exists σ2', star2 step σ2 nil σ2' /\ activated σ2' /\
           ( forall (evt : event) (σ1'' : S1),
               step σ1 evt σ1'' ->
               exists σ2'' : S2,
                 step σ2' evt σ2'' /\
                 (bisim σ1'' σ2''))
           /\
           ( forall (evt : event) (σ2'' : S2),
               step σ2' evt σ2'' ->
               exists σ1' : S1,
                 step σ1 evt σ1' /\
                 (bisim σ1' σ2'')).
Proof.
  intros.
  inv H2; subst.
  -  exfalso. edestruct (plus2_destr_nil H3); dcr.
     destruct H1 as [? []].
     exploit (step_internally_deterministic _ _ _ _ H7 H1); dcr; congruence.
  - assert (σ1 = σ0). {
      eapply activated_star_eq; eauto.
    }
    subst σ1.
    eexists σ3; split; eauto.
  - exfalso. refine (activated_normal_star _ H1 _ _); eauto using star2.
Qed.


(* Chap 16 Auto *)
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import omega.Omega.
From LF Require Import Maps.
From LF Require Import Imp.

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

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> 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.
    { apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b = true *)
    apply IHE1. assumption.
  - (* b = false *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b = true *)
    rewrite H in H5. inversion H5.
  - (* b = false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b = false *)
    reflexivity.
  - (* b = true *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b = false *)
    rewrite H in H4. inversion H4.
  - (* b = true *)
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
Qed.

(* Chap 16.1 The auto Tactic *)
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.

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

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.

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.
  auto.
  auto 6.
Qed.

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

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.

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

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

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

Theorem ceval_deterministic': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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 *)
    + rewrite H in H5. discriminate.
  - (* E_IfFalse *)
    + rewrite H in H5. discriminate.
  - (* E_WhileFalse *)
    + rewrite H in H2. discriminate.
  - (* E_WhileTrue, b = false *)
    rewrite H in H4. discriminate.
  - (* E_WhileTrue, b = true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0. auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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 *)
    + rewrite H in H5. discriminate.
  - (* E_IfFalse *)
    + rewrite H in H5. discriminate.
  - (* E_WhileFalse *)
    + rewrite H in H2. discriminate.
  - (* E_WhileTrue, b = false *)
    rewrite H in H4. discriminate.
  - (* E_WhileTrue, b = true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* Chap 16.2 Searching For Hypotheses *)
Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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 *)
    + rwinv H5 H.
  - (* E_IfFalse *)
    + rwinv H5 H.
  - (* E_WhileFalse *)
    + rwinv H2 H.
  - (* E_WhileTrue, b = false *)
    rwinv H4 H.
  - (* E_WhileTrue, b = true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0. auto.
Qed.

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

Theorem ceval_deterministic''': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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 = true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0. auto.
Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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 = true *)
    rewrite (IHE1_1 st'0 H3) in *. auto.
Qed.

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

Theorem ceval_deterministic''''': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> 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.

Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAss (x: string) (a: aexp)
  | CSeq (c1 c2: com)
  | CIf (b: bexp) (c1 c2: com)
  | CWhile (b: bexp) (c: com)
  | CRepeat (c: com) (b: bexp).

Notation "'SKIP'" :=
   CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'REPEAT' c 'UNTIL' b 'END'" :=
  (CRepeat c b) (at level 80, right associativity).

Reserved Notation "st '=[' c ']=>' st'"
                  (at level 40, st' at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st =[ WHILE b DO c END ]=> st''
  | E_RepeatEnd : forall st st' b c,
      st =[ c ]=> st' ->
      beval st' b = true ->
      st =[ REPEAT c UNTIL b END ]=> st'
  | E_RepeatLoop : forall st st' st'' b c,
      st =[ c ]=> st' ->
      beval st' b = false ->
      st' =[ REPEAT c UNTIL b END ]=> st'' ->
      st =[ REPEAT c UNTIL b END ]=> st''
where "st =[ c ]=> st'" := (ceval c st st').

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> 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 *)
    + find_rwinv.
  - (* E_RepeatLoop *)
     + find_rwinv.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> 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.

(*** eapply & eauto ***)
Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq.
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity.
    apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.
Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example: exists s',
  st21 =[ TEST X <= Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]=> s'.
Proof. eauto. Qed.

(* eauto & eapply is slower,
   we prefer to use auto & apply! *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(*i $Id: DoubleType.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import ZArith.
Local Open Scope Z_scope.

Definition base digits := Zpower 2 (Zpos digits).

Section Carry.

 Variable A : Type.

 Inductive carry :=
  | C0 : A -> carry
  | C1 : A -> carry.

 Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c :=
  match c with
  | C0 x => interp x
  | C1 x => sign*B + interp x
  end.

End Carry.

Section Zn2Z.

 Variable znz : Type.

 (** From a type [znz] representing a cyclic structure Z/nZ,
     we produce a representation of Z/2nZ by pairs of elements of [znz]
     (plus a special case for zero). High half of the new number comes
     first.
 *)

 Inductive zn2z :=
  | W0 : zn2z
  | WW : znz -> znz -> zn2z.

 Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) :=
  match x with
  | W0 => 0
  | WW xh xl => w_to_Z xh * wB + w_to_Z xl
  end.

End Zn2Z.

Implicit Arguments W0 [znz].

(** From a cyclic representation [w], we iterate the [zn2z] construct
    [n] times, gaining the type of binary trees of depth at most [n],
    whose leafs are either W0 (if depth < n) or elements of w
    (if depth = n).
*)

Fixpoint word (w:Type) (n:nat) : Type :=
 match n with
 | O => w
 | S n => zn2z (word w n)
 end.