From stdpp Require Import tactics sets.
Require Import Reals Psatz Omega Fourier.
From discprob.measure Require Export measurable_space.
From mathcomp Require Import choice.
Require ClassicalEpsilon.
Export Hierarchy.
Open Scope R_scope.

(* Usually the Borel sigma algebra is defined for more general topological spaces,
   but the Coquelicot hierarchy is oriented around uniform spaces, and in any case
   that will be good enough *)
Definition borel_sigma (A: UniformSpace) : sigma_algebra A := minimal_sigma (@open A).

(* Todo: should we make it global? or only if second countable *)
Instance borel (A: UniformSpace) : measurable_space A :=
  {| measurable_space_sigma := borel_sigma A |}.

Lemma continuous_inverse_open (A B: UniformSpace) (f: A → B) :
  (∀ x, continuous f x) →
  ∀ U, open U → open (fun_inv f U).
Proof.
  rewrite /open. intros Hcont U Hopen x Hf.
  rewrite /continuous_on in Hcont.
  rewrite /fun_inv. specialize (Hcont x). edestruct Hcont as [eps ?]; first eauto.
  exists eps. auto.
Qed.

Lemma continuous_borel_measurable (A B: UniformSpace) (f: A → B) :
  (∀ x, continuous f x) →
  measurable f.
Proof.
  intros Hcont. apply sigma_measurable_generating_sets => U Hopen. apply minimal_sigma_ub.
  by apply continuous_inverse_open.
Qed.

Lemma closed_compl {A: UniformSpace} (U: A → Prop) :
  open U → closed (compl U).
Proof. by apply closed_not. Qed.
Lemma closed_compl' {A: UniformSpace} (U: A → Prop) :
  open (compl U) → closed U.
Proof. intros. eapply closed_ext; last eapply closed_compl; eauto. apply compl_involutive. Qed.
Lemma open_compl {A: UniformSpace} (U: A → Prop) :
  closed U → open (compl U).
Proof. by apply open_not. Qed.
Lemma open_compl' {A: UniformSpace} (U: A → Prop) :
  closed (compl U) → open U.
Proof. intros. eapply open_ext; last eapply open_compl; eauto. apply compl_involutive. Qed.

Hint Resolve closed_compl open_compl closed_compl' open_compl'.

