Require Import CContext.
Require Import Types.
Require Import String.
Require Import Maps.

(* at its core, everything in C can be modeled as a natural **)
Definition CCore_Value :=
  nat.

Inductive CCore_exp :=
| CVal: CCore_Value -> CCore_exp
| CAddr: string -> CCore_exp
| CVar: string -> CCore_exp
| CPlus: CCore_exp -> CCore_exp -> CCore_exp
| CMinus: CCore_exp -> CCore_exp -> CCore_exp
| CMult: CCore_exp -> CCore_exp -> CCore_exp
(* | CDiv: CCore_exp -> CCore_exp -> CCore_exp **)
| CEq: CCore_exp -> CCore_exp -> CCore_exp
| CLt: CCore_exp -> CCore_exp -> CCore_exp
| CAnd: CCore_exp -> CCore_exp -> CCore_exp
| CPtr: CCore_Value -> CCore_exp
(* | CStruct: forall xl, struct xl -> string -> CCore_exp.
 how do I do this? **)
| CStruct: string -> string -> CCore_exp.

Inductive C_exp :=
| C_mod: C_exp -> C_exp -> C_exp (* a % b **)
| C_u_plus: C_exp -> C_exp (* +a **)
| C_u_min: C_exp -> C_exp (* -a **)
| C_neq: C_exp -> C_exp -> C_exp (* a != b **)
| C_gt: C_exp -> C_exp -> C_exp (* a > b **)
| C_ge: C_exp -> C_exp -> C_exp (* a >= b **)
| C_le: C_exp -> C_exp -> C_exp (*a <= b **)
| C_not: C_exp -> C_exp (* !a **)
| C_or: C_exp -> C_exp -> C_exp (* a || b **)
| C_deref: CCore_Value -> C_exp -> C_exp (* A[b] **)
| C_arrow: CCore_Value -> string -> C_exp
| C_tern: C_exp -> C_exp -> C_exp -> C_exp (* a ? b : c **).

Bind Scope Exp_scope with C_exp.
Bind Scope Exp_scope with CCore_exp.
Delimit Scope Exp_scope with Ccom.

Notation "a '_[_' b '_]'"
  := (C_mod a b) (at level 105, left associativity) : Exp_scope.

Notation "a '_._' b"
  := (CStruct a b) (at level 105, left associativity) : Exp_scope.

Notation "a '_->_' b"
  := (C_arrow a b) (at level 105, left associativity) : Exp_scope.

Notation "'+_' a"
  := (C_u_plus a) (at level 80) :  Exp_scope.

Notation "'-_' a"
  := (C_u_min a) (at level 80) : Exp_scope.

Notation "'!_' a"
  := (C_not a) (at level 80) : Exp_scope.

Notation "'*_' a"
  := (CPtr a) (at level 80) : Exp_scope.

Notation "'&_' a"
  := (CAddr a) (at level 80) : Exp_scope.

Notation "a '_*_' b"
  := (CMult a b) (at level 50, left associativity) : Exp_scope.

Notation "a '_%_' b"
  := (CMult a b) (at level 50, left associativity) : Exp_scope.

Notation "a '_+_' b"
  := (CPlus a b) (at level 50, left associativity) : Exp_scope.

Notation "a '_-_' b"
  := (CMinus a b) (at level 50, left associativity) : Exp_scope.

Notation "a '_==_' b"
  := (CEq a b) (at level 38, left associativity) : Exp_scope.

Notation "a '_!=_' b"
  := (C_neq a b) (at level 38, left associativity) : Exp_scope.

Notation "a '_<_' b"
  := (CLt a b) (at level 38, left associativity) : Exp_scope.

Notation "a '_<=_' b"
  := (C_le a b) (at level 38, left associativity) : Exp_scope.

Notation "a '_>_' b"
  := (C_gt a b) (at level 38, left associativity) : Exp_scope.

Notation "a '_>=_' b"
  := (C_ge a b) (at level 38, left associativity) : Exp_scope.

Notation "a _&&_ b"
  := (CAnd a b) (at level 25, left associativity) : Exp_scope.

Notation "a _||_ b"
  := (C_or a b) (at level 24, left associativity) : Exp_scope.

Notation "a _?_ b _:_ c"
  := (C_tern a b c) (at level 23, right associativity) : Exp_scope.

Open Scope Exp_scope.
Reserved Notation " ctx '>>' exp '>>>' exp'" (at level 40).
Inductive E_eval : context -> CCore_exp -> CCore_exp -> Prop :=
| E_Eval_Var_s: forall s st h ht ctx str n,
    space s st h ht = ctx ->
    lookup_s s st str = Some n ->
    ctx >> CVar str >>> CVal n
| E_Eval_Var_h: forall s st h ht ctx str n,
    space s st h ht = ctx ->
    lookup_h h ht str = Some n ->
    ctx >> CVar str >>> CVal n
| E_Eval_Addr_s: forall s st h ht ctx str addr,
    space s st h ht = ctx ->
    addr_s st str = Some addr ->
    ctx >> &_ str >>> CVal addr
| E_Eval_Addr_h: forall s st h ht ctx str addr,
    space s st h ht = ctx ->
    addr_h ht str = Some addr ->
    ctx >> &_ str >>> CVal addr
