Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics.
From discprob.measure Require Export measures borel outer_measure.
From discprob.prob Require Import countable rearrange double.
From mathcomp Require Import choice.
Require ClassicalEpsilon ClassicalEpsilon.

Definition Interval a b : Type := { x : R | a <= x <= b }.
Coercion interval_R {a b} (x : Interval a b) : R := (sval x).

Hint Resolve Rabs_pos Rle_ge.
Hint Resolve disc_neighbourhood.

(* Lebesgue number lemma. Most pencil and paper proofs don't seem
   to use this, but I think it makes the proof that the outer measure
   of intervals is equal to their length simpler *)

Lemma lebesgue_number_lemma (I: Type) D (U: I → (R → Prop)) :
  compact D →
  (∀ x, D x → ∃ i, U i x) →
  (∀ i, open (U i)) →
  ∃ δ, 0 < δ ∧ ∀ x, D x → ∃ i, (∀ z, D z → ball x δ z → U i z).
Proof.
  intros Hcompact Hcover Hopen.
  apply Classical_Pred_Type.not_all_not_ex => Hnot.
  assert (Hneg: ∀ y, 0 < y → (∃ x, D x ∧ ∀ i, ∃ z, D z ∧ ball x y z ∧ ¬ U i z)).
  {
    intros y. specialize (Hnot y) => Hpos.
    apply Classical_Prop.not_and_or in Hnot as [?|Hnot]; first by auto.
    apply Classical_Pred_Type.not_all_ex_not in Hnot.
    destruct Hnot as (x&Hnot).
    apply Classical_Prop.imply_to_and in Hnot as (HDx&Hnot).
    exists x; split; auto. intros i.
    unshelve (eapply Classical_Pred_Type.not_ex_all_not in Hnot); first by exact i.
    apply Classical_Pred_Type.not_all_ex_not in Hnot.
    destruct Hnot as (r&Hnot).
    exists r.
    apply Classical_Prop.imply_to_and in Hnot as (?&Hnot).
    apply Classical_Prop.imply_to_and in Hnot as (?&Hnot).
    split_and!; auto.
  }
  unshelve (refine (let un : nat → R := _ in _)).
  { intros n.  specialize (Hneg (/(INR (n+1)))).
    apply ClassicalEpsilon.constructive_indefinite_description in Hneg as (x&Hspec).
    exact x.
    abstract (apply Rinv_0_lt_compat, pos_INR'; lia).
  }
  edestruct (Bolzano_Weierstrass un) as (x&Hneighbor); eauto.
  { intros.  rewrite /un. destruct ClassicalEpsilon.constructive_indefinite_description.
    intuition.
  }
  rewrite /ValAdh in Hneighbor.
  assert (D x).
  {
    apply adherence_P2; first by apply compact_P2.
    rewrite /adherence/point_adherent => V Hneighbor'.
    edestruct (Hneighbor V O) as (p&Hge&HV); eauto.
    exists (un p). rewrite /intersection_domain; split; auto.
    rewrite /un. destruct ClassicalEpsilon.constructive_indefinite_description; intuition.
  }
  edestruct (Hcover x) as (i&HU); auto.
  destruct (open_included_disc (U i) x) as (δ&Hsub); eauto.
  edestruct (archimed_cor1 (δ / 2)) as (N&HleN&?).
  { destruct δ => //=. nra. }
  destruct (Hneighbor (ball x (δ/2)) N) as (N'&Hle&Hin).
  { apply ball_neighbourhood. destruct δ => //=. nra. }
  rewrite /un in Hin.
  destruct (ClassicalEpsilon.constructive_indefinite_description) as (xbad&?&Hneg').
  specialize (Hneg' i). destruct Hneg' as (z&HD&Hball&Hneg').
  apply Hneg'. apply Hsub.
  apply disc_ball.
  apply: (ball_le _ (δ/2 + (/ (INR (N' + 1))))).
  { destruct δ as (δ&?) => //=.
     replace δ with (δ/2 + δ/2) at 2 by nra.
     apply Rplus_le_compat_l.
     transitivity (/ (INR N)); last (rewrite //= in HleN; nra).
     left; apply Rinv_lt_contravar.
     * assert (0 < INR N) by (apply pos_INR'; omega).
       assert (0 < INR (N' + 1)) by (apply pos_INR'; omega).
       nra.
     * apply lt_INR. lia.
  }
  eapply ball_triangle; eauto.
Qed.

Hint Resolve Rabs_pos Rle_ge.

Section Interval_UniformSpace.
  Variable a b : R.
  Implicit Types x y : Interval a b.

  Definition Interval_ball (x: Interval a b) eps y := ball (x : R) eps y.
  Definition Interval_ball_center x (e: posreal) : Interval_ball x e x := @ball_center _ _ _.
  Definition Interval_ball_sym x y e := @ball_sym _ (x : R) y e.
  Definition Interval_ball_triangle x y e := @ball_triangle _ (x : R) y e.
  Definition Interval_UniformSpace_mixin : UniformSpace.mixin_of (Interval a b).
  Proof.
    apply (UniformSpace.Mixin _ Interval_ball
                              Interval_ball_center
                              Interval_ball_sym
                              Interval_ball_triangle).
  Defined.

  Canonical Interval_UniformSpace := UniformSpace.Pack _ Interval_UniformSpace_mixin (Interval a b).
End Interval_UniformSpace.

(* Lebesgue measure restricted to finite intervals of the Reals *)

Section lebesgue_measure.
  Context {a b : R}.

  (* TODO: deduce these from the versions on R in borel.v *)
  Lemma borel_gen_closed_ray1 :
    le_prop (minimal_sigma (λ (U: Interval a b → Prop), ∃ x y, U = (λ z, x < z <= y)))
            (minimal_sigma (λ (U : Interval a b → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    apply minimal_sigma_lub. intros ? (x&y&?); subst.
    assert ((λ z : Interval a b, x < z ∧ z <= y) ≡
            (λ z : Interval a b, z <= y) ∩ compl (λ z : Interval a b, z <= x)) as Heq.
    { intros z; split => //=.
      * intros (?&?). split => //=; intros Hneg. nra.
      * intros (?&Hcomp). split => //=. apply Rnot_ge_lt. intros Hge.
        apply Hcomp. nra.
    }
    rewrite Heq.
    apply sigma_closed_pair_intersect.
    * apply minimal_sigma_ub. eexists; eauto.
    * apply sigma_closed_complements,  minimal_sigma_ub. eexists; eauto.
  Qed.

  Lemma borel_gen_closed_ray2 :
    le_prop (borel (Interval_UniformSpace a b))
    (minimal_sigma (λ (U : Interval a b → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    etransitivity; last eapply borel_gen_closed_ray1.
    apply minimal_sigma_lub => U HopenU.
    unshelve (eapply sigma_proper; last eapply sigma_closed_unions).
    {
      intros n.
      destruct (@pickle_inv [countType of (nat * nat * nat)] n) as [((x&y)&N)|]; last exact ∅.
      set (V := (λ z : Interval a b, a + (INR x / INR y) - (1/(INR N)) < z ∧
                                     z <= a + (INR x / INR y))).
      destruct (ClassicalEpsilon.excluded_middle_informative
                  (V ⊆ U)).
      * exact V.
      * exact ∅.
    }
    {
      split.
      * intros HUz. specialize (HopenU _ HUz).
        destruct HopenU as ((δ&Hpos)&Hdelta).
        destruct x as (x&Hx1&Hx2) => //=.
        edestruct (archimed_cor1 δ) as (K&?&?); first by nra.
        assert (0 < / INR K).
        { apply Rinv_0_lt_compat, pos_INR'; done. }
        edestruct (archimed_rat_dense1 (/INR K) (x - a)) as (n&m&(?&?)&?); auto; try nra.
        exists (pickle (n, m, K)).
        rewrite pickleK_inv.
        destruct ClassicalEpsilon.excluded_middle_informative as [Hsub|Hnsub]; last first.
        { exfalso. destruct Hnsub.
          intros (z&?&?). rewrite //=. intros [? ?].
          apply Hdelta => //=.
          rewrite /ball//=/Interval_ball/ball//=/AbsRing_ball//=/abs//=.
          rewrite /minus/opp/plus//=.
          assert (z - a >= z - x) by nra.
          apply Rabs_case => Hcase; try nra.
        }
        rewrite //=. nra.
      * intros (n&HUn).
        destruct pickle_inv as [((n'&m')&K)|]; rewrite //= in HUn.
        destruct ClassicalEpsilon.excluded_middle_informative as [Hsub|Hnsub];
          rewrite //= in HUn.
        by apply Hsub.
    }
    intros i.
    destruct (@pickle_inv [countType of nat * nat * nat] i) as [((n&m)&K)|] eqn:Heq; rewrite Heq.
    * set (V := λ z : Interval a b, a + INR n / INR m - 1 / INR K < z ∧ z <= a + INR n / INR m).
      destruct (Classical_Prop.classic (V ⊆ U)) as [Hsub|Hnsub].
      ** apply minimal_sigma_ub. do 2 eexists. rewrite /V.
         destruct ClassicalEpsilon.excluded_middle_informative as [|Hnsub]; first reflexivity.
         exfalso; apply Hnsub. eauto.
      ** eapply sigma_proper; last eapply sigma_empty_set; rewrite //=.
         destruct ClassicalEpsilon.excluded_middle_informative as [Hsub'|]; last reflexivity.
         exfalso; apply Hnsub; eauto.
    * apply sigma_empty_set.
  Qed.

  Definition leb_outer_set_cand (U : Interval a b → Prop)  (Us: nat → R * R) :=
    U ⊆ unionF (λ i, open_interval (fst (Us i)) (snd (Us i))).

  Definition leb_outer_set U Us :=
    leb_outer_set_cand U Us ∧ ex_series (λ i, Rabs (snd (Us i) - fst (Us i))).

  Lemma leb_outer_set_proj2 U Us :
    leb_outer_set U Us →
    ex_series (λ i, Rabs (snd (Us i) - fst (Us i))).
  Proof. intros [? ?]; auto. Qed.

  Hint Resolve leb_outer_set_proj2.

  Definition trivial_outer_set (i : nat) :=
    match i with
    | O => (a - 1, b + 1)
    | _ => (a, a)
    end.

  Lemma leb_outer_set_non_empty U : leb_outer_set U (trivial_outer_set).
  Proof.
    split.
    - intros (x&Hl&Hu) _. exists O. split => //=; nra.
    - apply ex_series_incr_1 => //=.
      exists 0. apply is_series_0 => ? //=.
        by rewrite Rminus_eq_0 Rabs_R0.
  Qed.

  Definition leb_outer_pre_fun U r :=
    ∃ Us, leb_outer_set U Us ∧ - Series (λ i, Rabs (snd (Us i) - fst (Us i))) = r.

  Lemma leb_outer_pre_fun_non_empty U : ∃ r, leb_outer_pre_fun U r.
  Proof.
    eexists. exists trivial_outer_set.
    split; first apply leb_outer_set_non_empty. reflexivity.
  Qed.

  Lemma leb_outer_pre_fun_bound U : bound (leb_outer_pre_fun U).
  Proof.
    exists 0. intros ? (Us&(Hcand&Hex)&<-).
    apply Ropp_le_cancel. rewrite Ropp_involutive Ropp_0.
    apply Series_pos => n. auto.
  Qed.

  Definition leb_outer_fun (U : Interval a b → Prop) : R.
    refine (- sval (completeness (leb_outer_pre_fun U) _ _)).
    - apply leb_outer_pre_fun_bound.
    - apply leb_outer_pre_fun_non_empty.
  Defined.

  Lemma leb_outer_fun_glb U r :
    (∀ Us, leb_outer_set U Us → r <= Series (λ i, Rabs (snd (Us i) - fst (Us i)))) →
    r <= leb_outer_fun U.
  Proof.
    intros HUs. rewrite /leb_outer_fun. destruct (completeness) as (r'&Hlub).
    rewrite //=. destruct Hlub as (?&Hlub).
    cut (r' <= - r).
    { nra.  }
    apply Hlub. intros x (?&(?&<-)).
    apply Ropp_le_contravar. auto.
  Qed.

  Lemma leb_outer_fun_lb U Us:
    leb_outer_set U Us → leb_outer_fun U <= Series (λ i, Rabs (snd (Us i) - fst (Us i))).
  Proof.
    intros HUs. rewrite /leb_outer_fun. destruct (completeness) as (r'&Hlub).
    rewrite //=. destruct Hlub as (Hub&Hlub).
    rewrite /is_upper_bound in Hub.
    apply Ropp_le_cancel. rewrite Ropp_involutive. etransitivity; last eapply Hub.
    { reflexivity. }
    eexists; eauto.
  Qed.

  Global Instance is_upper_bound_proper : Proper (eq_prop ==> eq ==> iff) is_upper_bound.
  Proof.
    intros U U' Heq ?? ->. firstorder.
  Qed.

  Lemma completeness_proper E E' Hpf1 Hpf1' Hpf2 Hpf2' :
    eq_prop E E' → sval (completeness E Hpf1 Hpf2) = sval (completeness E' Hpf1' Hpf2').
  Proof.
    intros Heq.
    destruct completeness as (x&Hub&Hlub).
    destruct completeness as (x'&Hub'&Hlub').
    rewrite //=.
    apply Rle_antisym.
    - apply Hlub. rewrite Heq; done.
    - apply Hlub'. rewrite -Heq; done.
  Qed.

  Global Instance leb_outer_set_anti : Proper (le_prop --> eq ==> impl) leb_outer_set.
  Proof.
    intros U U' Hle Us Us' ->. rewrite /leb_outer_set/leb_outer_set_cand.
    intros (?&?); split; auto.
    transitivity U;
    etransitivity; eauto.
  Qed.

  Global Instance leb_outer_set_proper : Proper (eq_prop ==> eq ==> iff) leb_outer_set.
  Proof.
    intros U U' Heq Us Us' ->. rewrite /leb_outer_set/leb_outer_set_cand.
    rewrite Heq. done.
  Qed.

  Global Instance leb_outer_pre_fun_proper : Proper (eq_prop ==> eq ==> iff) leb_outer_pre_fun.
  Proof.
    intros U U' Heq ?? ->. rewrite /leb_outer_pre_fun. setoid_rewrite Heq. done.
  Qed.

  Global Instance leb_outer_fun_proper : Proper (eq_prop ==> eq) leb_outer_fun.
  Proof.
    intros U U' Heq.
    rewrite /leb_outer_fun => //=. apply Ropp_eq_compat.
    apply completeness_proper. intros x. by rewrite Heq.
  Qed.

  Lemma leb_outer_fun_empty :
    leb_outer_fun ∅ = 0.
  Proof.
    apply Rle_antisym.
    etransitivity; first eapply (leb_outer_fun_lb _ (λ i, (a, a))).
    { split => //=. exists 0. apply is_series_0 => ?.
        by rewrite Rminus_eq_0 Rabs_R0. }
    right. apply Series_0 => ? //=. by rewrite Rminus_eq_0 Rabs_R0.
    apply leb_outer_fun_glb => Us ?.
    apply Series_pos => ?. auto.
  Qed.

  Instance leb_outer_fun_mono : Proper (le_prop ==> Rle) leb_outer_fun.
  Proof.
    intros U U' Hle.
    apply leb_outer_fun_glb => Us.
    intros H. apply leb_outer_fun_lb.
    setoid_rewrite <-Hle in H. done.
  Qed.

  Lemma leb_outer_eps_close U eps :
    0 < eps →
    ∃ Us, leb_outer_set U Us
          ∧ Series (λ i, Rabs (snd (Us i) - fst (Us i))) < leb_outer_fun U + eps.
  Proof.
    intros Hpos.
    apply Classical_Pred_Type.not_all_not_ex.
    intros Hneg.
    apply (Rlt_not_ge (leb_outer_fun U) (leb_outer_fun U + eps)); first nra.
    apply Rle_ge, leb_outer_fun_glb => Us Hin.
    apply Rnot_gt_le. intros Hgt. apply (Hneg Us).
    split; auto.
  Qed.

  Lemma leb_outer_eps_close' U eps :
    0 < eps →
    { Us : _ | leb_outer_set U Us
          ∧ Series (λ i, Rabs (snd (Us i) - fst (Us i))) < leb_outer_fun U + eps }.
  Proof.
    intros.
    apply (ClassicalEpsilon.constructive_indefinite_description).
    by apply leb_outer_eps_close.
  Qed.

  Lemma ex_series_double_shift aseq:
    (∀ j k, j = O ∨ k = O → aseq (j, k) = 0) →
    ex_series (λ j : nat, Series (λ k : nat, Rabs (aseq (S j, S k)))) →
    ex_series (λ j : nat, Series (λ k : nat, Rabs (aseq (j, k)))).
  Proof.
    intros Hjk Hex.
    eapply (ex_series_ext (λ j : nat, Series (λ k : nat, Rabs (aseq (j, S k))))).
    { intros j. destruct j.
      * apply Series_ext => k. rewrite ?Hjk //=; by left.
      * symmetry. rewrite Series_incr_1_aux; last first.
        { rewrite Hjk; last by right. rewrite Rabs_R0. done. }
        done.
    }
      by apply ex_series_incr_1.
  Qed.

  Definition int_len := λ xy, Rabs (snd xy - fst xy).

  Lemma Series_double_shift aseq:
    (∀ j k, j = O ∨ k = O → aseq (j, k) = 0) →
    (Series (λ j : nat, Series (λ n : nat, aseq (j, n)))) =
    (Series (λ j : nat, Series (λ n : nat, aseq (S j, S n)))).
  Proof.
    intros. rewrite Series_incr_1_aux.
    * apply Series_ext.
      intros n'. rewrite Series_incr_1_aux; eauto.
    * rewrite Series_0; eauto.
  Qed.

  Lemma leb_outer_fun_subadditivity Us :
    ex_series (λ n, leb_outer_fun (Us n)) →
    leb_outer_fun (unionF Us) <= Series (λ n, leb_outer_fun (Us n)).
  Proof.
    intros Hex.
    apply le_epsilon => eps Hpos.
    assert (Hpos_scale: ∀ n, 0 < eps/2 * (pow (1/2) n)).
    { intros n. cut (0 < (1 /2)^n); first by (intros; nra).
      apply pow_lt. nra. }
    set (Us' := λ n : nat, match @pickle_inv [countType of nat * nat] n with
                           | Some (n, i) =>
                             (sval (leb_outer_eps_close' (Us n) (eps/2 * (pow (1/2) n))
                                                         (Hpos_scale n)) i)
                           | None => (a, a)
                           end).
    assert (unionF Us ⊆ unionF (λ i, open_interval (fst (Us' i)) (snd (Us' i)))).
    { intros x (n&Hin).
      destruct (leb_outer_eps_close' (Us n) _ (Hpos_scale n)) as (Vs&(Hcover&?)&?) eqn:Heq.
      generalize (Hcover x Hin). intros (i&Hin').
      exists (pickle (n, i)).
      rewrite /Us'. rewrite pickleK_inv => //=.
      rewrite Heq. auto.
    }

    set (len := λ xy, Rabs (snd xy - fst xy)).
    set (aseq0 := λ mn, match mn with
                       | (S m, S n) =>
                         (sval (leb_outer_eps_close' (Us m) (eps/2 * (pow (1/2) m))
                                                         (Hpos_scale m)) n)
                       | (_, _) => (a, a)
                    end).
    set (aseq := λ mn, len (aseq0 mn)).
    set (σ := λ n, match @pickle_inv [countType of nat * nat] n with
                   | Some (m, n) => (S m, S n)
                   | _ => (O, O)
                   end).
    assert (∀ n, aseq (σ n) = len (Us' n)).
    { intros n.   rewrite /aseq/σ/Us'//=.
      destruct pickle_inv as [(?&?)|] => //=.
    }
    assert (His_plus: is_series (λ n : nat, leb_outer_fun (Us n) + eps/2 * (pow (1/2) n))
                                (Series (λ n, leb_outer_fun (Us n)) + eps)).
    { apply: is_series_plus.
      * apply Series_correct; auto.
      * assert (eps = (eps/2 * / ( 1 - 1/2))) as Heq by field. rewrite {2}Heq.
        apply: is_series_scal.
        apply: is_series_geom.
        rewrite Rabs_right; nra.
    }
    assert (double.double_summable aseq).
    {
      apply ex_series_rows_ds.
      intros j.
      * rewrite /aseq/aseq0.
        destruct j => //=.
        ** eexists; eapply is_series_0. by rewrite /aseq/aseq0 /len Rminus_eq_0 ?Rabs_R0.
        ** apply ex_series_incr_1 => //=.
           destruct (leb_outer_eps_close') as (?&Hex'&?); auto.
           eapply ex_series_ext; last eapply Hex'.
           intros ?. rewrite /len Rabs_Rabsolu => //=.
      * apply: ex_series_double_shift.
        { intros j k [?|?]; subst => //=; try destruct j;
                                       rewrite /aseq/aseq0 /len ?Rminus_eq_0 ?Rabs_R0 //.
        }
        apply: ex_series_le; last by (eexists; eapply His_plus).
        intros n. rewrite /aseq//=.
        destruct (leb_outer_eps_close') as (?&Hex'&Hlt); auto.
        etransitivity; last by (left; eapply Hlt).
        right. rewrite /norm//=/abs//=. rewrite Rabs_right.
        ** apply Series_ext => ? //=. by rewrite Rabs_Rabsolu.
        ** apply Rle_ge, Series_pos => ?. auto.
    }
    feed pose proof (series_double_covering' aseq σ) as His; auto.
    { intros n n'. rewrite /σ/aseq.
      specialize (@pickle_invK [countType of nat * nat] n).
      specialize (@pickle_invK [countType of nat * nat] n').
      destruct (pickle_inv) as [(?&?)|] => //=; destruct (pickle_inv) as [(?&?)|] => //=.
      intros <- ? ?. inversion 1. subst => //=.
      rewrite /len//= Rminus_eq_0 Rabs_R0 //=.
    }
    { rewrite /aseq/aseq0. intros ([|m]&[|n]) => //=;
      rewrite /len ?Rminus_eq_0 ?Rabs_R0 //=.
      exists (pickle (m, n)).
      rewrite /σ pickleK_inv => //=. }
    etransitivity.
    * apply (leb_outer_fun_lb _ (λ n, aseq0 (σ n))). split.
      ** intros x (n&Hin).
         destruct (leb_outer_eps_close' (Us n) _ (Hpos_scale n)) as (Vs&(Hcover&?)&?) eqn:Heq.
         generalize (Hcover x Hin). intros (i&Hin').
         exists (pickle (n, i)).
         rewrite /aseq0/σ//=. rewrite pickleK_inv => //=.
         rewrite Heq. auto.
      ** eexists; eauto.
    * rewrite (is_series_unique _ _ His).
      rewrite -(is_series_unique _ _ His_plus).
      rewrite Series_double_shift; last first.
      { intros ?? [?|?]; subst; try destruct j; rewrite /aseq/len//= ?Rminus_eq_0 ?Rabs_R0 //=. }
      apply Series_le; last by (eexists; eauto).
      intros n.
      split.
      ** apply Series_pos => n'. rewrite /aseq/len//=. apply Rle_ge, Rabs_pos.
      ** rewrite /aseq/aseq0//=. destruct (leb_outer_eps_close') as (?&?&Hdone); eauto.
         rewrite /len//=. nra.
  Qed.

  Lemma Rabs_Rminus_eq_0 x:
    Rabs (x - x) = 0.
  Proof.
    rewrite Rminus_eq_0 Rabs_R0 //.
  Qed.

  Hint Resolve Rabs_Rminus_eq_0.

  Inductive decreasing_intervals : list (R * R) → Prop :=
      | di_nil: decreasing_intervals nil
      | di_singleton a b: a <= b → decreasing_intervals ((a, b) :: nil)
      | di_cons a1 b1 a2 b2 l:
          b1 <= a2 <= b2 →
          decreasing_intervals ((a1, b1) :: l) →
          decreasing_intervals ((a2, b2) :: (a1, b1) :: l).

  Lemma open_interval_subset_len x1 y1 x2 y2:
    x1 <= y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    Rabs (y1 - x1) <= Rabs (y2 - x2).
  Proof.
    intros Hle Hsubseteq. rewrite Rabs_right; last by nra.
    destruct Hle; last first.
    - assert (y1 - x1 = 0) as -> by nra. auto.
    - specialize (Rabs_pos (y2 - x2)). intros Hpos.
      apply le_epsilon => eps ?.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?]; last by nra.
      destruct (Hsubseteq (x1 + eps/2)).
      { split; nra. }
      rewrite Rabs_right; last by nra.
      destruct (Hsubseteq (y1 - eps/2)).
      { split; nra. }
      nra.
  Qed.

  Lemma open_interval_subset_left_ordering x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    x2 <= x1.
  Proof.
    intros Hle Hsubseteq.
    cut (∀ eps : R, 0 < eps → eps < (y1 - x1) → x2 <= x1 + eps).
    { intros Hcut. apply le_epsilon.
      intros eps Hlt.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?].
      * eauto.
      * transitivity (x1 + (y1 - x1)/2); eauto.
        { eapply Hcut; nra.  }
        nra.
    }
    intros.
    destruct (Hsubseteq (x1 + eps/2)).
    { split; nra. }
    destruct (Hsubseteq (y1 - eps/2)).
    { split; nra. }
    nra.
  Qed.

  Lemma open_interval_subset_right_ordering x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    y1 <= y2.
  Proof.
    intros Hle Hsubseteq.
    cut (∀ eps : R, 0 < eps → eps < (y1 - x1) → y1 <= y2 + eps).
    { intros Hcut. apply le_epsilon.
      intros eps Hlt.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?].
      * eauto.
      * transitivity (y2 + (y1 - x1)/2); eauto.
        { eapply Hcut; nra.  }
        nra.
    }
    intros.
    destruct (Hsubseteq (x1 + eps/2)).
    { split; nra. }
    destruct (Hsubseteq (y1 - eps/2)).
    { split; nra. }
    nra.
  Qed.

  Lemma open_interval_subset_non_empty x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    x2 <= y2.
  Proof.
    intros Hle Hopen.
    transitivity x1.
    { eapply open_interval_subset_left_ordering; eauto; nra.  }
    transitivity y1; first nra.
    { eapply open_interval_subset_right_ordering; eauto; nra.  }
  Qed.

  Hint Resolve open_interval_subset_non_empty.

  Lemma decreasing_intervals_1 l
    (Hdec : decreasing_intervals l):
    ∀ x' y', In (x', y') l → x' <= y'.
  Proof.
    induction Hdec => //=.
    - intros ??. destruct 1 as [Heq|[]]. inversion Heq; subst; done.
    - intros ??. destruct 1 as [Heq|[]].
      * inversion Heq; subst; nra.
      * eapply IHHdec. by left.
      * eapply IHHdec. by right.
  Qed.

  Lemma decreasing_intervals_2 x1 y1 l
    (Hdec : decreasing_intervals ((x1, y1) :: l)):
    ∀ x' y', In (x', y') l → y' <= x1.
  Proof.
    remember ((x1, y1) :: l) as l0 eqn:Heql. revert x1 y1 l Heql.
    induction Hdec.
    - congruence.
    - intros x1 y1 l. inversion 1; subst. intros ?? [].
    - intros x1 y1 l0. inversion 1; subst.
      intros ??. inversion 1.
      * inversion H1.  subst. intuition.
      * assert (y' <= a1); eauto.
        assert (a1 <= b1).
        { eapply decreasing_intervals_1. eauto. by left. }
        nra.
  Qed.

  Lemma decreasing_intervals_3 x1 y1 l
    (Hdec : decreasing_intervals ((x1, y1) :: l)):
    ∀ x' y', In (x', y') ((x1, y1) :: l) → y' <= y1.
  Proof.
    intros ?? [Heq1|Htl].
    - inversion Heq1; reflexivity.
    - transitivity x1.
      * eapply decreasing_intervals_2; eauto.
      * eapply decreasing_intervals_1; eauto; by left.
  Qed.

  Lemma intervals_contained_length Us (l: list (R * R)) :
    decreasing_intervals l →
    ex_series (λ i : nat, Rabs ((Us i).2 - (Us i).1)) →
    (∀ a b, In (a, b) l → ∃ i, (open_interval a b) ⊆ open_interval (Us i).1 (Us i).2) →
    fold_right Rplus 0 (map int_len l) <= Series (λ i : nat, Rabs ((Us i).2 - (Us i).1)).
  Proof.
    intros Hdec. revert Us.
    induction Hdec as [ | x y | x1 y1 x2 y2 l] => Us Hex Hcov.
    - rewrite //=. apply Series_pos => n; auto.
    - rewrite //= Rplus_0_r.
      destruct (Hcov x y) as (i&Hsub); first by left.
      rewrite -(Series_bump i (int_len (x, y))).
      apply Series_le.
      * intros n. destruct Nat.eq_dec => //=; split; rewrite /int_len; auto; try nra.
        apply open_interval_subset_len => //=. subst; done.
      * auto.
    - rewrite //=.
      destruct (Req_dec x2 y2).
      { subst.  rewrite /int_len//=. rewrite Rabs_Rminus_eq_0 Rplus_0_l.
        apply IHHdec; eauto. intros. eapply Hcov. by right. }
      edestruct (Hcov x2 y2) as (i&Hsubseteq).
      { by left. }
      assert (ex_series
                (λ i0 : nat, Rabs
       ((match Nat.eq_dec i0 i with | left _ => ((Us i).1, x2) | _ => Us i0 end).2 -
       ((match Nat.eq_dec i0 i with | left _ => ((Us i).1, x2) | _ => Us i0 end).1)))).
      {
        apply: ex_series_le; eauto.
        intros n. rewrite /norm//=/abs//= Rabs_Rabsolu.
        destruct Nat.eq_dec => //=; last reflexivity.
        subst.
        apply open_interval_subset_len.
        * apply open_interval_subset_left_ordering in Hsubseteq; nra.
        * apply open_interval_subset_right_ordering in Hsubseteq; last by nra.
          intros x [? ?]. split; nra.
      }
      feed pose proof (IHHdec (λ n, match eq_nat_dec n i with
                                    | left _ => ((Us i).1, x2)
                                    | _ => Us n
                                    end)); auto.
      {
        intros a' b' Hin. edestruct (Hcov a' b') as (n&Hin'); first by right.
        exists n. destruct Nat.eq_dec => //=; subst.
        intros x Hrange. specialize (Hin' _ Hrange) as (?&?).
        destruct Hrange as (?&?).
        split; first nra.
        eapply (Rlt_le_trans _ b'); first eassumption.
        transitivity y1; last by nra.
        eapply decreasing_intervals_3; eauto.
      }
      rewrite //= in H1.
      etransitivity.
      { eapply Rplus_le_compat_l. eassumption. }
      rewrite -(Series_bump i (int_len (x2, y2))).
      rewrite -Series_plus; auto; last by (eexists; eapply is_series_bump).
      apply: Series_le; eauto.
      intros n; split.
      * destruct Nat.eq_dec => //=; ring_simplify; auto.
        rewrite /int_len.
        replace 0 with (0 + 0) by nra. apply Rplus_le_compat; auto.
      * destruct Nat.eq_dec => //=; ring_simplify; auto; try reflexivity.
        rewrite /int_len//=.
        subst.
        rewrite ?Rabs_right.
        { ring_simplify.  cut (y2 <= snd (Us i)); first (intros; nra).
          eapply open_interval_subset_right_ordering; eauto. nra.
        }
        ** eapply open_interval_subset_non_empty in Hsubseteq; nra.
        ** eapply open_interval_subset_left_ordering in Hsubseteq; nra.
        ** eapply open_interval_subset_right_ordering in Hsubseteq; nra.
  Qed.

  Fixpoint decreasing_intervals_delta x δ n :=
    match n with
      0 => []
    | S n' => (x - δ, x) :: decreasing_intervals_delta (x - δ) δ n'
    end.

  Lemma decreasing_intervals_delta1  x δ n :
    0 < δ →
    decreasing_intervals (decreasing_intervals_delta x δ n).
  Proof.
    intros Hpos.
    revert x. induction n => x //=.
    - constructor.
    - induction n => //=.
      * constructor. nra.
      * econstructor; eauto. nra.
  Qed.

  Lemma decreasing_intervals_delta2  x δ n :
    0 < δ →
    ∀ a' b', In (a', b') (decreasing_intervals_delta x δ n) →
             ∃ x0, x - (δ * INR n) <= x0 <= x ∧ open_interval a' b' ⊆ ball x0 (δ/2) ∧
                   (∀ z, ball x0 (δ/2) z → x - (δ * INR n) <= z <= x).
  Proof.
    intros Hpos.
    revert x. induction n => x.
    - done.
    - intros a' b'. intros [Hhd|Htl].
      * exists (x - δ/2); split_and!.
        ** rewrite //=. destruct n; try nra. specialize (pos_INR (S n)) => H. nra.
        ** nra.
        ** inversion Hhd. subst => z [Hr1 Hr2].
           rewrite /ball//=/AbsRing_ball/abs//=/minus/plus/opp//=.
           apply Rabs_case => H; nra.
        ** rewrite S_INR //=. inversion Hhd. subst => z.
           rewrite /ball//=/AbsRing_ball/abs//=/minus/plus/opp//=.
           specialize (pos_INR n).
           apply Rabs_case => H1 H2; nra.
      * edestruct IHn as (x0&(Hlb&?)&?&Hrange); eauto.
        exists x0. split_and!; auto; try nra.
        ** rewrite S_INR. nra.
        ** intros. edestruct Hrange; eauto. rewrite S_INR. nra.
  Qed.

  Lemma decreasing_intervals_delta3  x δ n :
    0 < δ →
    fold_right Rplus 0 (map int_len (decreasing_intervals_delta x δ n)) = (INR n * δ).
  Proof.
    intros Hpos.
    revert x. induction n => x.
    - rewrite //=. nra.
    - rewrite S_INR //= IHn.
      rewrite /int_len Rabs_right //=; nra.
  Qed.

  Lemma decreasing_interval_covering x y δ:
    0 < δ →
    a <= x → x <= y → y <= b →
    ∃ l, decreasing_intervals l ∧
         (∀ a' b', In (a', b') l → ∃ x0, x <= x0 <= y ∧ open_interval a' b' ⊆ ball x0 (δ/2) ∧
                   (∀ z, open_interval a' b' z → x <= z <= y)) ∧
         fold_right Rplus 0 (map int_len l) = (y - x).
  Proof.
    intros Hpos Hle1 Hle2 Hle3.
    destruct Hle2 as [Hlt|Heq]; last first.
    { subst. exists []; split_and! => //=.
      * econstructor.
      * nra.
    }
    assert (∃ N, (y - x) / INR N < δ ∧ (0 < N)%nat) as (N&Hsize&HposN).
    { edestruct (archimed_cor1 (δ / (y - x))) as (N&?&Hpos').
      { apply Rdiv_lt_0_compat; nra. }
      exists N; split_and!; auto.
      apply pos_INR' in Hpos'.  rewrite /Rdiv.
      apply (Rmult_lt_reg_r (/ (y - x))).
      { apply Rinv_0_lt_compat; nra. }
      field_simplify; nra.
    }
    assert (0 < INR N) by (apply pos_INR'; auto).
    assert (0 < (/ INR N)) by (apply Rinv_0_lt_compat; auto).
    assert (0 < ((y - x)/ INR N)).
    { rewrite /Rdiv. nra. }
    exists (decreasing_intervals_delta y (( y - x) / INR N) N).
    split_and!.
    - by apply decreasing_intervals_delta1.
    - intros a' b' Hin.
      edestruct (decreasing_intervals_delta2 y ((y - x)/INR N) N) as (x0&(Hlb&Hub)&?&Hrange); eauto.
      exists x0. split_and!.
      * field_simplify in Hlb; nra.
      * auto.
      * etransitivity; eauto. intros z. apply ball_le.
        nra.
      * intros z ?. edestruct Hrange as (Hlb'&Hub'); eauto.
        split; auto. field_simplify in Hlb'; try nra.
    - rewrite decreasing_intervals_delta3 //=. field; nra.
  Qed.

  Lemma leb_outer_fun_interval_length x y :
    a <= x → x <= y → y <= b →
    leb_outer_fun (λ z, x <= z <= y) = y - x.
  Proof.
    intros Hle1 Hle2 Hle3.
    apply Rle_antisym.
    - apply le_epsilon => eps Hpos.
      set (aseq := (λ i, match i with
                         | O => (x - eps/2, y + eps/2)
                         | _ => (a, a)
                         end)).
      assert (ex_series (λ i : nat, Rabs ((aseq i).2 - (aseq i).1))).
      { apply ex_series_incr_1. exists 0. by apply is_series_0. }
      etransitivity.
      * eapply (leb_outer_fun_lb _ aseq).
        split.
        ** intros t [? ?]. exists O. rewrite /open_interval => //=. nra.
        ** apply ex_series_incr_1. exists 0. apply is_series_0.
           rewrite //= Rminus_eq_0 Rabs_R0 //.
      * rewrite Series_incr_1 //=. rewrite Series_0; auto.
        rewrite Rabs_right; nra.
    - apply leb_outer_fun_glb => Us Houter.
      edestruct (lebesgue_number_lemma nat (λ z, x <= z <= y)
                                       (λ n, open_interval (fst (Us n)) (snd (Us n))))
                as (δ&Hpos&Hdelta).
      { apply (compact_P3 x y). }
      { intros x' Hin.
        assert (Hrange: a <= x' <= b) by nra.
        destruct Houter as (Hcov&?).
        destruct (Hcov (exist _ x' Hrange)); eauto. }
      { intros. apply open_interval_open. }
      edestruct (decreasing_interval_covering x y δ) as (l&Hdec&Hin&Hlen); eauto.
      rewrite -Hlen.
      apply intervals_contained_length; eauto.
      intros.
      edestruct Hin as (x0&?&Hball&Hrange); eauto.
      edestruct (Hdelta x0) as (n&Hsub); eauto.
      exists n. intros z' Hin'. eapply Hsub; eauto.
      eapply ball_le; last eapply Hball; eauto. nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary1 x y :
    leb_outer_fun (λ z, x <= z <= y) <= Rabs (y - x).
  Proof.
    destruct (Rle_dec a y) as [?|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec x b) as [?|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec a b) as [Hle|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec x y) as [Hle'|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    transitivity (leb_outer_fun (λ z, Rmax a x <= z <= Rmin y b)).
    {
      apply leb_outer_fun_mono. intros (z&(?&?)) => //=. intros (?&?); split.
      * apply Rmax_case_strong; intros; try nra.
      * apply Rmin_case_strong; intros; try nra.
    }
    rewrite leb_outer_fun_interval_length; auto using Rmax_r, Rmax_l, Rmin_r, Rmin_l.
    - apply Rmax_case_strong; apply Rmin_case_strong; intros; rewrite ?Rabs_right; nra.
    - apply Rmax_case_strong; apply Rmin_case_strong; intros; nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary2 x y :
    leb_outer_fun (λ z, x < z <= y) <= Rabs (y - x).
  Proof.
    etransitivity; last eapply leb_outer_fun_interval_length_arbitrary1.
    apply leb_outer_fun_mono => z; nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary3 x y :
    leb_outer_fun (λ z, x < z < y) <= Rabs (y - x).
  Proof.
    etransitivity; last eapply leb_outer_fun_interval_length_arbitrary1.
    apply leb_outer_fun_mono => z; nra.
  Qed.

  Definition leb_outer_measure : outer_measure (Interval a b).
  refine {| outer_measure_fun := leb_outer_fun |}.
  - apply leb_outer_fun_empty.
  - apply leb_outer_fun_subadditivity.
  Defined.

  Definition leb_measure := outer_measure_measure leb_outer_measure.

  Lemma norm_R_right (r: R):
    0 <= r → norm r = r.
  Proof. intros; rewrite /norm//=/abs//= Rabs_right; nra. Qed.

  Lemma leb_borel_measurable :
    le_prop (borel _) (outer_measure_sigma leb_outer_measure).
  Proof.
    etransitivity; first apply borel_gen_closed_ray2.
    apply minimal_sigma_lub. intros ? (x&->).
    apply outer_measurable_ge => V.
    apply Rle_ge, le_epsilon => eps Hpos.
    edestruct (leb_outer_eps_close V eps) as (Us&HUs_spec&?); auto.
    assert (Hbound: ∀ n, Rabs ((Us n).2 - (Us n).1) >=
                 leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩
                                                 (λ z, z <= x)) +
                 leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩
                                                 compl (λ z, z <= x))).
    { intros n.
      destruct (Rle_dec x (Us n).1).
      {
        assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ (λ y, Rle y x)) x0)
                        ∅) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); try nra.
          * inversion 1.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (λ y, Rle y x)) x0)
                  (open_interval (Us n).1 (Us n).2)) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); split; try nra.
          * rewrite /compl/open_interval; intros (Hr1&Hr2); split_and!; try nra.
        }
        rewrite Heq1 Heq2.
        rewrite /leb_outer_measure//= leb_outer_fun_empty Rplus_0_l.
        apply Rle_ge. apply leb_outer_fun_interval_length_arbitrary3.
      }
      destruct (Rlt_dec x (Us n).2).
      * assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ (λ y, Rle y x)) x0)
                      (λ x0, (Us n).1 < x0 <= x)) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); split; nra.
          * rewrite /open_interval; intros; split_and!; try nra.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (λ y, Rle y x)) x0)
                  (λ x0, x < x0 < (Us n).2)) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); split; try nra.
          * rewrite /compl/open_interval; intros; split_and!; nra.
        }
        rewrite Heq1 Heq2.
        apply Rle_ge.
        setoid_rewrite leb_outer_fun_interval_length_arbitrary2.
        setoid_rewrite leb_outer_fun_interval_length_arbitrary3.
        repeat apply Rabs_case; intros; try nra.
      * assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ (λ y, Rle y x)) x0)
                        (open_interval (Us n).1 (Us n).2)) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); split; nra.
          * rewrite /open_interval; intros; split_and!; try nra.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (λ y, Rle y x)) x0)
                  ∅) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); try nra.
          * inversion 1.
        }
        rewrite Heq1 Heq2.
        rewrite /leb_outer_measure//= leb_outer_fun_empty Rplus_0_r.
        apply Rle_ge. apply leb_outer_fun_interval_length_arbitrary3.
    }
    assert (ex_series (λ n : nat,
         leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩ (λ y, Rle y x)))).
    { apply: ex_series_le; eauto => n. rewrite norm_R_right; last apply outer_measure_nonneg.
      specialize (Hbound n). apply Rge_le in Hbound.
      etransitivity; eauto. rewrite -[a in a <= _]Rplus_0_r.
      apply Rplus_le_compat_l; auto using outer_measure_nonneg.
    }
    assert (ex_series (λ n : nat,
         leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩ compl (λ y, Rle y x)))).
    { apply: ex_series_le; last (destruct HUs_spec as (?&Hex); eapply Hex).
      eauto => n. rewrite norm_R_right; last apply outer_measure_nonneg.
      specialize (Hbound n). apply Rge_le in Hbound.
      etransitivity; eauto. rewrite -[a in a <= _]Rplus_0_l.
      apply Rplus_le_compat_r; auto using outer_measure_nonneg.
    }
    etransitivity; last (by left; eassumption).
    etransitivity; last first.
    { apply Series_le with (a := λ n,
           leb_outer_measure (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ (λ y, Rle y x)) x0) +
           leb_outer_measure
             (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (λ y, Rle y x)) x0));
        last eauto.
      intros n. split; eauto.
      * replace 0 with (0 + 0) by field. apply Rplus_le_compat; apply outer_measure_nonneg.
      * apply Rge_le. eapply Hbound.
    }
    rewrite Series_plus; eauto.
    apply Rplus_le_compat.
    * rewrite /leb_outer_measure//=.
      etransitivity; last eapply leb_outer_fun_subadditivity; eauto.
      apply leb_outer_fun_mono. intros z (HinV&Hrange).
      edestruct (HUs_spec) as (HUs1&HUs2). edestruct (HUs1 _ HinV) as (n&?).
      exists n. split; auto.
    * rewrite /leb_outer_measure//=.
      etransitivity; last eapply leb_outer_fun_subadditivity; eauto.
      apply leb_outer_fun_mono. intros z (HinV&Hrange).
      edestruct (HUs_spec) as (HUs1&HUs2). edestruct (HUs1 _ HinV) as (n&?).
      exists n. split; auto.
  Qed.

End lebesgue_measure.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic.

    This chapter is optional.  Before reading it, you'll want to read
    the [SF.ProofObjects] chapter. *)

Require Import SF.Imp.
Require Import SF.Hoare.

(** * Definitions *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

(** We don't need to include axioms corresponding to
    [hoare_consequence_pre] or [hoare_consequence_post], because
    these can be proven easily from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X.  apply H.  intros. apply H0. Qed.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X. intros. apply H0.  apply H. Qed.

(** As an example, let's construct a proof object representing a
    derivation for the hoare triple

      {{assn_sub X (X+1) (assn_sub X (X+2) (X=3))}}
      X::=X+1 ;; X::=X+2
      {{X=3}}.

    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof :
  hoare_proof
    (assn_sub X (APlus (AId X) (ANum 1))
              (assn_sub X (APlus (AId X) (ANum 2))
                        (fun st => st X = 3) ))
    (X ::= APlus (AId X) (ANum 1);; (X ::= APlus (AId X) (ANum 2)))
    (fun st => st X = 3).
Proof.
  eapply H_Seq; apply H_Asgn.
Qed.

(*
Print sample_proof.
====>
  H_Seq
    (assn_sub X (APlus (AId X) (ANum 1))
       (assn_sub X (APlus (AId X) (ANum 2))
                (fun st : state => st X = VNat 3)))
    (X ::= APlus (AId X) (ANum 1))
    (assn_sub X (APlus (AId X) (ANum 2))
              (fun st : state => st X = VNat 3))
    (X ::= APlus (AId X) (ANum 2))
      (fun st : state => st X = VNat 3)
    (H_Asgn
       (assn_sub X (APlus (AId X) (ANum 2))
                   (fun st : state => st X = VNat 3))
       X (APlus (AId X) (ANum 1)))
    (H_Asgn (fun st : state => st X = VNat 3) X
            (APlus (AId X) (ANum 2)))
*)

(** * Properties *)

(** **** Exercise: 2 stars (hoare_proof_sound)  *)
(** Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  induction c; intro P.
  - (* SKIP *)
    eapply H_Consequence.
    apply H_Skip.
    intros. apply H.
    (* Proof of True *)
    intros. apply I.
  - (* ::= *)
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  - (* ;; *)
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  - (* IFB *)
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  - (* WHILE *)
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  induction c; intro Q.
  - (* SKIP *) pre_false_helper H_Skip.
  - (* ::= *) pre_false_helper H_Asgn.
  - (* ;; *) pre_false_helper H_Seq. apply IHc1. apply IHc2.
  - (* IFB *)
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  - (* WHILE *)
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** As a last step, we can show that the set of [hoare_proof] axioms
    is sufficient to prove any true fact about (partial) correctness.
    More precisely, any semantic Hoare triple that we can prove can
    also be proved from these axioms.  Such a set of axioms is said to
    be _relatively complete_.  Our proof is inspired by this one:

      http://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html

    To carry out the proof, we need to invent some intermediate
    assertions using a technical device known as _weakest
    preconditions_.  Given a command [c] and a desired postcondition
    assertion [Q], the weakest precondition [wp c Q] is an assertion
    [P] such that [{{P}} c {{Q}}] holds, and moreover, for any other
    assertion [P'], if [{{P'}} c {{Q}}] holds then [P' -> P].  We can
    more directly define this as follows: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', c / s \\ s' -> Q s'.

(** **** Exercise: 1 star (wp_is_precondition)  *)

Lemma wp_is_precondition: forall c Q,
  {{wp c Q}} c {{Q}}.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star (wp_is_weakest)  *)

Lemma wp_is_weakest: forall c Q P',
   {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
(* FILL IN HERE *) Admitted.

(** The following utility lemma will also be useful. *)

Lemma bassn_eval_false : forall b st, ~ bassn b st -> beval st b = false.
Proof.
  intros b st H. unfold bassn in H. destruct (beval st b).
    exfalso. apply H. reflexivity.
    reflexivity.
Qed.
(** [] *)

(** **** Exercise: 5 stars (hoare_proof_complete)  *)
(** Complete the proof of the theorem. *)

Theorem hoare_proof_complete: forall P c Q,
  {{P}} c {{Q}} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* SKIP *)
    eapply H_Consequence.
     eapply H_Skip.
      intros.  eassumption.
      intro st. apply HT.  apply E_Skip.
  - (* ::= *)
    eapply H_Consequence.
      eapply H_Asgn.
      intro st. apply HT. econstructor. reflexivity.
      intros; assumption.
  - (* ;; *)
    apply H_Seq with (wp c2 Q).
     eapply IHc1.
       intros st st' E1 H. unfold wp. intros st'' E2.
         eapply HT. econstructor; eassumption. assumption.
     eapply IHc2. intros st st' E1 H. apply H; assumption.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we might hope that our axiomatic Hoare logic is
    _decidable_; that is, that there is an (terminating) algorithm (a
    _decision procedure_) that can determine whether or not a given
    Hoare triple is valid (derivable).  But such a decision procedure
    cannot exist!

    Consider the triple [{{True}} c {{False}}]. This triple is valid
    if and only if [c] is non-terminating.  So any algorithm that
    could determine validity of arbitrary triples could solve the
    Halting Problem.

    Similarly, the triple [{{True} SKIP {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of
    Coq's logic. But it is known that there can be no decision
    procedure for this logic.

    Overall, this axiomatic style of presentation gives a clearer
    picture of what it means to "give a proof in Hoare logic."
    However, it is not entirely satisfactory from the point of view of
    writing down such proofs in practice: it is quite verbose.  The
    section of chapter [Hoare2] on formalizing decorated programs
    shows how we can do even better. *)

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


Theorem frobenius (A: Set) (p: A -> Prop) (q: Prop) :
 (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).

Proof.
 split.
 intros [y [H1 H2]].
 split.
 assumption.
 exists y.
 assumption.

 intros [H1 [y H2]].
 exists y.
 split.
 assumption.
 assumption.


Require Import Brzozowski.Alphabet.
Require Import Brzozowski.Derive.
Require Import Brzozowski.Language.
Require Import Brzozowski.Regex.

CoInductive DeriveTree: Type :=
  | mk_derive: lang -> (alphabet -> DeriveTree) -> DeriveTree.

CoFixpoint build_regex_tree (r: regex): DeriveTree :=
  mk_derive {{r}} (fun a => (build_regex_tree (derive_def r a))).

CoFixpoint build_lang_tree (l: lang): DeriveTree :=
  mk_derive l (fun a => (build_lang_tree (derive_lang a l))).


Require Export FunctorCategory.
Require Import Common.

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

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope functor_scope.

Section PointwiseFunctor.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable C' : PreCategory.
  Variable F : Functor C' C.

  Variable D : PreCategory.
  Variable D' : PreCategory.
  Variable G : Functor D D'.

  Local Notation PointwiseFunctor_ObjectOf H := (G ∘ H ∘ F : Object [C', D']).
  Local Notation PointwiseFunctorWhiskerL_ObjectOf H := (G ∘ H : Object [C, D']).
  Local Notation PointwiseFunctorWhiskerR_ObjectOf H := (H ∘ F : Object [C', D]).
(*  Definition PointwiseFunctor_ObjectOf : [C, D] -> [C', D']
    := fun H => G ∘ H ∘ F.*)

  Definition PointwiseFunctor_MorphismOf s d (m : Morphism [C, D] s d)
  : Morphism [C', D']
             (PointwiseFunctor_ObjectOf s)
             (PointwiseFunctor_ObjectOf d)
      := Eval simpl in (G ∘ m ∘ F)%natural_transformation.

  Definition PointwiseFunctorWhiskerL_MorphismOf s d (m : Morphism [C, D] s d)
  : Morphism [C, D']
             (PointwiseFunctorWhiskerL_ObjectOf s)
             (PointwiseFunctorWhiskerL_ObjectOf d)
      := Eval simpl in (G ∘ m)%natural_transformation.

  Definition PointwiseFunctorWhiskerR_MorphismOf s d (m : Morphism [C, D] s d)
  : Morphism [C', D]
             (PointwiseFunctorWhiskerR_ObjectOf s)
             (PointwiseFunctorWhiskerR_ObjectOf d)
      := Eval simpl in (m ∘ F)%natural_transformation.

  Global Arguments PointwiseFunctor_MorphismOf _ _ _ / .
  Global Arguments PointwiseFunctorWhiskerL_MorphismOf _ _ _ / .
  Global Arguments PointwiseFunctorWhiskerR_MorphismOf _ _ _ / .

  Definition PointwiseFunctor : Functor [C, D] [C', D'].
  Proof.
    refine (Build_Functor
              [C, D] [C', D']
              (fun x => PointwiseFunctor_ObjectOf x)
              PointwiseFunctor_MorphismOf
              _
              _);
    abstract (intros; simpl; nt_eq; auto with functor).
  Defined.

  Definition PointwiseFunctorWhiskerL : Functor [C, D] [C, D'].
  Proof.
    refine (Build_Functor
              [C, D] [C, D']
              (fun x => PointwiseFunctorWhiskerL_ObjectOf x)
              PointwiseFunctorWhiskerL_MorphismOf
              _
              _);
    abstract (intros; simpl; nt_eq; auto with functor).
  Defined.

  Definition PointwiseFunctorWhiskerR : Functor [C, D] [C', D].
  Proof.
    refine (Build_Functor
              [C, D] [C', D]
              (fun x => PointwiseFunctorWhiskerR_ObjectOf x)
              PointwiseFunctorWhiskerR_MorphismOf
              _
              _);
    abstract (intros; simpl; nt_eq; auto with functor).
  Defined.
End PointwiseFunctor.

Section notations.
  (** We do some black magic with typeclasses to make notations play
      well.  The cost is extra verbosity, but it will all disappear
      with [simpl]. *)

  Global Class PointwiseFunctor_Typable `{Funext} A B (a : A) (b : B) (T : Type) (term : T) := {}.

  Definition PointwiseFunctor_Typable_term `{@PointwiseFunctor_Typable H A B a b T term} := term.
  Global Arguments PointwiseFunctor_Typable_term / .

  Global Instance PointwiseFunctor_FunctorFunctor `{Funext} C C' D D' (F : Functor C C') (G : Functor D D')
  : PointwiseFunctor_Typable F G (PointwiseFunctor F G) | 1000.

  Global Instance PointwiseFunctor_CategoryFunctor `{Funext} C D D' (G : Functor D D')
  : PointwiseFunctor_Typable C G (PointwiseFunctorWhiskerL C G) | 100.

  Global Instance PointwiseFunctor_FunctorCategory `{Funext} C C' (F : Functor C C') D
  : PointwiseFunctor_Typable F D (PointwiseFunctorWhiskerR F D) | 100.

  Global Instance PointwiseFunctor_CategoryCategory `{Funext} C D
  : PointwiseFunctor_Typable C D (FunctorCategory C D) | 10.
End notations.

Hint Unfold PointwiseFunctor_Typable_term : typeclass_instances.

(** Set some notations for printing *)
Notation "G ^ F" := (PointwiseFunctor F G) : functor_scope.
Notation "D ^ F" := (PointwiseFunctorWhiskerR F D) : functor_scope.
Notation "G ^ C" := (PointwiseFunctorWhiskerL C G) : functor_scope.
(** Included for completeness, but not required, because we want the version in category_scope to dominate. *)
Notation "D ^ C" := (FunctorCategory C D) (only parsing) : functor_scope.
Notation "[ F , G ]" := (PointwiseFunctor F G) : functor_scope.
Notation "[ F , D ]" := (PointwiseFunctorWhiskerR F D) : functor_scope.
Notation "[ C , G ]" := (PointwiseFunctorWhiskerL C G) : functor_scope.
(** Included for completeness, but not required, because we want the version in category_scope to dominate. *)
Notation "[ C , D ]" := (FunctorCategory C D) (only parsing) : functor_scope.

(* Notation for parsing *)
Notation "G ^ F"
  := (@PointwiseFunctor_Typable_term _ _ _ F%functor G%functor _ _ _) : functor_scope.
Notation "[ F , G ]"
  := (@PointwiseFunctor_Typable_term _ _ _ F%functor G%functor _ _ _) : functor_scope.


(* ミニコンパイラ *)

(* Minus を追加した *)
(* 2011_01_21 *)

(* Correctness proof of a (very) simple compiler *)

Require Import Arith.
Require Import Omega.
Require Import String.

(* source language *)

(* Parameter string : Set. *)

Inductive expr : Set :=
| Lit : nat -> expr
| Var : string -> expr
| Plus : expr -> expr -> expr
| Minus : expr -> expr -> expr
  .

(* semantics of source language *)

Definition state := string -> nat.

(* エバリュエータ *)

Fixpoint E (s : state) (e : expr) {struct e} : nat :=
  match e with
    | Lit n => n
    | Var v => s v
    | Plus e1 e2 => E s e1 + E s e2
    | Minus e1 e2 => E s e1 - E s e2
  end.

(* VM *)
(* target language *)

Inductive instr : Set :=
| LI : nat -> instr
| LOAD : nat -> instr
| STO : nat -> instr
| ADD : nat -> instr
| SUB : nat -> instr
  .

(* memory *)

Inductive cell : Set :=
| Acc : cell
| Reg : nat -> cell.

Definition store := cell -> nat.

Lemma cell_eq_dec :
  forall c1 c2 : cell, {c1 = c2} + {c1 <> c2}.
Proof.
  simple destruct c1; simple destruct c2; intros; try (right; discriminate).
  left; trivial.
  elim (eq_nat_dec n n0); intuition.
  right; intro; injection H; trivial.
Defined.

Definition update (s : store) (c : cell) (v : nat) : store :=
  fun c' : cell =>
    match cell_eq_dec c' c with
      | left _ => v
      | right _ => s c'
    end.

(* semantics of target language *)

Definition Si (s : store) (i : instr) : store :=
  match i with
    | LI n => update s Acc n
    | LOAD r => update s Acc (s (Reg r))
    | STO r => update s (Reg r) (s Acc)
    | ADD r => update s Acc (s (Reg r) + s Acc)
    | SUB r => update s Acc (s (Reg r) - s Acc)
  end.

Require Import List.
Definition list1 (i : instr) := i :: nil.

Fixpoint Sl (s : store) (l : list instr) {struct l} : store :=
  match l with
    | nil => s
    | i :: l' => Sl (Si s i) l'
  end.

(* コンパイラ *)
(* the compiler *)

Definition symt := string -> nat.
Definition M (s : string) : nat :=
  match s with
    | "aa"%string => 1
    | _ => 0
  end.

Fixpoint C (m : symt) (r : nat) (e : expr) {struct e} :
  list instr :=
  match e with
    | Lit n => list1 (LI n)
    | Var s => list1 (LOAD (m s))
    | Plus e1 e2 =>
      (C m r e1 ++ list1 (STO r)) ++ C m (S r) e2 ++ list1 (ADD r)
    | Minus e1 e2 =>
      (C m r e1 ++ list1 (STO r)) ++ C m (S r) e2 ++ list1 (SUB r)
  end.
Check C M 1 (Plus (Var "aa"%string) (Lit 1)).
Eval cbv in C M 1 (Plus (Var "aa"%string) (Lit 1)).

(* lemmas *)

Lemma Sl_append :
  forall (l1 l2 : list instr) (s : store), Sl s (l1 ++ l2) = Sl (Sl s l1) l2.
Proof.
  simple induction l1; simpl; intuition.
Qed.

(* コンパイル時でr番め以降のレジスタを使うように指定したコードを実行しても、
   r' < r である、r'レジスタの値は書き換わらない。
   *)

Lemma Sl_invariant :
  forall (m : symt) (e : expr) (r r' : nat),
    r' < r -> forall s : store, Sl s (C m r e) (Reg r') = s (Reg r').
Proof.
  simple induction e; simpl in |- *; intuition.

  (* Plus *)
  repeat rewrite Sl_append.
  generalize (H r r' H1); intuition.
  set (s' := Sl (Sl s (C m (S r) e0)) (list1 (STO (S r)))) in *.
  assert (r' < S r). omega.
  generalize (H0 (S r) r' H3); intuition.
  simpl in |- *; unfold update in |- *; simpl in |- *.
  rewrite H4.
  case (cell_eq_dec (Reg r') (Reg r)); intro.
  injection e2; omega.
  rewrite H2; trivial.

  (* Minus *)
  repeat rewrite Sl_append.
  generalize (H r r' H1); intuition.
  set (s' := Sl (Sl s (C m (S r) e0)) (list1 (STO (S r)))) in *.
  assert (r' < S r). omega.
  generalize (H0 (S r) r' H3); intuition.
  simpl in |- *; unfold update in |- *; simpl in |- *.
  rewrite H4.
  case (cell_eq_dec (Reg r') (Reg r)); intro.
  injection e2; omega.
  rewrite H2; trivial.
Qed.

(* correctness *)

Theorem correctness :
  forall (e : expr) (m : symt) (s : state) (s' : store) (r : nat),
    (forall v : string, m v < r) ->
    (forall v : string, s v = s' (Reg (m v))) ->
    Sl s' (C m r e) Acc = E s e /\
    (forall x : nat, x < r -> Sl s' (C m r e) (Reg x) = s' (Reg x)).
Proof.
  simple induction e; simpl in |- *; intros.
  intuition.
  intuition.
  unfold update in |- *; simpl in |- *; intuition.

(* ADD *)
  repeat rewrite Sl_append.
  Check (H m s s' r H1 H2).
  generalize (H m s s' r H1 H2).
  intros (H3, H4).
  set (s'' := Sl (Sl s' (C m r e0)) (list1 (STO r))) in *.
  assert (H01 : forall v : string, m v < S r).
  intuition.
  assert (H02 : forall v : string, s v = s'' (Reg (m v))).
  intro; unfold s'' in |- *; simpl in |- *; unfold update in |- *.
  case (cell_eq_dec (Reg (m v)) (Reg r)); intro.
  injection e2; generalize (H1 v); omega.
  rewrite H2. rewrite H4. trivial.
  intuition.
  generalize (H0 m s s'' (S r) H01 H02); intuition.
  simpl in |- *.
  rewrite H6.
  unfold s'' in |- *; simpl in |- *.
  rewrite H3.
  unfold update in |- *; simpl in |- *.
  apply (f_equal2 plus); trivial.
  rewrite Sl_invariant.
  case (cell_eq_dec (Reg r) (Reg r)); intro.
  trivial.
  elim n; trivial. omega.
  simpl in |- *.
  rewrite H7.
  unfold s'' in |- *; simpl in |- *.
  rewrite H3.
  unfold update in |- *; simpl in |- *.
  rewrite Sl_invariant.
  case (cell_eq_dec (Reg x) (Reg r)); intro.
  injection e2; omega.
  rewrite H4; trivial.
  omega.
  omega.

(* SUB *)
  repeat rewrite Sl_append.
  Check (H m s s' r H1 H2).
  generalize (H m s s' r H1 H2).
  intros (H3, H4).
  set (s'' := Sl (Sl s' (C m r e0)) (list1 (STO r))) in *.
  assert (H01 : forall v : string, m v < S r).
  intuition.
  assert (H02 : forall v : string, s v = s'' (Reg (m v))).
  intro; unfold s'' in |- *; simpl in |- *; unfold update in |- *.
  case (cell_eq_dec (Reg (m v)) (Reg r)); intro.
  injection e2; generalize (H1 v); omega.
  rewrite H2. rewrite H4. trivial.
  intuition.
  generalize (H0 m s s'' (S r) H01 H02); intuition.
  simpl in |- *.
  rewrite H6.
  unfold s'' in |- *; simpl in |- *.
  rewrite H3.
  unfold update in |- *; simpl in |- *.
  apply (f_equal2 minus); trivial.
  rewrite Sl_invariant.
  case (cell_eq_dec (Reg r) (Reg r)); intro.
  trivial.
  elim n; trivial. omega.
  simpl in |- *.
  rewrite H7.
  unfold s'' in |- *; simpl in |- *.
  rewrite H3.
  unfold update in |- *; simpl in |- *.
  rewrite Sl_invariant.
  case (cell_eq_dec (Reg x) (Reg r)); intro.
  injection e2; omega.
  rewrite H4; trivial.
  omega.
  omega.
Qed.

(* END *)


(** * Focused Sequent system
This file specifies a one-sided focused system for first-order
classical linear logic. The system is parametric to [theory:
oo->Prop], defining the formulas that can be used in rule
[tri_dec3]. In this implementation, all the atoms are assumed to be
positive and then, proofs must finish with the initial rule focusing
on atomic propositions of the form [perp A]. The exchange rule is
embedded in the definition, e.g., of [tri_tensor].
 *)

Require Export FLL.Misc.Utils.
Require Export FLL.SL.Syntax.

Export ListNotations.
Set Implicit Arguments.

Section LLSequent.
  Context `{OLS: OLSig}.
  Variable theory : oo -> Prop. (* theory Definition *)

  (* Andreoli's triadic system for linear logic *)
  Reserved Notation " n '|-F-' B ';' L ';' X " (at level 80).

  (** Sequent rules. in [n '|-F-' B ';' L ';' X], [n] is the height of
  the derivation ; [B] a list representing the classical context ; [L]
  the linear context and [X] and [Arrow] that can be [DW F] (for the
  positive phase) or [UP L] (for the negative phase). *)
  Inductive seqN:  nat -> multiset oo -> multiset oo -> Arrow -> Prop :=
  | tri_init1 : forall B A n,  n |-F- B ; [atom A] ; DW (perp A)
  | tri_init2 : forall B A n,  In (atom A) B -> n |-F- B ; [] ; DW (perp A)
  | tri_one : forall B n,  n |-F- B ; [] ; DW One
  | tri_tensor : forall B M N MN F G n, Permutation MN (M++N) ->
                                        (n |-F- B ; M ; DW F) ->
                                        (n |-F- B ; N ; DW G )->
                                        S n |-F- B ; MN ; DW (MAnd F G)
  | tri_plus1 : forall B M F G n,
      n |-F- B ; M ; DW F -> S n |-F- B ; M ; DW (AOr F G)
  | tri_plus2 : forall B M F G n,
      n |-F- B ; M ; DW G -> S n |-F- B ; M ; DW (AOr F G)
  | tri_bang : forall B F n,
      n |-F- B ; [] ; UP [F] -> S n  |-F- B ; [] ; DW (Bang F)
  | tri_rel : forall B F L n,
      release F -> n |-F- B ; L ; UP [F] ->  S n |-F- B ; L ; DW F
  | tri_top : forall B L M n,
      n |-F- B ; L ; UP (Top :: M)
  | tri_bot : forall B L M n,
      n |-F- B ; L ; UP M -> S n  |-F- B ; L ; UP (Bot :: M)
  | tri_par : forall B L M F G n,
      n |-F- B ; L ; UP (F::G::M) -> S n  |-F- B ; L ; UP((MOr F G) :: M)
  | tri_with : forall B L M F G n,
      (n |-F- B ; L ; UP (F :: M)) ->
      (n |-F- B ; L ; UP (G :: M)) -> S n|-F- B ; L ; UP ((AAnd F  G) :: M)
  | tri_quest : forall B L M F n,
      n |-F- B ++ [F] ; L ; UP M -> S n  |-F- B ; L ; UP ((Quest F) :: M)
  | tri_store : forall B L M F n,
      ~ asynchronous  F-> n |-F- B ; L ++ [F] ; UP M -> S n |-F- B ; L ; UP (F::M)
  | tri_dec1 : forall B L L' F n,
      ~IsPositiveAtom F -> Remove F L L' -> n |-F- B ; L' ; DW F -> S n |-F- B ; L ; UP []
  | tri_dec2 : forall B L F n,
      ~IsPositiveAtom F -> In F B -> n |-F- B ; L ; DW F -> S n |-F- B ; L ; UP []
  | tri_dec3 : forall B L F n,
      theory F -> ~IsPositiveAtom F -> n |-F- B ; L ; DW F -> S n |-F- B ; L ; UP []
  | tri_ex  : forall B FX M t n,
      uniform_oo FX -> proper t -> n |-F- B; M ; DW (FX t) -> S n|-F- B; M ; DW (Some  FX)
  | tri_fx  : forall B L FX M n,
      uniform_oo FX -> (forall x, proper x -> n |-F- B ; L ; UP( (FX x) ::  M)) ->
      S n |-F- B ; L ; UP ((All FX) :: M)
  where " n '|-F-' B ';' L ';' X " := (seqN n B L X).

  Hint Constructors seqN : core .

  (** Well formedness conditions for arrows. *)
  Definition isArrow (A:Arrow) : Prop :=
    match A with
    | UP l => isFormulaL l
    | DW F => isFormula F
    end.

  Reserved Notation " '|-f-' B ';' L ';' X " (at level 80).

  (** The same system without the height of the derivation *)
  Inductive seq:  multiset oo -> multiset oo -> Arrow -> Prop :=
  | tri_init1' : forall B A,  |-f- B ; [atom A] ; DW (perp A)
  | tri_init2' : forall B A,  In (atom A) B -> |-f- B ; [] ; DW (perp A)
  | tri_one' : forall B,  |-f- B ; [] ; DW One
  | tri_tensor' : forall B M N MN F G, Permutation MN (M ++ N) ->
                                       (|-f- B ; M ; DW F) ->
                                       (|-f- B ; N ; DW G) ->
                                       |-f- B ; MN ; DW (MAnd F G)
  | tri_plus1' : forall B M F G,
      |-f- B ; M ; DW F -> |-f- B ; M ; DW (AOr F G)
  | tri_plus2' : forall B M F G,
      |-f- B ; M ; DW G -> |-f- B ; M ; DW (AOr F G)
  | tri_bang' : forall B F,
      |-f- B ; [] ; UP [F] -> |-f- B ; [] ; DW (Bang F)
  | tri_rel' : forall B F L, release F -> |-f- B ; L ; UP [F] ->  |-f- B ; L ; DW F
  | tri_top' : forall B L M,
      |-f- B ; L ; UP (Top :: M)
  | tri_bot' : forall B L M,
      |-f- B ; L ; UP M ->  |-f- B ; L ; UP (Bot :: M)
  | tri_par' : forall B L M F G,
      |-f- B ; L ; UP (F::G::M) -> |-f- B ; L ; UP((MOr F G) :: M)
  | tri_with' : forall B L M F G,
      |-f- B ; L ; UP (F :: M) -> |-f- B ; L ; UP (G :: M) -> |-f- B ; L ; UP ((AAnd F  G) :: M)
  | tri_quest' : forall B L M F,
      |-f- B ++ [F] ; L ; UP M -> |-f- B ; L ; UP ((Quest F) :: M)
  | tri_store' : forall B L M F,
      ~ asynchronous  F-> |-f- B ; L ++ [F] ; UP M -> |-f- B ; L ; UP (F::M)
  | tri_dec1' : forall B L L' F,
      ~IsPositiveAtom F -> Remove F L L' -> |-f- B ; L' ; DW F -> |-f- B ; L ; UP []
  | tri_dec2' : forall B L F,
      ~IsPositiveAtom F -> In F B -> |-f- B ; L ; DW F -> |-f- B ; L ; UP []
  | tri_dec3' : forall B L F,
      theory F -> ~IsPositiveAtom F -> |-f- B ; L ; DW F -> |-f- B ; L ; UP []
  | tri_ex'  : forall B FX M t,
      uniform_oo FX -> proper t -> |-f- B; M ; DW (FX t) -> |-f- B; M ; DW (Some  FX)
  | tri_fx'  : forall B L FX M,
      uniform_oo FX -> (forall x, proper x -> |-f- B ; L ; UP( (FX x) ::  M)) ->
      |-f- B ; L ; UP ((All FX) :: M)
  where " '|-f-' B ';' L ';' X " := (seq B L X).

  Hint Constructors seq : core.
  Definition adeq_seq (B: multiset oo) (L:multiset oo) (X:Arrow) : Prop :=
    isFormulaL B /\ isFormulaL L /\ isArrow X  . (* /\ |-f- B ; L ; X. *)

End LLSequent .

Module LLNotations .
  Notation "'bot'" := Bot.
  Notation "'top'" := Top.
  Notation "'one'" := One.
  Notation "'zero'" := Zero.
  Notation "A ** B" := (MAnd A B ) (at level 50) .
  Notation "A $ B" := (MOr A B) (at level 50) .
  Notation "A 'op' B" := (AOr A B) (at level 50) .
  Notation "A & B" := (AAnd A B) (at level 50) .
  Notation "! A" := (Bang A) (at level 50) .
  Notation "? A" := (Quest A) (at level 50) .
  Notation " A ^ " := (dual A) (at level 10) .
  Notation " A -o B" := ( (A ^) $ (B) ) (at level 60).
  Notation "'F{' FX '}'" := (All FX) (at level 10) .
  Notation "'E{' FX '}'" := (Some FX) (at level 10) .
  Notation "F == G" := ( ( F -o G ) & ( G -o F )) (at level 60) .

  (** Notation for arrows *)
  (**  Positive phase *)
  Notation ">> F" := (DW F) (at level 80)  .
  (** Negative phase *)
  Notation "> L" := (UP L) (at level 80) .
End LLNotations .


(** * Taking a quotient of a submodule of a module over a fixed ring

Auke Booij, December 2017
*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.Modules.Core.
Require Import UniMath.Algebra.Modules.Submodule.

(** * Preliminaries: notion of an equivalence relation on a module that is closed under the module
structure
*)
Section quotmod_rel.

  Context {R : ring}
          (M : module R).

  Local Open Scope module_scope.
  Definition isactionhrel (E : hrel M) : UU :=
    ∏ r a b, E a b -> E (r * a) (r * b).

  Definition module_eqrel : UU :=
    ∑ E : eqrel M, isbinophrel E × isactionhrel E.
  Definition hrelmodule_eqrel (E : module_eqrel) : eqrel M := pr1 E.
  Coercion hrelmodule_eqrel : module_eqrel >-> eqrel.

  Definition binophrelmodule_eqrel (E : module_eqrel) : binopeqrel M := make_binopeqrel E (pr1 (pr2 E)).
  Coercion binophrelmodule_eqrel : module_eqrel >-> binopeqrel.

  Definition isactionhrelmodule_eqrel (E : module_eqrel) : isactionhrel E := pr2 (pr2 E).
  Coercion isactionhrelmodule_eqrel : module_eqrel >-> isactionhrel.

  Definition make_module_eqrel (E : eqrel M) : isbinophrel E -> isactionhrel E -> module_eqrel :=
    λ H0 H1, (E,,(H0,,H1)).

End quotmod_rel.

(** * Preliminaries: construction of an appropriate equivalence relation from a submodule
*)
Section quotmod_submodule.

  Context {R : ring}
          (M : module R)
          (A : submodule M).

  Local Notation "x + y" := (@op _ x y).
  Local Notation "x - y" := (@op _ x (grinv _ y)).
  Local Notation "  - y" := (grinv _ y).
  Local Notation "0" := (unel _).
  Local Open Scope module_scope.

  Definition eqrelsubmodule : eqrel M.
  Proof.
    use eqrelconstr.
    - exact (λ m m', A (m - m')).
    - intros x y z xy yz.
      assert (K := submoduleadd A (x - y) (y - z) xy yz).
      rewrite (assocax M) in K.
      rewrite <- (assocax M (grinv _ y) y) in K.
      rewrite grlinvax in K.
      rewrite lunax in K.
      exact K.
    - intros x.
      rewrite (grrinvax M x).
      exact (submodule0 A).
    - intros x y axy.
      assert (K := submoduleinv A (x - y) axy).
      rewrite grinvop in K.
      rewrite grinvinv in K.
      exact K.
  Defined.

  Definition module_eqrelsubmodule : module_eqrel M.
  Proof.
    use make_module_eqrel.
    - exact eqrelsubmodule.
    - split.
      + intros a b c.
        assert (H : a - b = c + a - (c + b)).
        {
          etrans; [|eapply (maponpaths (λ z, z - (c + b))); apply (commax M)];
            rewrite assocax.
          apply maponpaths.
          now rewrite grinvop, commax, assocax, grlinvax, runax.
        }
        simpl in *.
        now rewrite H.
      + intros a b c.
        assert (H : a - b = a + c - (b + c)).
        {
          rewrite assocax.
          apply maponpaths.
          now rewrite grinvop, <- (assocax M), grrinvax, lunax.
        }
        simpl in *.
        now rewrite H.
    - intros r m m'.
      assert (H : (r * m) - (r * m') = r * (m - m')) by
          now rewrite module_inv_mult, module_mult_is_ldistr.
      generalize (submodulemult A r (m - m')).
      simpl in *.
      now rewrite H.
  Defined.

End quotmod_submodule.

(** * Construction of quotient module, as well as its universal property
*)
Section quotmod_def.

  Context {R : ring}
          (M : module R)
          (E : module_eqrel M).

  Local Notation "x + y" := (@op _ x y).
  Local Notation "x - y" := (@op _ x (grinv _ y)).
  Local Open Scope module_scope.

  Definition quotmod_abgr : abgr := abgrquot E.

  Definition quotmod_ringact (r : R) : quotmod_abgr -> quotmod_abgr.
  Proof.
    use setquotuniv.
    - intros m.
      exact (setquotpr E (r * m)).
    - intros m m' Hmm'.
      apply weqpathsinsetquot.
      now apply isactionhrelmodule_eqrel.
  Defined.

  Definition quotmod_ringmap : R -> ringofendabgr quotmod_abgr.
  Proof.
    intros r. use tpair.
    + exact (quotmod_ringact r).
    + use make_ismonoidfun.
      * use make_isbinopfun.
        use (setquotuniv2prop E (λ a b, make_hProp _ _)); [use isasetsetquot|].
        intros m m'.
        unfold quotmod_ringact, setquotfun2;
          rewrite (setquotunivcomm E), (setquotunivcomm E);
          simpl; unfold setquotfun2;
            rewrite (setquotuniv2comm E), (setquotuniv2comm E), (setquotunivcomm E).
        apply weqpathsinsetquot.
        assert (H : r * (m + m') = r * m + r * m') by use module_mult_is_ldistr.
        simpl in H; rewrite H.
        use eqrelrefl.
      * unfold unel, quotmod_ringact; simpl; rewrite (setquotunivcomm E).
        apply maponpaths.
        apply module_mult_1.
  Defined.

  Definition quotmod_ringfun : ringfun R (ringofendabgr quotmod_abgr).
  Proof.
    unfold ringfun, rigfun.
    use rigfunconstr.
    - exact quotmod_ringmap.
    - use make_isrigfun.
      (* To show that quotmod_ringmap is a ring action, we show it is a monoid homomorphism with
      respect to both monoids on R. *)
      all: use make_ismonoidfun;
        (* To show that a map is a monoid homomorphism, we show that it respects the binary
        operation, as well as that it preserves the unit. *)
        [ use make_isbinopfun; intros r r' | ].
      (* It suffices to prove the underlying maps of the resulting automorphism of our group are
      equal. *)
      all: use monoidfun_paths; use funextfun.
      (* We show this using the universal property of the set quotient. *)
      all: use (setquotunivprop E (λ m, make_hProp _ _)); [use isasetsetquot|].
      (* Expand out some definitions. *)
      all: intros m; simpl; unfold unel, quotmod_ringact.
      (* Apply the computation rule of the universal property of the set quotient. *)
      all: [> do 3 rewrite (setquotunivcomm E) | rewrite (setquotunivcomm E)
            | do 3 rewrite (setquotunivcomm E) | rewrite (setquotunivcomm E)].
      (* We can show the required equalities because the representatives of the equivalence classes
      are already equal. *)
      all: use maponpaths; simpl.
      (* The representatives are equal because of the fact that our input map was a ring action. *)
      + use module_mult_is_rdistr.
      + use module_mult_0_to_0.
      + use module_mult_assoc.
      + use module_mult_unel2.
  Defined.

  Definition quotmod_mod_struct : module_struct R quotmod_abgr := quotmod_ringfun.

  Definition quotmod : module R.
  Proof.
    use make_module.
    - exact quotmod_abgr.
    - exact quotmod_mod_struct.
  Defined.
  Notation "M / A" := (quotmod M (module_eqrelsubmodule M A)) : module_scope.

  Notation "R-mod( M , N )" := (modulefun M N) : module_scope.
  Definition quotmod_quotmap : R-mod(M, quotmod).
  Proof.
    use make_modulefun.
    - exact (setquotpr E).
    - now use (make_ismodulefun (make_isbinopfun _)).
  Defined.

  Definition quotmoduniv
             (N : module R)
             (f : R-mod(M, N))
             (is : iscomprelfun E f) :
    R-mod(quotmod, N).
  Proof.
    use make_modulefun.
    - now use (setquotuniv E _ f).
    - use make_ismodulefun.
      + use make_isbinopfun.
        use (setquotuniv2prop E (λ m n, make_hProp _ _)); [use isasetmodule|].
        intros m m'.
        simpl.
        unfold op, setquotfun2.
        rewrite setquotuniv2comm.
        do 3 rewrite (setquotunivcomm E).
        apply modulefun_to_isbinopfun.
      + intros r.
        use (setquotunivprop E (λ m, make_hProp _ _)); [use isasetmodule|].
        intros m.
        assert (H : r * quotmod_quotmap m = quotmod_quotmap (r * m)) by
            use (! modulefun_to_islinear _ _ _).
        simpl in H. simpl.
        rewrite H.
        do 2 rewrite (setquotunivcomm E).
        apply modulefun_to_islinear.
  Defined.

End quotmod_def.

(** * Universal property in terms of submodules
*)
Section from_submodule.

  Context {R : ring}
          (M : module R)
          (A : submodule M).

  Notation "R-mod( M , N )" := (modulefun M N) : module_scope.
  Local Open Scope module_scope.

  Definition quotmoduniv_submodule
             (N : module R)
             (f : R-mod(M, N))
             (is : iscomprelfun (module_eqrelsubmodule M A) f) :
    R-mod(quotmod M (module_eqrelsubmodule M A), N) :=
    quotmoduniv M (module_eqrelsubmodule M A) N f is.

End from_submodule.


Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.

Require Import Qtt.tactics.
Require Import Qtt.usage.
Require Import Qtt.dctx.
Require Import Qtt.dctx_sub.

(* A Q-left semimodule is the definition of a carrier set M with commutative monoid structure (M,+,0) and left multiplication function.

• for 𝑞1, 𝑞2 ∈ 𝑄 and 𝑚∈𝑀, we have (𝑞1 + 𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ 𝑚 ⊕ 𝑞2 ⊙ 𝑚     [distrib2]
• for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, we have, 𝑞 ⊙ (𝑚1 ⊕ 𝑚2) = 𝑞 ⊙ 𝑚1 ⊕ 𝑞 ⊙ 𝑚2  [distrib]
 •for 𝑞1, 𝑞2 ∈𝑄 and 𝑚∈𝑀,we have (𝑞1·𝑞2) ⊙ 𝑚 = 𝑞1 ⊙ (𝑞2 ⊙ 𝑚)           [mul_assoc]
• for 𝑚 ∈ 𝑀, we have 1 ⊙ 𝑚 = 𝑚                                       [mul_id]
• for 𝑞 ∈ 𝑄 and 𝑚 ∈ 𝑀, we have 0 ⊙ 𝑚 = 𝑞 ⊙ 0 = 0.                     [mul_zero1, mul_zero2]

A left 𝑄-semimodule 𝑀 is said to be partially-ordered iff there exists a partial order ≤𝑀 on 𝑀 such that the following properties hold.
• for 𝑚1,𝑚2, 𝑚 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑚 ⊕ 𝑚1 ≤𝑀 𝑚 ⊕ 𝑚2            [ctx_sub_ctx_plus]
• for 𝑞 ∈ 𝑄 and 𝑚1,𝑚2 ∈ 𝑀, if 𝑚1 ≤𝑀 𝑚2, then 𝑞 ⊙ 𝑚1 ≤𝑀 𝑞 ⊙ 𝑚2       [po_semiring_context]
• for 𝑞1,𝑞2 ∈𝑀 and 𝑚∈𝑀, if 𝑞1 ≤𝑞2, then 𝑞1 ⊙ 𝑚 ≤ 𝑀  𝑞2 ⊙ 𝑚.           [ctx_sub_ctx_mul]
*)

(* Here we show that contexts form a module; uses ctx_plus, ctx_mul, and ctx_sub. *)

(* We reorient some of these properties so that we can add them to rewr_list hint database.
   That way they will be automatically applied by the [simpl_env] tactic.  *)

Section CtxMod.

Variables A:Type.

(* First, ctx_plus with 0=(ctx_mul 0 G) is a commutative monoid. *)

Lemma ctx_plus_0_l : forall (G:list(atom*(usage*A))),
  G = ctx_plus (ctx_mul 0 G) G.
Proof.
  induction G; simpl. auto.
  destruct a as [x [q1 ?]].
  simpl.
  ring_equal.
  auto.
Qed.

Lemma ctx_plus_0_r : forall (G:list(atom*(usage*A))),
  G = ctx_plus G (ctx_mul 0 G).
Proof.
  induction G; simpl. auto.
  destruct a as [x [q1 ?]].
  simpl.
  ring_equal.
  auto.
Qed.

(* if we add a pre-condition, we can generalize this identity. *)

Lemma ctx_ctx_plus_0_l : forall {D:list(atom*A)} {G1 G2},
  ctx D G1 ->
  ctx D G2 ->
  ctx_plus (ctx_mul 0 G1) G2 = G2.
Proof.
  induction D; intros; destruct_ctx; simpl. auto.
  ring_equal.
  auto.
Qed.

Lemma ctx_ctx_plus_0_r : forall {D:list(atom*A)} {G1 G2},
  ctx D G1 ->
  ctx D G2 ->
  ctx_plus G2 (ctx_mul 0 G1) = G2.
Proof.
  induction D; intros; destruct_ctx; simpl. auto.
  ring_equal.
  auto.
Qed.

(* Associativity also has a precondition. *)

Lemma ctx_plus_assoc : forall D (G1:list(atom*(usage*A))) G2 G3,
    ctx D G1 ->
    ctx D G2 ->
    ctx D G3 ->
    ctx_plus (ctx_plus G1 G2) G3 = ctx_plus G1 (ctx_plus G2 G3).
Proof.
  induction D; intros; invert_ctx; simpl; auto.
  f_equal. f_equal. f_equal. ring_equal.
  eauto.
Qed.

Lemma ctx_plus_comm :
  forall D (G1:list(atom*(usage*A))) G2, ctx D G1 -> ctx D G2 -> ctx_plus G1 G2 = ctx_plus G2 G1.
Proof.
  induction D; intros; invert_ctx. auto.
  simpl.
  f_equal. f_equal. rewrite qplus_comm. auto.
  rewrite IHD; auto.
Qed.

(* Next, the explicit module laws *)

Lemma ctx_distrib2 q1 q2 (G:list(atom*(usage*A))) : forall (D:list(atom*A)) G1 G2, ctx D G1 -> ctx D G2 ->
  ctx_plus (ctx_mul q1 G) (ctx_mul q2 G) = ctx_mul (q1 + q2) G.
Proof.
  induction G. intros. simpl. auto.
  intros. destruct a as [x [? ?]].
  simpl.
  rewrite distr_l.
  f_equal.
  eauto.
Qed.

Lemma ctx_distrib1 r D (G1:list(atom*(usage*A))) : ctx D G1 -> forall G G2, ctx D G2 ->
  G = ctx_plus G1 G2 -> (ctx_mul r G) = ctx_plus (ctx_mul r G1) (ctx_mul r G2).
Proof.
  induction 1; intros; invert_ctx. auto.
  simpl.
  rewrite distr_r.
  f_equal.
  auto.
Qed.

Lemma ctx_distrib {r D}{G1:list(atom*(usage*A))} G2 : ctx D G1 -> ctx D G2 ->
  ctx_mul r (ctx_plus G1 G2) = ctx_plus (ctx_mul r G1) (ctx_mul r G2).
Proof.
  intros.
  eapply ctx_distrib1; eauto.
Qed.

Lemma ctx_mul_assoc q1 q2 {G:list(atom*(usage*A))} : ctx_mul q1 (ctx_mul q2 G) = ctx_mul (q1 * q2) G.
Proof.
   induction G; simpl; try done.
   destruct a as [x [? ?]].
   simpl.
   rewrite IHG.
   rewrite qmul_assoc.
   auto.
Qed.

Lemma ctx_mul_id : forall {G:list(atom*(usage*A))}, ctx_mul 1 G = G.
Proof.
  induction G. auto.
  destruct a as [x [? ?]].
  simpl. rewrite IHG.
  rewrite qmul_1_l. auto.
Qed.

(* The identities for multiplying by zero are a bit tricky. ctx_mul 0 G is defined to be zero, for any G.
   So the identities listed above are a bit trivial.
*)

(* This lemma says that all zeros are the same *)
Lemma same_ctx : forall {D}{G1:list(atom*(usage*A))}, ctx D G1 -> forall G2, ctx D G2 -> ctx_mul 0 G1 = ctx_mul 0 G2.
Proof.
  induction 1; intros; invert_ctx; simpl_env. auto.
  simpl. erewrite IHctx.
  repeat rewrite qmul_0_l.
  f_equal.
  auto.
Qed.

(* This is another variant of the same lemma *)
Lemma ctx_mul_0_eq : forall {G1 G2:list(atom*(usage*A))}, ctx_mul 0 G1 = G2 -> ctx_mul 0 G2 = G2.
Proof.
  intros G1. induction G1.
  - intros. destruct G2; inversion H. auto.
  - intros. simpl in H. destruct a. destruct p. simpl in H.
    destruct G2; inversion H.
    destruct p. destruct p. inversion H1. subst. clear H1.
    asimpl. rewrite ctx_mul_assoc. asimpl. auto.
Qed.

(* --------------- Partially-ordered semimodule ------------------- *)

Lemma po_semiring_context {q}{D:list(atom*A)}{G1 G2} :
     ctx_sub D G1 G2
   -> ctx_sub D (ctx_mul q G1) (ctx_mul q G2).
Proof.
  induction 1. simpl. auto.
  simpl. econstructor; auto.
  eapply po_semiring3. auto.
Qed.

Lemma ctx_sub_ctx_mul: forall {D} {G:list(atom*(usage*A))} {q3 q0}, q3 <= q0 -> ctx D G -> ctx_sub D (ctx_mul q3 G) (ctx_mul q0 G).
Proof. induction 2. simpl. auto.
       econstructor; auto. apply po_semiring2. auto.
Qed.

Lemma ctx_sub_ctx_plus_aux:
  forall {D}{G3':list(atom*(usage*A))} {G3},
    ctx_sub D G3' G3 -> forall G, ctx D G ->
    ctx_sub D (ctx_plus G3' G) (ctx_plus G3 G).
Proof.
  induction 1; intros; invert_ctx; simpl; auto.
  econstructor; eauto.
  eapply qplus_sub_r; auto.
Qed.

Lemma ctx_sub_ctx_plus: forall {D:list (atom*A)}{G1 G1' G2 G2'},
    ctx_sub D G1 G1' -> ctx_sub D G2 G2' ->
    ctx_sub D (ctx_plus G1 G2) (ctx_plus G1' G2').
Proof.
  intros.
  transitivity (ctx_plus G1 G2').
  rewrite (@ctx_plus_comm D G1 G2); try eassumption.
  eapply ctx_sub_ctx1; eauto.
  eapply ctx_sub_ctx1; eauto.
  rewrite (@ctx_plus_comm D G1 G2'); try eassumption.
  eapply ctx_sub_ctx1; eauto.
  eapply ctx_sub_ctx2; eauto.
  eapply ctx_sub_ctx_plus_aux; eauto.
  eapply ctx_sub_ctx1; eauto.
  eapply ctx_sub_ctx_plus_aux; eauto.
  eapply ctx_sub_ctx2; eauto.
Qed.

(* --------------- Derived properties ------------------- *)

Lemma ctx_plus_sub: forall {D1} {G1 G2' G2:list(atom*(usage*A))}, ctx D1 G1 ->
                               G2' = ctx_mul 0 G2' ->
                               ctx_sub D1 G2' G2 -> ctx_sub D1 G1 (ctx_plus G1 G2).
Proof.
induction D1; intros; invert_ctx; simpl; auto.
inversion H1. auto.
simpl_env in *. inversion H1. subst. simpl.
unfold ctx_mul in H0. simpl_env in H0. inversion H0.
econstructor. auto. eapply qplus_sub. rewrite H2 in H5. ring_simpl in H5. auto.
eauto. auto.
Qed.

Lemma ctx_plus_swap: forall {D:list(atom*A)} a,
    ctx D a -> forall b c d, ctx D b ->
    ctx D c -> ctx D d ->
    ctx_plus (ctx_plus a b) (ctx_plus c d) =
    ctx_plus (ctx_plus a c) (ctx_plus b d).
Proof.
  induction 1; intros;
  simpl in *.
  - inversion H. inversion H0. inversion H1. auto.
  - inversion H1. inversion H2. inversion H3. subst.
    asimpl.
    rewrite IHctx; try eclarify_ctx.
    f_equal.
    f_equal.
    f_equal.
    f_equal.
    f_equal.
    rewrite <- qplus_assoc.
    rewrite <- qplus_assoc.
    f_equal.
    rewrite qplus_comm.
    auto.
Qed.

Lemma ctx_plus_ctx_mul_0 : forall (G:list(atom*(usage*A))) G1 G2, G = ctx_plus (ctx_mul 0 G1) (ctx_mul 0 G2) ->
                          G = ctx_mul 0 G.
Proof.
  induction G; intros; simpl; auto.
  destruct a as [x [q ?]].
  destruct G1 as [|[y [q1' ?]]];
  destruct G2 as [|[z [q1 ?]]]; simpl in H; try inversion H. subst. clear H.
  simpl. repeat rewrite qmul_0_l. repeat rewrite qplus_0_l.
  repeat f_equal.
  eauto.
Qed.

End CtxMod.

(* by adding these lemmas to the rewr_list hint database, it will be automatically
   applied by the [simpl_env] tactic.  *)

Hint Rewrite ctx_mul_id : rewr_list.
Hint Rewrite ctx_mul_assoc : rewr_list.
Hint Rewrite ctx_distrib2 : rewr_list.

Hint Rewrite ctx_ctx_plus_0_l ctx_ctx_plus_0_r : rewr_list.


Require Import FunctionalExtensionality.
Require Export functor.

(** prod is a covariant bifunctor. *)
Instance Bimap_prod : Bimap prod :=
  fun _ _ _ _ f g p => let (x, y) := p in (f x, g y).

Instance Bifunctor_prod : Bifunctor prod.
Proof. constructor; intros; extensionality x; destruct x; auto. Qed.

Definition swap {A B} : prod A B -> prod B A :=
  fun p => (snd p, fst p).


(** Proof Reflection in Coq ; lift.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export objects.

Set Implicit Arguments.

Section lifting.

Variable l1 l2 : list nat.

Let T := trm l1.
Let Ts := trms l1.
Let F := frm l1 l2.
Let P := prf l1 l2.

Fixpoint lift (n i : nat) {struct n} : nat :=
  match n with
  | O => S i
  | S n' => match i with
            | O => 0
            | S i' => S (lift n' i')
            end
  end.

(** `projection': the reverse of lifting when [n] unequal to [i] *)

Fixpoint proj (n i : nat) {struct i} : nat :=
  match i with
  | O => 0
  | S i' => match n with
            | O => i'
            | S n' => S (proj n' i')
            end
  end.

Definition lift_trm : nat -> T -> T := map_trm lift.
Definition proj_trm : nat -> T -> T := map_trm proj.

Definition lift_trms n := mapn (lift_trm n).
Definition proj_trms n := mapn (proj_trm n).

Definition lift_frm : nat -> F -> F := map_frm_var lift_trm.
Definition proj_frm : nat -> F -> F := map_frm_var proj_trm.

Definition lift_cxt n := map (lift_frm n).

Definition lift_var_prf : nat -> P -> P := map_prf_var lift_trm.

Definition lift_hyp_prf : nat -> P -> P := map_prf_hyp lift.

Variable A : Set.

Fixpoint shiftVAR (VAR : nat -> A) (n : nat) {struct n} :
 nat -> A :=
  match n with
  | O => VAR
  | S n' => shiftVAR (fun p => VAR (S p)) n'
  end.

End lifting.