Lemma borel_gen_closed (A: UniformSpace) : eq_sigma (borel A) (minimal_sigma (@closed A)).
Proof.
  rewrite /eq_sigma/eq_prop/borel => U; split; apply minimal_sigma_lub => U' ?;
    rewrite -(compl_involutive U'); apply sigma_closed_complements;
    apply minimal_sigma_ub; auto.
Qed.

Lemma borel_closed (A: UniformSpace) U : closed U → (borel A) U.
Proof.
  intros Hclosed. rewrite borel_gen_closed. by apply minimal_sigma_ub.
Qed.

(* Technically this would be the Borel sigma algebra on the extended reals,
 but we do not have the UniformSpace structure on Rbar *)
Definition Rbar_sigma : sigma_algebra Rbar :=
  minimal_sigma (λ U, ∃ x, U = (λ z, Rbar_le z x)).
Instance Rbar_measurable_space : measurable_space Rbar :=
  {| measurable_space_sigma := Rbar_sigma |}.

Section borel_R.

  Lemma Rbar_sigma_p_infty:
    Rbar_sigma {[p_infty]}.
  Proof.
    assert (Hequiv: eq_prop ({[p_infty]}) (intersectF (λ n, compl (λ x, Rbar_le x (INR n : Rbar))))).
    { split.
      - inversion 1; subst.
        intros n. rewrite /compl//=.
      - intros Hall. destruct x as [r | |].
        * exfalso.
          destruct (Rle_dec 0 r).
          ** destruct (archimed_pos r) as (n&Hrange); auto.
             rewrite S_INR in Hrange. eapply (Hall (S n)). rewrite S_INR //=.
             nra.
          ** apply (Hall O) => //=. nra.
        * rewrite //=.
        * exfalso. apply (Hall O) => //=.
    }
    rewrite Hequiv.
    apply sigma_closed_intersections => n.
    apply sigma_closed_complements.
    apply minimal_sigma_ub. exists (INR n). auto.
  Qed.

  Lemma Rbar_sigma_m_infty:
    Rbar_sigma {[m_infty]}.
  Proof.
    assert (Hequiv: eq_prop ({[m_infty]}) (intersectF (λ n, (λ x, Rbar_le x (-INR n))))).
    { split.
      - inversion 1; subst.
        intros n. rewrite /compl//=.
      - intros Hall. destruct x as [r | |].
        * exfalso. destruct (Rle_dec 0 r).
          ** exfalso. feed pose proof (Hall (S O)) as H. rewrite //= in H. nra.
          ** destruct (archimed_pos (-r)) as (n'&?); first nra.
             feed pose proof (Hall (S n')) as H'. rewrite S_INR //= in H' H.
             apply Ropp_le_ge_contravar in H'.
             rewrite Ropp_involutive in H'.
             nra.
        * exfalso. destruct (Hall O).
        * done.
    }
    rewrite Hequiv.
    apply sigma_closed_intersections => n.
    apply minimal_sigma_ub. exists (-INR n). auto.
  Qed.

  Lemma borel_gen_closed_ray1 :
    le_prop (minimal_sigma (λ (U: R → Prop), ∃ x y, U = (λ z, x < z <= y)))
            (minimal_sigma (λ (U : R  → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    apply minimal_sigma_lub. intros ? (x&y&?); subst.
    assert ((λ z : R, x < z ∧ z <= y) ≡
            (λ z : R, z <= y) ∩ compl (λ z : R, 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 (R_UniformSpace))
    (minimal_sigma (λ (U : R → 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 (bool * (nat * nat * nat))] n) as [(b&(x&y)&N)|];
        last exact ∅.
      set (V := (λ z, match b with
                        | true => (INR x / INR y) - (1/(INR N)) < z ∧
                                  z <= (INR x / INR y)
                        | false => - ((INR x / INR y)) - (1/(INR N)) < z ∧
                                  z <= - (INR x / INR y)
                      end)).
      destruct (ClassicalEpsilon.excluded_middle_informative
                  (V ⊆ U)).
      * exact V.
      * exact ∅.
    }
    {
      split.
      * intros HUz. specialize (HopenU _ HUz).
        destruct HopenU as ((δ&Hpos)&Hdelta).
        destruct (Rle_dec 0 x) as [Hle|Hnle].
        ** 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) as (n&m&(?&?)&?); auto; try nra.
           exists (pickle (true, (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//=/ball//=/AbsRing_ball//=/abs//=.
             rewrite /minus/opp/plus//=.
             assert (z >= z - x) by nra.
             apply Rabs_case => Hcase; try nra.
           }
           rewrite //=. nra.
        ** edestruct (archimed_cor1 δ) as (K&?&?); first by nra.
           assert (0 < / INR K).
           { apply Rinv_0_lt_compat, pos_INR'; done. }
           edestruct (archimed_rat_dense2 (/INR K) x) as (n&m&(?&?)&?); auto; try nra.
           exists (pickle (false, (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//=/ball//=/AbsRing_ball//=/abs//=.
             rewrite /minus/opp/plus//=.
             assert (z >= z + x) by nra.
             apply Rabs_case => Hcase; try nra.
           }
           rewrite //=. nra.
      * intros (n&HUn).
        destruct pickle_inv as [(b&(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 bool * (nat * nat * nat)] i) as
        [(b&(n&m)&K)|] eqn:Heq; rewrite Heq; last by apply sigma_empty_set.
    destruct b.
    * set (V := λ z, INR n / INR m - 1 / INR K < z ∧ z <= 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.
    * set (V := λ z, - (INR n / INR m) - 1 / INR K < z ∧ z <= - (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.
  Qed.

  Lemma borel_gen_open_ray_gt:
    le_prop (borel (R_UniformSpace))
    (minimal_sigma (λ (U : R → Prop), ∃ x, U = (λ z, x < z))).
  Proof.
    etransitivity; first apply borel_gen_closed_ray2.
    apply minimal_sigma_lub => U. intros (x&Heq).
    subst. eapply (sigma_proper _ _ (compl (λ z, x < z))).
    * rewrite /compl//=. split; nra.
    * apply sigma_closed_complements. apply minimal_sigma_ub.
      eexists; eauto.
  Qed.

  Lemma open_ray_borel_gt z:
    borel _ (λ x, z < x).
  Proof.
    apply minimal_sigma_ub.
    apply open_gt.
  Qed.

  Lemma open_ray_borel_lt z:
    borel _ (λ x, x < z).
  Proof.
    apply minimal_sigma_ub.
    apply open_lt.
  Qed.

  Lemma closed_ray_borel_ge z:
    borel _ (λ x, z <= x).
  Proof.
    apply borel_closed. apply closed_compl'.
    eapply open_ext; last eapply (open_lt z).
    intros x => //=. rewrite /compl.
    nra.
  Qed.

  Lemma closed_ray_borel_le z:
    borel _ (λ x, x <= z).
  Proof.
    apply borel_closed. apply closed_compl'.
    eapply open_ext; last eapply (open_gt z).
    intros x => //=. rewrite /compl.
    nra.
  Qed.

  Lemma closed_interval_borel a b:
    borel _ (λ x, a <= x <= b).
  Proof.
    assert ((λ x, a <= x <= b) ≡ (λ x, a <= x) ∩ (λ x, x <= b)) as ->.
    { split; intros; rewrite //=; nra. }
    eapply sigma_closed_pair_intersect; auto using closed_ray_borel_le, closed_ray_borel_ge.
  Qed.

  Lemma borel_equiv_closed_ray :
    eq_sigma (borel (R_UniformSpace))
    (minimal_sigma (λ (U : R → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    intros z; split.
    * apply borel_gen_closed_ray2.
    * apply minimal_sigma_lub. intros U (?&Heq). subst.
      apply (closed_ray_borel_le x).
  Qed.

  Lemma measurable_plus {A: Type} {F: measurable_space A} (f1 f2: A → R) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, f1 x + f2 x).
  Proof.
    intros Hmeas1 Hmeas2.
    eapply sigma_measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
    eapply sigma_measurable_generating_sets.
    intros ? (t&->). rewrite /fun_inv.
    cut (eq_prop (λ a, t < f1 a + f2 a)
                 (unionF (λ n, match @pickle_inv [countType of (bool * (nat * nat))] n with
                               | None => empty_set
                               | Some (b, (n, m)) =>
                                 let r := if b then INR n / INR m else - (INR n / INR m) in
                                 (fun_inv f1 (λ x, Rlt r x)) ∩ (fun_inv f2  (λ x, Rlt (t - r) x))
                               end))).
    { intros ->. apply sigma_closed_unions => i.
      destruct (pickle_inv) as [(b&(n&m))|]; last apply sigma_empty_set.
      destruct b => //=; apply sigma_closed_pair_intersect;
                      first [ apply Hmeas1 | apply Hmeas2 ]; apply open_ray_borel_gt.
    }
    intros a; split.
    - intros Hlt.
      destruct (Rtotal_order 0 (f1 a)) as [Hgt0|[Heq|Hlt0]].
      * set (δ := Rmin ((f1 a + f2 a) - t) (f1 a / 2)).
        edestruct (archimed_rat_dense1 (δ/2) (f1 a - δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        { apply Rmin_case_strong; intros; try nra. }
        { apply Rmin_case_strong; intros; try nra. }
        exists (pickle (true, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           apply Rmin_case_strong; nra.
      * set (δ := ((f1 a + f2 a) - t) / 2).
        edestruct (archimed_rat_dense2 (δ/2) (-δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        exists (pickle (false, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           rewrite -?Heq //=. nra.
      * set (δ := ((f1 a + f2 a) - t) / 2).
        edestruct (archimed_rat_dense2 (δ/2) (f1 a - δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        exists (pickle (false, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           rewrite -?Heq //=. nra.
    - intros (bnm&Hspec). destruct (pickle_inv) as [(b&(n&m))|].
      * destruct b; rewrite /fun_inv//= in Hspec; destruct Hspec as [H1 H2]; nra.
      * destruct Hspec.
  Qed.

  Lemma measurable_scal {A: Type} {F: measurable_space A} (f: A → R) (c: R):
    measurable f →
    measurable (λ x, c * f x).
  Proof.
    intros Hmeas.
    destruct (Rtotal_order 0 c) as [Hgt0|[Heq|Hlt0]].
    - eapply sigma_measurable_mono.
      { rewrite /le_sigma; reflexivity. }
      { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
      eapply sigma_measurable_generating_sets.
      intros ? (x&->).
      rewrite /fun_inv. eapply (sigma_proper _ _ (λ a, x /c < f a)).
      { intros z; split.
        * intros. eapply (Rmult_lt_reg_r (1/c)). move: Hgt0. clear.
          rewrite /Rinv. apply Rlt_mult_inv_pos; nra.
          field_simplify; nra.
        * intros. eapply (Rmult_lt_reg_r c); first nra.
          field_simplify; nra.
      }
      apply Hmeas, open_ray_borel_gt.
    - subst. intros U HU. rewrite /fun_inv.
      destruct (Classical_Prop.classic (U 0)).
      * eapply sigma_proper; last apply sigma_full.
        intros x; rewrite Rmult_0_l; split; auto.
      * eapply sigma_proper; last apply sigma_empty_set.
        intros x; rewrite Rmult_0_l; split; auto.
        inversion 1.
    - eapply sigma_measurable_mono.
      { rewrite /le_sigma; reflexivity. }
      { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
      eapply sigma_measurable_generating_sets.
      intros ? (x&->).
      rewrite /fun_inv. eapply (sigma_proper _ _ (λ a, x /c > f a)).
      { intros z; split.
        * intros Hineq%(Rmult_lt_gt_compat_neg_l c); last nra.
          field_simplify in Hineq; nra.
        * intros Hineq%(Rmult_lt_gt_compat_neg_l (1/c)); last first.
          { rewrite /Rdiv Rmult_1_l. apply Rinv_lt_0_compat. nra. }
          field_simplify in Hineq; nra.
      }
      apply: Hmeas. apply open_ray_borel_lt.
  Qed.

  Lemma measurable_square {A: Type} {F: measurable_space A} (f: A → R) :
    measurable f →
    measurable (λ x, f x * f x).
  Proof.
    intros Hmeas.
    eapply sigma_measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_closed_ray2. }
    eapply sigma_measurable_generating_sets.
    intros ? (t&->).
    rewrite /fun_inv//=.
    destruct (Rlt_dec t 0) as [Hlt|Hnlt].
    - eapply sigma_proper; last eapply sigma_empty_set.
      intros x; split.
      * intros Hle. assert (f x * f x >= 0).
        { apply Rle_ge. apply Rle_0_sqr. }
        nra.
      * inversion 1.
    - apply Rnot_lt_ge, Rge_le in Hnlt.
      assert (eq_prop (λ a, f a * f a <= t) (fun_inv f (λ a, - sqrt t <= a <= sqrt t))) as ->.
      { rewrite /fun_inv//=. intros a; split.
        * intros Hsqr. apply sqrt_le_1_alt in Hsqr.
          rewrite sqrt_Rsqr_abs in Hsqr.
          move: Hsqr. apply Rabs_case; nra.
        * intros Hrange.
          replace (f a * f a) with (Rsqr (f a)) by auto.
          rewrite (Rsqr_abs (f a)).
          apply sqrt_le_0; try nra.
          ** apply Rle_0_sqr.
          ** rewrite sqrt_Rsqr; last by auto.
             move: Hrange. apply Rabs_case; nra.
      }
      apply Hmeas, closed_interval_borel.
  Qed.

  Lemma measurable_opp {A: Type} {F: measurable_space A} (f: A → R) :
    measurable f →
    measurable (λ x, - f x).
  Proof.
    intros. eapply measurable_comp.
    * eauto.
    * apply continuous_borel_measurable. rewrite //=.
      intros x. apply: continuous_opp. apply: continuous_id.
  Qed.

  Lemma measurable_minus {A: Type} {F: measurable_space A} (f1 f2: A → R) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, f1 x - f2 x).
  Proof.
    intros Hmeas1 Hmeas2. rewrite /Rminus.
    apply measurable_plus; auto.
    eapply measurable_comp; eauto.
    apply measurable_opp, measurable_id.
  Qed.

  Lemma measurable_mult {A: Type} {F: measurable_space A} (f1 f2: A → R) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, f1 x * f2 x).
  Proof.
    intros Hmeas1 Hmeas2.
    assert (∀ x, f1 x * f2 x = /2 * ((f1 x + f2 x) * (f1 x + f2 x)) -
                               /2 * (f1 x * f1 x) - /2 * (f2 x * f2 x)) as Heq.
    { intros x. field. }
    setoid_rewrite Heq.
    repeat (apply measurable_plus || apply measurable_minus ||
            apply measurable_scal || apply measurable_opp ||
            apply measurable_square || auto).
  Qed.

  Ltac measurable := repeat (apply measurable_plus || apply measurable_minus ||
                             apply measurable_scal || apply measurable_opp ||
                             apply measurable_square || apply measurable_mult ||
                             apply measurable_const || auto).

  Lemma measurable_Rabs {A: Type} {F: measurable_space A} f1:
    measurable f1 →
    measurable (λ x, Rabs (f1 x)).
  Proof.
    intros Hmeas. eapply measurable_comp; eauto.
    apply continuous_borel_measurable => x.
    apply: continuous_abs.
  Qed.

  Lemma measurable_Rmax {A: Type} {F: measurable_space A} (f1 f2: A → R) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, Rmax (f1 x) (f2 x)).
  Proof.
    intros. assert (Heq: ∀ x, Rmax (f1 x) (f2 x) = /2 * ((f1 x + f2 x) + Rabs (f1 x - f2 x))).
    { intros. apply Rmax_case_strong; apply Rabs_case; nra. }
    setoid_rewrite Heq.
    measurable.
    apply measurable_Rabs.
    apply measurable_minus; auto.
  Qed.

  Lemma measurable_Rmin {A: Type} {F: measurable_space A} (f1 f2: A → R) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, Rmin (f1 x) (f2 x)).
  Proof.
    intros. assert (Heq: ∀ x, Rmin (f1 x) (f2 x) = /2 * ((f1 x + f2 x) - Rabs (f1 x - f2 x))).
    { intros. apply Rmin_case_strong; apply Rabs_case; nra. }
    setoid_rewrite Heq.
    measurable.
    apply measurable_Rabs.
    apply measurable_minus; auto.
  Qed.

  Lemma measurable_real:
    measurable real.
  Proof.
    eapply sigma_measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_closed_ray2. }
    eapply sigma_measurable_generating_sets.
    intros ? (t&->).
    destruct (Rlt_dec t 0).
    - eapply (sigma_proper _ _ ((λ x, Rbar_le x t) ∩ compl ({[m_infty]}))).
      * intros x; split.
        ** intros (Hle&Hm); destruct x => //=.
           exfalso. apply Hm. done.
        ** destruct x; rewrite /fun_inv//=; nra.
      * apply sigma_closed_pair_intersect.
        ** eapply minimal_sigma_ub. exists t => //=.
        ** apply sigma_closed_complements, Rbar_sigma_m_infty.
    - eapply (sigma_proper _ _ ((λ x, Rbar_le x t) ∪ ({[m_infty]} ∪ {[p_infty]}))).
      * intros x; split.
        ** intros [Hle|[Hm|Hp]]; destruct x => //=; rewrite /fun_inv/real; nra.
        ** rewrite /fun_inv/real//=.
           destruct x => //=; try firstorder.
      * apply sigma_closed_pair_union.
        ** eapply minimal_sigma_ub. exists t => //=.
        ** apply sigma_closed_pair_union.
           *** apply Rbar_sigma_m_infty.
           *** apply Rbar_sigma_p_infty.
  Qed.

  Lemma measurable_Finite:
    measurable Finite.
  Proof.
    intros.
    eapply sigma_measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    - assert (eq_prop (fun_inv Finite ((λ x, Rbar_le x r)))
                      (λ x, Rle x r)) as ->.
      { intros x. split => //=. }
      apply closed_ray_borel_le.
    - eapply sigma_proper; last eapply sigma_full.
      split; auto.
    - eapply sigma_proper; last eapply sigma_empty_set.
      split; auto.
  Qed.

  Lemma Rbar_sigma_real_pt r:
    Rbar_sigma {[Finite r]}.
  Proof.
    assert (eq_prop {[Finite r]}
                    (fun_inv real {[r]} ∩ compl {[p_infty]} ∩ compl {[m_infty]})) as ->.
    { split.
      * inversion 1; subst. rewrite /compl/fun_inv//=.
      * rewrite /compl/fun_inv//=. intros ((Heq&?)&?); destruct x; try firstorder.
        ** inversion Heq as [Heq'].
           rewrite //= in Heq'. subst. done.
    }
    apply sigma_closed_pair_intersect; first apply sigma_closed_pair_intersect.
    * apply measurable_real. apply borel_closed. apply closed_eq.
    * apply sigma_closed_complements, Rbar_sigma_p_infty.
    * apply sigma_closed_complements, Rbar_sigma_m_infty.
  Qed.

  Lemma Rbar_sigma_pt r:
    Rbar_sigma {[r]}.
  Proof.
    destruct r; auto using Rbar_sigma_real_pt, Rbar_sigma_p_infty, Rbar_sigma_m_infty.
  Qed.

  Lemma Rbar_sigma_gen_ge_ray:
    le_prop (minimal_sigma (λ U, ∃ x, U = (λ z, Rbar_le x z))) Rbar_sigma.
  Proof.
    apply minimal_sigma_lub.
    intros ? (x&->).
    assert (eq_prop (λ z, Rbar_le x z) (compl (λ z, Rbar_le z x) ∪ {[x]})) as Heq.
    { intros z; split.
      * intros [Hlt|Heq]%Rbar_le_lt_or_eq_dec.
        ** left. by apply Rbar_lt_not_le.
        ** right; subst; done.
      * intros [Hnle|Heq].
        ** apply Rbar_not_le_lt in Hnle. by apply Rbar_lt_le.
        ** inversion Heq; subst; apply Rbar_le_refl.
    }
    rewrite Heq.
    apply sigma_closed_pair_union.
    - apply sigma_closed_complements.
      apply minimal_sigma_ub; eexists. reflexivity.
    - apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_Rbar_opp {A: Type} {F: measurable_space A} (f: A → Rbar) :
    measurable f →
    measurable (λ x, Rbar_opp (f x)).
  Proof.
    intros Hmeas.
    apply sigma_measurable_generating_sets.
    intros ? (t&->).
    assert (fun_inv (λ x, Rbar_opp (f x)) (λ x, Rbar_le x t) ≡
                    fun_inv f (Rbar_le (Rbar_opp t))) as ->.
    { rewrite /fun_inv//= => x. rewrite -{1}(Rbar_opp_involutive t).
      apply Rbar_opp_le. }
    apply Hmeas. apply Rbar_sigma_gen_ge_ray.
    apply minimal_sigma_ub. eauto.
  Qed.

  Lemma Sup_seq_minor_Rbar_le (u : nat → Rbar) (M : Rbar) (n : nat):
    Rbar_le M (u n) → Rbar_le M (Sup_seq u).
  Proof.
    intros Hle.
    rewrite Rbar_sup_eq_lub. rewrite /Lub.Rbar_lub.
    destruct (Lub.Rbar_ex_lub) as (?&r).
    rewrite /=. eapply Rbar_le_trans; eauto. apply r.  eauto.
  Qed.

  Lemma measurable_Sup {A: Type} {F: measurable_space A} (fn : nat → A → Rbar):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Sup_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    eapply sigma_measurable_generating_sets.
    intros ? (t&->).
    assert (eq_prop (λ x, Rbar_le (Sup_seq (λ n, fn n x)) t)
                    (intersectF (λ n, fun_inv (fn n) (λ x, Rbar_le x t)))) as ->.
    { split.
      - intros Hsup n. rewrite /fun_inv.
        eapply Rbar_le_trans; eauto.
        eapply Sup_seq_minor_Rbar_le; eauto.
        apply Rbar_le_refl.
      - intros Hle.
        rewrite Rbar_sup_eq_lub. rewrite /Lub.Rbar_lub.
        destruct (Lub.Rbar_ex_lub) as (?&(Hub&Hlub)).
        apply Hlub => //=.
        intros r (?&->); eapply Hle.
    }
    apply sigma_closed_intersections. intros. apply Hmeas.
    apply minimal_sigma_ub. eauto.
  Qed.

  Lemma measurable_Inf {A: Type} {F: measurable_space A} (fn : nat → A → Rbar):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Inf_seq (λ n, fn n x)).
  Proof.
    intros.
    setoid_rewrite Inf_opp_sup.
    apply measurable_Rbar_opp.
    apply measurable_Sup.
    intros n. apply measurable_Rbar_opp. done.
  Qed.

  Lemma measurable_LimSup {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, LimSup_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    setoid_rewrite LimSup_InfSup_seq.
    apply measurable_Inf => n.
    apply measurable_Sup => m.
    eapply measurable_comp; last apply measurable_Finite.
    eauto.
  Qed.

  Lemma measurable_LimInf {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, LimInf_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    setoid_rewrite LimInf_SupInf_seq.
    apply measurable_Sup => m.
    apply measurable_Inf => n.
    eapply measurable_comp; last apply measurable_Finite.
    eauto.
  Qed.

  Lemma measurable_Sup_seq {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Sup_seq (λ n, fn n x) : R).
  Proof.
    intros Hmeas. eapply measurable_comp. apply measurable_Sup.
    { intros n. eapply measurable_comp; last apply measurable_Finite.
      eauto. }
    apply measurable_real.
  Qed.

  Lemma measurable_Inf_seq {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Inf_seq (λ n, fn n x) : R).
  Proof.
    intros Hmeas. eapply measurable_comp. apply measurable_Inf.
    { intros n. eapply measurable_comp; last apply measurable_Finite.
      eauto. }
    apply measurable_real.
  Qed.

  Lemma measurable_Rbar_div_pos y:
    measurable (λ x, Rbar_div_pos x y).
  Proof.
    apply sigma_measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    - assert (fun_inv (λ x, Rbar_div_pos x y) (λ x, Rbar_le x r) ≡
                      λ x, Rbar_le x (r * y)) as ->.
      { rewrite /fun_inv//=; intros [ r' | |] => //=; apply Rle_div_l; destruct y; done. }
      apply minimal_sigma_ub; eauto.
    - eapply sigma_proper; last apply sigma_full.
      intros [ | |] => //=.
    - eapply sigma_proper; last apply Rbar_sigma_m_infty.
      intros [ | |] => //=.
  Qed.

  Lemma measurable_Rbar_plus {A: Type} {F: measurable_space A} (f1 f2: A → Rbar) :
    measurable f1 →
    measurable f2 →
    measurable (λ x, Rbar_plus (f1 x) (f2 x)).
  Proof.
    intros Hmeas1 Hmeas2.
    apply sigma_measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    -
      destruct (Rle_dec 0 r) as [Hle0|Hnle0].
      {
        assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (λ x, Rbar_le x r) ≡
                        (fun_inv (λ x, Rplus (f1 x) (f2 x)) (λ x, Rle x r)
                                 ∩ compl (fun_inv f1 ({[p_infty]} ∪ {[m_infty]}))
                                 ∩ compl (fun_inv f2 ({[p_infty]} ∪ {[m_infty]}))) ∪
                        fun_inv f1 {[m_infty]} ∪ fun_inv f2 {[m_infty]}) as ->.
        { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); rewrite //=;
                                             try (left; right; firstorder; done);
            try (right; firstorder; done).
            intros Hle. do 2 left. split_and!; auto; intros [Hin|Hin]; inversion Hin.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            intros [[((Hplus&Hnot1)&Hnot2)|Hinf1]|Hinf2].
            * destruct (f1 a), (f2 a) => //=;
                                           try nra;
                                           try (exfalso; apply Hnot1; firstorder; done);
                                           try (exfalso; apply Hnot2; firstorder; done).
            * inversion Hinf1 as [Heq]. rewrite Heq => //=.
              destruct (f2 a) => //=.
            * inversion Hinf2 as [Heq]. rewrite Heq => //=.
              destruct (f1 a) => //=.
        }
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty.
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty.
        repeat apply sigma_closed_pair_intersect.
        * apply measurable_plus; try eapply measurable_comp; eauto using measurable_real.
          apply closed_ray_borel_le.
        * apply sigma_closed_complements; eapply Hmeas1.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty, Rbar_sigma_p_infty.
        * apply sigma_closed_complements; eapply Hmeas2.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty, Rbar_sigma_p_infty.
      }
      {
        assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (λ x, Rbar_le x r) ≡
                        (fun_inv (λ x, Rplus (f1 x) (f2 x)) (λ x, Rle x r)
                                 ∩ compl (fun_inv f1 ({[p_infty]} ∪ {[m_infty]}))
                                 ∩ compl (fun_inv f2 ({[p_infty]} ∪ {[m_infty]}))) ∪
                        (compl (fun_inv f2 {[p_infty]}) ∩ fun_inv f1 {[m_infty]}) ∪
                        (compl (fun_inv f1 {[p_infty]}) ∩ fun_inv f2 {[m_infty]})) as ->.
        { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); rewrite //=;
                                             try (left; right; firstorder; done);
            try (right; firstorder; done).
            intros Hle. do 2 left. split_and!; auto; intros [Hin|Hin]; inversion Hin.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            intros [[((Hplus&Hnot1)&Hnot2)|(Hn1&Hinf1)]|(Hn2&Hinf2)].
            * destruct (f1 a), (f2 a) => //=;
                                           try nra;
                                           try (exfalso; apply Hnot1; firstorder; done);
                                           try (exfalso; apply Hnot2; firstorder; done).
            * inversion Hinf1 as [Heq]. rewrite Heq => //=.
              destruct (f2 a) => //=. firstorder.
            * inversion Hinf2 as [Heq]. rewrite Heq => //=.
              destruct (f1 a) => //=. firstorder.
        }
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty;
        first apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty;
        first repeat apply sigma_closed_pair_intersect.
        * apply measurable_plus; try eapply measurable_comp; eauto using measurable_comp, measurable_real.
          apply closed_ray_borel_le.
        * apply sigma_closed_complements; eapply Hmeas1.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_pt.
        * apply sigma_closed_complements; eapply Hmeas2.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_pt.
        * apply sigma_closed_pair_intersect.
          ** apply sigma_closed_complements.
             apply Hmeas2; eauto using Rbar_sigma_pt.
          ** apply Hmeas1; eauto using Rbar_sigma_pt.
        * apply sigma_closed_pair_intersect.
          ** apply sigma_closed_complements.
             apply Hmeas1; eauto using Rbar_sigma_pt.
          ** apply Hmeas2; eauto using Rbar_sigma_pt.
      }
    - eapply sigma_proper; last eapply sigma_full.
      intros x; split; auto. rewrite /fun_inv//=. by destruct (Rbar_plus).
    - assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (λ x, Rbar_le x m_infty) ≡
                      (fun_inv f1 (compl {[p_infty]}) ∩
                       fun_inv f2 {[m_infty]}) ∪
                      (fun_inv f2 (compl {[p_infty]}) ∩
                       fun_inv f1 {[m_infty]})) as ->.
      { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); firstorder set_unfold; done.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); firstorder set_unfold; done.
      }
      apply sigma_closed_pair_union; apply sigma_closed_pair_intersect.
      * eapply Hmeas1. apply sigma_closed_complements; eauto using Rbar_sigma_pt.
      * eapply Hmeas2. eauto using Rbar_sigma_pt.
      * eapply Hmeas2. apply sigma_closed_complements; eauto using Rbar_sigma_pt.
      * eapply Hmeas1. eauto using Rbar_sigma_pt.
  Qed.

  Lemma measurable_Lim {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Lim_seq (λ n, fn n x)).
  Proof.
    intros Hmeas. rewrite /Lim_seq//=.
    eapply (measurable_comp _ (λ x, Rbar_div_pos x {| pos := 2 ; cond_pos := Rlt_R0_R2|}));
      eauto using measurable_Rbar_div_pos.
    apply measurable_Rbar_plus.
    * apply measurable_LimSup. done.
    * apply measurable_LimInf. done.
  Qed.

  Lemma measurable_Lim' {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, real (Lim_seq (λ n, fn n x))).
  Proof.
    intros. eapply measurable_comp; eauto using measurable_real.
    apply measurable_Lim. done.
  Qed.

  Lemma measurable_sum_n {A: Type} {F: measurable_space A} (fn : nat → A → R) m:
    (∀ n, measurable (fn n)) →
    measurable (λ x : A, sum_n (λ n : nat, fn n x) m).
  Proof.
    intros Hmeas. induction m => //=.
    - setoid_rewrite sum_O. eauto.
    - setoid_rewrite sum_Sn. apply measurable_plus; eauto.
  Qed.

  Lemma measurable_Series {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    measurable (λ x, Series (λ n, fn n x)).
  Proof. intros. apply measurable_Lim'; eauto. intros; eapply measurable_sum_n; eauto. Qed.

  Lemma measurable_fun_eq_0 {A: Type} {F: measurable_space A} f:
    measurable f →
    is_measurable (λ x, f x = 0).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x = 0)).
    apply borel_closed, closed_eq.
  Qed.

  Lemma measurable_fun_eq_0_Rbar {A: Type} {F: measurable_space A} (f: A → Rbar):
    measurable f →
    is_measurable (λ x, f x = 0).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x = 0)).
    apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_fun_ge {A: Type} {F: measurable_space A} f k:
    measurable f →
    is_measurable (λ x, k <= f x).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, k <= x)).
    apply closed_ray_borel_ge.
  Qed.

  Lemma measurable_fun_le_const {A: Type} {F: measurable_space A} f k:
    measurable f →
    is_measurable (λ x, f x <= k).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x <= k)).
    apply closed_ray_borel_le.
  Qed.

  Lemma measurable_fun_lt_p_infty {A: Type} {F: measurable_space A} f:
    measurable f →
    is_measurable (λ x, Rbar_lt (f x) p_infty).
  Proof.
    intros Hmeas.
    rewrite /is_measurable.
    assert ((λ x, Rbar_lt (f x) p_infty)  ≡ compl (fun_inv f {[p_infty]})) as ->.
    { intros x. rewrite /fun_inv/compl//=. split.
      - intros Hlt Heq. inversion Heq as [Heq']. rewrite Heq' in Hlt.
        rewrite //= in Hlt.
      - intros Heq. destruct (f x) => //=. apply Heq. done.
    }
    apply sigma_closed_complements.
    eapply Hmeas.
    apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_fun_eq_inv {A: Type} {F: measurable_space A} (f g: A → R):
    measurable f →
    measurable g →
    is_measurable (λ x, f x = g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, f x - g x = 0)).
    { intros x; split; nra. }
    apply measurable_fun_eq_0. measurable.
  Qed.

  Lemma measurable_fun_le_inv {A: Type} {F: measurable_space A} f g:
    measurable f →
    measurable g →
    is_measurable (λ x, f x <= g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, f x - g x <= 0)).
    { intros x; split; nra. }
    apply measurable_fun_le_const. measurable.
  Qed.

  Lemma measurable_fun_eq_inv_Rbar {A: Type} {F: measurable_space A} (f g: A → Rbar):
    measurable f →
    measurable g →
    is_measurable (λ x, f x = g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, Rbar_minus (f x) (g x) = 0)).
    { intros x; split.
      - destruct (f x), (g x) => //=.
        inversion 1; subst; f_equal; nra.
      - destruct (f x), (g x) => //=.
        intros Heq. inversion Heq; subst. f_equal. nra.
    }
    apply measurable_fun_eq_0_Rbar. rewrite /Rbar_minus.
    apply measurable_Rbar_plus, measurable_Rbar_opp; auto.
  Qed.

  Lemma measure_ex_lim_seq {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    is_measurable (λ x, ex_lim_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    eapply sigma_proper.
    { intros x. apply ex_lim_LimSup_LimInf_seq. }
    apply measurable_fun_eq_inv_Rbar; auto using measurable_LimSup, measurable_LimInf.
  Qed.

  Lemma measure_ex_finite_lim_seq {A: Type} {F: measurable_space A} (fn : nat → A → R):
    (∀ n, measurable (fn n)) →
    is_measurable (λ x, ex_finite_lim_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    eapply (sigma_proper _ _ ((λ x, ex_lim_seq (λ n, fn n x))
                                ∩ (fun_inv (λ x, Lim_seq (λ n, fn n x)) (compl {[p_infty]}))
                                ∩ (fun_inv (λ x, Lim_seq (λ n, fn n x)) (compl {[m_infty]})))).
    { intros x. rewrite /fun_inv. split.
      - intros ((Hex&Hlim1)&Hlim2).
        destruct Hex as (v&His).
        destruct v as [r | |].
        * exists r; eauto.
        * rewrite (is_lim_seq_unique _ _ His) //= in Hlim1. exfalso; apply Hlim1; done.
        * rewrite (is_lim_seq_unique _ _ His) //= in Hlim2. exfalso; apply Hlim2; done.
      - intros (v&His).
        split; first split.
        * eexists; eauto.
        * rewrite //= (is_lim_seq_unique _ _ His) //=.
        * rewrite //= (is_lim_seq_unique _ _ His) //=.
    }
    apply sigma_closed_pair_intersect; first apply sigma_closed_pair_intersect.
    - apply measure_ex_lim_seq; auto.
    - apply measurable_Lim; eauto. apply sigma_closed_complements, Rbar_sigma_pt.
    - apply measurable_Lim; eauto. apply sigma_closed_complements, Rbar_sigma_pt.
  Qed.

  Lemma measure_is_lim_seq {A: Type} {F: measurable_space A} (fn : nat → A → R) (f: A → Rbar):
    (∀ n, measurable (fn n)) →
    measurable f →
    is_measurable (λ x, is_lim_seq (λ n, fn n x) (f x)).
  Proof.
    intros.
    assert (Hequiv: (λ x, is_lim_seq (λ n, fn n x) (f x))
                      ≡ (λ x, ex_lim_seq (λ n, fn n x)) ∩ (λ x, Lim_seq (λ n, fn n x) = f x)).
    {
      intros x. split.
      - intros His; split; first by (eexists; eauto).
        by apply is_lim_seq_unique.
      - intros (Hex&Heq). rewrite -Heq. apply Lim_seq_correct; eauto.
    }
    rewrite /is_measurable.
    rewrite Hequiv. apply sigma_closed_pair_intersect.
    - apply measure_ex_lim_seq; eauto.
    - apply measurable_fun_eq_inv_Rbar; eauto using measurable_Lim.
  Qed.

End borel_R.

Ltac measurable := repeat (apply measurable_plus || apply measurable_minus ||
                           apply measurable_scal || apply measurable_opp ||
                           apply measurable_square || apply measurable_mult ||
                           apply measurable_const || apply measurable_real ||
                           apply measurable_Rabs ||
                           apply measurable_Rmax || apply measurable_Rmin ||
                           apply measure_is_lim_seq || apply measure_ex_lim_seq ||
                           apply measure_ex_finite_lim_seq ||
                           apply measurable_fun_le_inv ||
                           apply measurable_fun_eq_inv ||
                           auto).


Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Psatz. (* lia *)
Require Import Metalib.LibTactics.
Require Import Language Tactical.

(** * Definitions *)

Inductive ordinary : type -> Prop :=
| Ord_Top : ordinary Top
| Ord_Tnt : ordinary Int
| Ord_Arrow : forall A B,
    ordinary B -> ordinary (Arr A B).

Hint Constructors ordinary : core.

Inductive splitable : type -> type -> type -> Prop :=
| Spl_And : forall A B,
    splitable (And A B) A B
| Spl_Arr : forall A B B1 B2,
    splitable B B1 B2 ->
    splitable (Arr A B) (Arr A B1) (Arr A B2).

Hint Constructors splitable : core.

Notation "A1 ↩ A ↪ A2" := (splitable A A1 A2) (at level 40).

(** * Splitable and Ordinary *)

(** splitable is not ordinary *)

Lemma splitable_not_ordinary :
  forall A A1 A2,
    splitable A A1 A2 -> ~ ordinary A.
Proof.
  introv Spl Ord. gen A1 A2.
  dependent induction Ord; intros; try solve [inversion Spl; eauto | eauto].
Qed.

(** * Automations *)

(** add this lemma to hint base to exclude absurd cases *)

Ltac solve_splitable :=
  match goal with
  | [H1: splitable ?A _ _, H2: ordinary ?A |- _] =>
      (pose proof (splitable_not_ordinary _ _ _ H1) as Contra; contradiction)
  | [H1: splitable (Arr _ ?B) _ _, H2: ordinary ?B |- _] =>
      (dependent destruction H1; pose proof (splitable_not_ordinary _ _ _ H1) as Contra; contradiction)
  | [H: splitable Int _ _ |- _] =>
      (inversion H)
  | [H: splitable Top _ _ |- _] =>
      (inversion H)
  end.

Hint Extern 5 => solve_splitable : core.

Ltac solve_ordinary :=
  match goal with
  | [H: ordinary (And _ _) |- _] =>
      (inversion H)
  end.

Hint Extern 5 => solve_ordinary : core.

(** [contra_ordinary] solves contradiction cases of ordinary *)

Ltac contra_ordinary :=
  match goal with
  | [H1: ordinary ?A, H2: not (ordinary ?A) |- _] =>
      (contradiction)
  | [H1: ordinary (Arr _ ?A), H2: not (ordinary ?A) |- _] =>
      (dependent destruction H1; contradiction)
     end.

(** * Splitable or Ordinary *)

(** For any type A, it's [ordinary] or [splitable] **)

Lemma splitable_or_ordinary :
  forall A,
    ordinary A \/ exists A1 A2, splitable A A1 A2.
Proof.
  introv. dependent induction A; eauto.
  destruct IHA1; destruct IHA2; eauto.
  - right. destruct_conjs; eauto.
  - right. destruct_conjs; eauto.
Qed.

(** * Determinism of Splitable *)

Lemma splitable_determinism :
  forall A A1 A2 A3 A4,
    splitable A A1 A2 -> splitable A A3 A4 ->
    A1 = A3 /\ A2 = A4.
Proof.
  introv Spl1 Spl2. gen A3 A4.
  dependent induction Spl1; eauto; intros.
  - dependent destruction Spl2.
    split; eauto.
  - dependent destruction Spl2.
    assert (B1 = B3 /\ B2 = B4); eauto.
    destruct_conjs. split; congruence.
Qed.

(** * Unify Splitable Varialbes *)

(** unify variables into same names *)

Ltac subst_splitable :=
  match goal with
  | [H1: splitable ?A ?A1 ?A2, H2: splitable ?A ?A3 ?A4 |- _] =>
      (pose proof (splitable_determinism _ _ _ _ _ H1 H2) as Eqs; destruct Eqs; subst; clear H1)
  end.

(** * Decidablility of Ordinary *)

Lemma ordinary_decidable :
  forall A,
    ordinary A \/ not (ordinary A).
Proof.
  introv. induction A; eauto.
  destruct IHA1; destruct IHA2; eauto.
  - right. intros Contra. contra_ordinary.
  - right. intros Contra. contra_ordinary.
Qed.

(** * Splitable & Size *)

(** If A can split into A1 and A2, the size of A1 and A2 is smaller than A *)

Lemma splitable_decrease_size:
  forall A A1 A2,
    splitable A A1 A2 -> size_type A1 < size_type A /\ size_type A2 < size_type A.
Proof.
  introv H. dependent induction H; simpl; lia.
Qed.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple.

(******************************************************************************)
(* This file implements a type for functions with a finite domain:            *)
(*    {ffun aT -> rT} where aT should have a finType structure.               *)
(* Any eqType, choiceType, countType and finType structures on rT extend to   *)
(* {ffun aT -> rT} as Leibnitz equality and extensional equalities coincide.  *)
(*     (T ^ n)%type is notation for {ffun 'I_n -> T}, which is isomorphic     *)
(*                     ot n.-tuple T.                                         *)
(*  For f : {ffun aT -> rT}, we define                                        *)
(*              f x == the image of x under f (f coerces to a CiC function)   *)
(*         fgraph f == the graph of f, i.e., the #|aT|.-tuple rT of the       *)
(*                     values of f over enum aT.                              *)
(*       finfun lam == the f such that f =1 lam; this is the RECOMMENDED      *)
(*                     interface to build an element of {ffun aT -> rT}.      *)
(* [ffun x => expr] == finfun (fun x => expr)                                 *)
(*   [ffun => expr] == finfun (fun _ => expr)                                 *)
(*  f \in ffun_on R == the range of f is a subset of R                        *)
(*   f \in family F == f belongs to the family F (f x \in F x for all x)      *)
(*     y.-support f == the y-support of f, i.e., [pred x | f x != y].         *)
(*                     Thus, y.-support f \subset D means f has y-support D.  *)
(*                     We will put Notation support := 0.-support in ssralg.  *)
(* f \in pffun_on y D R == f is a y-partial function from D to R:             *)
(*                     f has y-support D and f x \in R for all x \in D.       *)
(*  f \in pfamily y D F == f belongs to the y-partial family from D to F:     *)
(*                     f has y-support D and f x \in F x for all x \in D.     *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Def.

Variables (aT : finType) (rT : Type).

Inductive finfun_type : predArgType := Finfun of #|aT|.-tuple rT.

Definition finfun_of of phant (aT -> rT) := finfun_type.

Identity Coercion type_of_finfun : finfun_of >-> finfun_type.

Definition fgraph f := let: Finfun t := f in t.

Canonical finfun_subType := Eval hnf in [newType for fgraph].

End Def.

Notation "{ 'ffun' fT }" := (finfun_of (Phant fT))
  (at level 0, format "{ 'ffun'  '[hv' fT ']' }") : type_scope.
Definition finexp_domFinType n := ordinal_finType n.
Notation "T ^ n" := (@finfun_of (finexp_domFinType n) T (Phant _)) : type_scope.

Notation Local fun_of_fin_def :=
  (fun aT rT f x => tnth (@fgraph aT rT f) (enum_rank x)).

Notation Local finfun_def := (fun aT rT f => @Finfun aT rT (codom_tuple f)).

Module Type FunFinfunSig.
Parameter fun_of_fin : forall aT rT, finfun_type aT rT -> aT -> rT.
Parameter finfun : forall (aT : finType) rT, (aT -> rT) -> {ffun aT -> rT}.
Axiom fun_of_finE : fun_of_fin = fun_of_fin_def.
Axiom finfunE : finfun = finfun_def.
End FunFinfunSig.

Module FunFinfun : FunFinfunSig.
Definition fun_of_fin := fun_of_fin_def.
Definition finfun := finfun_def.
Lemma fun_of_finE : fun_of_fin = fun_of_fin_def. Proof. by []. Qed.
Lemma finfunE : finfun = finfun_def. Proof. by []. Qed.
End FunFinfun.

Notation fun_of_fin := FunFinfun.fun_of_fin.
Notation finfun := FunFinfun.finfun.
Coercion fun_of_fin : finfun_type >-> Funclass.
Canonical fun_of_fin_unlock := Unlockable FunFinfun.fun_of_finE.
Canonical finfun_unlock := Unlockable FunFinfun.finfunE.

Notation "[ 'ffun' x : aT => F ]" := (finfun (fun x : aT => F))
  (at level 0, x ident, only parsing) : fun_scope.

Notation "[ 'ffun' : aT => F ]" := (finfun (fun _ : aT => F))
  (at level 0, only parsing) : fun_scope.

Notation "[ 'ffun' x => F ]" := [ffun x : _ => F]
  (at level 0, x ident, format "[ 'ffun'  x  =>  F ]") : fun_scope.

Notation "[ 'ffun' => F ]" := [ffun : _ => F]
  (at level 0, format "[ 'ffun' =>  F ]") : fun_scope.

(* Helper for defining notation for function families. *)
Definition fmem aT rT (pT : predType rT) (f : aT -> pT) := [fun x => mem (f x)].

(* Lemmas on the correspondance between finfun_type and CiC functions. *)
Section PlainTheory.

Variables (aT : finType) (rT : Type).
Notation fT := {ffun aT -> rT}.
Implicit Types (f : fT) (R : pred rT).

Canonical finfun_of_subType := Eval hnf in [subType of fT].

Lemma tnth_fgraph f i : tnth (fgraph f) i = f (enum_val i).
Proof. by rewrite [@fun_of_fin]unlock enum_valK. Qed.

Lemma ffunE (g : aT -> rT) : finfun g =1 g.
Proof.
move=> x; rewrite [@finfun]unlock unlock tnth_map.
by rewrite -[tnth _ _]enum_val_nth enum_rankK.
Qed.

Lemma fgraph_codom f : fgraph f = codom_tuple f.
Proof.
apply: eq_from_tnth => i; rewrite [@fun_of_fin]unlock tnth_map.
by congr tnth; rewrite -[tnth _ _]enum_val_nth enum_valK.
Qed.

Lemma codom_ffun f : codom f = val f.
Proof. by rewrite /= fgraph_codom. Qed.

Lemma ffunP f1 f2 : f1 =1 f2 <-> f1 = f2.
Proof.
split=> [eq_f12 | -> //]; do 2!apply: val_inj => /=.
by rewrite !fgraph_codom /= (eq_codom eq_f12).
Qed.

Lemma ffunK : cancel (@fun_of_fin aT rT) (@finfun aT rT).
Proof. move=> f; apply/ffunP; exact: ffunE. Qed.

Definition family_mem mF := [pred f : fT | [forall x, in_mem (f x) (mF x)]].

Lemma familyP (pT : predType rT) (F : aT -> pT) f :
  reflect (forall x, f x \in F x) (f \in family_mem (fmem F)).
Proof. exact: forallP. Qed.

Definition ffun_on_mem mR := family_mem (fun _ => mR).

Lemma ffun_onP R f : reflect (forall x, f x \in R) (f \in ffun_on_mem (mem R)).
Proof. exact: forallP. Qed.

End PlainTheory.

Notation family F := (family_mem (fun_of_simpl (fmem F))).
Notation ffun_on R := (ffun_on_mem _ (mem R)).

Implicit Arguments familyP [aT rT pT F f].
Implicit Arguments ffun_onP [aT rT R f].

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

Lemma nth_fgraph_ord T n (x0 : T) (i : 'I_n) f : nth x0 (fgraph f) i = f i.
Proof.
by rewrite -{2}(enum_rankK i) -tnth_fgraph (tnth_nth x0) enum_rank_ord.
Qed.

Section Support.

Variables (aT : Type) (rT : eqType).

Definition support_for y (f : aT -> rT) := [pred x | f x != y].

Lemma supportE x y f : (x \in support_for y f) = (f x != y). Proof. by []. Qed.

End Support.

Notation "y .-support" := (support_for y)
  (at level 2, format "y .-support") : fun_scope.

Section EqTheory.

Variables (aT : finType) (rT : eqType).
Notation fT := {ffun aT -> rT}.
Implicit Types (y : rT) (D : pred aT) (R : pred rT) (f : fT).

Lemma supportP y D g :
  reflect (forall x, x \notin D -> g x = y) (y.-support g \subset D).
Proof.
by apply: (iffP subsetP) => Dg x; [apply: contraNeq | apply: contraR] => /Dg->.
Qed.

Definition finfun_eqMixin :=
  Eval hnf in [eqMixin of finfun_type aT rT by <:].
Canonical finfun_eqType := Eval hnf in EqType _ finfun_eqMixin.
Canonical finfun_of_eqType := Eval hnf in [eqType of fT].

Definition pfamily_mem y mD (mF : aT -> mem_pred rT) :=
  family (fun i : aT => if in_mem i mD then pred_of_simpl (mF i) else pred1 y).

Lemma pfamilyP (pT : predType rT) y D (F : aT -> pT) f :
  reflect (y.-support f \subset D /\ {in D, forall x, f x \in F x})
          (f \in pfamily_mem y (mem D) (fmem F)).
Proof.
apply: (iffP familyP) => [/= f_pfam | [/supportP f_supp f_fam] x].
  split=> [|x Ax]; last by have:= f_pfam x; rewrite Ax.
  by apply/subsetP=> x; case: ifP (f_pfam x) => //= _ fx0 /negP[].
by case: ifPn => Ax /=; rewrite inE /= (f_fam, f_supp).
Qed.

Definition pffun_on_mem y mD mR := pfamily_mem y mD (fun _ => mR).

Lemma pffun_onP y D R f :
  reflect (y.-support f \subset D /\ {subset image f D <= R})
          (f \in pffun_on_mem y (mem D) (mem R)).
Proof.
apply: (iffP (pfamilyP y D (fun _ => R) f)) => [] [-> f_fam]; split=> //.
  by move=>  _ /imageP[x Ax ->]; exact: f_fam.
by move=> x Ax; apply: f_fam; apply/imageP; exists x.
Qed.

End EqTheory.
Canonical exp_eqType (T : eqType) n := [eqType of T ^ n].

Implicit Arguments supportP [aT rT y D g].
Notation pfamily y D F := (pfamily_mem y (mem D) (fun_of_simpl (fmem F))).
Notation pffun_on y D R := (pffun_on_mem y (mem D) (mem R)).

Definition finfun_choiceMixin aT (rT : choiceType) :=
  [choiceMixin of finfun_type aT rT by <:].
Canonical finfun_choiceType aT rT :=
  Eval hnf in ChoiceType _ (finfun_choiceMixin aT rT).
Canonical finfun_of_choiceType (aT : finType) (rT : choiceType) :=
  Eval hnf in [choiceType of {ffun aT -> rT}].
Canonical exp_choiceType (T : choiceType) n := [choiceType of T ^ n].

Definition finfun_countMixin aT (rT : countType) :=
  [countMixin of finfun_type aT rT by <:].
Canonical finfun_countType aT (rT : countType) :=
  Eval hnf in CountType _ (finfun_countMixin aT rT).
Canonical finfun_of_countType (aT : finType) (rT : countType) :=
  Eval hnf in [countType of {ffun aT -> rT}].
Canonical finfun_subCountType aT (rT : countType) :=
  Eval hnf in [subCountType of finfun_type aT rT].
Canonical finfun_of_subCountType (aT : finType) (rT : countType) :=
  Eval hnf in [subCountType of {ffun aT -> rT}].

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

Section FinTheory.

Variables aT rT : finType.
Notation fT := {ffun aT -> rT}.
Notation ffT := (finfun_type aT rT).
Implicit Types (D : pred aT) (R : pred rT) (F : aT -> pred rT).

Definition finfun_finMixin := [finMixin of ffT by <:].
Canonical finfun_finType := Eval hnf in FinType ffT finfun_finMixin.
Canonical finfun_subFinType := Eval hnf in [subFinType of ffT].
Canonical finfun_of_finType := Eval hnf in [finType of fT for finfun_finType].
Canonical finfun_of_subFinType := Eval hnf in [subFinType of fT].

Lemma card_pfamily y0 D F :
  #|pfamily y0 D F| = foldr (fun x m => #|F x| * m) 1 (enum D).
Proof.
have:= enum_uniq D; have:= mem_enum D.
elim: {D}(enum _) {2 4}D => [|x0 s IHs] D eqDs => [_|] /=.
  rewrite -(card1 [ffun=> y0]); apply: eq_card => f.
  apply/familyP/eqP=> [f_y0 | ->{f} x]; last by rewrite ffunE -eqDs !inE.
  by apply/ffunP=> x; have:= f_y0 x; rewrite -eqDs ffunE => /eqP.
case/andP=> /negPf nsx0 /(IHs (mem s)) <- {IHs}//.
pose g1 (f : fT) := (f x0, [ffun x => if x == x0 then y0 else f x]).
pose g2 (xf : rT * fT) := [ffun x => if x == x0 then xf.1 else xf.2 x].
have g1K: cancel g1 g2.
  by move=> f; apply/ffunP=> x; rewrite !ffunE; case: eqP => // ->.
rewrite -cardX -(card_image (can_inj g1K)); apply: eq_card => [] [y f] /=.
apply/imageP/andP=> /= [[f' /familyP F_f'] [-> ->]| [Fy /familyP Ff]].
  split; first by have:= F_f' x0; rewrite -eqDs mem_head.
  apply/familyP=> x; have:= F_f' x; rewrite ffunE -eqDs inE /=.
  by case: eqP => //= -> _; rewrite nsx0 !inE.
exists (g2 (y, f)); last first.
  congr (_, _); first by rewrite ffunE eqxx.
  apply/ffunP=> x; rewrite !ffunE /=; case: (x =P x0) => // ->{x}.
  by have:= Ff x0; rewrite /= nsx0 => /eqP.
by apply/familyP=> x; have:= Ff x; rewrite -eqDs ffunE !inE; case: eqP => // ->.
Qed.

Lemma card_family F : #|family F| = foldr (fun x m => #|F x| * m) 1 (enum aT).
Proof.
case: (pickP rT) => [y0 _ | rT0].
  by rewrite -(card_pfamily y0); apply: eq_card.
case: (enum _) (mem_enum aT) => [aT0 | x0 e _]; last first.
  by rewrite /= !eq_card0 // => [f | y]; [have := rT0 (f x0) | have := rT0 y].
have no_aT P (x : aT) : P by have:= aT0 x.
rewrite /= -(card1 [ffun x => no_aT rT x]); apply: eq_card => f'.
by apply/familyP/eqP=> _; [apply/ffunP | ] => x; exact: no_aT.
Qed.

Lemma card_pffun_on y0 D R : #|pffun_on y0 D R| = #|R| ^ #|D|.
Proof.
by rewrite (cardE D) card_pfamily; elim: (enum _) => //= _ ? ->; rewrite expnS.
Qed.

Lemma card_ffun_on R : #|ffun_on R| = #|R| ^ #|aT|.
Proof.
by rewrite card_family cardT; elim: (enum _) => //= _ e ->; rewrite expnS.
Qed.

Lemma card_ffun : #|fT| = #|rT| ^ #|aT|.
Proof.
by rewrite -card_ffun_on; apply: eq_card => f; symmetry; exact/forallP.
Qed.

End FinTheory.
Canonical exp_finType (T : finType) n := [finType of T ^ n].


(* TLC in Coq
 *
 * Module: tlc.logic.predicate
 * Purpose: Contains derived rules and lemmas regarding predicates.
 *)

Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import tlc.logic.context.
Require Import tlc.logic.derives.
Require Import tlc.logic.sequent.
Require Import tlc.semantics.all_semantics.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.result.
Require Import tlc.utility.seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Basic predicate lifting *)

(* Directly prove that x1 and x2 are equal *)
Lemma DPEqual C Delta x1 x2 :
  x1 = x2 ->
  Context Delta [::] ||- C, {-A x1 = x2 -}.
Proof.
Admitted.

(* Directly prove that x1 is less than x2 *)
Lemma DPLess C Delta x1 x1' x2 x2' :
  nat_of_term x1 = Some x1' ->
  nat_of_term x2 = Some x2' ->
  x1' < x2' ->
  Context Delta [::] ||- C, {-A x1 < x2 -}.
Proof.
Admitted.

(* Directly prove that y is a member of list xs *)
Lemma DPMember C Delta y xs xs' :
  list_of_term xs = Some xs' ->
  y \in xs' ->
  Context Delta [::] ||- C, {-A y \in xs -}.
Proof.
Admitted.

(* Directly prove that xs' is an extension of xs *)
Lemma DPExtension C Delta xs' xs'l xs xsl :
  list_of_term xs' = Some xs'l ->
  list_of_term xs = Some xsl ->
  extension xs'l xsl ->
  Context Delta [::] ||- C, {-A xs' <<< xs -}.
Proof.
Admitted.

(* Equality *)

(* FEqual reflects PEqual *)
Lemma DPEqualReflect C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x1, x2 *)
    ($$1 == $$0) = true <->
    $$1 = $$0
  -}.
Proof.
Admitted.

(* Directly prove that x1 and x2 are not equal *)
Lemma DPNotEqual C Delta x1 x2 :
  x1 <> x2 ->
  Context Delta [::] ||- C, {-A x1 <> x2 -}.
Proof.
Admitted.

(* Equality is symmetric *)
Lemma DPEqualSymm C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x1, x2 *)
    $$1 = $$0 <-> $$0 = $$1
  -}.
Proof.
  (* Used in PLC *)
Admitted.

Lemma DPEqual3 C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: forall: (* x, y1, y2 *)
    $$2 = $$1 /\ $$2 = $$0 <->
    $$1 = $$0
  -}.
Proof.
Admitted.

(* Less than *)

(* Equality is a subset of less-than or equal *)
Lemma DPEqualLessEqual C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x1, x2 *)
    $$1 = $$0 -> $$1 <= $$0
  -}.
Proof.
  (* Used in PLC *)
Admitted.

(* Equality is a subset of greater-than or equal *)
Lemma DPEqualGreaterEqual C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x1, x2 *)
    $$1 = $$0 -> $$1 >= $$0
  -}.
Proof.
  (* Used in PLC *)
Admitted.

Lemma DPSuccGreaterEqual C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x, y *)
    $$1 >= $$0 -> $$1.+1 >= $$0
  -}.
Proof.
Admitted.

Lemma DPGreaterEqual C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x, y *)
    $$1 >= $$0 <-> $$1 = $$0 \/ $$1 > $$0
  -}.
Proof.
Admitted.

Lemma DPLessThanSucc C Delta :
  Context Delta [::] ||- C, {-A
    forall: (* x *)
    $$0 < $$0.+1
  -}.
Proof.
Admitted.

Lemma DPNotLessThanIfGreaterThan C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x, y *)
    $$1 < $$0 ->
    ~($$1 > $$0)
  -}.
Proof.
Admitted.

(* Membership *)

(* FMember reflects PMember *)
Lemma DPMemberReflect C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* x, xs *)
    $$1 \in $$0 = true <->
    $$1 \in $$0
  -}.
Proof.
  (* Used in PLC *)
Admitted.

(* A member of a list appears at least once in that list *)
Lemma DPMemberCount C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* y, xs *)
    $$1 \in $$0 <->
    FCount ' $$1 ' $$0 >= 1
  -}.
Proof.
  (* Used in PLC *)
Admitted.

(* No element may appear in an empty list *)
Lemma DPMemberNil C Delta :
  Context Delta [::] ||- C, {-A
    forall: (* x *)
    ~ $$0 \in []
  -}.
Proof.
  (* Used in SLC & PLC *)
Admitted.
Ltac dpmembernil :=
  rewrite /ANotIn; match goal with
  | |- context[ {-A ?x_ \in [] -} ] =>
    duse DPMemberNil; dforallp x_
  end.
Ltac dpmembernilp :=
  match goal with
  | |- Context _ ({-A ?x \in [] -} :: _) ||- _, _ =>
    duse DPMemberNil; dforallp x; dnotp
  end.

(* Inductive definition of Member *)
Lemma DPMemberCons C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: forall: (* y, x, xs *)
    $$2 \in $$1 :: $$0 <->
    ($$2 = $$1 \/ $$2 \in $$0)
  -}.
Proof.
  (* Used in SLC *)
Admitted.

(* An element is always a member of a list containing only itself *)
Lemma DPMemberSingleton C Delta :
  Context Delta [::] ||- C, {-A
    forall: (* x *)
    $$0 \in [$$0]
  -}.
Proof.
  (* Used in SLC *)
Admitted.
Ltac dpmembersingletonp :=
  match goal with
  | |- Context _ ({-A ?x \in [?y] -} :: _) ||- _, _ =>
    duse DPMemberCons;
    dforallp x; dforallp y; dforallp {-t [] -};
    dsplitp; dswap; dclear; difp; first (by []);
    dorp; last (by dpmembernilp); dswap; dclear
  end.

(* Membership is closed under mapping *)
Lemma DPMemberMap C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: forall: (* f, xs, y *)
    $$0 \in $$1 <->
    ($$2 ' $$0) \in (FMap ' $$2 ' $$1)
  -}.
  Proof.
  (* Used in SLC *)
Admitted.

(* Membership is closed under concatenation *)
Lemma DPMemberConcat C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: forall: (* xs1, xs2, y *)
    $$0 \in $$2 \/ $$0 \in $$1 ->
    $$0 \in $$2 ++ $$1
  -}.
Proof.
  (* Used in SLC *)
Admitted.

(* An element is a member of a list iff a surrounding prefix/suffix pair exists *)
Lemma DPConcatMember C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: (* y, xs *)
    $$1 \in $$0 <->
    exists: exists: (* xs1, xs2 *)
    $$2 = $$1 ++ [$$3] ++ $$0
  -}.
Proof.
  (* Used in SLC & PLC *)
Admitted.

(* Membership is closed under set union *)
Lemma DPMemberSetUnion C Delta :
  Context Delta [::] ||- C, {-A
    forall: forall: forall: (* xs1, xs2, y *)
    $$0 \in $$2 \/ $$0 \in $$1 <->
    $$0 \in $$2 :|: $$1
  -}.
Proof.
  (* Used in SLC *)
Admitted.
Ltac dpmembersetunion :=
  match goal with
  | |- _ ||- _, {-A ?x \in ?y :|: ?z -} =>
    duse DPMemberSetUnion;
    dforallp y; dforallp z; dforallp x; dclean;
    dsplitp; dswap; dclear; difp; last by []
  end.

Lemma DPCountSingleton C Delta :
  Context Delta [::] ||- C, {-A
    forall: (* x *)
    FCount ' $$0 ' [$$0] = 1
  -}.
Proof.
Admitted.


Require Export D.

(** **** Exercise: 3 stars, optional (CSeq_congruence)  *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  unfold cequiv. intros. split; intros; inversion H1; subst; try apply E_Seq with st'0; try apply H; try assumption; try apply H0; assumption.
Qed.


(** * How to Add Laziness to a Strict Languages Without Even Being Odd *)

(** ** 1 Introduction *)

(** ** 2 Odd and even, with ease and difficulty *)

From CoqMTL Require Import Control.Monad.Lazy.

(** *** 2.1 The odd style, with ease *)

(** This kind of streams is called odd because it contains odd number of
    constructors, where as constructors we count [Nil], [Cons] and delay. *)

Inductive OStream (A : Type) : Type :=
    | ONil : OStream A
    | OCons : A -> Lazy (OStream A) -> OStream A.

Arguments ONil {A}.
Arguments OCons {A} _ _.

Fixpoint omap {A B : Type} (f : A -> B) (os : OStream A) : OStream B :=
match os with
    | ONil => ONil
    | OCons h t => OCons (f h) (delay (omap f (force t)))
end.

Fixpoint ocountdown (n : nat) : OStream nat :=
match n with
    | 0 => OCons 0 (delay ONil)
    | S n' => OCons n (delay (ocountdown n'))
end.

Fixpoint ocutoff (n : nat) {A : Type} (os : OStream A) : OStream A :=
match n, os with
    | 0, _ => ONil
    | _, ONil => ONil
    | S n', OCons h t => OCons h (delay (ocutoff n' (force t)))
end.

(** *** 2.2 The even style, with difficulty *)

(*Inductive EStreamCell (A : Type) : Type :=
    | ENil : EStreamCell A
    | ECons : A -> EStream A -> EStreamCell A

with EStream (A : Type) : Type :=
    | mkEStream : Lazy (EStreamCell A) -> EStream A.

Arguments ENil {A}.
Arguments ECons {A} _ _.

Fixpoint emap {A B : Type} (f : A -> B) (es : EStream A) : EStream A :=
  delay (emap' f (force es))

with emap' {A B : Type} (f : A -> B) (esc : EStreamCell A) : EStreamCell A :=
match esc with
    | ENil => ENil
    | ECons h t => ECons (f h) (emap f t)
end.*)

(** This kind of streams is called "even" because all streams are made from
    an even number of constructors, where as constructors we count [ONil],
    [OCons] and [delay]. *)
Definition EStream (A : Type) : Type :=
  Lazy (OStream A).

Definition emap {A B : Type} (f : A -> B) (es : EStream A) : EStream B :=
  delay (omap f (force es)).

Definition ecountdown (n : nat) : EStream nat :=
  delay (ocountdown n).

Definition ecutoff (n : nat) {A : Type} (es : EStream A) : EStream A :=
  delay (ocutoff n (force es)).


Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.

Import ListNotations.

Require Import Maps.
Require Import Imp.

Definition isWhite (c:ascii) : bool :=
  let n := nat_of_ascii c in
  orb (orb (beq_nat n 32)
           (beq_nat n 9))
      (orb (beq_nat n 10)
           (beq_nat n 13)).

Notation "x '<=?' y" := (leb x y)
                          (at level 70, no associativity) : nat_scope.

Definition isLowAlpha (c:ascii) : bool :=
  let n := nat_of_ascii c in
  andb (97 <=? n) (n <=? 122).

Definition isAlpha (c:ascii) : bool :=
  let n:= nat_of_ascii c in
  orb (andb (65 <=? n) (n <=? 90))
      (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c:ascii) : bool :=
  let n:= nat_of_ascii c in
  andb (48 <=? n) (n <=? 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c: ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
         alpha
       else if isDigit c then
              digit
            else
              other.

Fixpoint list_of_string (s:string) : list ascii :=
  match s with
    | EmptyString => []
    | String c s => c :: (list_of_string s)
  end.

Fixpoint string_of_list (xs:list ascii) : string :=
  fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls:chartype) (acc xs : list ascii)
: list (list ascii) :=
  let tk:= match acc with [] => [] | _ :: _ => [rev acc] end in
  match xs with
    | [] => tk
    | (x :: xs') =>
      match cls, classifyChar x, x with
        | _, _, "(" =>
          tk ++ ["("] :: (tokenize_helper other [] xs')
        | _, _, ")" =>
          tk ++ [")"] :: (tokenize_helper other [] xs')
        | _, white, _ =>
          tk ++ (tokenize_helper white [] xs')
        | alpha, alpha, x =>
          tokenize_helper alpha (x :: acc) xs'
        | digit, digit,


Require Import NaturalDeduction.
Require Import SequentCalculus.
Require Import List.
Require Import Subcontext.

Lemma ND_SC_equiv {atom:Type} :
  forall (Γ : list (prop atom)) (P : prop atom),
  Γ ⊢ P <-> Γ ⇒ P.
Proof.
split; intros.
+ induction H.
  - apply SC_admits_cut with (1 := IHND_proves).
    apply SC_bot_elim. left; reflexivity.
  - apply SC_top_intro.
  - apply SC_or_introl; trivial.
  - apply SC_or_intror; trivial.
  - apply SC_admits_cut with (1 := IHND_proves1).
    apply @SC_or_elim with (P := P) (Q := Q).
    * left; reflexivity.
    * refine (SC_context_extension _ _ _ _ _ eq_refl IHND_proves2).
      prove_subcontext.
    * refine (SC_context_extension _ _ _ _ _ eq_refl IHND_proves3).
      prove_subcontext.
  - apply SC_and_intro; assumption.
  - apply SC_admits_cut with (1 := IHND_proves1).
    apply @SC_and_elim with (P := P) (Q := Q).
    * left; reflexivity.
    * refine (SC_context_extension _ _ _ _ _ eq_refl IHND_proves2).
      prove_subcontext.
  - apply SC_impl_intro. assumption.
  - apply SC_admits_cut with (1 := IHND_proves1).
    apply @SC_impl_elim with (P := P) (Q := Q).
    * left; reflexivity.
    * refine (SC_context_extension _ _ _ _ _ eq_refl IHND_proves2).
      apply subcontext_cons_r.
    * apply SC_init. left; reflexivity.
  - apply SC_init; assumption.
  - eapply SC_admits_cut; eassumption.
+ induction H.
  - apply ND_assumption; trivial.
  - apply ND_exfalso_quodlibet. apply ND_assumption; trivial.
  - apply ND_True_intro.
  - apply ND_and_intro; trivial.
  - apply @ND_and_elim with (P := P) (Q := Q).
    * apply ND_assumption; trivial.
    * assumption.
  - apply ND_or_introl; trivial.
  - apply ND_or_intror; trivial.
  - apply @ND_proof_by_cases with (P := P) (Q := Q).
    * apply ND_assumption; trivial.
    * assumption.
    * assumption.
  - apply ND_cond_proof. assumption.
  - apply @ND_cut with (P := Q).
    * apply @ND_modus_ponens with (P := P).
      { apply ND_assumption; trivial. }
      { assumption. }
    * assumption.
Qed.

Corollary ND_consistent {atom : Type} : ~ (nil ⊢ @bot_prop atom).
Proof.
rewrite ND_SC_equiv. apply SC_consistent.
Qed.


Require Import MLTT2F.Overture MLTT2F.Path_eq.

Generalizable All Variables.

Module Export CylinderHIT.
  Private Inductive Cyl {X Y} (f: X -> Y) : Y -> Type :=
    | top : forall x, Cyl f (f x)
    | base : forall y, Cyl f y.

  Axiom cyl_eq : forall {X Y} {f: X -> Y}, (base f) o f == top f.

  Global Arguments top {X Y f} x.
  Global Arguments base {X Y f} y.

  Axiom FibrantF_Cyl : forall {Δ} {X Y : Δ -> Type}
                        {FibX: FibrantF X} {FibY: FibrantF Y}
                        {f: forall x, X x -> Y x},
      FibrantF2 (fun δ (y : Y δ) => Cyl (f δ) y).

  Instance Fibrant_Cyl {X Y} {FibX: Fibrant X} {FibY: Fibrant Y}
           {f: X -> Y} : FibrantF (Cyl f)
    := @FibrantF_compose _ _ (@FibrantF_Cyl unit _ _ _ _ (fun _ => f)) _ (fun y => (tt; y)).

  Definition Cyl_ind {X Y} {FibX: Fibrant X} {FibY: Fibrant Y} {f: X -> Y}
             (P: forall y, Cyl f y -> Type) {FibP: FibrantF2 P}
             (top': forall x, P (f x) (top x))
             (base': forall y, P y (base y))
             (cyl_eq' : forall x, (cyl_eq x) # (base' (f x)) = top' x)
  : forall y (w: Cyl f y), P y w
    := fun y w => match w with
                  | top x => top' x
                  | base x => base' x
                end.
End CylinderHIT.

Section Cylinder.
  Context {X Y} {FibX: Fibrant X} {FibY: Fibrant Y} {f: X -> Y}.

  Definition Cyl_Contr (y: Y) : Contr (Cyl f y).
  Proof.
    exists (base y).
    revert y. ref (Cyl_ind (fun y x => base y = x) _ _ _).
    - exact cyl_eq.
    - intro. exact 1.
    - intros x; cbn.
      ref (transport_paths_r (x:= base (f x)) _ (cyl_eq x) 1 @ _).
      exact (concat_1p _).
  Defined.

  (* ∃ y, Cyl f y  is the homotopy pushout of f and idmap *)
  Definition sig_cyl_ind (P: sigT (Cyl f) -> Type) {FibP: FibrantF P}
             (top': forall x, P (f x; top x))
             (base': forall y, P (y; base y))
             (cyl_eq': forall x,
                 transport (λ w, P (f x; w)) (cyl_eq x) (base' (f x)) = top' x)
    : forall w, P w.
  Proof.
    intros [y w].
    exact (Cyl_ind (λ y w, P (y; w)) top' base' cyl_eq' y w).
  Defined.

  Definition sig_cyl_rec P {FibP: Fibrant P}
             (top': X -> P) (base': Y -> P)
             (cyl_eq': forall x, base' (f x) = top' x)
    : (sigT (Cyl f)) -> P.
  Proof.
    intros [y w].
    ref (Cyl_ind (λ y w, P) top' base' _ y w); cbn.
    intro x. exact (transport_const _ _ @ cyl_eq' _).
  Defined.
End Cylinder.