| E_Eval_Plus_l: forall ctx (expl expl' expr: CCore_exp),
    ctx >> expl >>> expl' ->
    ctx >> (expl _+_ expr) >>> (expl' _+_ expr)
| E_Eval_Plus_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _+_ expr) >>> (expl _+_ expr')
| E_Eval_Plus_c: forall ctx n1 n2,
    ctx >>  ((CVal n1) _+_ (CVal n2)) >>> CVal (n1 + n2)
| E_Eval_Min_l: forall ctx expl expl' expr,
    ctx >> expl >>> expl' ->
    ctx >> (expl _-_ expr) >>> (expl' _-_ expr)
| E_Eval_Min_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _-_ expr) >>> (expl _-_ expr')
| E_Eval_Min_c: forall ctx n1 n2,
    ctx >> ((CVal n1) _-_ (CVal n2)) >>> CVal (n1 - n2)
| E_Eval_Mult_l: forall ctx expl expl' expr,
    ctx >> expl >>> expl' ->
    ctx >> (expl _*_ expr) >>> (expl' _*_ expr)
| E_Eval_Mult_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _*_ expr) >>> (expl _*_ expr')
| E_Eval_Mult_c: forall ctx n1 n2,
    ctx >> ((CVal n1) _*_ (CVal n2)) >>> CVal (n1 * n2)
| E_Eval_Eq_l: forall ctx expl expl' expr,
    ctx >> expl >>> expl' ->
    ctx >> (expl _==_ expr) >>> (expl' _==_ expr)
| E_Eval_Eq_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _==_ expr) >>> (expl _==_ expr')
| E_Eval_Eq_c_tru: forall ctx n1 n2,
    n1 = n2 ->
    ctx >> ((CVal n1) _==_ (CVal n2)) >>> CVal 0
| E_Eval_Eq_c_fls: forall ctx n1 n2,
    n1 <> n2 ->
    ctx >> ((CVal n1) _==_ (CVal n2)) >>> CVal 1
| E_Eval_Lt_l: forall ctx expl expl' expr,
    ctx >> expl >>> expl' ->
    ctx >> (expl _<_ expr) >>> (expl' _<_ expr)
| E_Eval_Lt_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _<_ expr) >>> (expl _<_ expr')
| E_Eval_Lt_c_tru: forall ctx n1 n2,
    n1 < n2 ->
    ctx >> ((CVal n1) _<_ (CVal n2)) >>> CVal 0
| E_Eval_Lt_c_fls: forall ctx n1 n2,
    n1 >= n2 ->
    ctx >> ((CVal n1) _<_ (CVal n2)) >>> CVal 1
| E_Eval_And_l: forall ctx expl expl' expr,
    ctx >> expl >>> expl' ->
    ctx >> (expl _&&_ expr) >>> (expl' _&&_ expr)
| E_Eval_And_r: forall ctx expl expr expr',
    ctx >> expr >>> expr' ->
    ctx >> (expl _&&_ expr) >>> (expl _&&_ expr')
| E_Eval_And_c_tru: forall ctx n1 n2,
    n1 = 0 /\ n2 = 0 ->
    ctx >> ((CVal n1) _&&_ (CVal n2)) >>> CVal 0
| E_Eval_And_c_fls: forall ctx n1 n2,
    n1 <> 0 \/ n2 <> 0 ->
    ctx >> ((CVal n1) _&&_ (CVal n2)) >>> CVal 1
| E_Eval_Ptr_s: forall s st h ht ctx ptr n,
    space s st h ht = ctx ->
    get_val_s s ptr = Some n ->
    ctx >> *_ ptr >>> CVal n
| E_Eval_Ptr_h: forall s st h ht ctx ptr n,
    space s st h ht = ctx ->
    get_val_h h ptr = Some n ->
    ctx >> *_ ptr >>> CVal n
| E_EVal_Struct_s: forall s st h ht ctx s_name s_var var val,
    query_struct_space ctx s_name s_var = Some var ->
    space s st h ht = ctx ->
    lookup_s s st var = Some val ->
    ctx >> (s_var _._ var) >>> CVal val

where " ctx '>>' exp '>>>' exp'" := (E_eval ctx exp exp').


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.composition
     lax_functor.examples.identity
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     general_category.

Section LaxRightIdentity.
  Context `{Univalence}
          {C D : BiCategory}.
  Variable (F : LaxFunctor C D).

  Definition lax_right_identity_d
    : PseudoTransformation_d (lax_comp F (lax_id_functor C)) F.
  Proof.
    make_pseudo_transformation.
    - exact (fun X => id₁ (F X)).
    - exact (fun X Y f => (left_unit_inv (F ₁ f)) ∘ right_unit (F ₁ f)).
    - exact (fun X Y f => right_unit_inv (F ₁ f) ∘ left_unit (F ₁ f)).
  Defined.

  Definition is_lax_right_d
    : is_pseudo_transformation_p lax_right_identity_d.
  Proof.
    make_is_pseudo_transformation.
    - intros X Y f g α ; simpl.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite !vcomp_assoc.
      reflexivity.
    - intros X ; cbn in *.
      rewrite <- right_unit_id_is_left_unit_id.
      rewrite !vcomp_assoc.
      rewrite right_unit_right.
      rewrite vcomp_right_identity.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite right_unit_id_is_left_unit_id.
      rewrite vcomp_assoc.
      rewrite left_unit_right.
      rewrite !vcomp_right_identity.
      rewrite Fmor₂_id₂, vcomp_left_identity.
      reflexivity.
    - intros X Y Z f g ; cbn in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      symmetry.
      rewrite <- (vcomp_left_identity (id₂ (F ₁ f))).
      rewrite <- (vcomp_left_identity (id₂ (F ₁ g))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ z))) (vcomp_assoc _ _ _)^).
      rewrite triangle_l.
      rewrite <- interchange.
      rewrite left_unit_left.
      rewrite vcomp_left_identity, hcomp_id₂, Fmor₂_id₂.
      rewrite !vcomp_left_identity.
      f_ap.
      rewrite <- right_unit_assoc.
      rewrite <- !vcomp_assoc.
      f_ap.
      pose (left_unit_inv_assoc (F ₁ g) (F ₁ f)) as p.
      unfold bc_whisker_r in p.
      rewrite p ; clear p.
      rewrite <- vcomp_assoc.
      rewrite assoc_left.
      apply vcomp_left_identity.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite right_unit_left, vcomp_left_identity.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite left_unit_left, vcomp_left_identity.
      apply right_unit_right.
  Qed.

  Definition lax_right_identity
    : PseudoTransformation (lax_comp F (lax_id_functor C)) F
    := Build_PseudoTransformation lax_right_identity_d is_lax_right_d.
End LaxRightIdentity.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp span2.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.
Global Set Bullet Behavior "Strict Subproofs".

Module decreasing_rec.
Section decreasing_rec.
Variable X: eqType.
Variable B : X → finType.
Variable size: X → R.
Variable msr: X → R.
Variable Ωh: ∀ x, distrib (B x).
Variable h: ∀ x: X, rvar (Ωh x) X.
Variable d: R.
Variable msr_cutoff: R.
Hypothesis cutoff_non_neg: 0 ≤ msr_cutoff.
Hypothesis hmsr_shrink:
  ∀ z i, d < size z → msr (h z i) ≤ msr z - 1.
Hypothesis hmsr_below: ∀ x n, msr x ≤ msr_cutoff → size ((h x) n) <= d.
Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
Hypothesis hrange2: ∀ x n, d < size x →  0 ≤ size ((h x) n).

Lemma recN_h_decreasing n z x:
  (rvar_comp (recN_rvar h z n) size) x ≤ size z.
Proof.
  revert z x; induction n as [| n IH]; rewrite //=.
  - reflexivity.
  - intros. destruct x as (x&s).
    specialize (IH ((h z) x) s). rewrite //= in IH.
    specialize (hrange2 z x). etransitivity; eauto.
Qed.

Lemma hinf_0_aux1:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) size) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i ?.
  destruct (Rgt_dec) as [Hgt|?] => //=.
  apply Rgt_not_le in Hgt.
  exfalso; apply Hgt. specialize (hrange1 z i). etransitivity; eauto.
Qed.

Lemma hinf_0_aux2:
  ∀ r z n, size z ≤ r → pr_gt (rvar_comp (recN_rvar h z n) size) r = 0.
Proof.
  intros r z n Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i ?.
  destruct (Rgt_dec) as [Hgt|?] => //=.
  apply Rgt_not_le in Hgt.
  exfalso; apply Hgt.
  etransitivity; first apply recN_h_decreasing; eauto.
Qed.

Lemma hinf_decreasingS:
  ∀ z r n, pr_gt (rvar_comp (recN_rvar h z (S n)) size) r
               ≤ pr_gt (rvar_comp (recN_rvar h z n) size) r.
Proof.
  intros z r n.
  rewrite recN_pr_gt'.
  rewrite /pr_gt.
  rewrite pr_gt_alt_comp.
  rewrite /index_enum.
  rewrite [@Finite.enum]unlock //=.
  rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr (rvar_dist (rvar_comp (h i) size))
                                                (λ a, Rgt_dec ((rvar_comp (h i) size) a) r)))
                          (λ i, true)).
  rewrite (img_fin_big' _ (λ i, if ((Rgt_dec (size i) r)) then
                                  pr_eq _ i
                                else
                                  0) (λ i, true)).
  eapply Rle_bigr => i _.
  destruct (Rgt_dec) as [?|Hngt] => //=.
 -  rewrite -[a in _ ≤ a]Rmult_1_r.
    apply Rmult_le_compat_l.
    * apply Rge_le, ge_pr_0.
    * apply pr_le_1.
  - apply Rnot_gt_le in Hngt. specialize (hinf_0_aux1 _ _ Hngt).
    rewrite /pr_gt //= => ->; fourier.
Qed.

Lemma hinf_decreasing:
  ∀ z r n n', (le n n') →
              pr_gt (rvar_comp (recN_rvar h z n') size) r
                    ≤ pr_gt (rvar_comp (recN_rvar h z n) size) r.
Proof.
  induction 1 as [| ? ? IHle].
  - reflexivity.
  - etransitivity; first apply hinf_decreasingS. done.
Qed.

Lemma hinf_decreasing0:
  ∀ z r n n', (le n n') →
              pr_gt (rvar_comp (recN_rvar h z n) size) r = 0 →
              pr_gt (rvar_comp (recN_rvar h z n') size) r = 0.
Proof.
  intros ???? Hle Hgt. apply (Rle_antisym).
  - etransitivity; last (right; apply Hgt).
    apply hinf_decreasing; auto.
  - rewrite /pr_gt. apply Rge_le, ge_pr_0.
Qed.

Lemma hinf_0_aux3:
  ∀ z, pr_gt (rvar_comp (recN_rvar h z (S (Z.to_nat (Rceil (msr z))))) size) d = 0.
Proof.
  intros z.
  remember (Z.to_nat (Rceil (msr z))) as k eqn:Hk.
  revert z Hk.
  induction k as [k IH] using lt_wf_ind. intros z (* Hlt *) Hk.
  destruct k.
  * rewrite /pr_gt.
    assert (msr z ≤ msr_cutoff) as Hbelow.
    {
      case (Rle_dec (msr z) msr_cutoff) as [Hle|Hnle]; auto.
      cut (msr z ≤ 0); first (intros; fourier).
      apply Rnot_le_gt in Hnle.
      assert (0 <= (Rceil (msr z)))%Z.
      { rewrite -Rceil_0. apply Rceil_mono. fourier. }
      assert ( Rceil 0 = (Rceil (msr z)))%Z as Hz.
      {
        rewrite Rceil_0. replace 0%nat with (Z.to_nat 0) in Hk by auto.
        apply Z2Nat.inj; omega.
      }
      apply Rnot_lt_le => Hlt'. apply Rceil_mono_strict in Hlt';
          last apply frac_part_0.
      omega.
    }
    rewrite //=.
    rewrite /pr_gt /pr //= ?SeriesC_fin_big.
    apply big1.  intros (i&?) Hin.
    destruct (Rgt_dec) as [Hgt|Hngt] => //.
    exfalso. apply Rgt_not_le in Hgt. apply Hgt.
    apply hmsr_below. eauto.
  * case (Rlt_dec d (size z)) as [Hlt|Hnlt]; last (by apply hinf_0_aux2, Rnot_lt_le).
    rewrite recN_pr_gt.
    rewrite big_seq_cond.
    apply big1. intros i. move/andP=>[Hin _].
    destruct i as (i&Hin').
    clear Hin. generalize Hin'. apply img_alt in Hin' as (x&Hin) => Hin'.
    generalize (hmsr_shrink z x) => Hle_size; rewrite Hin in Hle_size.
    apply Rmult_eq_0_compat_l.
    rewrite /sval.
    destruct (Rle_dec 0 (msr i)) as [Hlei|Hlt0%Rnot_le_gt]; last first.
    {
      assert (msr i ≤ msr_cutoff) as Hbelow by nra.
      assert (1 <= (S k))%coq_nat as Hto1 by omega.
      apply (hinf_decreasing0 _ _ _ _ Hto1).
      rewrite //=.
      rewrite /pr_gt /pr //= ?SeriesC_fin_big.
      apply big1.  intros (i'&?) _.
      destruct (Rgt_dec) as [Hgt|Hngt] => //.
      exfalso. apply Rgt_not_le in Hgt. apply Hgt.
      apply hmsr_below. eauto.
    }
    assert (le (Z.to_nat (Rceil (msr i))) k) as Hlek.
    {
    apply Rceil_mono in Hle_size.
    rewrite Rceil_minus_1 in Hle_size.
    apply Z2Nat.inj_le in Hle_size.
    - rewrite Z2Nat.inj_sub in Hle_size; last omega.
      replace (Z.to_nat 1) with 1%nat in Hle_size by auto with *.
      omega.
    - rewrite -Rceil_0. apply Rceil_mono. done.
    - transitivity (Rceil (msr i)); auto.
      rewrite -Rceil_0. apply Rceil_mono. done.
    - done.
    }
    assert (le (S (Z.to_nat (Rceil (msr i)))) (S k)) as HleSk.
    { omega. }
    apply (hinf_decreasing0 _ _ _ _ HleSk).
    apply IH; auto; try omega.
Qed.

Lemma hinf_0:
  ∀ z eps, eps > 0 → ∃ n, pr_gt (rvar_comp (recN_rvar h z n) size) d < eps.
Proof.
  intros z eps Hgt0.
  exists (S (Z.to_nat (Rceil (msr z)))).
  apply (Rle_lt_trans _ 0); last fourier.
  right; apply hinf_0_aux3.
Qed.
End decreasing_rec.
End decreasing_rec.

Module decreasing_rec_binary.
Section decreasing_rec_binary.
Variable X: eqType.
Variable B : X → finType.
Variable size: X → R.
Variable Ωh: ∀ x, distrib (B x).
Variable h: ∀ x: X, rvar (Ωh x) [eqType of X * X].
Variable d: R.
Hypothesis d_non_neg: 0 ≤ d.
Hypothesis hrange_shrink:
  ∀ x n, d < size x → size (fst ((h x) n)) + size (snd ((h x) n)) ≤ size x - 1.
Hypothesis hrange11: ∀ x n, size (fst ((h x) n)) ≤ size x.
Hypothesis hrange21: ∀ x n, size (snd ((h x) n)) ≤ size x.
Hypothesis hrange12: ∀ x n, d < size x →  0 ≤ size (fst ((h x) n)).
Hypothesis hrange22: ∀ x n, d < size x →  0 ≤ size (snd ((h x) n)).

Lemma recN_h_decreasing n z φ k x:
  (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) x ≤ size z.
Proof.
  revert z k x; induction n as [| n IH]; rewrite //=.
  - reflexivity.
  - intros. destruct x as (x&s).
    destruct (φ k).
    * move: x s. rewrite /Bn//= => x s.
      specialize (IH (fst ((h z) x)) (S k)).
      rewrite //= in IH. specialize (hrange12 z x). etransitivity; eauto.
    * move: x s. rewrite /Bn//= => x s.
      specialize (IH (snd ((h z) x)) (S k)).
      rewrite //= in IH. specialize (hrange22 z x). etransitivity; eauto.
Qed.

Lemma hinf_0_aux11:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) (λ x, size (fst x))) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  rewrite //= in Hgt. generalize (hrange11 z i) => //=; nra.
Qed.

Lemma hinf_0_aux21:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) (λ x, size (snd x))) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  rewrite //= in Hgt. generalize (hrange21 z i) => //=; nra.
Qed.

Lemma hinf_0_aux_below:
  ∀ r z n φ k,
    size z ≤ r → pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r = 0.
Proof.
  intros r z n φ k Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  apply Rgt_not_le in Hgt. exfalso; apply Hgt.
  etransitivity; first apply recN_h_decreasing; eauto.
Qed.

Lemma hinf_decreasingS:
  ∀ z r n φ k, pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) (S n)) (λ x, size (snd x))) r
               ≤ pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r.
Proof.
  intros z r n φ k.
  rewrite recN_pr_gt'.
  rewrite /pr_gt.
  rewrite pr_gt_alt_comp.
  eapply Rle_bigr => i Hin.
  destruct (Rgt_dec) as [?|Hle] => //=.
  - rewrite -[a in _ ≤ a]Rmult_1_r.
    apply Rmult_le_compat_l.
    * apply Rge_le, ge_pr_0.
    * apply pr_le_1.
  - rewrite //=. destruct i as ((k'&?)&?). rewrite /hpath//=.
    rewrite //= in Hle. apply Rnot_gt_le in Hle.
    destruct (φ k').
    * specialize (hinf_0_aux11 _ _ Hle).
      rewrite /pr_gt //= => ->; fourier.
    * specialize (hinf_0_aux21 _ _ Hle).
      rewrite /pr_gt //= => ->; fourier.
Qed.

Lemma hinf_decreasing:
  ∀ z r n n' φ k,
    (le n n') →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n') (λ x, size (snd x))) r
          ≤ pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r.
Proof.
  induction 1 as [| ? ? IHle].
  - reflexivity.
  - etransitivity; first apply hinf_decreasingS. done.
Qed.

Lemma hinf_decreasing0:
  ∀ z r n n' φ k, (le n n') →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r = 0 →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n') (λ x, size (snd x))) r = 0.
Proof.
  intros ?????? Hle Hgt. apply (Rle_antisym).
  - etransitivity; last (right; apply Hgt).
    apply hinf_decreasing; auto.
  - rewrite /pr_gt. apply Rge_le, ge_pr_0.
Qed.

Lemma hinf_0_aux3:
  ∀ z φ sidx,
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (sidx, z) (Z.to_nat (Rceil (size z))))
                   (λ x, size (snd x))) d = 0.
Proof.
  intros z φ sidx.
  remember (Z.to_nat (Rceil (size z))) as k eqn:Hk.
  revert z Hk sidx.
  induction k as [k IH] using lt_wf_ind. intros z (* Hlt *) Hk sidx.
  destruct k.
  * rewrite /pr_gt.
    assert (size z ≤ d) as Hbelow.
    {
      case (Rle_dec (size z) d) as [Hle|Hnle]; auto.
      cut (size z ≤ 0); first (intros; fourier).
      apply Rnot_le_gt in Hnle.
      assert (0 <= (Rceil (size z)))%Z.
      { rewrite -Rceil_0. apply Rceil_mono. fourier. }
      assert ( Rceil 0 = (Rceil (size z)))%Z as Hz.
      {
        rewrite Rceil_0. replace 0%nat with (Z.to_nat 0) in Hk by auto.
        apply Z2Nat.inj; omega.
      }
      apply Rnot_lt_le => Hlt'. apply Rceil_mono_strict in Hlt';
          last apply frac_part_0.
      omega.
    }
    rewrite //=.
    rewrite /pr_gt /pr //= SeriesC_fin_big.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite big_seq1 => //=.
    destruct (Rgt_dec) => //=. nra.
  * case (Rlt_dec d (size z)) as [Hlt|Hnlt]; last (by apply hinf_0_aux_below, Rnot_lt_le).
    rewrite recN_pr_gt.
    rewrite big_seq_cond.
    apply big1. intros ((sidx', i)&Hin'). move/andP=>[Hin _].
    clear Hin. generalize Hin'. apply img_alt in Hin' as (x&Hin) => Hin'.
    generalize (hrange_shrink z x) => Hle_size. (* rewrite Hin in Hle_size. *)
    apply Rmult_eq_0_compat_l.
    destruct (Rle_dec 0 (size i)) as [Hlei|?%Rnot_le_gt]; last first.
    { apply hinf_0_aux_below. fourier. }
    assert (le (Z.to_nat (Rceil (size i))) k) as Hlek.
    {
      specialize (Hle_size Hlt).
      assert (Hle_size1: size (fst ((h z) x)) ≤ size z - 1).
      { generalize (hrange22 _ x Hlt). rewrite //= => ?.
        rewrite //= in Hle_size. fourier. }
      assert (Hle_size2: size (snd ((h z) x)) ≤ size z - 1).
      { generalize (hrange12 _ x Hlt). rewrite //= => ?.
        rewrite //= in Hle_size. fourier. }
    apply Rceil_mono in Hle_size1.
    apply Rceil_mono in Hle_size2.
    rewrite //= in Hin. destruct (φ sidx).
    - inversion Hin. subst. rewrite Rceil_minus_1 in Hle_size1.
      apply Z2Nat.inj_le in Hle_size1.
      * rewrite Z2Nat.inj_sub in Hle_size1; last omega.
        replace (Z.to_nat 1) with 1%nat in Hle_size1 by auto with *.
        rewrite -Hk //= in Hle_size1. omega.
      * rewrite -Rceil_0. apply Rceil_mono. done.
      * transitivity (Rceil (size (fst ((h z) x)))); auto.
        rewrite -Rceil_0. apply Rceil_mono. done.
    - inversion Hin. subst. rewrite Rceil_minus_1 in Hle_size2.
      apply Z2Nat.inj_le in Hle_size2.
      * rewrite Z2Nat.inj_sub in Hle_size2; last omega.
        replace (Z.to_nat 1) with 1%nat in Hle_size1 by auto with *.
        rewrite -Hk //= in Hle_size2. omega.
      * rewrite -Rceil_0. apply Rceil_mono. done.
      * transitivity (Rceil (size (snd ((h z) x)))); auto.
        rewrite -Rceil_0. apply Rceil_mono. done.
    }
    apply (hinf_decreasing0 _ _ _ _ _ _ Hlek).
    apply IH; auto; try omega.
Qed.

Lemma hinf_0: ∀ a, ∃ n, ∀ φ, pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (O, a) n)
                                                  (λ x, size (snd x))) d = 0.
Proof.
  intros z.
  exists (Z.to_nat (Rceil (size z))) => φ.
  apply hinf_0_aux3.
Qed.
End decreasing_rec_binary.
End decreasing_rec_binary.


(** * Rings category *)
(** ** Contents
- Precategory of rings
- Category of rings
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.RigsAndRings.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Local Open Scope cat.

(** * Precategory of rings *)
Section def_ring_precategory.

  Definition ring_fun_space (A B : ring) : hSet := make_hSet (ringfun A B) (isasetrigfun A B).

  Definition ring_precategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) ring (λ A B : ring, ring_fun_space A B).

  Definition ring_precategory_data : precategory_data :=
    make_precategory_data
      ring_precategory_ob_mor (λ (X : ring), (rigisotorigfun (idrigiso X)))
      (fun (X Y Z : ring) (f : ringfun X Y) (g : ringfun Y Z) => rigfuncomp f g).

  Local Lemma ring_id_left (X Y : ring) (f : ringfun X Y) :
    rigfuncomp (rigisotorigfun (idrigiso X)) f = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque ring_id_left.

  Local Lemma ring_id_right (X Y : ring) (f : ringfun X Y) :
    rigfuncomp f (rigisotorigfun (idrigiso Y)) = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque ring_id_right.

  Local Lemma ring_assoc (X Y Z W : ring) (f : ringfun X Y) (g : ringfun Y Z) (h : ringfun Z W) :
    rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque ring_assoc.

  Lemma is_precategory_ring_precategory_data : is_precategory ring_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros a b f. use ring_id_left.
    - intros a b f. use ring_id_right.
    - intros a b c d f g h. use ring_assoc.
  Qed.

  Definition ring_precategory : precategory :=
    make_precategory ring_precategory_data is_precategory_ring_precategory_data.

  Lemma has_homsets_ring_precategory : has_homsets ring_precategory.
  Proof.
    intros X Y. use isasetrigfun.
  Qed.

End def_ring_precategory.

(** * Category of rings *)
Section def_ring_category.

  Definition ring_category : category := make_category _ has_homsets_ring_precategory.

  (** ** (ringiso X Y) ≃ (z_iso X Y) *)

  Lemma ring_iso_is_equiv (A B : ob ring_category) (f : z_iso A B) : isweq (pr1 (pr1 f)).
  Proof.
    use isweq_iso.
    - exact (pr1rigfun _ _ (inv_from_z_iso f)).
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x).
      intros x0. use isapropisrigfun.
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x).
      intros x0. use isapropisrigfun.
  Defined.
  Opaque ring_iso_is_equiv.

  Lemma ring_iso_equiv (X Y : ob ring_category) : z_iso X Y -> ringiso (X : ring) (Y : ring).
  Proof.
    intro f.
    use make_ringiso.
    - exact (make_weq (pr1 (pr1 f)) (ring_iso_is_equiv X Y f)).
    - exact (pr2 (pr1 f)).
  Defined.

  Lemma ring_equiv_is_z_iso (X Y : ob ring_category) (f : ringiso (X : ring) (Y : ring)) :
    @is_z_isomorphism ring_category X Y (ringfunconstr (pr2 f)).
  Proof.
    exists (ringfunconstr (pr2 (invrigiso f))).
    use make_is_inverse_in_precat.
    - use rigfun_paths. use funextfun. intros x. use homotinvweqweq.
    - use rigfun_paths. use funextfun. intros y. use homotweqinvweq.
  Defined.
  Opaque ring_equiv_is_z_iso.

  Lemma ring_equiv_iso (X Y : ob ring_category) : ringiso (X : ring) (Y : ring) -> z_iso X Y.
  Proof.
    intros f. exact (_,,ring_equiv_is_z_iso X Y f).
  Defined.

  Lemma ring_iso_equiv_is_equiv (X Y : ring_category) : isweq (ring_iso_equiv X Y).
  Proof.
    use isweq_iso.
    - exact (ring_equiv_iso X Y).
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
  Defined.
  Opaque ring_iso_equiv_is_equiv.

  Definition ring_iso_equiv_weq (X Y : ob ring_category) :
    weq (z_iso X Y) (ringiso (X : ring) (Y : ring)).
  Proof.
    use make_weq.
    - exact (ring_iso_equiv X Y).
    - exact (ring_iso_equiv_is_equiv X Y).
  Defined.

  Lemma ring_equiv_iso_is_equiv (X Y : ob ring_category) : isweq (ring_equiv_iso X Y).
  Proof.
    use isweq_iso.
    - exact (ring_iso_equiv X Y).
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
  Defined.
  Opaque ring_equiv_iso_is_equiv.

  Definition ring_equiv_weq_iso (X Y : ob ring_category) :
    (ringiso (X : ring) (Y : ring)) ≃ (z_iso X Y).
  Proof.
    use make_weq.
    - exact (ring_equiv_iso X Y).
    - exact (ring_equiv_iso_is_equiv X Y).
  Defined.

  (** ** Category of rings *)

  Definition ring_category_isweq (X Y : ob ring_category) : isweq (λ p : X = Y, idtoiso p).
  Proof.
    use (@isweqhomot
           (X = Y) (z_iso X Y)
           (pr1weq (weqcomp (ring_univalence X Y) (ring_equiv_weq_iso X Y)))
           _ _ (weqproperty (weqcomp (ring_univalence X Y) (ring_equiv_weq_iso X Y)))).
    intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use total2_paths_f.
    - apply idpath.
    - use proofirrelevance. use isaprop_is_z_isomorphism.
  Defined.
  Opaque ring_category_isweq.

  Definition ring_category_is_univalent : is_univalent ring_category.
  Proof.
    intros X Y. exact (ring_category_isweq X Y).
  Defined.

  Definition ring_univalent_category : univalent_category :=
    make_univalent_category ring_category ring_category_is_univalent.

End def_ring_category.


From Coq Require Import ssreflect ssrfun FunctionalExtensionality.
From Mon Require Export Base.
From Mon Require Import SPropBase.
From Coq Require Import Relation_Definitions Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

(***************************************************************)
(* Preorder srelations                                         *)
(***************************************************************)

Definition SProp_order : relation Prop := fun x y => (x -> y).
#[export] Instance SProp_order_preorder : PreOrder SProp_order.
Proof. constructor ; cbv ; intuition. Qed.

Definition SProp_op_order : relation Prop := Basics.flip SProp_order.
#[export] Instance SProp_op_order_preorder : PreOrder SProp_op_order.
Proof. unfold SProp_op_order. typeclasses eauto. Qed.

#[export] Instance pointwise_preorder A {B} (R:relation B) `{PreOrder _ R} :
  PreOrder (pointwise_relation A R).
Proof. constructor ; cbv ; intuition ; transitivity (y a) ; auto. Qed.

Definition Pred_op_order A : relation (A -> Prop) :=
  pointwise_relation A SProp_op_order.
#[export] Instance Pred_op_order_prorder A : PreOrder (@Pred_op_order A).
Proof. unfold Pred_op_order ; typeclasses eauto. Qed.

(***************************************************************)
(* Monads, in Kleisli triple form                              *)
(***************************************************************)

Record Monad : Type :=
  mkMonad
    { monad_tyop :> Type -> Type
    ; monad_ret  : forall A, A -> monad_tyop A
    ; monad_bind : forall A B,
        monad_tyop A -> (A -> monad_tyop B) -> monad_tyop B
    ; monad_law1 : forall A B a (f : A -> monad_tyop B),
        monad_bind (monad_ret a) f = f a
    ; monad_law2 : forall A c, monad_bind c (@monad_ret A) = c
    ; monad_law3 : forall A B C c (f : A -> monad_tyop B) (g : B -> monad_tyop C),
        monad_bind (monad_bind c f) g
        = monad_bind c (fun a => monad_bind (f a) g)
    }.

Definition ret {M : Monad} {A} := @monad_ret M A.
Definition bind {M : Monad} {A} {B} := @monad_bind M A B.
Definition map {M:Monad} {A B} (f : A -> B) (m : M A) : M B :=
  bind m (fun x => ret (f x)).
Notation "f <$> m" := (@map _ _ _ f m) (at level 60).
Ltac intro_map :=
  change (bind ?a (fun x => ret (?f x))) with (f <$> a).

Section StrongBind.
  Context {M:Monad}.
  Context {Γ A B} (m : Γ -> M A) (f : Γ × A -> M B).

  Definition bindStr (γ : Γ) : M B :=
    bind (m γ) (fun a => f ⟨γ,a⟩).
End StrongBind.

Section MapLemmas.
  Context (M : Monad).
  Import FunctionalExtensionality.
  Lemma map_id : forall A (m : M A), id <$> m = m.
  Proof. intros ; rewrite /map /id /= /bind monad_law2 //. Qed.

  Lemma map_functorial : forall A B C (f : A -> B) (g : B -> C) (m : M A),
      g <$> (f <$> m) = (fun x => g (f x)) <$> m.
  Proof.
    intros ; cbv. rewrite monad_law3. f_equal. extensionality a.
    rewrite monad_law1. reflexivity.
  Qed.

  Lemma map_bind : forall A B C (f : B -> C) (m:M A) g,
      (f <$> bind m g = bind m (fun x => f <$> (g x))).
  Proof.
    intros ; cbv. rewrite monad_law3. reflexivity.
  Qed.
  Lemma bind_map : forall A B C (f : A -> B) (m:M A) (g : B -> M C),
      bind (f <$> m) g = bind m (fun x => g (f x)).
  Proof.
    intros ; cbv. rewrite monad_law3.
    f_equal ; extensionality a. rewrite monad_law1.
    reflexivity.
  Qed.
End MapLemmas.

(***************************************************************)
(* Ordered Monads, where the bind respects the order           *)
(***************************************************************)

Record OrderedMonad : Type :=
  mkOrderedMonad
    { omon_monad :> Monad
      ; omon_rel : forall A, relation (omon_monad A)
      ; omon_order : forall A, PreOrder (@omon_rel A)
      ; omon_bind  : forall A B,
          Proper (@omon_rel A ==> pointwise_relation A (@omon_rel B) ==> @omon_rel B) bind
    }.

#[export] Existing Instance omon_order.

Declare Scope SPropMonadicStructures_scope.
Delimit Scope SPropMonadicStructures_scope with SMS.

Module SPropMonadicStructuresNotation.

  Notation "x ≤[ M ] y" :=
    (@omon_rel M _ x y)
    (at level 70) : SPropMonadicStructures_scope.
  Notation "x ≤ y" :=
    (@omon_rel _ _ x y)
    (at level 70) : SPropMonadicStructures_scope.

End SPropMonadicStructuresNotation.

Import SPropMonadicStructuresNotation.
Open Scope SPropMonadicStructures_scope.

Section DiscreteMonad.
  Import SPropNotations.
  Program Definition DiscreteMonad (M:Monad) : OrderedMonad :=
    @mkOrderedMonad M (fun A x y => x = y) _ _.
  Next Obligation.
    constructor. by cbv.
    cbv. move=> *. etransitivity ; by eassumption.
  Qed.
  Next Obligation.
    compute. move=> x y Exy x0 y0 pe_x0y0.
    rewrite Exy. apply functional_extensionality in pe_x0y0.
    rewrite pe_x0y0. reflexivity.
  Qed.
End DiscreteMonad.

(***************************************************************)
(* Monad algebras, and algebras on ordered monads              *)
(***************************************************************)
Record MonadAlgebra (M : Monad) : Type :=
  mkMonadAlgebra
    { malg_carrier : Type
    ; malg_map     :> M malg_carrier -> malg_carrier
    ; malg_ret     : forall c, malg_map (ret c) = c
    ; malg_bind    : forall X (m : M X) f,
        malg_map (bind m (fun x => ret (malg_map (f x)))) = malg_map (bind m f)
    }.

Record OrderedAlgebra (M : Monad) : Type :=
  mkOrderedAlgebra
    { oalg_alg     :> MonadAlgebra M
    ; oalg_rel     : relation (malg_carrier oalg_alg)
    ; oalg_order   : PreOrder oalg_rel
    ; oalg_mono    : forall A, Proper
                            (pointwise_relation A oalg_rel ==> pointwise_relation (M A) oalg_rel)
                            (fun k m => oalg_alg (map k m))}.

Section OrderedMonadAlgebra.
  Context (OM : OrderedMonad).

  Record OrderedMonadAlgebra : Type :=
    mkOrderedMonadAlgebra
      { omalg_alg     :> MonadAlgebra OM
      ; omalg_rel     : relation (malg_carrier omalg_alg)
      ; omalg_order   : PreOrder omalg_rel
      ; omalg_mono    : forall A, Proper
                              (pointwise_relation A omalg_rel ==> (@omon_rel OM A) ==> omalg_rel)
                              (fun k m => omalg_alg (map k m))}.

End OrderedMonadAlgebra.

Section AssertAssumeStructure.
  Context A (rel : relation A) `{PreOrder _ rel}.

  Notation "x ≤ y" := (rel x y).
  Import SPropNotations.
  Class aa :=
    mkAa
      { assert_p : Prop -> A -> A
      ; assume_p : Prop -> A -> A
      ; aa_assert_stronger : forall p x, assert_p p x ≤ x
      ; aa_assume_weaker : forall p x, x ≤ assume_p p x
      ; aa_assert_assume_adjoint : forall p x1 x2,
          assert_p p x1 ≤ x2 <-> x1 ≤ assume_p p x2
      }.

End AssertAssumeStructure.

(**************************************************************************)
(* Left/Right kan extensions in the Kleisli category of an ordered monad  *)
(**************************************************************************)

Section KleisliKanExtension.
  Context (W:OrderedMonad) (B C : Type) (f : W C) (p : W B).
  Import SPropNotations.

  (* Right Kan extension of f along p *)
  Definition ran :=
    { ext : B -> W C |
      bind p ext  ≤[W] f /\
      forall (w' : B -> W C), bind p w' ≤[W] f -> forall b, w' b ≤[W] ext b
    }.

  Definition lan :=
    { ext : B -> W C |
      f ≤ bind p ext /\
      forall (w' : B -> W C), f ≤ bind p w' -> forall b, w' b ≤ ext b
    }.

End KleisliKanExtension.

Section KanExtensionMonotonic.
  Context (W:OrderedMonad) (B C : Type).
  Context (f : W C) (p : W B) (Hran:ran f p).
  Context (f':W C) (p':W B) (Hran':ran f' p').
  Context (Hf : f ≤ f') (Hp : p' ≤ p).
  Definition ran_mono : forall b, proj1_sig Hran b ≤ proj1_sig Hran' b.
  Proof.
    move:Hran Hran' => [w [H1 H2]] [w' [H1' H2']] b /=.
    apply H2'. transitivity f ; [|assumption].
    transitivity (bind p w).
    apply omon_bind ; [assumption|reflexivity].
    assumption.
  Qed.
End KanExtensionMonotonic.

Section KanExtensionIsoStable.
  Context (W:OrderedMonad) (B C : Type) (f : W C) (p : W B).
  Import SPropNotations.
  Notation "w ≅ w'" := (w ≤ w' /\ w' ≤ w) (at level 65).
  Context (Hran:ran f p) (f':W C) (p':W B) (Hf : f ≅ f') (Hp : p ≅ p').
  Definition ran_iso : ran f' p'.
    constructor 1 with (x:=proj1_sig Hran).
    (* Rem.: this is such an ugly fix.
     * Program Definition ... := exist _ (proj1_sig Hran) _.
     * was hanging. *)
    destruct Hf as [Hf1 Hf2] ; destruct Hp as [Hp1 Hp2] ; destruct (proj2_sig Hran) as [Hran1 Hran2].
    split.
    transitivity (bind p (proj1_sig Hran)).
    apply omon_bind. assumption.  move=> //= ?. reflexivity.
    transitivity f ; assumption.
    move=> w' Hw'. apply Hran2.
    transitivity (bind p' w'). apply omon_bind. assumption.
    move=> //= ? ; reflexivity.
    transitivity f' ; assumption.
  Defined.
End KanExtensionIsoStable.

(***************************************************************)
(* Monad morphisms                                             *)
(***************************************************************)

Record MonadMorphism (M W : Monad) : Type :=
  mkMorphism
    { mon_morph :> forall {A}, M A -> W A
    ; mon_morph_ret : forall A (a : A), mon_morph (ret a) = ret a
    ; mon_morph_bind : forall A B (m : M A) (f : A -> M B),
        mon_morph (bind m f) = bind (mon_morph m) (fun a => mon_morph (f a))
    }.

Program Definition identity_monad_morphism M : MonadMorphism M M :=
  @mkMorphism M M (fun A => id) _ _.

Program Definition comp_monad_morphism {M1 M2 M3}
  : MonadMorphism M1 M2 -> MonadMorphism M2 M3 -> MonadMorphism M1 M3
  := fun f12 f23 => @mkMorphism M1 M3 (fun A a => f23 A (f12 A a)) _ _.
Next Obligation. rewrite !mon_morph_ret //. Qed.
Next Obligation. rewrite !mon_morph_bind //. Qed.

Section MonadMorphismRefinement.
  Context {M : Monad} {W : OrderedMonad} (ϕ ψ : MonadMorphism M W).
  Definition monad_morph_refines :=
    forall A, pointwise_relation (M A) (@omon_rel W A) (ϕ A) (ψ A).
End MonadMorphismRefinement.

#[export] Instance mon_morph_refines_preorder M W : PreOrder (@monad_morph_refines M W).
Proof.
  constructor ; cbv ; intuition.
  transitivity (y A a) ; auto.
Qed.

Section MonadMorphismNatural.
  Context {M1 M2 : Monad} (θ : MonadMorphism M1 M2).
  Import FunctionalExtensionality.
  Lemma monad_morphism_natural : forall A B f m, f <$> (θ A m) = θ B (f <$> m).
  Proof.
    intros. cbv. rewrite mon_morph_bind. cbv ; f_equal.
    extensionality a. rewrite mon_morph_ret ; reflexivity.
  Qed.
End MonadMorphismNatural.

(***************************************************************)
(* Monotonic Monad morphisms                                   *)
(***************************************************************)

Record MonotonicMonadMorphism (M W : OrderedMonad) : Type :=
  mkMonMorphism
    { monmon_morph :> MonadMorphism M W
    ; monmon_monotonic : forall A,
          Proper (@omon_rel M A ==> @omon_rel W A) (monmon_morph A)
    }.

Program Definition identity_monmon M : MonotonicMonadMorphism M M :=
  @mkMonMorphism _ _ (identity_monad_morphism M) _.
Next Obligation. cbv ; intuition. Qed.

Program Definition comp_monmon {M1 M2 M3}
  : MonotonicMonadMorphism M1 M2 ->
    MonotonicMonadMorphism M2 M3 ->
    MonotonicMonadMorphism M1 M3
  := fun f12 f23 => @mkMonMorphism M1 M3 (comp_monad_morphism f12 f23) _.
Next Obligation.
  cbv ; intuition.
  do 2 apply monmon_monotonic => //.
Qed.

Program Definition from_discrete_monad_monotonic
           (M:Monad) (W:OrderedMonad) (θ : MonadMorphism M W)
  : MonotonicMonadMorphism (DiscreteMonad M) W
  := @mkMonMorphism _ _ θ _.

(* An ordered monad equipped with a morphism from M *)
Record OrderedMonadUnder (M:OrderedMonad) :=
  mkMonadUnder {
    mu_carrier :> OrderedMonad ;
    mu_lift : MonotonicMonadMorphism M mu_carrier
  }.

(***************************************************************)
(* Monad Relations                                             *)
(***************************************************************)

Record MonadRelation (M W : Monad) : Type :=
  mkMonadRelation
    { mrel      :> forall A, M A -> W A -> Prop
    ; mrel_ret  : forall A (a:A), mrel (ret a) (ret a)
    ; mrel_bind : forall A B m w (f : A -> M B)  g,
        mrel m w -> (forall a, mrel (f a) (g a)) -> mrel (bind m f) (bind w g)
    }.

Section MonadIdeal.
  Context (M : Monad) (W:OrderedMonad).
  Record MonadIdeal : Type :=
    mkMonadIdeal
      { mid_rel :> MonadRelation M W
      ; mid_upper_closed : forall A, Proper (pointwise_relation (M A) (@omon_rel W A ==> SProp_order)) (@mid_rel A)
      }.
End MonadIdeal.

Section MonadMorphismToIdeal.
  Context (M : Monad) (W:OrderedMonad) (θ : MonadMorphism M W).
  Program Definition relation_from_mmorph : MonadRelation M W :=
    @mkMonadRelation _ _ (fun A m w => θ A m ≤ w) _ _.
  Next Obligation. rewrite mon_morph_ret. reflexivity. Qed.
  Next Obligation.
    rewrite mon_morph_bind.
    apply omon_bind; [|move=> ?] ; auto.
  Qed.

  Program Definition ideal_from_mmorph : MonadIdeal M W :=
    @mkMonadIdeal _ _ relation_from_mmorph _.
  Next Obligation. cbv ; intuition ; etransitivity ; eassumption. Qed.

End MonadMorphismToIdeal.

(***************************************************************)
(* Monad Transformer                                           *)
(***************************************************************)

Record OrderedMonadTransformer :=
  mkOrderedMonadTransformer
    { mt_monad :> forall (M:OrderedMonad), OrderedMonadUnder M
    ; mt_map : forall (M1 M2:OrderedMonad),
        MonotonicMonadMorphism M1 M2 ->
        MonotonicMonadMorphism (mt_monad M1) (mt_monad M2)
    ; mt_map_id : forall M A m,
        mt_map (identity_monmon M) A m = identity_monmon _ A m
    ; mt_map_comp : forall (M1 M2 M3 : OrderedMonad)
                      (θ12 : MonotonicMonadMorphism M1 M2)
                      (θ23 : MonotonicMonadMorphism M2 M3) A m,
        mt_map θ23 _ (mt_map θ12 A m)  = mt_map (comp_monmon θ12 θ23) A m
    ; mt_natural_lift :
        forall (M1 M2 : OrderedMonad) (θ : MonotonicMonadMorphism M1 M2) A m,
          mt_map θ  _(mu_lift (mt_monad M1) A m)
        = mu_lift (mt_monad M2) _ (θ A m)
    }.

(***************************************************************)
(* Dijkstra Monads over specification (i.e. ordered) monads    *)
(***************************************************************)

Import SPropNotations.
Record Dijkstra (W : OrderedMonad) : Type := mkDM
  { dm_tyop :> forall A, W A -> Type
  ; dm_ret  : forall A, forall (a : A), dm_tyop (ret a)
  ; dm_bind : forall A B (w : W A) (f : A -> W B)
                     (d : dm_tyop w) (g : forall a, dm_tyop (f a)),
      dm_tyop (bind w f)
  ; dm_wkn : forall {A} {w w' : W A}, dm_tyop w -> w ≤[W] w' -> dm_tyop w'
  ; dm_law1 : forall A B (a : A) (f : A -> W B) (g : forall a, dm_tyop (f a)),
      dm_bind (dm_ret a) g =⟨monad_law1 a f⟩ g a
  ; dm_law2 : forall A c m ,
      dm_bind m (@dm_ret A) =⟨monad_law2 c⟩  m
  ; dm_law3 : forall A B C c f g (m : dm_tyop c)
                     (f' : forall (a : A), dm_tyop (f a))
                     (g' : forall (b : B), @dm_tyop C (g b)),
      dm_bind (dm_bind m f') g' =⟨monad_law3 c f g⟩
                                   dm_bind m (fun a => dm_bind(f' a) g')
  ; dm_law4 : forall A w (m:@dm_tyop A w), dm_wkn m (reflexivity _) = m
  ; dm_law5 : forall A w1 w2 w3 (m:@dm_tyop A w1) (H12 :w1 ≤ w2) (H23 :w2 ≤ w3),
      dm_wkn m (transitivity H12 H23) = dm_wkn (dm_wkn m H12) H23
  ; dm_law6 : forall A B wm wm' wf wf' (m:@dm_tyop A wm) (f : forall (a:A), @dm_tyop B (wf a)) (Hm : wm ≤ wm') (Hf : forall a, wf a ≤ wf' a),
       (dm_wkn (dm_bind m f) (omon_bind Hm Hf) = dm_bind (dm_wkn m Hm) (fun a => dm_wkn (f a) (Hf a)))
  }.

Definition dret {W} {D : Dijkstra W} {A} := @dm_ret W D A.
Definition dbind {W} {D : Dijkstra W} {A} {B} {w} {f} := @dm_bind W D A B w f.
Definition wkn {W} {D : Dijkstra W} {A} {w w'} := @dm_wkn W D A w w'.

(* Generic if-then-else for Dijkstra monads *)
Definition ifTE {A} {W} {D : Dijkstra W} {w1 w2 : W A} :
  forall (b: bool), D A w1 -> D A w2 -> D A (if b then w1 else w2) :=
  fun b tt ff =>
    match b as b return D A (if b then w1 else w2) with
    | true => tt
    | false => ff
    end.

Module DijkstraMonadNotations.
  Notation "x <- m1 ; m2" := (dbind m1 (fun x => m2)) (at level 80, right associativity).
  Notation "'ifDM' b 'then' c1 'else' c2 'end'" := (@ifTE _ _ _ _ _ b c1 c2).
End DijkstraMonadNotations.

(***********************************************************************)
(* Deriving Dijkstra Monads from Effect Observations / Monad morphisms *)
(***********************************************************************)
Section OfMorphism.
  Import SPropNotations.

  Variable M : Monad.
  Variable W : OrderedMonad.
  Variable θ : MonadMorphism M W.

  Definition Dθ_carrier A (w : W A) : Type :=
    { m : M A | θ A m ≤ w }.

  Program Definition Dθ_ret A (a : A): Dθ_carrier (ret a) :=
    exist _ (ret a) _.
  Next Obligation.
    rewrite mon_morph_ret ; reflexivity.
  Qed.

  Program Definition Dθ_bind A B (w : W A) (f : A -> W B)
          (d : Dθ_carrier w) (g : forall a, Dθ_carrier (f a)) :
    Dθ_carrier (bind w f) :=
    exist _ (bind (proj1_sig d) (fun a => proj1_sig ( g a))) _.
  Next Obligation.
    rewrite mon_morph_bind.
    apply (omon_bind (proj2_sig d) (fun a => proj2_sig (g a))).
  Qed.

  Program Definition Dθ_wkn A (w w' : W A) (d: Dθ_carrier w) (H : w ≤[W] w') : Dθ_carrier w' :=
    exist _ (proj1_sig d) _.
  Next Obligation.
    transitivity w. exact (proj2_sig d). assumption.
  Qed.

  Program Definition Dθ : Dijkstra W :=
    @mkDM W Dθ_carrier Dθ_ret Dθ_bind Dθ_wkn _ _ _ _ _ _.
  (* Anomaly when trying to factorize *)
  Next Obligation. apply eq_above_sig ; cbv ; by rewrite monad_law1. Qed.
  Next Obligation. apply eq_above_sig ; cbv ; by rewrite monad_law2. Qed.
  Next Obligation. apply eq_above_sig ; cbv ; by rewrite monad_law3. Qed.
(*in the remaining obligations one use proof_irrelevance, which implies
that equality of sigma types is equivalent to equality of carriers members*)
  Next Obligation.
    destruct m as (m,e).
    compute.
    have hintUnif :
(Dθ_wkn_obligation_1
       (exist (fun m0 : M A => θ A m0 ≤ w) m e)
       ((let (PreOrder_Reflexive, _) := omon_order W A in
         PreOrder_Reflexive) w)) = e. apply ax_proof_irrel.
    rewrite hintUnif. reflexivity.
Qed.
  Next Obligation. compute.
  have hintUnif :
(Dθ_wkn_obligation_1 m
       ((let (_, PreOrder_Transitive) := omon_order W A in
         PreOrder_Transitive) w1 w2 w3 H12 H23))
=
(Dθ_wkn_obligation_1
       (exist (fun m0 : M A => θ A m0 ≤ w2)
          (let (w, _) := m in w) (Dθ_wkn_obligation_1 m H12))
       H23). apply ax_proof_irrel. rewrite hintUnif. reflexivity.
Qed.
  Next Obligation. compute.
have hintUnif :
(Dθ_wkn_obligation_1
       (exist (fun m0 : M B => θ B m0 ≤ monad_bind wm wf)
          (monad_bind (let (w, _) := m in w)
             (fun a : A => let (w, _) := f a in w))
          (Dθ_bind_obligation_1 m f)) (omon_bind Hm Hf))
=
(Dθ_bind_obligation_1
       (exist (fun m0 : M A => θ A m0 ≤ wm')
          (let (w, _) := m in w) (Dθ_wkn_obligation_1 m Hm))
       (fun a : A =>
        exist (fun m0 : M B => θ B m0 ≤ wf' a)
          (let (w, _) := f a in w)
          (Dθ_wkn_obligation_1 (f a) (Hf a)))).
apply ax_proof_irrel. rewrite hintUnif. reflexivity.
Qed.

  Program Definition lift {A} (m : M A) : Dθ A (θ A m) := exist _ m _.
  Next Obligation. reflexivity. Qed.

End OfMorphism.

(*****************************************************************)
(* Deriving Dijkstra monads from Monadic Relations               *)
(*****************************************************************)

Section OfRelation.
  Context (M:Monad) (W:OrderedMonad) (R:MonadIdeal M W).
  Import SPropNotations.

  Definition Drel_carrier A (w : W A) :=
    { m : M A | R A m w }.

  Definition Drel_ret A (a : A): Drel_carrier (ret a) :=
    let initCand := (exist _ (@ret M A a) (mrel_ret R a)) in
    initCand.

  Program Definition Drel_bind A B (wm : W A) (wf : A -> W B)
          (m : Drel_carrier wm) (f : forall a, Drel_carrier (wf a)):
    Drel_carrier (bind wm wf) :=
    exist _ (bind (proj1_sig m) (fun a => proj1_sig (f a))) _.
  Next Obligation.
    apply mrel_bind ; [exact (proj2_sig m)| intros a ; apply (proj2_sig (f a))].
  Qed.

  Program Definition Drel_wkn A (w w' : W A) (m : Drel_carrier w) (Hww' : w ≤[W] w')
    : Drel_carrier w' :=
    exist _ (proj1_sig m) (mid_upper_closed Hww' (proj2_sig m)).

  Program Definition Drel : Dijkstra W :=
    @mkDM W Drel_carrier Drel_ret Drel_bind Drel_wkn _ _ _ _ _ _.
  Next Obligation. apply eq_above_sig ; cbv ; rewrite !monad_law1 //. Qed.
  Next Obligation. apply eq_above_sig ; cbv ; rewrite !monad_law2 //. Qed.
  Next Obligation. apply eq_above_sig ; cbv ; rewrite !monad_law3 //. Qed.
  Next Obligation. compute. destruct m as (m,bla). f_equal.
    apply ax_proof_irrel.
  Qed.
  Next Obligation. compute. f_equal. apply ax_proof_irrel. Qed.
  Next Obligation. compute. f_equal. apply ax_proof_irrel. Qed.
End OfRelation.


(* -*- mode: coq; mode: visual-line -*-  *)

From HoTT Require Import Basics.
From WildCat Require Import Basics.
From WildCat Require Export Cat1.

Generalizable Variables m n p A B C.

(** ** Cores and opposites *)

(** The core of a category is obtained by discarding noninvertible morphisms.  We can do this at any selection of dimensions.  We don't make this an [Instance], of course; the user must decide when and how to use it. *)
CoFixpoint isglob_gencore (bs : Stream Bool) `{HasEquivs m A}
  : IsGlob m A.
Proof.
  unshelve econstructor; intros a b; destruct (head bs).
  1:exact (a $<~> b).
  1:exact (a $-> b).
  all: cbn; rapply (isglob_gencore (tail bs)).
Defined.

(** We could combine cores with opposites by using a [Stream Laxity] instead. *)

CoFixpoint isfunctor0_gencore (bs : Stream Bool)
           `{HasEquivs m A, IsCat1 n B}
           (F : A -> B) `{!IsFunctor0 F, !IsFunctor1 F}
  : @IsFunctor0 m A n B (isglob_gencore bs) (isglob_gencore bs) F.
Proof.
  snrapply Build_IsFunctor0; intros a b; cbn; destruct (head bs).
  1:apply (cate_fmap F).
  1:apply (fmap F).
  all:cbn; srapply isfunctor0_gencore.
Defined.

CoFixpoint iscat0_gencore (bs : Stream Bool) `{IsCat1 m A}
  : @IsCat0 m A (isglob_gencore bs).
Proof.
  unshelve econstructor; cbn; destruct (head bs).
  1: intros a b c g f; exact (g $oE f).
  1: intros a b c g f; exact (g $o f).
  1: intros a; apply cate_id.
  1: intros a; apply cat_id.
  1-4: cbn; intros a b c g; srapply isfunctor0_gencore.
  1: intros _ a b f; exact (f^-1$).
  1: intros; apply gpd_inv; assumption.
  all: exact _.
Defined.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Aaron Bohannon
     Arthur Charg\'eraud
     Stephanie Weirich *)

(** remove printing ~ *)

Require Import Coq.FSets.FSets.
Require Import Coq.Lists.List.
Require Import Coq.Logic.Decidable.

Require Import Metalib.CoqFSetDecide.
Require Import Metalib.CoqListFacts.
Require Import Metalib.LibTactics.

Require Import Metalib.MetatheoryAtom.
Import AtomSetImpl.
Require Import Metalib.LibTactics.

(* *********************************************************************** *)
(** * Implementation *)

  (* ********************************************************************* *)
  (** ** Basic definitions *)

  (** This section defines the following basic operations and
      predicates on association lists.

        - [one]: Constructs an association list consisting of exactly
          one binding.
        - [map]: Maps a function over the values in an association list.
        - [dom]: Computes the domain of an association list, i.e., the
          set consisting of its keys.
        - [disjoint]: Binary predicate that holds when the domains of
          two association lists are disjoint.
        - [binds]: Ternary predicate that holds when a key-value pair
          appears somewhere in an association list.
        - [uniq]: Unary predicate that holds when an association list
          binds any given key at most once.  Note that [uniq_push] is
          defined in terms of [one], due to our normal form for
          association lists.

      Implicit arguments are declared by default for these
      definitions.  We define some local notations to make the
      definition of [uniq] easier to read and to be consistent with
      the notations used in the rest of this library. *)

  Section Definitions.
    Set Implicit Arguments.
    Variables A B C : Set.

    Definition one (C : Set) (item : C) : list C := cons item nil.

    Inductive asn (A:Set) (B:Set) : Set :=
      | VarAsn : atom -> A -> asn A B
      | AltAsn : B         -> asn A B
    .

    Definition map (f1 : A -> A) (f2: B -> B) (E : list (asn A B)) : list (asn A B) :=
      List.map (fun x => match x with
                         | VarAsn _ x a => VarAsn B x (f1 a)
                         | AltAsn _ b   => AltAsn A (f2 b)
                         end) E.

    Fixpoint dom (A: Set) (B: Set) (E : list (asn A B)) {struct E} : atoms :=
      match E with
        | nil => empty
        | (VarAsn _ x _) :: E' => add x (dom E')
        | _ :: E' => dom E'
      end.

    Definition disjoint (E : list (asn A B)) (F : list (asn A B)) : Prop :=
      Subset (inter (dom E) (dom F)) empty.

    Definition binds (x : atom) (a : A) (E : list (asn A B)) : Prop :=
      List.In (VarAsn  B x a) E.

    Definition bindsAlt (b : B) (E : list (asn A B)) : Prop :=
      List.In (AltAsn A b) E.

    Local Notation "x ~~ a" := (one (VarAsn B x a)) (at level 68).
    Local Notation "x `notin` E" := (~ In x E) (at level 70).

    Inductive uniq : list (asn A B) -> Prop :=
      | uniq_nil :
          uniq nil
      | uniq_push : forall x a E,
          uniq E ->
          x `notin` dom E ->
          uniq ((x ~~ a) ++ E)
      | uniq_alt : forall b E,
          uniq E ->
          uniq (one (AltAsn A b) ++ E).

    Fixpoint erase (E : list (asn A B)) : list B :=
      match E with
      | nil => nil
      | (AltAsn _ b) :: E => b :: erase E
      | (VarAsn _ x a) :: E => erase E
      end.

    Unset Implicit Arguments.
  End Definitions.

  (* ********************************************************************* *)
  (** ** Local notations *)

  (** We make a local notation for [one], and for operations and
      predicate on finite sets, in order to make the statements of the
      lemmas below more readable.  The notations are local so that
      users of this functor may choose their own notations. *)

  Local Notation "[ i ]" := (one i).
(*  Local Notation "x ~~ T" := (one (VarAsn B x T)) (at level 68). *)

  Local Notation "E `union` F" :=
    (union E F)
    (at level 65, right associativity).
  Local Notation "x `in` E" :=
    (In x E)
    (at level 70).
  Local Notation "x `notin` E" :=
    (~ In x E)
    (at level 70).
  Local Notation "E [=] F" :=
    (Equal E F)
    (at level 70, no associativity).
  Local Notation "E [<=] F" :=
    (Subset E F)
    (at level 70, no associativity).

  (* ********************************************************************* *)
  (** ** List properties *)

  (** The following block of properties is used mainly for rewriting
      association lists into the normal form described above.  See the
      [simpl_alist] and [rewrite_alist] tactics below. *)

  Section ListProperties.
    Variables X : Set.
    Variables x y : X.
    Variables l l1 l2 l3 : list X.

    Lemma cons_app_one :
      cons x l = [ x ] ++ l.
    Proof. clear. reflexivity. Qed.

    Lemma cons_app_assoc :
      (cons x l1) ++ l2 = cons x (l1 ++ l2).
    Proof. clear. reflexivity. Qed.

    Lemma app_assoc :
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
    Proof. clear. apply app_ass. Qed.

    Lemma app_nil_1 :
      nil ++ l = l.
    Proof. clear. reflexivity. Qed.

    Lemma app_nil_2 :
      l ++ nil = l.
    Proof. clear. auto with datatypes. Qed.

    Lemma in_one :
      List.In x [ y ] <-> x = y.
    Proof. clear. simpl. intuition congruence. Qed.

    Lemma in_app :
      List.In x (l1 ++ l2) <-> List.In x l1 \/ List.In x l2.
    Proof. clear. split; auto using in_or_app, in_app_or. Qed.

  End ListProperties.

  Hint Rewrite cons_app_one cons_app_assoc app_assoc : rewr_list.
  Hint Rewrite app_nil_1 app_nil_2 : rewr_list.
  Hint Rewrite in_one in_app : rewr_list_in.

  (** The following block of properties is an assortment of
      structural properties about lists. *)

  Section AssortedListProperties.
    Variables X : Set.
    Variables x y : X.
    Variables l l1 l2 l3 : list X.

    Lemma one_eq_app :
      [ x ] ++ l1 = l2 ++ l3 ->
      (exists qs, l2 = x :: qs /\ l1 = qs ++ l3) \/
      (l2 = nil /\ l3 = x :: l1).
    Proof. simpl. auto using CoqListFacts.cons_eq_app. Qed.

    Lemma app_eq_one :
      l2 ++ l3 = [ x ] ++ l1 ->
      (exists qs, l2 = x :: qs /\ l1 = qs ++ l3) \/
      (l2 = nil /\ l3 = x :: l1).
    Proof. simpl. auto using CoqListFacts.app_eq_cons. Qed.

    Lemma nil_neq_one_mid :
      nil <> l1 ++ [ x ] ++ l2.
    Proof. simpl. apply List.app_cons_not_nil. Qed.

    Lemma one_mid_neq_nil :
      l1 ++ [ x ] ++ l2 <> nil.
    Proof.
      intros H; symmetry in H; revert H.
      simpl. apply List.app_cons_not_nil.
    Qed.

  End AssortedListProperties.

  (* ********************************************************************* *)
  (** ** Properties of [map] and [dom] *)

  (** The following lemmas are used mainly to simplify applications of
      [map] and [dom] to association lists.  See also the [simpl_alist]
      and [rewrite_alist] tactics below. *)

  Section Properties.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x : atom.
    Variables b : A.
    Variables a : B.
    Variables E F G : list (asn A B).

    Lemma map_nil :
      map f1 f2 nil = nil.
    Proof. clear. reflexivity. Qed.

    Lemma map_consVar :
      map f1 f2 ((VarAsn B x b) :: E) = (VarAsn B x (f1 b)) :: map f1 f2 E.
    Proof. clear. reflexivity. Qed.

    Lemma map_consAlt :
      map f1 f2 ((AltAsn A a) :: E) = (AltAsn A (f2 a)) :: map f1 f2 E.
    Proof. clear. reflexivity. Qed.

    Lemma map_oneVar :
      map f1 f2 (one (VarAsn B x b)) = one (VarAsn B x (f1 b)).
    Proof. clear. reflexivity. Qed.

    Lemma map_oneAlt :
      map f1 f2 (one (AltAsn A a)) = one (AltAsn A (f2 a)).
    Proof. clear. reflexivity. Qed.

    Lemma map_app :
      map f1 f2 (E ++ F) = map f1 f2 E ++ map f1 f2 F.
    Proof. clear. unfold map. rewrite -> List.map_app. reflexivity. Qed.

    Lemma dom_nil :
      (@dom A B nil) = empty.
    Proof. clear. reflexivity. Qed.

    Lemma dom_consVar :
      dom (VarAsn B x b :: E) [=] singleton x `union` dom E.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_consAlt :
      dom (AltAsn A a :: E) [=] dom E.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_one :
      dom (one (VarAsn B x b)) [=] singleton x.
    Proof. clear. simpl. fsetdec. Qed.

    Lemma dom_app :
      dom (E ++ F) [=] dom E `union` dom F.
    Proof. clear. induction E as [ | a ]; simpl; try (destruct a); fsetdec. Qed.

    Lemma dom_map :
      dom (map f1 f2 E) [=] dom E.
    Proof. clear. induction E as [ | a ]; simpl; try (destruct a); fsetdec. Qed.

  End Properties.

  Hint Rewrite map_nil map_consVar map_consAlt map_oneVar map_oneAlt map_app : rewr_map.
  Hint Rewrite dom_nil dom_consVar dom_consAlt dom_one dom_app dom_map : rewr_dom.

  (* ********************************************************************* *)
  (** ** The [simpl_alist] tactic *)

  (** The [simpl_alist] tactic rewrites association lists so that they
      are in the normal form described above.  Similar to the [simpl]
      tactic, we define "[in *]" and "[in H]" variants of the tactic. *)

  Ltac simpl_asnlist :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom.
  Tactic Notation "simpl_asnlist" "in" hyp(H) :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom in H.
  Tactic Notation "simpl_asnlist" "in" "*" :=
    autorewrite with rewr_list rewr_list_in rewr_map rewr_dom in *.

  (* ********************************************************************* *)
  (** ** The [rewrite_alist] tactic *)

  (** The tactic [(rewrite_alist E)] replaces an association list in
      the conclusion of the goal with [E].  Suitability for
      replacement is determined by whether [simpl_alist] can put [E]
      and the chosen environment in the same normal form, up to
      convertibility's in Coq.  We also define an "[in H]" variant
      that performs the replacement in a hypothesis [H].  *)

  Tactic Notation "rewrite_asnlist" constr(E) :=
    match goal with
      | |- context[?x] =>
        change x with E
      | |- context[?x] =>
        replace x with E;
          [ | try reflexivity; simpl_asnlist; reflexivity ]
    end.

  Tactic Notation "rewrite_asnlist" constr(E) "in" hyp(H) :=
    match type of H with
      | context[?x] =>
        change x with E in H
      | context[?x] =>
        replace x with E in H;
          [ | try reflexivity; simpl_asnlist; reflexivity ]
    end.

  (* ********************************************************************* *)
  (** ** Basic facts about [disjoint] *)

  Section BasicDisjointFacts.
    Implicit Types A B C D : Set.

    Lemma disjoint_sym_1 :
      forall A B (E : list (asn A B)) (F : list (asn A B)),
      disjoint E F ->
      disjoint F E.
    Proof. unfold disjoint. fsetdec. Qed.

    Lemma disjoint_sym :
      forall A B (E : list (asn A B)) (F : list (asn A B)),
      disjoint E F <-> disjoint F E.
    Proof. intuition auto using disjoint_sym_1. Qed.

    Lemma disjoint_one_1 :
      forall A B (x : atom) (a : A) (F : list (asn A B)),
      disjoint (one (VarAsn B x a)) F ->
      x `notin` dom F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_one_2 :
      forall A B (x : atom) (a : A) (F : list (asn A B)),
      x `notin` dom F ->
      disjoint (one (VarAsn B x a)) F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_one_l :
      forall A B (x : atom) (a : A) (E : list (asn A B)),
      disjoint (one (VarAsn B x a)) E <-> x `notin` dom E.
    Proof. intros. unfold disjoint; simpl_asnlist; split; fsetdec. Qed.

    Lemma disjoint_one_r :
      forall A B (x : atom) (a : A) (E : list (asn A B)),
      disjoint E (one (VarAsn B x a)) <-> x `notin` dom E.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_one_l. Qed.

    Lemma disjoint_app_1 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G ->
      disjoint E G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_2 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G ->
      disjoint F G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_3 :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint E G ->
      disjoint F G ->
      disjoint (E ++ F) G.
    Proof. intros. unfold disjoint in *. simpl_asnlist in *. fsetdec. Qed.

    Lemma disjoint_app_l :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint (E ++ F) G <-> disjoint E G /\ disjoint F G.
    Proof.
      intros; intuition eauto using
        disjoint_app_1, disjoint_app_2, disjoint_app_3.
    Qed.

    Lemma disjoint_app_r :
      forall A B (E F : list (asn A B)) (G : list (asn A B)),
      disjoint G (E ++ F) <-> disjoint E G /\ disjoint F G.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_app_l. Qed.

    Lemma disjoint_map_1 :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2 : B -> B),
      disjoint (map f1 f2 E) F ->
      disjoint E F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. trivial. Qed.

    Lemma disjoint_map_2 :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A)(f2: B -> B),
      disjoint E F ->
      disjoint (map f1 f2 E) F.
    Proof. unfold disjoint. intros. simpl_asnlist in *. trivial. Qed.

    Lemma disjoint_map_l :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2: B -> B),
      disjoint (map f1 f2 E) F <-> disjoint E F.
    Proof. intros; intuition eauto using disjoint_map_1, disjoint_map_2. Qed.

    Lemma disjoint_map_r :
      forall A B C (E : list (asn A B)) (F : list (asn A B)) (f1 : A -> A) (f2: B -> B),
      disjoint F (map f1 f2 E) <-> disjoint E F.
    Proof. intros. rewrite -> disjoint_sym. apply disjoint_map_l. auto. Qed.

  End BasicDisjointFacts.

  Hint Rewrite
    disjoint_one_l disjoint_one_r
    disjoint_app_l disjoint_app_r
    disjoint_map_l disjoint_map_r
  : rewr_uniq.

  (* ********************************************************************* *)
  (** ** Basic facts about [uniq] *)

  (** The following lemmas are facts about [uniq] with respect to the
      basic functions ([one], [app], and [map]) that can be used to
      build association lists. *)

  Section UniqProperties.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x : atom.
    Variables b : A.
    Variables E F G : list (asn A B).

    Lemma uniq_one_1 :
      uniq (one (VarAsn B x b)).
    Proof.
      clear. rewrite_asnlist ((one (VarAsn B x b)) ++ nil).
      apply uniq_push; [ apply uniq_nil | fsetdec ].
    Qed.

    Lemma uniq_app_1 :
      uniq (E ++ F) -> uniq E.
    Proof.
      clear. intros H; induction E as [ | a E']; simpl_asnlist in *.
        apply uniq_nil.
        destruct a.
        apply uniq_push; inversion H; subst.
          auto.
          simpl_asnlist in *. fsetdec.
        apply uniq_alt; inversion H; subst.
          auto.
    Qed.

    Lemma uniq_app_2 :
      uniq (E ++ F) -> uniq F.
    Proof.
      clear. intros H; induction E as [ | a E'].
        apply H.
        inversion H; subst. auto.
        inversion H; subst. auto.
    Qed.

    Lemma uniq_app_3 :
      uniq (E ++ F) -> disjoint E F.
    Proof.
      clear. intros H. red. induction E as [ | a E'].
        fsetdec.
        inversion H; subst. simpl_asnlist in *. lapply IHE'.
          fsetdec.
          assumption.
        inversion H; subst. simpl_asnlist in *. lapply IHE'.
          fsetdec.
          assumption.
    Qed.

    Lemma uniq_app_4 :
      uniq E ->
      uniq F ->
      disjoint E F ->
      uniq (E ++ F).
    Proof.
      clear. intros HE HF Hd.
      induction E as [ | a E']; simpl_asnlist in *.
        assumption.
        rewrite -> disjoint_app_l in Hd.
          inversion HE; subst. apply uniq_push.
            intuition.
            rewrite disjoint_one_l in Hd. simpl_asnlist. fsetdec.
        apply uniq_alt.
          inversion HE; subst.
            intuition.
    Qed.

    Lemma uniq_app :
      uniq (E ++ F) <-> uniq E /\ uniq F /\ disjoint E F.
    Proof.
      clear; intuition eauto using
        uniq_app_1, uniq_app_2, uniq_app_3, uniq_app_4.
    Qed.

    Lemma uniq_map_1 :
      uniq (map f1 f2 E) ->
      uniq E.
    Proof.
      clear. intros H. induction E as [ | a E']; simpl_asnlist in *.
        apply uniq_nil.
        destruct a.
        inversion H; subst. apply uniq_push; simpl_asnlist in *; auto.
        inversion H; subst. apply uniq_alt; simpl_asnlist in *; auto.
    Qed.

    Lemma uniq_map_2 :
      uniq E ->
      uniq (map f1 f2 E).
    Proof.
      clear. intros J. induction E as [ | a E']; simpl_asnlist in *.
      apply uniq_nil.
      inversion J; subst. simpl_asnlist. apply uniq_push.
        auto.
        rewrite dom_map. trivial.
      inversion J; subst. simpl_asnlist. apply uniq_alt. auto.
    Qed.

    Lemma uniq_map :
      uniq (map f1 f2 E) <-> uniq E.
    Proof.
      clear. intuition eauto using uniq_map_1, uniq_map_2.
    Qed.

  End UniqProperties.

  Hint Rewrite uniq_app uniq_map : rewr_uniq.

  (* ********************************************************************* *)
  (** ** The [solve_uniq] tactic *)

  (** This tactic attempts to solve goals about [uniq].  Given its
      definition, it's likely to work only when the hypotheses in the
      goal already contain all the relevant [uniq] propositions.
      Thus, the tactic may not be generally useful.  It is useful,
      however, for proving facts about [uniq] such as the ones below.

      Implementation note: The second [simpl_asnlist] in the definition
      is because of [disjoint_one_{l,r}].  The "[|| fail]" at the end
      is so that in the case of failure, the error message reported to
      the user is not the one from [fsetdec]. *)

  Ltac solve_uniq :=
    try trivial;
    simpl_asnlist in *;
    autorewrite with rewr_uniq in *;
    simpl_asnlist in *;
    intuition (
      auto using uniq_nil, uniq_one_1 ||
      (rewrite -> disjoint_sym; auto) ||
      (unfold disjoint in *; fsetdec))
    || fail.

  (* ********************************************************************* *)
  (** ** Facts about [uniq] *)

  Section UniqDerived.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma uniq_cons_3 :
      uniq E ->
      x `notin` dom E ->
      uniq ((VarAsn B x a) :: E).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_insert_mid :
      uniq (G ++ E) ->
      x `notin` dom (G ++ E) ->
      uniq (G ++ (one (VarAsn B x a)) ++ E).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_remove_mid :
      uniq (E ++ F ++ G) ->
      uniq (E ++ G).
    Proof. clear. solve_uniq. Qed.

    Lemma uniq_map_app_l : forall (f1 : A -> A)(f2: B -> B),
      uniq (F ++ E) ->
      uniq (map f1 f2 F ++ E).
    Proof. clear. intros. solve_uniq. Qed.

    Lemma fresh_mid_tail :
      uniq (F ++ (one (VarAsn B x a)) ++ E) ->
      x `notin` dom E.
    Proof. clear. solve_uniq. Qed.

    Lemma fresh_mid_head :
      uniq (F ++ (one (VarAsn B x a)) ++ E) ->
      x `notin` dom F.
    Proof. clear. solve_uniq. Qed.

  End UniqDerived.

  (* ********************************************************************* *)
  (** ** Basic facts about [binds] *)

  (** The following lemmas are facts about [binds] with respect to the
      basic functions ([one] and [app]) that can be used to build
      association lists.

      Note: [map] is treated further below. *)

  Section BindsProperties.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_nil :
      binds x a (@nil (asn A B)) <-> False.
    Proof. clear. split. inversion 1. intuition. Qed.

    Lemma binds_one_3 :
      x = y ->
      a = b ->
      binds x a (one (VarAsn B y b)).
    Proof. clear. intros. red. simpl. left. congruence. Qed.

    Lemma binds_one_1 :
      binds x a (one (VarAsn B y b)) ->
      x = y.
    Proof.
      clear. intros H1. inversion H1 as [HEq | HIn].
        inversion HEq; intuition.
        intuition.
    Qed.

    Lemma binds_one_2 :
      binds x a (one (VarAsn B y b)) ->
      a = b.
    Proof.
      clear. intros H1. inversion H1 as [HEq | HIn].
        inversion HEq; intuition.
        intuition.
    Qed.

    Lemma binds_one_iff :
      binds x a (one (VarAsn B y b)) <-> x = y /\ a = b.
    Proof.
      clear. split.
        intros H1. intuition eauto using binds_one_1, binds_one_2.
        intros H1. intuition auto using binds_one_3.
    Qed.

  Lemma binds_cons_1 :
    binds x a ((VarAsn B y b) :: E) ->
    (x = y /\ a = b) \/ binds x a E.
  Proof. clear. inversion 1 as [J | J]; try injection J; auto. Qed.

  Lemma binds_cons_2 :
    x = y ->
    a = b ->
    binds x a ((VarAsn B y b) :: E).
  Proof. clear. unfold binds. simpl. left. f_equal; auto. Qed.

  Lemma binds_cons_3 :
    binds x a E ->
    binds x a ((VarAsn B y b) :: E).
  Proof. clear. unfold binds. simpl. right. trivial. Qed.

  Lemma binds_cons_iff :
    binds x a ((VarAsn B y b) :: E) <-> (x = y /\ a = b) \/ binds x a E.
  Proof.
    clear. intuition auto using binds_cons_1, binds_cons_2, binds_cons_3.
  Qed.

    Lemma binds_app_1 :
      binds x a E ->
      binds x a (E ++ F).
    Proof. clear. intros H. red in H |- *. rewrite -> in_app. auto. Qed.

    Lemma binds_app_2 :
      binds x a F ->
      binds x a (E ++ F).
    Proof. clear. intros H. red in H |- *. rewrite -> in_app. auto. Qed.

    Lemma binds_app_3 :
      binds x a (E ++ F) ->
      binds x a E \/ binds x a F.
    Proof.
      clear. induction E as [ | a1 E' ].
        auto.
        unfold binds. simpl. intros [H | H].
          inversion H; subst. auto.
          unfold binds in *. apply IHE' in H. intuition.
    Qed.

    Lemma binds_app :
      binds x a (E ++ F) <-> binds x a E \/ binds x a F.
    Proof.
      clear. intuition auto using binds_app_1, binds_app_2, binds_app_3.
    Qed.

  End BindsProperties.

  Hint Rewrite binds_nil binds_one_3 binds_app : rewr_binds.
  Hint Rewrite binds_nil binds_one_3 : rewr_binds_uniq.

  (* ********************************************************************* *)
  (** ** Additional lemmas and tactics for working with [binds] *)

  Section MoreBindsProperties.
    Variables A B : Set.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_dom_contradiction: forall (E : list (asn A B)),
      binds x a E ->
      x `notin` dom E ->
      False.
    Proof.
      clear. induction E as [ | a1 E' ]; simpl.
        intros H. inversion H.
        unfold binds in *. simpl. intros [H | H] J.
          inversion H; subst. fsetdec.
          apply IHE' in H. trivial. destruct a1. fsetdec. auto.
    Qed.

    Lemma binds_app_uniq :
      uniq (E ++ F) ->
      (binds x a (E ++ F) <->
        (binds x a E /\ x `notin` dom F) \/
        (binds x a F /\ x `notin` dom E)).
    Proof with intuition (fsetdec || eauto using binds_dom_contradiction).
      clear. intros H1.
      autorewrite with rewr_uniq in H1. unfold disjoint in H1.
      assert (H : x `notin` dom F \/ x `notin` dom E) by fsetdec.
      rewrite binds_app...
    Qed.

  End MoreBindsProperties.

  Hint Rewrite binds_app_uniq using solve_uniq : rewr_binds_uniq.

  (** The [apply_binds_dom_contradiction] tactic solves a goal by
      applying the [binds_dom_contradiction] lemma.  The tactic
      succeeds only if the the hypotheses of the lemma are immediately
      satisfied. *)

  Ltac apply_binds_dom_contradiction :=
    match goal with
      | H : binds ?x ?a ?E, J : ?x `notin` (dom ?E) |- _ =>
        assert False by apply (@binds_dom_contradiction _ _ _ _ H J);
        intuition
      | H : binds ?x ?a ?E, J : ?x `in` (dom ?E) -> False |- _ =>
        assert False by apply (@binds_dom_contradiction _ _ _ _ H J);
        intuition
    end.

  (** The [solve_binds] tactic attempts to solve goals about [binds].
      Given its definition, it's likely to work only when the
      hypotheses in the goal already contain all the relevant [binds]
      propositions.  Thus, the tactic may not be generally useful.  It
      is useful, however, for proving facts about [binds] such as the
      ones below. *)

  Ltac solve_binds :=
    simpl_asnlist in *;
    autorewrite with rewr_binds in *;
    intuition (auto || fsetdec || apply_binds_dom_contradiction)
    || fail.

  (** The tactics [analyze_binds] and [analyze_binds_uniq] tactics
      take as an argument a hypotheses about [binds] and perform a
      case analysis based on the structure of the association list.
      In the case of [analyze_binds_uniq], the analysis is performed
      assuming that the association list is [uniq].  The lemmas
      [binds_app] and [binds_app_uniq] are examples of such case
      analysis.

      Implementation notes:

        - The initial calls to [simpl_asnlist] put the relevant
          association lists into normal form.
        - In the case of [binds_app_uniq], we assert that the
          association list is [uniq].  This enables the [autorewrite]
          step to succeed.
        - Rather than work on [H] itself, we copy it and work on the
          copy.  Thus, in instances where the analysis leaves unsolved
          subgoals, it is still possible to see the original
          hypothesis.
        - The rest of the tactic breaks apart the copy of H and tries
          several simple means for solving the resulting subgoals. *)

  Ltac analyze_binds H :=
    simpl_asnlist;
    simpl_asnlist in H;
    match type of H with
      | binds ?x ?a ?E =>
        let J := fresh in
        pose proof H as J;
        autorewrite with rewr_binds in J;
        simpl_asnlist in J;
        try (progress decompose [and or] J; clear J);
        try solve [trivial | discriminate | intuition | fsetdec]
    end.

  Ltac analyze_binds_uniq H :=
    simpl_asnlist;
    simpl_asnlist in H;
    match type of H with
      | binds ?x ?a ?E =>
        match goal with
          | H : uniq ?E |- _ => idtac
          | _ => assert (uniq E); [ try solve_uniq | ]
        end;
        let J := fresh in
        pose proof H as J;
        autorewrite with rewr_binds_uniq in J;
        simpl_asnlist in J;
        try (progress decompose [and or] J; clear J);
        try solve [trivial | discriminate | intuition | fsetdec]
    end.

  (* ********************************************************************* *)
  (** ** Facts about [binds] *)

  Section BindsDerived.
    Variables A B : Set.
    Variables f1 : A -> A.
    Variables f2 : B -> B.
    Variables x y : atom.
    Variables a b : A.
    Variables E F G : list (asn A B).

    Lemma binds_map_2 :
      binds x a E ->
      binds x (f1 a) (map f1 f2 E).
    Proof.
      clear. induction E; simpl_asnlist.
        inversion 1.
        unfold binds in *. simpl. intros [? | ?].
          destruct a0.
             inversion H; subst.
             left. congruence.
             inversion H.
          destruct a0.
            right. auto.
            right. auto.
    Qed.

    Lemma binds_weaken :
      binds x a (E ++ G) ->
      binds x a (E ++ F ++ G).
    Proof. clear. intros. solve_binds. Qed.

    Lemma binds_In : forall x a (E : list (asn A B)),
      binds x a E ->
      x `in` dom E.
    Proof.
      clear. induction E as [ | y ? F ]; intros J; simpl_asnlist.
      analyze_binds J.
      analyze_binds J; subst; auto with set.
        inversion H0;subst. simpl. fsetdec.
          inversion H.
    Qed.

    Lemma fresh_app_l :
      uniq (F ++ E) ->
      binds x a E ->
      x `notin` dom F.
    Proof.
      clear. intros.
      assert (x `in` dom E) by eauto using binds_In.
      solve_uniq.
    Qed.

    Lemma fresh_app_r :
      uniq (F ++ E) ->
      binds x a F ->
      x `notin` dom E.
    Proof.
      clear. intros.
      assert (x `in` dom F) by eauto using binds_In.
      solve_uniq.
    Qed.

  End BindsDerived.


(* PREAMBLE *)

From compcert.common    Require AST Values.
From compcert.cfrontend Require Csyntax Csem.
From compcert.lib       Require Coqlib.
From trancert.lib       Require Tac Decidability Option.
From trancert.analysis  Require ExprQuant.

Import Coqlib BinNums AST Algebraic Csyntax Csem Decidability Option Tac ExprQuant common.Values.

(** * [forall] and [exists] for expressions in statements *)
Section Forall.

  Variable R: expr -> Prop.
  Inductive forall_expr_in_stmt : statement-> Prop :=
  | expr_in_skip: forall_expr_in_stmt Sskip
  | expr_in_do: forall e, R e -> forall_expr_in_stmt (Sdo e)
  | expr_in_sequence: forall s1 s2 ,
      forall_expr_in_stmt s1 ->
      forall_expr_in_stmt s2 ->
      forall_expr_in_stmt (Ssequence s1 s2)
  | expr_in_ifthenelse : forall s1 s2 s3 ,
      R s1  ->
      forall_expr_in_stmt s2 ->
      forall_expr_in_stmt s3 ->
      forall_expr_in_stmt (Sifthenelse s1 s2 s3)
  | expr_in_while: forall s1  s2 ,
      R s1 ->
      forall_expr_in_stmt s2  ->
      forall_expr_in_stmt (Swhile s1 s2)
  | expr_in_dowhile: forall s1  s2 ,
      R s1  ->
      forall_expr_in_stmt s2  ->
      forall_expr_in_stmt (Sdowhile s1 s2)
  | expr_in_for: forall s1  e  s2  s3 ,
      forall_expr_in_stmt s1  ->
      R e ->
      forall_expr_in_stmt s2  ->
      forall_expr_in_stmt s3 ->
      forall_expr_in_stmt (Sfor s1 e s2 s3)
  | expr_in_break:
      forall_expr_in_stmt Sbreak
  | expr_in_continue:
      forall_expr_in_stmt Scontinue
  | expr_in_return_some: forall e ,
      R e ->
      forall_expr_in_stmt (Sreturn (Some e))
  | expr_in_return_none:
      forall_expr_in_stmt (Sreturn None)
  | expr_in_goto : forall l, forall_expr_in_stmt (Sgoto l)
  | expr_in_label: forall l s,
      forall_expr_in_stmt s  ->
      forall_expr_in_stmt (Slabel l s)
  | expr_in_switch: forall e ss,
      R e  ->
      forall_expr_in_ls ss  ->
      forall_expr_in_stmt (Sswitch e ss)
  with forall_expr_in_ls : labeled_statements -> Prop :=
       | expr_in_lsnil:
           forall_expr_in_ls LSnil
       | expr_in_lscons: forall oz s ls,
           forall_expr_in_stmt s ->
           forall_expr_in_ls ls ->
           forall_expr_in_ls (LScons oz s ls)
  .

  Hypothesis R_dec: forall e, dec (R e).

  Theorem forall_expr_in_stmt_dec:
    forall s, dec (forall_expr_in_stmt s) with
      forall_expr_in_ls_dec:
    forall s, dec (forall_expr_in_ls s).
  Proof.
    {
      clear forall_expr_in_stmt_dec.
      induction s; try solve [repeat constructor].
      - destruct (R_dec e); [constructor 1| constructor 2].
        constructor; auto.
        inversion 1. contradiction.
      - destruct IHs1, IHs2;
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct IHs1, IHs2, (R_dec e);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct IHs, (R_dec e);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct IHs, (R_dec e);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct IHs1, IHs2, IHs3, (R_dec e);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct o.
        + destruct (R_dec e); [repeat constructor; auto | constructor 2; inversion 1; contradiction].
        + repeat constructor.
      - destruct (R_dec e), (forall_expr_in_ls_dec l);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
      - destruct IHs;
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
    }
    {
      clear forall_expr_in_ls_dec.
      induction s;
        [constructor 1; constructor; auto |  ].
      - destruct IHs, (forall_expr_in_stmt_dec s);
        [constructor 1; constructor; auto |
        constructor 2; inversion 1; contradiction..].
    }
  Defined.
End Forall.

Notation "∀ e ∈ s , P " := (forall_expr_in_stmt (fun e => P) s) (at level 51, no associativity).

Notation "∀ e ∈ 'stmts s , P " := (forall_expr_in_ls (fun e => P) s) (at level 51, no associativity).

Section ForallImpl.
  Hypotheses P Q: expr->Prop.

  Theorem forall_impl:
    forall s,
      (forall e, P e -> Q e) ->
      (forall_expr_in_stmt P s -> forall_expr_in_stmt  Q s)
    with forall_impl_ls:
           forall ls,
             (forall e, P e -> Q e) ->
             forall_expr_in_ls P ls ->
             forall_expr_in_ls Q ls.
  Proof.
    {
      clear forall_impl.
      induction s; try solve [inversion 2; constructor; auto].
    }
    {
      clear forall_impl_ls.
      induction ls; try solve [inversion 2; constructor; auto].
    }
  Defined.

End ForallImpl.

Section ForallPointers.
  Import common.Values Integers.Ptrofs.

  Variable P: block -> int  -> Prop.
  Hypothesis Hdec: forall b ofs, dec (P b ofs).

  Definition forall_pointers_in_stmt (s:statement) : Prop :=
    forall_expr_in_stmt (forall_pointers_in_expr P) s.

  Lemma forall_pointers_in_stmt_dec: forall s, dec (forall_pointers_in_stmt s).
  Proof.
    apply forall_expr_in_stmt_dec. apply forall_pointers_in_expr_dec. assumption.
  Defined.

End ForallPointers.

Section Exists.
  Hypothesis P: expr -> Prop.

Inductive exists_expr_in_stmt  : statement -> Prop :=
    ees_do : forall e : expr, P  e -> exists_expr_in_stmt  (Sdo e)
  | ees_seq : forall s1 s2 : statement,
      exists_expr_in_stmt  s1 \/
      exists_expr_in_stmt  s2 ->
      exists_expr_in_stmt  (Ssequence s1 s2)
  | ees_cond : forall (e : expr) (s1 s2 : statement),
      P  e \/
      exists_expr_in_stmt  s1 \/
      exists_expr_in_stmt  s2 ->
      exists_expr_in_stmt  (Sifthenelse e s1 s2)
  | ees_whl : forall (e : expr) (s : statement),
      P  e \/
      exists_expr_in_stmt  s ->
      exists_expr_in_stmt  (Swhile e s)
  | ees_dowhl : forall (e : expr) (s : statement),
      P  e \/
      exists_expr_in_stmt s ->
      exists_expr_in_stmt (Sdowhile e s)
  | ees_for : forall (s1 : statement) (e : expr) (s2 s3 : statement),
      exists_expr_in_stmt  s1 \/
      P  e \/
      exists_expr_in_stmt  s2 \/
      exists_expr_in_stmt  s3 ->
      exists_expr_in_stmt  (Sfor s1 e s2 s3)
  | ees_ret : forall e : expr,
      P e ->
      exists_expr_in_stmt  (Sreturn (Some e))
  | ees_sw : forall (e : expr) (ls : labeled_statements),
      P e \/
      exists_expr_in_ls ls ->
      exists_expr_in_stmt  (Sswitch e ls)
  | ees_label : forall (l : label) (s : statement),
      exists_expr_in_stmt s ->
      exists_expr_in_stmt (Slabel l s)
with exists_expr_in_ls: labeled_statements -> Prop :=
  eels : forall i s ss,
    exists_expr_in_stmt  s \/
    exists_expr_in_ls ss ->
    exists_expr_in_ls (LScons i s ss)
.

End Exists.

Notation "∃ e ∈ s , P " := (exists_expr_in_stmt (fun e => P) s) (at level 51, no associativity).

Notation "∃ e ∈ 'stmts s , P " := (exists_expr_in_ls (fun e => P) s) (at level 51, no associativity).

Section Decidability.
  Variable P: expr -> Prop.
  Hypothesis Hdec: forall e, dec (P e).
  Theorem exists_expr_in_stmt_dec : forall s, dec (exists_expr_in_stmt P s)
    with exists_expr_in_ls_dec : forall s, dec (exists_expr_in_ls P s).
  Proof.
    {
      clear exists_expr_in_stmt_dec.
      unfold dec in *.
      induction s; try solve [
                         try destruct (Hdec e);
                         try destruct IHs1;
                         try destruct IHs2;
                         try destruct IHs3;
                         try destruct IHs;
                         [left; constructor; auto.. | right; inversion_clear 1; decomp]
                       |
                       constructor 2; inversion_clear 1
                       ].
    - destruct o.
      + destruct (Hdec e); [left; constructor; auto|right; inversion_clear 1; contradiction].
      + right; inversion_clear 1.
    - destruct (exists_expr_in_ls_dec l), (Hdec e);
        [left; constructor; auto..|right; inversion_clear 1; decomp].
    }
    {
      clear exists_expr_in_ls_dec.
      induction s.
      - right. inversion 1.
      - destruct IHs.
        + left. constructor; auto.
        + destruct (exists_expr_in_stmt_dec s).
          * left. constructor; auto.
          * right. inversion_clear 1. decomp.
    }
  Defined.
End Decidability.

Section VarInStatement.
  Import common.AST.
  Variable P: ident -> Prop.

  Definition exists_var_in_stmt (s:statement) : Prop :=
    exists_expr_in_stmt (exists_var_in_expr P) s.

  Hypothesis Hdec: forall v, dec (P v).

  Theorem exists_var_in_stmt_dec : forall s, dec (exists_var_in_stmt s).
     exact (exists_expr_in_stmt_dec (exists_var_in_expr P) (exists_var_in_expr_dec P Hdec)).
  Defined.

End VarInStatement.

(** ** Quantifiers for [labeled_statements] *)

Inductive all_labeled_statements (P: statement -> Prop) : labeled_statements -> Prop:=
| ls_all_nil:
    all_labeled_statements P LSnil
| ls_all_cons:
    forall n s ls,
      P s ->
      all_labeled_statements P ls ->
      all_labeled_statements P (LScons n s ls).

Lemma all_labeled_statements_extract_condition:
  forall (P:Prop) (Q:statement->Prop) ss,
    (P -> all_labeled_statements (fun s => Q s) ss) ->
    all_labeled_statements (fun s => P -> Q s) ss .
Proof.
  intros P Q ss H.
  induction ss.
  constructor.
  constructor.
  intros HP.
  specialize (H HP).
  inversion H;auto.
  apply IHss .
  intros HP.
  specialize (H HP).
  inversion H.
  auto.
Qed.

Lemma all_labeled_statements_extract_condition2:
  forall (P:Prop) (Q:statement->Prop) ss,
    (P -> all_labeled_statements (fun s => P -> Q s) ss) ->
    all_labeled_statements (fun s => P -> Q s) ss .
Proof.
  intros P Q ss H.
  induction ss.
  constructor.
  constructor.
  intros HP.
  specialize (H HP).
  inversion H;auto.
  apply IHss .
  intros HP.
  specialize (H HP).
  inversion H.
  auto.
Qed.

Lemma all_labeled_statements_to_expr_in_statement:
  forall (P:expr->Prop) sl,
    all_labeled_statements (forall_expr_in_stmt P) sl ->
    forall_expr_in_stmt P (Csem.seq_of_labeled_statement sl).
Proof.
  induction sl.
  - constructor.
  - inversion 1; constructor; auto.
Qed.

Lemma all_labeled_statements_select_switch_commute:
  forall (P: statement -> Prop) sl sl' n,
    all_labeled_statements P sl ->
    Csem.select_switch_case n sl = Some sl' ->
    all_labeled_statements P sl'.
Proof.
  induction sl; simpl in *.
  - discriminate.
  - intros sl' n H H0.
    option_cases.
    + subst.
      option_cases.
      * autoinj; assumption.
      * inv H; eauto.
    + inv H; eauto.
Qed.

Theorem all_labeled_statements_impl:
  forall (P Q: statement -> Prop) ls,
    all_labeled_statements P ls ->
    (forall s, P s -> Q s) ->
    all_labeled_statements Q ls.
Proof.
  induction 1; constructor; eauto.
Qed.