From Coq Require Import Reals Lra ClassicalChoice.
From Coq Require Export Qreals.
Require Import RationalsInReals.
Local Close Scope Q_scope.
Local Close Scope R_scope.

Set Asymmetric Patterns.

(* define nonnegative dyadic rationals *)
Inductive dyadic_rational : Type :=
  | m_over_2_to_n: forall m n:nat, dyadic_rational.
Inductive dr_eq : dyadic_rational -> dyadic_rational -> Prop :=
  | dr_eq_refl: forall x:dyadic_rational, dr_eq x x
  | dr_eq_sym: forall x y:dyadic_rational, dr_eq x y -> dr_eq y x
  | dr_eq_trans: forall x y z:dyadic_rational,
    dr_eq x y -> dr_eq y z -> dr_eq x z
  | dr_eq_scale: forall (m n:nat),
    dr_eq (m_over_2_to_n m n)
          (m_over_2_to_n (2*m) (S n)).
Inductive dr_lt : dyadic_rational -> dyadic_rational -> Prop :=
  | intro_dr_lt: forall m m' n:nat, m < m' ->
    dr_lt (m_over_2_to_n m n) (m_over_2_to_n m' n)
  | dr_lt_wd: forall x x' y y':dyadic_rational,
    dr_lt x y -> dr_eq x x' -> dr_eq y y' -> dr_lt x' y'.

Lemma dr_incr_denom: forall (m n n':nat), n<=n' ->
  exists m':nat, dr_eq (m_over_2_to_n m' n')
                       (m_over_2_to_n m n).
Proof.
induction 1.
- exists m.
  apply dr_eq_refl.
- destruct IHle as [m'].
  exists (2*m').
  apply dr_eq_trans with (m_over_2_to_n m' m0); trivial.
  apply dr_eq_sym.
  apply dr_eq_scale.
Qed.

Lemma dr_total_order: forall x y:dyadic_rational,
  dr_lt x y \/ dr_eq x y \/ dr_lt y x.
Proof.
intros.
destruct x as [m n].
destruct y as [m' n'].
destruct (le_or_lt n n').
- destruct (dr_incr_denom m n n') as [m0]; trivial.
  destruct (le_or_lt m0 m').
  + destruct (le_lt_or_eq _ _ H1).
    * left.
      apply dr_lt_wd with
          (m_over_2_to_n m0 n') (m_over_2_to_n m' n'); trivial.
      -- apply intro_dr_lt; trivial.
      -- apply dr_eq_refl.
    * right; left.
      apply dr_eq_trans with (m_over_2_to_n m0 n').
      -- apply dr_eq_sym; trivial.
      -- rewrite H2; apply dr_eq_refl.
  + right; right.
    apply dr_lt_wd with
        (m_over_2_to_n m' n') (m_over_2_to_n m0 n'); trivial.
    * apply intro_dr_lt; trivial.
    * apply dr_eq_refl.
- assert (n' <= n) by auto with arith.
  destruct (dr_incr_denom m' n' n) as [m0]; trivial.
  destruct (le_or_lt m m0).
  + destruct (le_lt_or_eq _ _ H2).
    * left.
      apply dr_lt_wd with
          (m_over_2_to_n m n) (m_over_2_to_n m0 n).
      -- apply intro_dr_lt; trivial.
      -- apply dr_eq_refl.
      -- trivial.
    * right; left.
      apply dr_eq_trans with (m_over_2_to_n m0 n); trivial.
      rewrite H3; apply dr_eq_refl.
  + right; right.
    apply dr_lt_wd with
        (m_over_2_to_n m0 n) (m_over_2_to_n m n); trivial.
    * apply intro_dr_lt; trivial.
    * apply dr_eq_refl.
Qed.

Local Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.

Fixpoint pos_power2 (n:nat) : positive := match n with
  | O => 1%positive
  | S m => ((pos_power2 m)~0)%positive
end.

Definition dr2Q (x:dyadic_rational) : Q :=
  match x with
  | m_over_2_to_n m n => (Z_of_nat m) # (pos_power2 n)
  end.

Local Open Scope Q_scope.

Lemma dr2Q_wd: forall x y:dyadic_rational,
  dr_eq x y -> dr2Q x == dr2Q y.
Proof.
intros.
induction H;
  auto with qarith.
{ now transitivity (dr2Q y). }
unfold Qeq.
simpl.
change ((' (pos_power2 n)~0)%Z) with
    ((2 * ' pos_power2 n)%Z).
repeat rewrite inj_plus.
ring.
Qed.

Lemma dr2Q_incr: forall x y:dyadic_rational,
  dr_lt x y -> dr2Q x < dr2Q y.
Proof.
  induction 1.
  - unfold dr2Q, Qlt.
    cbn.
    apply Zmult_lt_compat_r.
    + easy.
    + now apply Znat.inj_lt.
  - now rewrite <- (dr2Q_wd _ _ H0),
                <- (dr2Q_wd _ _ H1).
Qed.

Lemma Qlt_dr_lt: forall x y:dyadic_rational,
  (dr2Q x < dr2Q y)%Q -> dr_lt x y.
Proof.
intros.
destruct (dr_total_order x y) as [|[|]];
  [ trivial | apply dr2Q_wd in H0 | apply dr2Q_incr in H0 ];
  contradict H0;
  auto with qarith.
Qed.

Open Scope R_scope.

Lemma dyadic_rationals_dense_in_reals: forall x y:R,
  0 <= x < y -> exists q:dyadic_rational,
  x < Q2R (dr2Q q) < y.
Proof.
intros.
assert (forall m:Z, exists n:nat, ((m < ' pos_power2 n)%Z)).
{ intros.
  case m; intros;
    try now exists O.
  induction p.
  - destruct IHp as [n].
    exists (S n).
    unfold Z.lt.
    simpl.
    rewrite Pos.compare_xI_xO.
    unfold Z.lt in H0.
    simpl in H0.
    now rewrite H0.
  - destruct IHp as [n].
    now exists (S n).
  - now exists 1%nat. }
destruct (H0 (up (1/(y-x)))) as [n].
destruct (rational_interpolation x y (pos_power2 n)) as [m].
- apply H.
- eapply Rlt_trans.
  + apply archimed.
  + now apply IZR_lt.
- destruct m as [|m|].
  + unfold Q2R in H2.
    simpl in H2.
    replace (0 * _) with 0 in H2 by ring.
    destruct H, H2.
    contradict H.
    auto with real.
  + exists (m_over_2_to_n (nat_of_P m) n).
    unfold dr2Q.
    now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
  + assert (x < 0).
    { eapply Rlt_trans.
      - apply H2.
      - replace 0 with (Q2R 0) by lra.
        apply Qlt_Rlt.
        auto with qarith. }
    lra.
Qed.

Require Export TopologicalSpaces.
Require Export InteriorsClosures.
Require Import Div2.
Require Import Even.
Require Import Arith.
Require Export RTopology.

Section Urysohns_Lemma_construction.

Variable X:TopologicalSpace.
Variable normal_sep_fun: forall F U:Ensemble X,
  closed F -> open U -> Included F U ->
  { V:Ensemble X | open V /\ Included F V /\
    Included (closure V) U }.
Variable U0 U1:Ensemble X.
Hypothesis U0_open: open U0.
Hypothesis U1_open: open U1.
Hypothesis U0_in_U1: Included (closure U0) U1.

Definition Un (n:nat) : Ensemble X :=
  match n with
  | O => U0
  | S O => U1
  | S (S _) => Full_set
  end.

Lemma Un_open: forall n:nat, open (Un n).
Proof.
destruct n as [|[|]]; trivial.
simpl.
apply open_full.
Qed.

Lemma Un_incr: forall n:nat, Included (closure (Un n))
                                    (Un (S n)).
Proof.
destruct n as [|].
- simpl.
  trivial.
- simpl.
  red; intros; constructor.
Qed.

Definition expand_U_dyadic (f:nat->Ensemble X)
  (Hopen: forall n:nat, open (f n))
  (Hincr: forall n:nat, Included (closure (f n)) (f (S n)))
  (n:nat) : Ensemble X :=
if (even_odd_dec n) then f (div2 n) else
let m := div2 n in proj1_sig
  (normal_sep_fun (closure (f m)) (f (S m))
     (closure_closed _) (Hopen _) (Hincr _)).

Lemma expand_U_dyadic_open: forall f Hopen Hincr n,
  open (expand_U_dyadic f Hopen Hincr n).
Proof.
intros.
unfold expand_U_dyadic.
destruct even_odd_dec.
- apply Hopen.
- destruct normal_sep_fun.
  simpl.
  apply a.
Qed.

Lemma expand_U_dyadic_incr: forall f Hopen Hincr n,
  Included (closure (expand_U_dyadic f Hopen Hincr n))
     (expand_U_dyadic f Hopen Hincr (S n)).
Proof.
intros.
unfold expand_U_dyadic.
simpl.
destruct even_odd_dec.
- destruct normal_sep_fun.
  simpl.
  destruct n.
  + simpl.
    apply a.
  + rewrite <- odd_div2.
    * apply a.
    * now inversion e.
- simpl.
  destruct normal_sep_fun.
  simpl.
  destruct o.
  rewrite even_div2.
  + now apply a.
  + trivial.
Qed.

Definition packaged_expand_U_dyadic :
  { f:nat->Ensemble X |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) } ->
  { f:nat->Ensemble X |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) }.
refine (fun fsig => match fsig with
  | exist f (conj Hopen Hincr as a) => exist _ (expand_U_dyadic f Hopen Hincr) _
  end).
destruct a.
split.
- apply expand_U_dyadic_open.
- apply expand_U_dyadic_incr.
Defined.

Definition U_dyadic_level_n (n:nat) :
  { f:nat->Ensemble X |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) }.
refine (let lev_n := fix lev_n (n:nat) :
  { f:nat->Ensemble X |
    (forall m:nat, open (f m)) /\
    (forall m:nat, Included (closure (f m)) (f (S m))) } :=
  match n with
  | O => exist _ Un _
  | S n' => packaged_expand_U_dyadic (lev_n n')
  end in lev_n n).
split.
- apply Un_open.
- apply Un_incr.
Defined.

Definition U_dyadic (x:dyadic_rational) :
  Ensemble X :=
match x with
| m_over_2_to_n m n => (proj1_sig (U_dyadic_level_n n)) m
end.

Lemma U_dyadic_wd: forall x y:dyadic_rational, dr_eq x y ->
  U_dyadic x = U_dyadic y.
Proof.
intros.
induction H; auto.
{ now transitivity (U_dyadic y). }
simpl.
unfold packaged_expand_U_dyadic.
destruct U_dyadic_level_n.
destruct a.
simpl.
unfold expand_U_dyadic.
change ((m + (m + 0))%nat) with ((2*m)%nat).
rewrite div2_double.
assert (forall m:nat, even (2*m)).
{ induction m0.
  { constructor. }
  replace ((2 * S m0)%nat) with ((S (S (2 * m0)))%nat) by ring.
  constructor.
  now constructor. }
destruct even_odd_dec; trivial.
now contradiction not_even_and_odd with ((2 * m)%nat).
Qed.

Lemma U_dyadic_open: forall x:dyadic_rational,
  open (U_dyadic x).
Proof.
intro.
destruct x.
unfold U_dyadic.
now destruct U_dyadic_level_n.
Qed.

Lemma U_dyadic_incr: forall x y:dyadic_rational, dr_lt x y ->
  Included (closure (U_dyadic x)) (U_dyadic y).
Proof.
intros.
induction H.
- induction H.
  + unfold U_dyadic.
    destruct U_dyadic_level_n.
    simpl.
    apply a.
  + cut (Included (closure (U_dyadic (m_over_2_to_n m0 n)))
       (U_dyadic (m_over_2_to_n (S m0) n))).
    * intro.
      pose proof (closure_inflationary
        (U_dyadic (m_over_2_to_n m0 n))).
      auto with sets.
    * unfold U_dyadic.
      destruct U_dyadic_level_n.
      simpl.
      apply a.
- now rewrite <- (U_dyadic_wd _ _ H0),
              <- (U_dyadic_wd _ _ H1).
Qed.

Definition Urysohns_Lemma_function : X -> RTop.
refine (fun x:X => proj1_sig (inf
 (Add
  (Im [ alpha:dyadic_rational | In (U_dyadic alpha) x ]
      (fun alpha:dyadic_rational => Q2R (dr2Q alpha)))
  1)
  _ _)).
- exists 0.
  red. intros.
  destruct H.
  + destruct H.
    destruct x0.
    simpl in H0.
    rewrite H0.
    replace 0 with (Q2R 0) by lra.
    cut (Q2R 0 <= Q2R (Z_of_nat m # pos_power2 n));
      auto with real.
    apply Qle_Rle.
    unfold Qle.
    simpl.
    auto with zarith.
  + destruct H.
    lra.
- exists 1.
  right.
  constructor.
Defined.

Lemma Urysohns_Lemma_function_range:
  forall x:X, 0 <= Urysohns_Lemma_function x <= 1.
Proof.
intros.
unfold Urysohns_Lemma_function.
destruct inf as [y].
simpl.
split.
- apply i.
  red; intros.
  destruct H.
  + destruct H.
    rewrite H0.
    replace 0 with (Q2R 0) by lra.
    cut (Q2R 0 <= Q2R (dr2Q x0));
      auto with real.
    apply Qle_Rle.
    destruct x0.
    unfold dr2Q, Qle.
    simpl.
    auto with zarith.
  + destruct H.
    auto with real.
- cut (1 >= y); auto with real.
  apply i.
  right.
  constructor.
Qed.

Lemma Urysohns_Lemma_function_0: forall x:X,
  In U0 x -> Urysohns_Lemma_function x = 0.
Proof.
intros.
apply Rle_antisym;
  [ | apply Urysohns_Lemma_function_range ].
unfold Urysohns_Lemma_function.
destruct inf as [y].
simpl.
cut (0 >= y); auto with real.
apply i.
left.
exists (m_over_2_to_n 0 0).
- now constructor.
- unfold Q2R.
  simpl.
  ring.
Qed.

Lemma Urysohns_Lemma_function_1: forall x:X,
  ~ In U1 x -> Urysohns_Lemma_function x = 1.
Proof.
intros.
apply Rle_antisym.
{ apply Urysohns_Lemma_function_range. }
unfold Urysohns_Lemma_function.
destruct inf as [y].
simpl.
apply i.
red. intros.
destruct H0;
  [ | destruct H0; now right ].
destruct H0.
destruct x0.
destruct H0.
assert (~ (m < (nat_of_P (pos_power2 n)))%nat).
{ intro.
  assert (forall n:nat, dr_eq
    (m_over_2_to_n (nat_of_P (pos_power2 n)) n)
    (m_over_2_to_n 1 0)).
  { induction n0.
    - simpl.
      unfold nat_of_P.
      simpl.
      apply dr_eq_refl.
    - apply dr_eq_trans with (2:=IHn0).
      apply dr_eq_sym.
      replace (nat_of_P (pos_power2 (S n0))) with
        ((2 * nat_of_P (pos_power2 n0))%nat).
      + apply dr_eq_scale.
      + simpl pos_power2.
        now rewrite Pos2Nat.inj_xO. }
  assert (dr_lt (m_over_2_to_n m n) (m_over_2_to_n 1 0)).
  { apply dr_lt_wd with (m_over_2_to_n m n)
      (m_over_2_to_n (nat_of_P (pos_power2 n)) n); trivial.
    - now apply intro_dr_lt.
    - apply dr_eq_refl. }
  pose proof (U_dyadic_incr _ _ H4).
  simpl (U_dyadic (m_over_2_to_n 1 0)) in H5.
  assert (Included (U_dyadic (m_over_2_to_n m n)) U1).
  { red. intros.
    now apply H5, closure_inflationary. }
  contradiction H.
  now apply H6. }
assert ((m >= nat_of_P (pos_power2 n))%nat) by
  auto with zarith.
red in H3.
assert ((nat_of_P (pos_power2 n) < m \/
        (nat_of_P (pos_power2 n) = m))%nat) by
  now apply le_lt_or_eq.
rewrite H1.
replace 1 with (Q2R (dr2Q (m_over_2_to_n 1 0))).
- match goal with |- ?a >= ?b =>
    cut (b <= a); auto with real end.
  apply Qle_Rle.
  unfold dr2Q.
  unfold Qle.
  simpl.
  ring_simplify.
  rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
  auto with zarith.
- unfold Q2R.
  simpl.
  field.
Qed.

Lemma Urysohns_Lemma_function_continuous:
  continuous Urysohns_Lemma_function.
Proof.
apply continuous_subbasis with (order_topology_subbasis _ Rle).
{ apply Build_TopologicalSpace_from_subbasis_subbasis. }
intros.
destruct H.
- (* proving that inverse image of lower open interval is open *)
  destruct (classic (x>1)).
  (* if x>1, inverse image is everything *)
  + match goal with |- open ?U => assert (U = Full_set) end.
    * extensionality_ensembles;
        constructor.
      constructor.
      cut (Urysohns_Lemma_function x0 < x);
        auto with real.
      apply Rle_lt_trans with 1; trivial.
      apply Urysohns_Lemma_function_range.
    * rewrite H0.
      apply open_full.
  + (* if x<=1, inverse image is union of U_alpha for alpha < x *)
    assert (x<=1) by
      now apply Rnot_gt_le.
    match goal with |- open ?U => assert (U =
      IndexedUnion (fun alpha:{alpha:dyadic_rational |
                               Q2R (dr2Q alpha) < x} =>
                    U_dyadic (proj1_sig alpha))) end.
    * extensionality_ensembles.
      ** destruct H1.
         assert (Urysohns_Lemma_function x0 < x).
         { destruct H1.
           { destruct (Rdichotomy _ _ H2); trivial. }
           contradict H2.
           auto with real. }
         clear H1.
         remember (Urysohns_Lemma_function x0) as y.
         unfold Urysohns_Lemma_function in Heqy.
         destruct inf in Heqy; simpl in Heqy.
         destruct Heqy.
         destruct (glb_approx _ _ (x-y) i).
         { now apply Rgt_minus. }
         destruct H1.
         destruct H1.
         *** destruct H1 as [alpha].
             destruct H1.
             destruct H4.
             ring_simplify in H6.
             rewrite H5 in H6.
             now exists (exist (fun beta:dyadic_rational => Q2R (dr2Q beta) < x)
               alpha H6).
         *** destruct H1.
             lra.
      ** destruct a as [alpha].
         simpl in H1.
         constructor.
         constructor.
         cut (Urysohns_Lemma_function x0 < x);
           auto with real.
         apply Rle_lt_trans with (2:=r).
         unfold Urysohns_Lemma_function. destruct inf. simpl.
         cut (Q2R (dr2Q alpha) >= x1); auto with real.
         apply i.
         left.
         now exists alpha.
    * rewrite H1.
      apply open_indexed_union.
      intro.
      apply U_dyadic_open.
- (* proving that inverse image of upper open interval is open *)
  destruct (classic (x<0)).
  + (* if x<0, inverse image is everything *)
    match goal with |- open ?U => assert (U = Full_set) end.
    * extensionality_ensembles;
        constructor.
      constructor.
      cut (x < Urysohns_Lemma_function x0); auto with real.
      apply Rlt_le_trans with (1:=H), Urysohns_Lemma_function_range.
    * rewrite H0.
      apply open_full.
  + assert (x >= 0) by now apply Rnot_lt_ge.
    clear H.
    (* if x>=1, inverse image is empty *)
    destruct (classic (x>=1)).
    * match goal with |- open ?U => assert (U = Empty_set) end.
      2 : { rewrite H1. apply open_empty. }
      extensionality_ensembles.
      destruct H1.
      assert (x < Urysohns_Lemma_function x0).
      { destruct (total_order_T x (Urysohns_Lemma_function x0)) as
        [[|]|]; trivial.
        - now contradiction H2.
        - contradict r.
          now apply Rle_not_gt. }
      exfalso.
      apply (Rlt_irrefl x).
      apply Rlt_le_trans with (Urysohns_Lemma_function x0); trivial.
      apply Rle_trans with 1; auto with real.
      apply Urysohns_Lemma_function_range.
    * (* if 0 <= x < 1, inverse image is union of
         Complement (closure U_alpha) for x < alpha < 1 *)
      assert (x < 1) by now apply Rnot_ge_lt.
      clear H.
      match goal with |- open ?U => assert (U =
        IndexedUnion (fun alpha:{alpha:dyadic_rational |
                           x < Q2R (dr2Q alpha) < 1} =>
                   (Complement (closure (U_dyadic (proj1_sig alpha))))))
       end.
      2 : {
        rewrite H.
        apply open_indexed_union.
        intros.
        apply closure_closed. }
      apply Extensionality_Ensembles; split; red; intros.
      ** destruct H.
         destruct H.
         destruct H.
         remember (Urysohns_Lemma_function x0) as y.
         assert (y <= 1).
         { rewrite Heqy. apply Urysohns_Lemma_function_range. }
         unfold Urysohns_Lemma_function in Heqy.
         destruct inf in Heqy. simpl in Heqy.
         destruct Heqy.
         assert (x < y).
         { destruct (total_order_T x y) as [[|]|]; trivial.
           - now contradiction H2.
           - contradict r.
             now apply Rle_not_gt. }
         destruct (dyadic_rationals_dense_in_reals x y) as [alpha].
         { auto with real. }
         assert (~ In (U_dyadic alpha) x0).
         { intro.
           absurd (Q2R (dr2Q alpha) >= y).
           - destruct H5.
             now apply Rlt_not_ge.
           - apply i.
             left.
             now exists alpha. }
         destruct (dyadic_rationals_dense_in_reals x (Q2R (dr2Q alpha)))
           as [beta].
         { split; auto with real.
           apply H5. }
         assert (dr_lt beta alpha) by
           apply Qlt_dr_lt, Rlt_Qlt, H7.
         pose proof (U_dyadic_incr _ _ H8).
         assert (x < Q2R (dr2Q beta) < 1).
         { split.
           { apply H7. }
           apply Rlt_trans with (Q2R (dr2Q alpha)).
           { apply H7. }
           apply Rlt_le_trans with y; trivial.
           apply H5. }
         exists (exist (fun alpha0:dyadic_rational =>
                        x < Q2R (dr2Q alpha0) < 1)
                 beta H10).
         simpl.
         intro.
         contradiction H6.
         now apply H9.
      ** destruct H.
         destruct a as [alpha].
         simpl in H.
         constructor.
         constructor.
         cut (x < Urysohns_Lemma_function x0); auto with real.
         apply Rlt_le_trans with (Q2R (dr2Q alpha)).
         { apply a. }
         unfold Urysohns_Lemma_function. destruct inf as [y]. simpl.
         apply i.
         red. intros.
         destruct H2.
         *** destruct H2 as [beta].
             assert (dr_lt alpha beta \/ dr_eq alpha beta).
             { cut (~ dr_lt beta alpha).
               - destruct (dr_total_order alpha beta) as [|[|]]; auto.
                 intro.
                 contradiction H5.
               - intro.
                 pose proof (U_dyadic_incr _ _ H4).
                 destruct H2.
                 contradiction H.
                 apply closure_inflationary.
                 apply H5.
                 now apply closure_inflationary. }
             destruct H4;
               rewrite H3.
             **** pose proof (dr2Q_incr _ _ H4).
                 cut (Q2R (dr2Q alpha) <= Q2R (dr2Q beta)); auto with real.
                 apply Qle_Rle.
                 auto with qarith.
             **** cut (Q2R (dr2Q alpha) <= Q2R (dr2Q beta)); auto with real.
                  apply Qle_Rle.
                  pose proof (dr2Q_wd _ _ H4).
                  auto with zarith qarith.
         *** destruct H2.
             destruct a.
             auto with real rorders.
Qed.

End Urysohns_Lemma_construction.

Theorem UrysohnsLemma: forall X:TopologicalSpace, normal_sep X ->
  forall F G:Ensemble X,
  closed F -> closed G -> Intersection F G = Empty_set ->
  exists f:X -> RTop,
  continuous f /\ (forall x:X, 0 <= f x <= 1) /\
  (forall x:X, In F x -> f x = 0) /\
  (forall x:X, In G x -> f x = 1).
Proof.
intros X [_ HX_normal] F G HF HG HFG.
destruct (HX_normal F G HF HG HFG) as [U [V [HU [HV [HFU [HGV HUV]]]]]].
assert (inhabited (forall F U:Ensemble X, closed F ->
  open U -> Included F U ->
  { V:Ensemble X | open V /\ Included F V /\
                               Included (closure V) U }))
       as [normal_sep_fun].
{ destruct (choice (fun (FU_pair:
    {p:Ensemble X * Ensemble X |
     closed (fst p) /\ open (snd p) /\ Included (fst p) (snd p)})
    (V0:Ensemble X) =>
     open V0 /\ Included (fst (proj1_sig FU_pair)) V0 /\
     Included (closure V0) (snd (proj1_sig FU_pair)))) as
    [pre_choice_fun Hpre_choice_fun].
  2: {
    exists.
    intros F0 U0 HF0 HU0 HF0U0.
    exists (pre_choice_fun (exist _ (F0,U0)
      (conj HF0 (conj HU0 HF0U0)))).
    apply Hpre_choice_fun. }
  intros [[F0 U0] [HF0 [HU0 HF0U0]]].
  simpl in *.
  destruct (HX_normal F0 (Complement U0))
    as [U1 [V1 [? [? [? [H_CU0_V1 HU1V1]]]]]]; trivial.
  { red. now rewrite Complement_Complement. }
  { extensionality_ensembles_inv.
    subst.
    match goal with
    | H : In F0 _ |- _ =>
      apply HF0U0 in H
    end.
    contradiction. }
  exists U1.
  repeat split; trivial.
  transitivity (Complement V1).
  - apply closure_minimal.
    + red. now rewrite Complement_Complement.
    + red. intros.
      intro.
      eapply Noone_in_empty.
      rewrite <- HU1V1.
      constructor;
        eassumption.
  - red. intros.
    apply NNPP. intros Hx.
    apply H_CU0_V1 in Hx.
    contradiction. }
unshelve eexists (Urysohns_Lemma_function _ normal_sep_fun
  U (Complement G) HU HG _).
{ transitivity (Complement V).
  - apply closure_minimal.
    + red. now rewrite Complement_Complement.
    + red. intros.
      intro.
      eapply Noone_in_empty.
      rewrite <- HUV.
      econstructor;
        eassumption.
  - red. intros x Hx ?.
    contradiction Hx.
    now apply HGV. }
split.
{ apply Urysohns_Lemma_function_continuous. }
split.
{ apply Urysohns_Lemma_function_range. }
split;
  intros.
- apply Urysohns_Lemma_function_0; auto.
- apply Urysohns_Lemma_function_1; auto.
Qed.


Require Import Arith.

(*Notation Q := RD.*)

(*
Section Arithmetic.
(*Section ignore_this_section.*)
Inductive Terms:Set :=
| ZE : Terms                   (*zero*)
| SU : Terms -> Terms          (*successor*)
| AD : Terms -> Terms -> Terms (*addition*)
| MU : Terms -> Terms -> Terms (*multiplication*)
.
Local Notation N := Terms. (* N is a set of terms *)
Inductive RD : Prop -> Prop := (* Derivable in Robinson Arithmetic *)
| R1 : RD (forall (x:N), not (SU x = ZE))
| R2 : RD (forall (x y:N), SU x = SU y -> x = y)
| R3 : RD (forall (y:N), (y = ZE) \/ exists x:N, y = SU x)
| R4 : RD (forall (x:N), AD x ZE = x)
| R5 : RD (forall (x y:N), AD x (SU y) = SU (AD x y))
| R6 : RD (forall (x:N), MU x ZE = ZE)
| R7 : RD (forall (x y:N), MU x (SU y) = AD (MU x y) x)
.
(*End ignore_this_section.*)
(*Context (N:Set) (ZE:N) (SU:N->N) (AD MU:N->N->N) (*EQ:N->N->Prop*).*)
*)

Module Type Ari.
Parameters (N:Set) (ZE:N) (SU:N->N) (AD MU:N->N->N).
End Ari.

Module Type RA (w: Ari). (* Robinson Arithmetic *)
Import w.
(*Axioms (N:Set) (ZE:N) (SU:N->N) (AD MU:N->N->N).*)
Axioms (Q1 : forall (x:N), not (SU x = ZE))
       (Q2 : forall (x y:N), SU x = SU y -> x = y)
       (Q3 : forall (y:N), (y = ZE) \/ exists x:N, y = SU x)
       (Q4 : forall (x:N), AD x ZE = x)
       (Q5 : forall (x y:N), AD x (SU y) = SU (AD x y))
       (Q6 : forall (x:N), MU x ZE = ZE)
       (Q7 : forall (x y:N), MU x (SU y) = AD (MU x y) x).
End RA.

Module Type PA (a:Ari) (ra : RA a). (* Peano Arithmetic *)
Export a.
Export ra.
Axioms (IND : forall (P:N->Prop),
 (P ZE -> (forall y:N, P y -> P (SU y))-> forall y:N, P y))
.
End PA.

Module TheoremsRA (a:Ari) (ra : RA a).
Import a.
Import ra.
Fixpoint num (x:nat) :=
 match x return N with
 | 0 => ZE
 | S y => SU (num y)
 end.
(*Coercion num: nat >-> N.*)
(*Section Robinson.
Context (Q1 : forall (x:N), not (SU x = ZE)).
Context (Q2 : forall (x y:N), SU x = SU y -> x = y).
Context (Q3 : forall (y:N), (y = ZE) \/ exists x:N, y = SU x).
Context (Q4 : forall (x:N), AD x ZE = x).
Context (Q5 : forall (x y:N), AD x (SU y) = SU (AD x y)).
Context (Q6 : forall (x:N), MU x ZE = ZE).
Context (Q7 : forall (x y:N), MU x (SU y) = AD (MU x y) x).
*)
(* Lemma 1 *)
Lemma l1_1 : forall k m, not (k = m) -> not (num m = num k).
Proof.
induction k,m.
+ intro r. exfalso. apply r. reflexivity.
+ intros r H.
  simpl in H.
  pose (y:=Q1 (num m)).
  unfold not in y.
  apply (y H).
+ intros r H. symmetry in H.
  simpl in H.
  apply (Q1 (num k) H).
+ intros r.
  simpl in r |- *.
  intro q.
  pose (g:= Q2 _ _ q).
  unshelve eapply (IHk m).
  2 : exact g.
  intro j.
  apply r.
  apply f_equal_nat, j.
Defined.

Lemma Q4_sym_num (x:nat): AD ZE (num x) = (num x).
Proof. induction x. simpl. apply Q4. simpl.
rewrite Q5. apply f_equal. apply IHx.
Defined.

Lemma not_imp_or (A B:Prop):(A\/B)->((A->False)->B).
Proof.
intros a b.
destruct a.
+ exfalso. exact (b H).
+ exact H.
Defined.

Lemma l1_2 : forall m k, AD (num k) (num m) = num (k + m).
Proof.
induction m.
+ intro k. rewrite plus_0_r. simpl. apply Q4.
+ intro k. simpl. rewrite -> Q5. rewrite -> IHm.
change (SU (num (k + m))) with (num (S (k + m))).
auto with arith.
Defined.

Lemma sum_sym : forall k m, AD (num k) (num m) = AD (num m) (num k) .
Proof. intros.
rewrite l1_2, l1_2. auto with arith.
Defined.

Lemma summ_assoc : forall a b c,
AD (AD (num a) (num b)) (num c) = AD (num a) (AD (num b) (num c)).
Proof.
intros a b c.
rewrite l1_2, l1_2.
rewrite l1_2, l1_2.
auto with arith.
Defined.

Lemma l1_3 : forall m k, MU (num k) (num m) = num (k * m).
Proof.
induction m.
+ intro k. rewrite mult_0_r. simpl. apply Q6.
+ intro k. simpl. rewrite -> Q7. rewrite -> IHm.
rewrite l1_2. apply f_equal. auto with arith.
Defined.

Lemma mul_sym : forall k m, MU (num k) (num m) = MU (num m) (num k).
Proof. intros.
rewrite l1_3, l1_3. auto with arith.
Defined.

Definition LE (x y:N) := exists z, (AD x z = y).

(*
Definition IMP : forall (x:N), exists n:nat, x = (num n).
Proof.
intros.
induction x.
+ exists 0. trivial.
+ destruct IHx as [n H].
  exists (S n). simpl. rewrite <- H. trivial.
+ destruct IHx1 as [n1 H1], IHx2 as [n2 H2].
  exists (n1 + n2). rewrite H1, H2. apply l1_2.
+ destruct IHx1 as [n1 H1], IHx2 as [n2 H2].
  exists (n1 * n2). rewrite H1, H2. apply l1_3.
Defined.

Lemma Q4_sym : forall (x:N), AD ZE x = x.
Proof.
intro x. destruct (IMP x) as [n H].
rewrite -> H. apply Q4_sym_num.
Defined.
*)
End TheoremsRA.

Module TermsMod : Ari.
Inductive Terms:Set :=
| cZE : Terms                   (*zero*)
| cSU : Terms -> Terms          (*successor*)
| cAD : Terms -> Terms -> Terms (*addition*)
| cMU : Terms -> Terms -> Terms (*multiplication*)
.
Definition N:=Terms.
Definition ZE:=cZE.
Definition SU:=cSU.
Definition AD:=cAD.
Definition MU:=cMU.
End TermsMod.

(*
Module TheoremsAboutTerms. (* (w : RA TermsMod) <: RA. *)
(*Module (ra: Q) *)
(*Check Terms_ind.*)
Export TermsMod.
Module FM1 := TermsMod.
Export FM1.
Check ZE.
Check N.
Check TermsMod.N.
Definition ghkjk (n:TermsMod.N):TermsMod.N.
destruct n.
(*Import w.*)
(*Check Terms.*)
(*Definition N:=Terms.*)
Lemma Q4_sym : forall (x:N), AD ZE x = x.
Proof.
intro x.

destruct x.
destruct (Q3 x) as [E|[w E]].
- rewrite -> E.
  apply Q4.
- (*induction E.*)
  rewrite -> E.
  rewrite -> Q5.
  apply f_equal.
  rewrite -> Q4.
(* destruct (IMP x) as [n H].
rewrite -> H. apply Q4_sym_num.*)
Defined.

Lemma l_1_5 : forall (m:nat) (x:N), (LE x (num m)) \/ (LE (num m) x).
Proof.
induction m.
+ intro x. simpl. right. unfold LE. exists x.
(*exact (Q4_sym x).*)
+ intro x.
  destruct (IHm x).
  * left.
    admit.
  * unfold LE in H |-*.
Abort.
End TheoremsAboutTerms.*)

Module TheoremsPA (a:Ari) (ra : RA a) (pa : PA a ra).
Module X := TheoremsRA a ra.
Import X.
Import pa.

Section Peano. (* TODO Separate the lemmas above *)
(*
Context (IND : forall (P:N->Prop),
(P ZE -> (forall y:N, P y -> P (SU y))-> forall y:N, P y)).
Check Q1. (* SU x <> ZE *)
Check Q2. (* SU - injective *)
Check Q3. (*forall y : N, y = ZE \/ (exists x : N, y = SU x)*)
Check Q4. (*  forall x : N, AD x ZE = x*)
Check Q5. (*: forall x y : N, AD x (SU y) = SU (AD x y)*)
Check Q6. (*: forall x : N, MU x ZE = ZE*)
Check Q7. (*: forall x y : N, MU x (SU y) = AD (MU x y) x*)
*)

(* Strong induction lemmas *)

Theorem AD_sym_lem :forall (n m:N), AD m (SU n) = AD (SU m) n.
Proof.
pose (P:= (fun n:N=> forall m : N, AD m (SU n) = AD (SU m) n)).
intro n.
apply (IND P); unfold P.
+ intro m.
  rewrite -> Q5.
  repeat rewrite -> Q4. reflexivity.
+ intros y H m.
  rewrite -> Q5.
  rewrite -> H.
  rewrite <- Q5.
  reflexivity.
Defined.

Theorem AD_sym (y x:N) : AD x y = AD y x.
Proof.
pose (P:= (fun y:N=> forall x : N, AD x y = AD y x)).
apply (IND P); unfold P.
+ apply (IND (fun x0=> AD x0 ZE = AD ZE x0)).
  * reflexivity.
  * intros.
    symmetry.
    rewrite -> Q5.
    rewrite <- H.
    rewrite -> Q4.
    rewrite -> Q4.
    reflexivity.
+ intros y0 H x0.
    rewrite -> Q5.
    rewrite H.
    rewrite <- Q5.
    apply AD_sym_lem.
Defined.

Theorem leq0_then_eq0 (m:N) (H : LE m ZE) : m = ZE.
Proof.
unfold LE in H.
destruct H as [z e].
pose (dv := Q3 m).
destruct dv.
exact H.
destruct H as [u J].
rewrite J in e.
rewrite AD_sym in e.
rewrite Q5 in e.
destruct (Q1 _ e). (* inversion e. *)
Defined.
(*simpl in e.
apply (IND (fun m=>m=ZE)).
reflexivity.
unfold AD in H.
(*remember (2+2) as tpt.*)*)
Lemma LE_redu (a y:N): LE (SU a) (SU y)-> LE a y.
Proof.
unfold LE.
intro W.
destruct W as [z U].
rewrite AD_sym in U.
rewrite Q5 in U.
apply Q2 in U.
rewrite AD_sym in U.
exists z.
exact U.
Defined.

Lemma LE_trans (a b c:N): LE a b -> LE b c -> LE a c.
Proof.
unfold LE.
intros.
Admitted.

(* strong induction *)
Section StrongInd.
Context (P:N->Prop).
Hypotheses IH0 : P ZE.
Hypotheses IHn : forall y:N, (forall z, LE z y -> P z) -> P (SU y).
Lemma strong_induction_all : forall n,
(forall m, LE m n -> P m).
Proof.
apply (IND (fun n=> forall m:N,LE m n -> P m)).
+ intros m H.
  rewrite (leq0_then_eq0 m H).
  exact IH0.
+ intros y F m l.
  destruct (Q3 m) as [H|[a b]].
  * rewrite H; exact IH0.
  * rewrite b. apply IHn.
    intro z.
    intro J.
    apply F.
    rewrite b in l.
    apply LE_redu in l.
    apply (LE_trans z a y); assumption.
Defined.

Lemma strong_induction : forall n, P n.
Proof.
intro n.
destruct (Q3 n) as [e|[x e]].
+ rewrite e; exact IH0.
+ rewrite e. apply IHn. apply strong_induction_all.
Defined.

End StrongInd.

(* Well-ordering lemmas *)
Lemma l1case0 : forall z, LE ZE z.
Proof.
unfold LE.
intro z.
exists z.
apply (IND (fun z => AD ZE z = z)).
apply Q4.
intros y H.
rewrite Q5.
apply f_equal.
exact H.
Defined.

Lemma wol0 (X:N->Prop) : (exists y, forall z, LE y z).
Proof.
exists ZE. exact l1case0.
Defined.

(* assume X has no least element. *)

Lemma wol1 (X:N->Prop)(K:~(exists y, X y /\ forall z, (X z -> LE y z))):
forall z, ~(X z).
Proof.
intros.
(*apply (IND (fun z=> ~(X z))).*)
apply (strong_induction (fun z=> ~(X z))).
+ unfold not.
  intro h.
  apply K.
  exists ZE.
  split. exact h.
  intros. apply l1case0.
+ (*intros y H q.
  apply K.
  exists (SU y).
  split. exact q.
  intros z0 H0.*)
  intros y G s.
  apply K.
  exists (SU y).
  split. exact s.
  intros q w.
  pose (Gq := G q).
Abort.

(* Well-ordering theorem *)
Theorem WO (F:N->Prop) :
(exists y, F y) -> (exists y, F y /\ forall z, (F z) -> LE y z).
Proof.
intro e.
Abort.

(* Classical variant of principle is not provable in IPA. *)
Theorem LNP (F:N->Prop):
(exists y, F y) -> (exists y, F y /\ forall z, LE z y -> not (F z)).
Proof.
Abort.
(*
~(exists y, F y /\ forall z, LE z y -> not (F z))
->
~(exists y, F y)
*)

(*Notation "'LT' z y " := (LE (SU z) y) (at level 1).*)
Definition LT z y := (LE (SU z) y).
Theorem LNP (F:N->Prop):
(forall y, ~ F y \/ exists z, LT z y /\ (F z))
->
(forall y, ~ F y)
.
Proof.
intros H y.
apply (strong_induction (fun x=> ~F x)).
+ destruct (H ZE) as [n|[z J]].
  exact n.
  destruct J as [[i k] J].
  rewrite AD_sym in k.
  rewrite Q5 in k.
  destruct (Q1 _ k). (* AKA "inversion k." *)
+ intros a E.
  destruct (H (SU a)) as [n|[z J]].
  exact n.
  destruct J as [B R].
  apply LE_redu in B.
  destruct (E z B R).
Defined.

(*  "The principle of induction is
          a consequence of the least number principle"
https://math.stackexchange.com/questions/1583102/least-number-principle
*)

End Peano.
End TheoremsPA.
(*End Robinson.
End Arithmetic.*)

(* The standard model of PA. *)
Module nat_pa (a:Ari) (ra:RA a) <: PA a ra.
Definition N:=nat.
Definition ZE:=0.
Definition SU:=S.
Definition AD x y:=x+y.
Definition MU x y:=x*y.
Theorem Q1 : forall (x:N), not (SU x = ZE).
Proof. firstorder. Defined.
Theorem Q2 : forall (x y:N), SU x = SU y -> x = y.
Proof. firstorder. Defined.
Theorem Q3 : forall (y:N), (y = ZE) \/ exists x:N, y = SU x.
Proof.
intro y. destruct y.
+ left; reflexivity.
+ right; exists y; reflexivity.
Defined.
Theorem Q4 : forall (x:N), AD x ZE = x.
Proof. firstorder. Defined.
Theorem Q5 : forall (x y:N), AD x (SU y) = SU (AD x y).
Proof. firstorder. Defined.
Theorem Q6 : forall (x:N), MU x ZE = ZE.
Proof. firstorder. Defined.
Theorem Q7 : forall (x y:N), MU x (SU y) = AD (MU x y) x.
Proof. firstorder. Defined.
Theorem IND : forall (P:N->Prop),
(P ZE -> (forall y:N, P y -> P (SU y))-> forall y:N, P y).
Proof. intros P H0 Hn y.
induction y.
+ exact H0.
+ exact (Hn y IHy).
Defined.
End nat_pa.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil :(list a))) = l).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

Parameter vertex : Type.

Parameter edge: vertex -> vertex -> Prop.

(* Why3 assumption *)
Inductive path : vertex -> (list vertex) -> vertex -> Prop :=
  | Path_empty : forall (x:vertex), (path x (Nil :(list vertex)) x)
  | Path_cons : forall (x:vertex) (y:vertex) (z:vertex) (l:(list vertex)),
      (edge x y) -> ((path y l z) -> (path x (Cons x l) z)).

Axiom path_right_extension : forall (x:vertex) (y:vertex) (z:vertex) (l:(list
  vertex)), (path x l y) -> ((edge y z) -> (path x (infix_plpl l (Cons y
  (Nil :(list vertex)))) z)).

Require Import Why3.

(* Why3 goal *)
Theorem path_right_inversion : forall (x:vertex) (z:vertex) (l:(list
  vertex)), (path x l z) -> (((x = z) /\ (l = (Nil :(list vertex)))) \/
  exists y:vertex, exists lqt:(list vertex), (path x lqt y) /\ ((edge y z) /\
  (l = (infix_plpl lqt (Cons y (Nil :(list vertex))))))).
induction 1.
left; auto.
right.
destruct IHpath.
intuition; subst.
exists x; exists Nil.
ae.
destruct H1 as (y', (l', (h1, (h2, h3)))).
exists y'; exists (Cons x l'); ae.
Qed.


From mathcomp Require Import all_ssreflect finmap zify.
From Equations Require Import Equations.

Equations foldIn {A B : Type} (l : list A) (f : forall (x : A), List.In x l -> B -> B) (b : B) : B :=
  foldIn nil f b := b;
  foldIn (x:: xs) f b := f x _ (foldIn xs (fun x H b => f x _ b) b).

Equations filterIn {A : Type} (l : list A) (f : forall (x : A), List.In x l -> bool)  : seq A :=
  filterIn nil f := nil;
  filterIn (x:: xs) f := if f x _ then x :: (filterIn xs (fun x H => f x _)) else filterIn xs (fun x H => f x _).

Lemma filterInP : forall (A : Type) (l : list A) (f : A -> bool), filterIn l (fun x H => f x) = filter f l.
Proof.
move => A. elim. done.
intros. simpl.   simp filterIn. destruct (f _ ). f_equal. done. done.
Qed.

Definition foldInMap {A B : Type} (l : list A) (f : forall (x : A), List.In x l -> B) : seq B :=
 foldIn l (fun x H b => (f x H)::b) nil.

Lemma foldInMapP : forall (A B : Type) (l : list A) (f : A -> B), foldInMap l (fun x H => f x) = map f l.
Proof.
move => A B. rewrite /foldInMap.  elim. done.
intros. simpl.   simp foldIn. f_equal. done.
Qed.

Definition foldInFilter {A : Type} (l : list A) (f : forall (x : A), List.In x l -> bool) : seq A :=
 foldIn l (fun x H b => if f x H then x::b else b) nil.

Lemma foldInFilterP : forall (A : Type) (l : list A) (f : A -> bool), foldInFilter l (fun x H => f x) = filter f l.
Proof.
move => A. rewrite /foldInFilter.  elim. done.
intros. simpl.   simp foldIn. destruct (f _ ). f_equal. done. done.
Qed.

Lemma foldInFilterP2 : forall (A : Type) (l : list A) (f : forall (x : A), List.In x l -> bool) (f' : A -> bool), (forall (x : A) (H : List.In x l), f x H = f' x) ->
  foldInFilter l f = filter (fun x => f' x) l.
Proof.
move => A. rewrite /foldInFilter.  elim. done.
intros. simpl.   simp foldIn. rewrite H0. destruct (f' _ ). f_equal. apply H. auto. apply H. auto.
Qed.

Definition foldInPmap {A B : Type} (l : list A) (f : forall (x : A), List.In x l -> option B) : seq B :=
 foldIn l (fun x H b => if f x H is Some e then e::b else b) nil.

Lemma foldInPmapP : forall (A B : Type) (l : list A) (f : A -> option B), foldInPmap l (fun x H => f x) = pmap f l.
Proof.
move => A B. rewrite /foldInPmap.  elim. done.
intros. simpl.   simp foldIn. destruct (f a). simpl. f_equal. apply H. simpl. done.
Qed.

Definition foldInHas {A : Type} (l : list A) (f : forall (x : A), List.In x l -> bool) : bool  :=
 foldIn l (fun x H b => (f x H) || b ) false.

Lemma foldInHasP : forall (A: Type) (l : list A) (f : A -> bool), foldInHas l (fun x H => f x) = has f l.
Proof.
move => A. rewrite /foldInHas.  elim. done.
intros. simpl.   simp foldIn. destruct (f a). done.  simpl. apply H.
Qed.

Definition foldInAll {A : Type} (l : list A) (f : forall (x : A), List.In x l -> bool) : bool  :=
 foldIn l (fun x H b => (f x H) && b ) true.

Lemma foldInAllP : forall (A: Type) (l : list A) (f : A -> bool), foldInAll l (fun x H => f x) = all f l.
Proof.
move => A. rewrite /foldInAll.  elim. done.
intros. simpl.   simp foldIn. f_equal.  done.
Qed.

Equations findIn {A: Type} (l : list A) (f : forall (x : A), List.In x l -> bool) : nat :=
  findIn nil f  := 0;
  findIn (x:: xs) f := if f x _ then 0 else (findIn xs (fun x H => f x _)).+1.

Lemma findInP : forall (A: Type) (l : list A) (f : A -> bool), findIn l (fun x H => f x) = find f l.
Proof.
move => A. elim. done. intros. simpl. simp findIn. destruct (f a). done. rewrite H. done.
Qed.

Locate Forall.
Notation In := List.In.
Notation Forall := List.Forall.

Lemma In_in : forall (A : eqType) (a : A) l, In a l <-> a \in l.
Proof.
move => A a. elim. split;done.
intros. rewrite /= inE. split. case. move=>->. rewrite eqxx. done. move/H. move=>->. by rewrite orbC.
move/orP. case. move/eqP. move=>->. auto. move/H. auto.
Qed.

Lemma Forall_forall
     : forall (A : eqType) (P : A -> Prop) (l : seq A), Forall P l <-> (forall x : A, x \in l -> P x).
Proof. intros. rewrite List.Forall_forall. split;intros;auto;by apply/H/In_in. Qed.

Lemma nat_fact : forall n, n - (n - n) = n. lia. Qed.

Lemma forallzipP1 : forall (A B : eqType) (P : A * B -> Prop) a b l l',  size l = size l' -> (forall x0, x0 < size l -> P (nth a l x0,nth b l' x0)) ->
Forall P (zip l l').
Proof.
intros. apply/Forall_forall. intros. move : H1. move/nthP=>HH. specialize HH with (a,b).
destruct HH. rewrite -H2. rewrite nth_zip //=. apply H0. move : H1. by rewrite size_zip minnE H nat_fact.
Qed.

Lemma forallzipP2 : forall (A B : eqType) (P : A * B -> Prop) a b l l', Forall P (zip l l') -> size l = size l' -> (forall x0, x0 < size l -> P (nth a l x0,nth b l' x0)).
Proof.
move => A B P a b. elim. case. done. done. move => a0 l IH. case. done. move => a1 l0 H Hsize. intros. simpl in H0. destruct x0. simpl. simpl in H. inversion H. done. simpl. apply IH. simpl in H. inversion H. done. simpl in Hsize. lia. lia.
Qed.

Lemma forallzipP : forall (A B : eqType) (P : A * B -> Prop) a b l l',  size l = size l' -> (forall x0, x0 < size l -> P (nth a l x0,nth b l' x0)) <->
Forall P (zip l l').
Proof.
intros.  split. apply forallzipP1. done. move/forallzipP2=>HH. apply HH. done.
Qed.

Lemma forallzipto1 : forall (A B : Type) (P : A -> Prop) (l : seq A) (l' : seq B), size l = size l' ->
Forall (fun p => P p.1) (zip l l') -> Forall P l.
Proof.
move => A B P. elim. case. done. done. intros. destruct l'. simpl in H0. done. simpl in *. inversion H1. subst. simpl in *. constructor. done. apply :H. inversion H0. eauto. done.
Qed.

Lemma forallzipto2 : forall (A B : Type) (P : B -> Prop) (l' : seq B) (l : seq A), size l = size l' ->
Forall (fun p => P p.2) (zip l l') -> Forall P l'.
Proof.
move => A B P. elim. case. done. done. intros. destruct l0. simpl in H0. done. simpl in *. inversion H1. subst. simpl in *. constructor. done. apply :H. inversion H0. eauto. done.
Qed.

Lemma forallP : forall (A : eqType) (P : A -> Prop) a l,(forall x0, x0 < size l -> P (nth a l x0)) ->
Forall P l.
Proof. intros.
apply/Forall_forall. intros. move : H0 => /nthP H3.  specialize H3 with a. destruct H3. rewrite -H1. auto.
Qed.

Lemma my_in_cons : forall (A :eqType) (a : A) l, a \in (a::l).
Proof. intros. rewrite !inE eqxx. done. Qed.

Lemma my_in_cons2 : forall (A :eqType) (a a0 : A) l, a \in l -> a \in (a0::l).
Proof. intros. rewrite !inE H. lia. Qed.

Hint Resolve my_in_cons my_in_cons2.

Ltac case_if := match goal with
                | [ |- context[if ?X then _ else _ ]] => have : X by subst
                | [ |- context[if ?X then _ else _ ]] => have : X = false by subst

                | [ |- context[if ?X then _ else _ ]] => let H := fresh in destruct X eqn:H

                end; try (move=>->).

Ltac rifliad := (repeat case_if); try done.

Lemma neg_sym : forall (A : eqType) (a b : A), (a != b) = (b != a).
Proof.
intros. destruct (eqVneq a b).  done. done.
Qed.

Ltac split_and := intros;repeat (match goal with
                   | [ H : is_true (_ && _) |- _ ] => destruct (andP H);clear H
                   | [ H : (_ && _) = true  |- _ ] => destruct (andP H);clear H
                   | [ H : _ /\ _  |- _ ] => destruct H
                   | [ |- _ /\ _ ] => split
                   | [ |- is_true (_ && _) ] => apply/andP;split

                  end);auto.

Notation eq_iff := Bool.eq_iff_eq_true.
Ltac ssa := rewrite ?inE;simpl in *; split_and;try done.

Lemma negb_involutive : forall b, ~~ ~~ b = b. case;done. Qed.

Open Scope fset_scope.
Lemma big_exists : forall (A : eqType) (B : choiceType) (l : seq A) (f0 : A -> {fset B}) p, p \in \bigcup_(j <- l) (f0 j) = has (fun x => p \in f0 x) l.
Proof.
move => A B. elim. move => f0 p. rewrite big_nil. done. intros. simpl. rewrite big_cons !inE. destruct ( (p \in f0 a) ) eqn:Heqn;rewrite /=.
done.
apply H.
Qed.

Lemma big_f_eq : forall (A : eqType) (B : choiceType)  (l : seq A) (f : A -> {fset B}) f1, (forall g, g \in l -> f g = f1 g) ->  \bigcup_(j <- l) (f j) =  \bigcup_(j <- l) (f1 j).
Proof. move => A B. elim. intros. by rewrite !big_nil.
intros. rewrite !big_cons. f_equal. auto. apply H. auto.
Qed.

Lemma big_if : forall (A : eqType) (B : choiceType) (l : seq A) (p : pred A) (f : A -> {fset B}) S,
                  \bigcup_(j <- l) (if p j then f j `|` S else f j) =
                   (\bigcup_(j <- l) (f j)) `|` (if has p l then S else fset0).
Proof. move => A B. elim. intros. rewrite !big_nil /=. apply/fsetP=>k. by rewrite !inE.
intros. rewrite !big_cons /= H. rifliad. all : apply/fsetP=>k; rewrite !inE; lia.
Qed.

Lemma big_cup_in : forall (A : eqType) (B: choiceType) n (l : seq A) (f0 f1 : A -> {fset B}), (forall x n, x \in l -> n \in (f0 x) -> n \in (f1 x)) -> n \in \bigcup_(j <- l) (f0 j) ->  n \in \bigcup_(j <- l) (f1 j).
Proof. move => A B n. elim. move => f0 f1.  rewrite big_nil. done. intros. move : H1. rewrite !big_cons !inE. move/orP=>[].  intros. rewrite H0 //=. intros. erewrite H. lia. intros. apply H0. eauto. eauto. apply b.
Qed.

Ltac norm_eqs := repeat (match goal with
                   | [ H : (_ == _) |- _ ] => move : H => /eqP=>H
                   | [ H : (_ == _) = true |- _ ] => move : H => /eqP=>H
                   | [ H : (_ == _) = false |- _ ] => move : H => /negbT=>H

                  end);subst;repeat (match goal with
                   | [ H : is_true (?a != ?a_) |- _ ] => rewrite eqxx in H;done

                  end).

Let inE := (inE, eqxx,negb_or,negb_and).

Fixpoint compose {A B C : Type} (aa : seq A) (bb : seq B) (r : A -> B -> C) :=
match aa with
| nil => nil
| a::aa' => (map (r a) bb) ++ (compose aa' bb r)
end.

Lemma mem_compose : forall (A B C : eqType) (aa : seq A) (bb : seq B) (a : A) (b : B) (r : A -> B -> C), a \in aa -> b \in bb -> r a b \in compose aa bb r.
Proof. move => A B C. elim;intros. done.
simpl. rewrite mem_cat. rewrite !inE in H0. destruct (orP H0). rewrite (eqP H2). apply/orP.
left. apply/map_f. done. apply/orP. right. apply/H. done. done.
Qed.

Lemma mem_compose2 : forall (A B : eqType) aa bb (a : A) (b : B),   pair a b \in compose aa bb pair ->  a \in aa /\ b \in bb.
Proof. move => A B. elim;intros. done.
move : H0=>/=. rewrite mem_cat. move/orP. case. move/mapP=>[] //=. intros. inversion q. subst. rewrite inE //= eqxx. lia.
move/H. case. rewrite inE. move=>->. ssa. lia.
Qed.

Lemma mem_zip : forall (A B: eqType) l0 l1  (a : A) (b : B),  (a,b) \in zip l0 l1 -> a \in l0 /\ b \in l1.
Proof.
move => A B.
elim.  intros. destruct l1.  done. done.
intros. destruct l1.  simpl in H0. done. simpl in H0. rewrite inE in H0. destruct (orP H0). move : (eqP H1). case. intros. subst.
rewrite inE eqxx /=. ssa. rewrite eqxx //=.
apply H in H1. ssa.
rewrite H1. lia. rewrite H2. lia.
Qed.

Arguments rem {_}.
Fixpoint rep_rem {A : eqType} (xs l : seq A) :=
match xs with
| nil => l
| x::xs' => rem x (rep_rem xs' l)
end.

Lemma mem_rem : forall (A : eqType) l' (a a' : A), a != a' -> a \in l' ->  a \in rem a' l'.
Proof.
move => A.
elim. done.
intros. simpl. case_if. move : H2. move/eqP=>HH. subst. rewrite inE in H1.
move : H1. move : (negbTE H0)=>-> //=.
move : H1.
rewrite !inE. move/orP. case. move=>-> //=. move/H=>->. lia. done.
Qed.

Lemma mem_rem2 : forall (A : eqType) l' (a a' : A), a != a' -> a \in rem a' l'  -> a \in l'.
Proof.
move => A.
elim. done.
intros. simpl in H1. move : H1. case_if. rewrite inE. move=>->. lia.
rewrite inE. move/orP=>[]. move/eqP=>->. done.
move/H. rewrite inE. move=>->. lia. lia.
Qed.

Lemma mem_rep_rem : forall (A : eqType) l l' (a : A), a \notin l -> a \in l' ->  a \in rep_rem l l'.
Proof.
move => A. elim. done.
intros. simpl. rewrite inE negb_or in H0. ssa. apply/mem_rem. done. auto.
Qed.

Lemma mem_rep_rem2 : forall (A : eqType) l l' (a : A), a \in rep_rem l l' -> a \notin l -> a \in l'.
Proof.
move => A. elim. done.
intros. simpl. rewrite inE negb_or in H1. ssa.
apply mem_rem2 in H0.  auto. lia.
Qed.

Lemma mem_rep_iff : forall (A : eqType) l l' (a : A),  a \notin l  -> a \in l'  <-> a \in rep_rem l l'.
Proof.
move => A.
intros. split;intros. apply/mem_rep_rem;auto.
apply/mem_rep_rem2;eauto.
Qed.

Definition next_closed {A: eqType} (l : seq A) (next : A -> seq A) := forall a a', a \in l -> a' \in next a -> a' \in l.
Definition unf_closed {A: eqType} (l : seq A) (unf : A ->  A) := forall a, a \in l -> unf a \in l.

Lemma closed_next_fin_next : forall (A : eqType) l (f : A -> seq A) , next_closed l f -> (adhoc_seq_sub_finType l) ->
seq  (adhoc_seq_sub_finType l).
Proof.
intros. destruct X.
move : ssvalP.  move/H=>HH. clear H.
elim : (f ssval) HH. intros. exact nil.
intros. simpl. apply cons. econstructor. apply/HH. rewrite inE.   apply/orP. left. apply eqxx.
apply/X. intros
apply cons.  apply/HH. rewrite inE cons. lia.
Defined.

CoInductive coseq (A : Type) : Type :=  conil : coseq A | cocons : A -> coseq A -> coseq A.

Arguments coseq _.
Arguments conil {_}.
Arguments cocons {_}.

Lemma coseq_match : forall {A : Type} (g : coseq A), g = match g with | conil  => conil | cocons a b => cocons a b end.
Proof. move => A[] //=. Qed.

Inductive forall_gen {A B : Type} (P : A -> B -> Prop)  (R : coseq A -> coseq B -> Prop)  : coseq A -> coseq B -> Prop :=
| FEE_nil : forall_gen P R conil conil
| FEE_cons e0 e1 es0 es1 : P e0 e1 -> R es0 es1 -> forall_gen P R (cocons e0 es0) (cocons e1 es1).

Require Import Paco.paco.
Lemma forall_gen_mon (A B : Type) (P : A -> B -> Prop)  : monotone2 (forall_gen P).
Proof.
move => x y. intros. induction IN. constructor. constructor. done. auto.
Qed.

Hint Resolve forall_gen_mon : paco.

Lemma forall_gen_nil : forall (A B : Type) (r : coseq A -> coseq B -> Prop) (P : A -> B -> Prop), paco2 (forall_gen P) r conil conil.
Proof.
intros. pfold. constructor.
Qed.

Hint Resolve forall_gen_nil.

Definition ForallC {A B : Type} (P : A -> B -> Prop)  es0 es1 := paco2 (forall_gen P) bot2 es0 es1.

Lemma forall_gen_mon2 : forall (A B : Type) (P0 P1: A -> B -> Prop) (R0 R1 : coseq A -> coseq B -> Prop),
 R0 <2= R1 -> P0 <2= P1 ->  paco2 (forall_gen P0) R0 <2= paco2 (forall_gen  P1) R1.
Proof.
move => A B P0 P1 R0 R1.
pcofix CIH.
intros. pfold. punfold PR. induction PR.  constructor.
constructor. auto. inversion H2. right. apply/CIH. auto. done.
done. auto.
Qed.

Lemma forall_genF_mon2 : forall (A B : Type) (P0 P1: A -> B -> Prop) (R0 R1 : coseq A -> coseq B -> Prop),
 R0 <2= R1 -> P0 <2= P1 ->  (forall_gen P0) R0 <2= (forall_gen  P1) R1.
Proof.
move => A B P0 P1 R0 R1.
intros. induction PR. constructor. constructor. auto. auto.
Qed.

CoFixpoint to_coseq {A: Type} (l : seq A) : coseq A :=
match l with
| nil => conil
| cons a l' => cocons a (to_coseq l')
end.

Coercion to_coseq : seq  >-> coseq.

Definition ForallC1 {A : Type} (P : A ->  Prop) aa := paco2 (forall_gen (fun a _ => P a)) bot2 aa aa.

Inductive CoIn {A : Type} (eq : A -> A -> Prop) :  A -> coseq A -> Prop :=
| CoInC1 a a' l : eq a  a' ->  CoIn eq a (cocons a' l)
| CoInC2 a a' l : CoIn eq a l ->  CoIn eq a (cocons a' l).

Notation "x <<( U ) R >> y" := (paco2 R U x y)(at level 10, R at next level).
Notation "x << R >> y" := (paco2 R bot2 x y)(at level 10, R at next level).

Ltac coseq_tac := rewrite (coseq_match (to_coseq _)) /=.
Ltac coseq_tac_in H := rewrite (coseq_match (to_coseq _)) /= in H.

Lemma cocons_coerce : forall (A : Type) (e0 : A) (es0 : coseq A) (es : seq A), cocons e0 es0 = to_coseq es -> exists es', es = e0::es' /\ to_coseq es' = es0.
Proof.
move => A. intros. coseq_tac_in H. destruct es;try done. exists es. ssa.
inversion H.
done. inversion H. done.
Qed.

Lemma to_coseq_cons : forall (A: Type) (a : A) (e : seq A), to_coseq (a::e) = cocons a e.
Proof.
intros. coseq_tac. done.
Qed.

Lemma to_coseq_nil : forall (A: Type) , to_coseq (@nil A) = conil.
Proof.
intros. coseq_tac. done.
Qed.

Let coeq := (to_coseq_nil, to_coseq_cons).

Lemma forall_gen_refl : forall (A : Type) g r (P : A -> A -> Prop) , (forall x, P x x) -> g <<(r) (forall_gen P)  >>  g.
Proof.
intros. move : g. pcofix CIH.
case. pfold. constructor.
intros. pfold. constructor ;auto.
Qed.

Hint Resolve forall_gen_refl.

Lemma forall_gen_P_mon : forall (A  B : Type) (P0 P1 : A -> B -> Prop) l0 l1, l0 << (forall_gen P0) >> l1 ->  (forall a b, P0 a b -> P1 a b) -> l0 << (forall_gen P1) >> l1.
Proof.
intros. move : l0 l1 H. pcofix CIH.
intros.
pcofix CIH.
intros. punfold H1. inversion H1. done. pfold. constructor. auto. eauto.
right. apply/CIH. pclearbot. done.
Qed.

Ltac inv H := inversion H;subst.
Ltac pc := pfold;constructor;auto.
Ltac uis H := (try  punfold H);inversion H;subst;try pc;auto;pclearbot.
Ltac cauto := pclearbot;auto.

Fixpoint approx_coseq {A : Type} n (l : coseq A) :=
if n is n'.+1 then if l is cocons a l' then a :: (approx_coseq n' l') else nil else nil.

Definition co_nth {A : Type} (d : A) (l : coseq A) (n : nat) := nth d (approx_coseq n.+1 l) n.

Lemma index_ForallIC : forall {A : eqType} {B : Type} (l0 : seq A) (l1 : coseq B) a b n (R : A -> B -> Prop), ForallC R l0 l1 -> n < size l0 ->  R (nth a l0 n) (co_nth b l1 n).
Proof.
move => A B.  elim;intros. done.
ssa. destruct l1. punfold H0. inversion H0. rewrite coeq in H0. inv H0.
destruct n.
simpl. pclearbot. rewrite /co_nth /=. rewrite coeq in H0. uis H0.
simpl. have :  (co_nth b (cocons b0 l1) n.+1) =  (co_nth b l1) n.   rewrite /co_nth /=. done. move=>->.
apply H. rewrite coeq in H0. uis H0. done. auto.
Qed.

Lemma forall_gen_mon_coerce : forall (A  B : Type) (aa : seq A) (bb : coseq B) (P0 P1 : A -> B -> Prop) (R0 R1 : coseq A -> coseq B -> Prop),
(forall a b, P0 a b -> P1 a b) ->
(forall (x0 : seq A) (x1 : coseq B), R0 x0 x1 -> R1 x0 x1) ->  paco2 (forall_gen P0) R0 aa bb  -> paco2 (forall_gen P1) R1 aa bb.
Proof.
move => A B. elim. intros. destruct bb. pfold.
rewrite (coseq_match (to_coseq _)) /=. constructor.
coseq_tac_in H1. punfold H1. inversion H1.
intros. destruct bb. coseq_tac_in H2. punfold H2. inversion H2.
coseq_tac_in H2. punfold H2. inversion H2. subst.
coseq_tac. pfold. constructor. auto.
inversion H8. left. apply/H. 2: { eauto. } eauto. done. right. auto.
Qed.

Lemma monotone_comp1 : forall (A : Type) (F0 F1 : (A  -> Prop) -> (A  -> Prop)),  monotone1 F0 -> monotone1 F1 -> monotone1 (F0 \o F1).
Proof. intros. move => x0 x1. intros. apply/H. eauto. eauto.
Qed.

Lemma monotone_comp : forall (A B : Type) (F0 F1 : (A -> B -> Prop) -> (A -> B -> Prop)),  monotone2 F0 -> monotone2 F1 -> monotone2 (F0 \o F1).
Proof. intros. move => x0 x1. intros. apply/H. eauto. eauto.  Qed.

Hint Resolve  monotone_comp1 monotone_comp : paco.

Definition idemp {A : Type} (f : A -> A) := forall a, f (f a) = f a.

Lemma rep_rem2 : forall (A : eqType) (l l0 l1 : seq A) a, a \notin l -> (forall x, x \in l0 -> x \in l1) ->a \in rep_rem l l0  -> a \in rep_rem l l1.
Proof.
move => A. elim.
simpl. intros. auto.
simpl.  ssa. rewrite inE negb_or in H0.  ssa.
apply/mem_rem. done. apply/H.  done. eauto. apply/mem_rem2. eauto. done.
Qed.

Lemma rep_rem_uniq : forall (A : eqType) (l l' : seq A), uniq l' -> uniq (rep_rem l l').
Proof.
move => A.
elim.  done.
intros. simpl. rewrite rem_uniq. done. auto.
Qed.

Lemma size_strict_sub : forall (A : eqType) (l l' : seq A) a, uniq l  -> (forall x, x \in l -> x \in l') -> a \notin l -> a \in l' -> size l < size l'.
Proof.
intros.
have : size (a::l) <= size l'.
apply/uniq_leq_size. ssa. move => x0 x1.
rewrite inE in x1. destruct (orP x1). rewrite (eqP H3). done. auto. done.
Qed.

Lemma rem_uniq2 : forall (A: eqType) (l'  : seq A) a x, uniq l' -> x <> a -> x \notin l' ->   x \notin rem a l'.
Proof.
move => A.
elim. done.
intros. ssa. case_if.
rewrite inE negb_or in H2. ssa.
rewrite inE negb_or. ssa. rewrite inE negb_or in H2. ssa.
apply/H. ssa.
done. rewrite inE negb_or in H2. ssa.
Qed.

Lemma rep_rem_uniq2 : forall (A: eqType) (l l' : seq A) x, uniq l' ->  x \in l -> x \notin rep_rem l l'.
Proof.
move => A.
elim. done.
intros. rewrite inE in H1.
destruct (eqVneq x a).   subst.

simpl. rewrite mem_rem_uniqF. done. apply/rep_rem_uniq. done.
simpl. simpl in H1. apply/rem_uniq2. apply/rep_rem_uniq. done. apply/eqP. done.
auto.
Qed.

Ltac con := constructor.

Definition comap' {A B : Type} (f0 : coseq A ->  coseq B) (f : A -> B) (l : coseq A) :=
match l with
| conil => conil
| cocons a l' => cocons (f a) (f0 l')
end.

Lemma comap'_eq : forall A B (f0 : coseq A -> coseq B) f l, comap' f0 f l = (match l with
| conil => conil
| cocons a l' => cocons (f a) (f0 l')
end).
Proof.
intros. rewrite /comap'. done.
Qed.

Definition comap {A B : Type} (f : A -> B) :=
 cofix comap (l : coseq A) : coseq B := comap' comap f l.

Lemma comap_eq : forall A B (f : A -> B) l, comap f l = comap' (comap f) f l.
Proof.
intros. rewrite /comap.  rewrite (coseq_match  (_ l)).
destruct (comap' (cofix comap (l0 : coseq A) : coseq B := comap' comap f l0) f l). done. done.
Qed.

Let comap_eqs := (comap'_eq, comap_eq).

Variant ApplyF {A B : Type} (fa : A -> A) (fb : B -> B) (R : A -> B  -> Prop) : A -> B  -> Prop :=
 Unf_intro a b :  R (fa a) (fb b) -> ApplyF fa fb R a b.

Lemma ApplyF_mon A B fa fb  : monotone2 (@ApplyF A B fa fb).
Proof. intro. intros. inv IN. con. eauto. Qed.

Hint Resolve ApplyF_mon : paco.

Variant ApplyF1 {A : Type} (f : A -> A) (R : A ->  Prop) : A  -> Prop :=
    Unf1_intro : forall (a : A), R (f a) -> ApplyF1 f R a.
Hint Constructors ApplyF1.

Lemma ApplyF1_mon (A : Type) (f : A -> A)  : monotone1 (ApplyF1 f).
Proof. intro. intros. con. inv IN. eauto.
Qed.

Hint Resolve ApplyF1_mon : paco.

Notation R_pair := (fun P p => P p.1 p.2).

Lemma coerce_forall : forall (A B : Type) (P : A -> B -> Prop) l0 l1, (to_coseq l0) << (forall_gen P) >> l1 -> exists l', size l0 = size l' /\ to_coseq l' = l1 /\ Forall (R_pair P) (zip l0 l').
Proof.
move => A B P.
elim;intros. rewrite coeq in H. uis H. exists nil. ssa. rewrite coeq //=.
uis H0. rewrite coeq in H2. done.
rewrite coeq in H1. inv H1. apply H in H3. destruct H3. ssa.
exists (e1::x). ssa. rewrite !coeq. f_equal. done.
Qed.

Lemma coerce_forall2 : forall (A B : Type) (P : A -> B -> Prop) l0 l1,  size l0 = size l1 -> Forall (R_pair P) (zip l0 l1) -> (to_coseq l0) << (forall_gen P) >> (to_coseq l1).
Proof.
move => A B P.
elim;intros. destruct l1. rewrite !coeq. auto.  done.
destruct l1. done. rewrite !coeq. inv H1.  simpl in *. pc.
Qed.

Lemma Forall_ForallC : forall (A B : Type) (l0 : seq A) (l1 : seq B) P, size l0 = size l1 -> Forall (R_pair P) (zip l0 l1)  -> (to_coseq l0) << (forall_gen P) >> (to_coseq l1).
Proof.
move => A B. elim. case. intros. rewrite !coeq. auto.
done.
move => a l IH [];first done. intros. rewrite !coeq.  inv H0.
pc.
Qed.

Lemma In_zip : forall (A B : Type) (a : A) l (l1 : seq B), In a l -> size l = size l1 -> exists a1, In a1 l1 /\ In (a,a1) (zip l l1).
Proof.
move => A B a. elim=> [] //=.
move => a0 l IH [] //= a1 l0 [ -> [Hsize ] |  Hin [Hsize] ].
- exists a1=>//=. ssa.
- move : (IH _ Hin Hsize)=>[] x [] Hin2 Hin3. exists x. ssa.
Qed.

Lemma In_zip2 : forall (A B : Type) (a1 : B) (l : seq A) (l1 : seq B), In a1 l1 -> size l = size l1 -> exists a, In a l /\ In (a,a1) (zip l l1).
Proof.
move => A B a1. elim=> [] //=. move=>[] //=.
move => a l IH [] //= a0 l0 [ -> [Hsize ] |  Hin [Hsize] ].
- exists a=>//=. ssa.
- move : (IH _ Hin Hsize)=>[] x [] Hin2 Hin3. exists x. ssa.
Qed.

Lemma to_coseq_inj : forall  (A : Type) (l0 l1 : seq A), to_coseq l0 = to_coseq l1 -> l0 = l1.
Proof.
move => A. elim. case. done. intros. rewrite !coeq in H. done.
intros. destruct l1. rewrite !coeq in H0. done.
rewrite !coeq in H0.  inv H0.
f_equal. auto.
Qed.

Ltac injt := match goal with
                   | [ H : to_coseq _ = to_coseq _ |- _ ] => apply to_coseq_inj in H;subst
                  end.

Definition Forall_consP := List.Forall_cons_iff.
Definition ForallP := List.Forall_forall.
Ltac forallApp H1 H2 := move : H1; move/[dup]/ForallP  => /(_ _ H2).


Require Import core fintype.
Import ScopedNotations.
From Chapter9 Require Export wn.

(** ** Schäfer's Expression Relation *)

Inductive E_strong' {m} (L_A : tm m -> Prop) (s : tm m) :  Prop :=
 | E_strong_In  : (value s -> L_A s) -> (forall s', step s s' -> E_strong' L_A s') -> E_strong' L_A s.

(** Logical relation for lambda expressions *)
Fixpoint L_strong {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun _ => True
  | Fun A1 A2 => fun e => match e with
                      |  (lam B s) => forall k (xi: fin m -> fin k) v, E_strong' (L_strong A1) v -> E_strong' (L_strong A2) (subst_tm (v .: (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Definition E_strong {m} (A : ty) : tm m -> Prop :=
  E_strong' (L_strong A).

Lemma E_strong_sn {m} (s : tm m) A:
  E_strong A s -> sn step s.
Proof.
  induction 1. constructor. intros s' HH. eauto.
Qed.

Lemma E_strong_step {m} (s: tm m) L_A :
  E_strong' L_A s -> forall s', step s s' -> E_strong' L_A s'.
Proof.
 induction 1; eauto.
Qed.

Lemma E_strong_base {m} (s: tm m) A :
  value s -> E_strong A s -> L_strong A s.
Proof.
  intros C []; eauto.
Qed.

Lemma E_strong_var {m} A (x: fin m) :
  E_strong A (var_tm x).
Proof.
  constructor; eauto.
  - cbn. contradiction.
  - intros. inversion H.
Qed.

Definition G_strong {k m} (Gamma : ctx k) : (fin k -> tm m)  -> Prop :=
  fun σ => forall (x : fin k), E_strong (Gamma x) (σ x) .

Definition has_ty_sem_strong {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G_strong Gamma sigma -> E_strong A (subst_tm sigma s).

Lemma L_close_ren_lam m n (xi: fin m -> fin n) s A :
  L_strong A s -> L_strong A (ren_tm xi s).
Proof.
  induction A; eauto.
  destruct s; try contradiction.
  subst. intros. cbn in *. intros. asimpl.
  eauto.
Qed.

Lemma close_ren  :
  (forall m n (xi: fin m -> fin n) s A, E_strong A s -> E_strong A (ren_tm xi s)).
Proof.
  intros. induction H.
  constructor; eauto. intros.
  assert (value s) by (now destruct s).
  specialize (H H3). now apply L_close_ren_lam.
  intros. apply step_naturality in H2. destruct H2 as (?&?&?); subst.
  apply H1; eauto.
Qed.

Lemma value_anti_renaming_lam m n s (xi: fin m -> fin n) :
  value (ren_tm xi s) -> value s.
Proof.
  destruct s;  eauto.
Qed.

Lemma sn_fundamental m Gamma (s: tm m) A :
  has_type Gamma s A -> has_ty_sem_strong Gamma s A.
Proof.
  intros C. induction C as [x | n Gamma A B s H IH | n Gamma A B s t H IH H' IH'].
  - unfold has_ty_sem_strong. intros. cbn. apply H.
  - intros k sigma ctx. cbn.
    assert (sn step (subst_tm (up_tm_tm sigma) s)).
    { eapply E_strong_sn. unfold has_ty_sem_strong in IH. apply IH.
      intros [|]; intros.
      - cbn. unfold funcomp. apply close_ren. eauto.
      - cbn. apply E_strong_var. }
    remember (subst_tm (up_tm_tm sigma) s) as s'.
    unfold has_ty_sem_strong in IH.
    assert (forall m (tau : fin (S k) -> tm m), G_strong (A .: Gamma) (up_tm_tm sigma >> subst_tm tau) -> E_strong B (subst_tm tau s')).
    { intros. rewrite Heqs'. revert H1. asimpl.  eauto.  }
    clear Heqs'.
    induction H0. constructor.
    + intros V m . intros. apply H1.
      intros [|]; intros; cbn; eauto.
      * unfold funcomp. asimpl.
        (* a.d.: I had to add the following line so that renamify works *)
        change (fun x0 : fin k => @var_tm m (xi x0)) with (funcomp var_tm xi).
        renamify. eauto.
        eapply close_ren. eauto.
    + intros. inv H3.
      apply H2; eauto.
      intros. specialize (H1 _ _ H4). eapply E_strong_step; eauto.
      eauto using step_inst.

  - intros k sigma D.
    specialize (IH _ _ D). specialize (IH' _ _ D).
    cbn.
    remember (subst_tm sigma s) as s'. remember (subst_tm sigma t) as t'.
    apply E_strong_sn in IH as IH1'. apply E_strong_sn in IH' as IH2'.
    clear s t Heqs' Heqt' H H'.
    revert t' IH' IH2'. induction IH1' as [s].
    intros t' IH2 IH2'. induction IH2' as [t].
    constructor.
    + contradiction.
    + intros ? HH. inv HH; eauto using E_strong_step.
      * apply E_strong_base in IH.
       -- cbn in IH.
          specialize (IH _ id t). eapply IH.
        assumption.
       -- reflexivity.
     * apply H0; eauto. eapply E_strong_step; eauto.
     * apply H2; eauto. eapply E_strong_step; eauto.
Qed.

Lemma sn (Gamma : fin 0 -> ty) (s: tm 0) A:
  has_type Gamma s A -> sn step s.
Proof.
  intros H%sn_fundamental.
  unfold has_ty_sem_strong in H.
  replace s with (s[ids]) by (now asimpl).
  eapply E_strong_sn. eapply H. intros [].
Qed.


Goal forall X Y : Prop, X -> Y -> X.

Proof.
    exact (fun X Y A B => A).
Qed.

Goal forall X Y Z : Prop, (X-> Y) -> (Y -> Z) -> (X -> Z).

Proof.
  exact (fun X Y Z A B C => B (A C)). Show Proof.
Qed.

Lemma lemS : forall X Y Z : Prop, (X -> Y -> Z) -> (X -> Y) -> X -> Z.

Proof.
    intros X Y Z A B C. apply A. Show Proof.
    - exact C.  Show Proof.
    - apply B, C. Show Proof.
Qed.

Print lemS.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Lemma invert_encode_I_shift_57: forall {opcode rd rs1 shamt5 funct3 funct7},
  verify_I_shift_57 opcode rd rs1 shamt5 funct3 funct7 ->
  forall inst,
  encode_I_shift_57 opcode rd rs1 shamt5 funct3 funct7 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  funct7 = bitSlice inst 25 32 /\
  rd = bitSlice inst 7 12 /\
  rs1 = bitSlice inst 15 20 /\
  shamt5 = bitSlice inst 20 25.
Proof. intros. unfold encode_I_shift_57, verify_I_shift_57 in *. prove_Zeq_bitwise. Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

From MuRec Require Import sigma relations arith_mini between.

Section linear_search.

  (* P and Q are two predicates on nat which are
     incompatible (over Dtest). For instance if
     b : nat → bool, then we could choose

            P n := b n = true
        and Q n := b n = false

     but we intentionnally do NOT require totality
     of P and Q here.

     We only require totality over Dtest, see "test" below *)

  Variables (Dtest P Q : nat → Prop)
            (PQ_abs : ∀{n}, Dtest n → P n → Q n → False).

  (* 𝔻ls : nat → Prop reads as "𝔻(omain of) l(inear) s(earch)"

     The predicate 𝔻ls n characterizes inductively the n such
     that for some m above n, P m holds, and Dtest holds on [n,m] *)

  Inductive 𝔻ls n : Prop :=
  | 𝔻ls_stop : (Dtest ∧₁ P) n → 𝔻ls n
  | 𝔻ls_next : Dtest n → 𝔻ls (S n) → 𝔻ls n.

  Arguments 𝔻ls_stop {_}.
  Arguments 𝔻ls_next {_}.

  Definition 𝔻ls_π₁ {n} (d : 𝔻ls n) : Dtest n :=
    match d with
    | 𝔻ls_stop ⟨t,_⟩ₚ => t
    | 𝔻ls_next  t _   => t
    end.

  (* This projection 𝔻ls_π₂ : ∀n, 𝔻ls n → Q n → 𝔻ls (S n)
     is used *critically* for termination in the Coq

       Fixpoint loop _ (d : 𝔻 _) ... { struct d } :=
             ... loop (𝔻ls_π₂ d q) ...

     below. Indeed, 𝔻ls_π₂ d q : 𝔻ls (S n) is a sub-term
     of d : 𝔻ls n. Hence it satisfies the guardedness condition
     of the termination checker.

     We insist that the exact term here is *essential* because the
     guardedness condition is *not* compositional. *)

  Definition 𝔻ls_π₂ {n} (d : 𝔻ls n) : Q n → 𝔻ls (S n) :=
    match d with
    (* An (empty) match on _ : False is a sub-term (of anything) *)
    | 𝔻ls_stop ⟨t,p⟩ₚ => λ q, match PQ_abs t p q with end
    (* dₛ : 𝔻ls (S n) is a sub-term of 𝔻ls_next _ dₛ : 𝔻ls n *)
    | 𝔻ls_next _ dₛ   => λ _, dₛ
    end.

  (* The existence of n such that ℙre_ls s n is
     the pre-condition for a terminating
     linear search starting at s *)
  Definition ℙre_ls s := (Dtest ∧₁ P) ∧₁ btwn Dtest s.

  (* The value n such that ℙost_ls s n characterizes,
     as a post-condition, the output value of linear
     search starting at s *)
  Definition ℙost_ls s := (Dtest ∧₁ P) ∧₁ btwn (Dtest ∧₁ Q) s.

  (* The pre-condition is enough the show that s belongs
     to the inductive domain predicate, ensurring termination
     on input s of the fixpoint loop below *)
  Lemma ℙre_ls_𝔻ls {s} : (∃n, ℙre_ls s n) → 𝔻ls s.
  Proof.
    intros (n & tp & b).
    generalize (𝔻ls_stop tp). apply btwn_ind.
    revert b. apply btwn_monotonic.
    exact @𝔻ls_next.
  Qed.

  (* test is specified by ∀n, Dtest n → {P n} + {Q n}
     so it is possible that neither P nor Q hold outside of Dtest *)
  Variable test : ∀n, Dtest n → {P n} + {Q n}.

  (* loop_ℕ : ∀n, 𝔻ls n → nat

     with inductive domain predicate d : 𝔻ls n
     implements linear search and computes the first m
     such that P m, starting the search at n,
     but without proving this post-condition.

     Notice that it is a "recursive terminal" function. *)

  Local Fixpoint loop_ℕ n (d : 𝔻ls n) : nat :=
    match test n (𝔻ls_π₁ d) with
    | left p  => n
    | right q => loop_ℕ (S n) (𝔻ls_π₂ d q)
    end.

  (* In order to have a meaningful post-condition,
     we now fix a starting point of linear search *)
  Variable s : nat.

  (* loop : ∀n, 𝔻ls n → btwn (Dtest ∧₁ Q) s n → {x | ℙost_ls s x}

     with inductive domain predicate d : 𝔻ls n
     and invariants b : btwn (Dtest ∧₁ Q) s
     implements linear search and computes the least m greater or equal
     to s such that P m, starting the search at n.

     It is still written as a "recursive terminal" function, including
     with respect to the computation of the proof of the post-condition. *)

  Let Fixpoint loop n (d : 𝔻ls n) (b : btwn (Dtest ∧₁ Q) s n) : sig (ℙost_ls s) :=
    let t := 𝔻ls_π₁ d in
    match test n t with
    | left p  => ⟪n, ⟨t,p, b⟩ₚ⟫
    | right q => loop (S n) (𝔻ls_π₂ d q) (btwn_next b ⟨t,q⟩ₚ)
    end.

  (* Wrapping up to get fully spec'd linear search algorithm,
     specifications expressed the language of FO arithmetic.
     From the (non-informative) existence of a value n above s
     which satisfies
                P n ∧ Dtest s ∧ ... ∧ Dtest n
     we compute a value m, above s and minimal in the sense that,
          P m ∧ Dtest s ∧ ... ∧ Dtest m ∧ Q s ∧ ... ∧ Q (m-1)
     Indeed, remember that P and Q are incompatible on Dtest.

     Notice, that it is perfectly possible that after m, neither
     P nor Q hold, because Dtest wouldn't be satisfied. *)

  Definition linear_search : (∃ n, ℙre_ls s n) → { m | ℙost_ls s m } :=
    λ e, loop s (ℙre_ls_𝔻ls e) btwn_refl.

End linear_search.

Arguments linear_search {_ _ _}.


(* File: Division.v *)
(* Author: Peter Urbak <peter@dragonwasrobot.com> *)
(* Version: 2012-04-12 *)

(* Implementation of euclidean division. *)

(* Fixpoints *)

Fixpoint dividend_greater_than_diviser_p
  (dividend diviser : nat) : option nat :=
  match dividend, diviser with
      | _, O => Some dividend
      | O, S _ => None
      | S dividend', S diviser'
        => dividend_greater_than_diviser_p dividend' diviser'
  end.

Fixpoint quotient_and_remainder_aux
  (dividend divisor quotient bogus_but_decreasing : nat) : option (nat * nat) :=
    match bogus_but_decreasing with
      | O => None
      | S bogus_but_decreasing' =>
        match dividend_greater_than_diviser_p dividend divisor with
          | None => Some (quotient, dividend)
          | Some dividend' =>
            quotient_and_remainder_aux
            dividend' divisor (S quotient) bogus_but_decreasing'
        end
    end.

Definition quotient_and_remainder (dividend divisor : nat) : option (nat * nat) :=
  match divisor with
    | O => None
    | S _ => quotient_and_remainder_aux dividend divisor 0 (S dividend)
  end.

Definition division (n m : nat) : option (nat * nat) :=
  quotient_and_remainder n m.

Notation "x / y" := (division x y)
  (at level 40, left associativity).

(* The correctness of the division function will not be proved. *)

(* end-of-Division.v *)


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

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

Require Import astCast.
Require Import confluenceCast.

Notation "Gamma `_ i" := (dget Gamma i) (at level 2).

Reserved Notation "[ Gamma |- ]".
Reserved Notation "[ Gamma |- s :- A ]".

(* TODO reorder constructors to mach paper *)
Inductive has_type : list term -> term -> term -> Prop :=
| ty_tt Gamma :
  [ Gamma |- TT :- TT ]
| ty_var Gamma x :
  x < size Gamma ->
  [ Gamma |- Var x :- Gamma`_x ]
| ty_pi Gamma A B :
  [ Gamma |- A :- TT ] ->
  [ A :: Gamma |- B :- TT ] ->
  [ Gamma |- Pi A B :- TT ]
| ty_fun Gamma A B s :
  [ Gamma |- Pi A B :- TT ] ->
  [ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ] ->
  [ Gamma |- Fun s :- Pi A B ]
| ty_app Gamma A B f a :
  [ Gamma |- f :- Pi A B ] ->
  [ Gamma |- a :- A ] ->
  [ Gamma |- App f a :- B.[a/] ]
| ty_cast Gamma A A' s o :
  [ Gamma |- A' :- TT ] ->
  [ Gamma |- A :- TT ] ->
  [ Gamma |- s :- A' ] ->
  [ Gamma |- Cast s A' A o :- A ]
| ty_conv Gamma A B s :
  A === B ->
  [ Gamma |- s :- A ] ->
  [ Gamma |- s :- B ]
where "[ Gamma |- s :- A ]" := (has_type Gamma s A).

Inductive context_ok : list term -> Prop :=
| ctx_nil : [ [::] |- ]
| ctx_ncons Gamma A :
  [ Gamma |- A :- TT ] ->
  [ Gamma |- ] ->
  [ A :: Gamma |- ]
where "[ Gamma |- ]" := (context_ok Gamma).

Notation "[ Gamma |- t ]" := [ Gamma |- t :- TT ].
Notation "[ Delta |- sigma -| Gamma ]" :=
  (forall x, x < size Gamma ->
    [ Delta |- sigma x :- (Gamma `_ x).[ sigma : _ -> _ ] ]).

(* TODO would preffer a mutually inductive definition *)
(* TODO when has_ty, ty matches up to === *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Require Import utils.

Set Implicit Arguments.

Section subcode.

  Variable (X : Type).

  Definition code := (nat * list X)%type.

  Implicit Type P : code.

  Definition code_start P := fst P.
  Definition code_end P := fst P + length (snd P).
  Definition code_length P := length (snd P).

  Definition in_code i P := code_start P <= i < code_end P.
  Definition out_code i P := i < code_start P \/ code_end P <= i.

  Fact in_out_code i P : in_code i P -> out_code i P -> False.
  Proof. unfold in_code, out_code; omega. Qed.

  Definition subcode P Q :=
    match P, Q with (i,li), (n,code) => exists l r, code = l ++ li ++ r /\ i = n+length l end.

  Arguments code_start P /.
  Arguments code_end P /.
  Arguments code_length P /.
  Arguments in_code i P /.
  Arguments out_code i P /.
  Arguments subcode P Q /.

  Fact in_out_code_dec i P : { in_code i P } + { out_code i P }.
  Proof. destruct P as (n,c); simpl; apply interval_dec. Qed.

  Infix "<sc" := subcode (at level 70, no associativity).

  Fact subcode_cons_inj i ρ δ P : (i,ρ::nil) <sc P -> (i,δ::nil) <sc P -> ρ = δ.
  Proof.
    destruct P as (j, P).
    intros (l1 & r1 & H1 & H2) (l2 & r2 & H3 & H4).
    rewrite H1 in H3.
    apply list_app_inj, proj2 in H3; try omega.
    inversion H3; trivial.
  Qed.

  Fact subcode_length P Q : P <sc Q -> code_start Q <= code_start P /\ code_end P <= code_end Q.
  Proof.
   destruct P as (iP,cP); destruct Q as (iQ,cQ); simpl.
   intros (l & r & H1 & H2).
   apply f_equal with (f := @length _) in H1.
   revert H1; rew length; split; omega.
  Qed.

  Fact subcode_length' P Q : P <sc Q -> length (snd P) <= length (snd Q).
  Proof.
    revert P Q; intros [] [] (? & ? & ? & ?); simpl; subst; rew length; omega.
  Qed.

  Fact subcode_length_le : forall P Q, P <sc Q -> fst Q <= fst P
                                               /\ fst P + length (snd P) <= fst Q + length (snd Q).
  Proof.
    intros (iP,cP) (iQ,cQ) (l & r & ? & ?); subst; simpl; rew length; omega.
  Qed.

  Fact subcode_start_in_code : forall P Q, 0 < code_length P -> P <sc Q -> in_code (code_start P) Q.
  Proof.
    intros (iP,cP) (iQ,cQ) H (l & r & H1 & H2); simpl in *; subst; revert H; rew length; intro; omega.
  Qed.

  Fact subcode_refl P : P <sc P.
  Proof.
    destruct P; exists nil, nil; split; simpl.
    rewrite <- app_nil_end; auto.
    omega.
  Qed.

  Fact subcode_trans P Q R : P <sc Q -> Q <sc R -> P <sc R.
  Proof.
    revert P Q R; intros (iP,cP) (iQ,cQ) (iR,cR).
    intros (ll1 & rr1 & H1 & H2) (ll2 & rr2 & H3 & H4); subst.
    exists (ll2++ll1), (rr1++rr2); split.
    solve list eq.
    rew length; omega.
  Qed.

  Fact subcode_in_code P Q i : P <sc Q -> in_code i P -> in_code i Q.
  Proof.
    revert P Q; intros (iP,cP) (iQ,cQ) (l & r & H1 & H2); simpl.
    subst; rew length; omega.
  Qed.

  Fact subcode_out_code P Q i : P <sc Q -> out_code i Q -> out_code i P.
  Proof.
    revert P Q; intros (iP,cP) (iQ,cQ) (l & r & H1 & H2); simpl.
    subst; rew length; omega.
  Qed.

  Fact subcode_left n m l r : n = m -> (n,l) <sc (m,l++r).
  Proof. exists nil, r; simpl; split; auto; omega. Qed.

  Fact subcode_right n m l r : n = m+length l -> (n,r) <sc (m,l++r).
  Proof.
    exists l, nil; split; auto.
    rewrite <- app_nil_end; auto.
  Qed.

  Fact subcode_app_end P n l r : P <sc (n,l) -> P <sc (n,l++r).
  Proof.
    intros; apply subcode_trans with (1 := H).
    exists nil, r; auto.
  Qed.

  Fact subcode_cons P n x l : P <sc (1+n,l) -> P <sc (n,x::l).
  Proof.
    intros; apply subcode_trans with (1 := H).
    exists (x::nil), nil; split.
    solve list eq.
    rew length; omega.
  Qed.

  Fact in_code_subcode i P : in_code i P -> exists a, (i,a::nil) <sc P.
  Proof.
    destruct P as (iP,cP); simpl; intros H.
    destruct (list_split_length cP) with (k := i-iP) as (l & [ | a r ] & H1 & H2).
    omega.
    exfalso; subst; solve list eq in H; omega.
    exists a, l, r; split; auto; omega.
  Qed.

  Fact subcode_app_invert_right j Q1 Q2 i I :
        (i,I::nil) <sc (j,Q1++Q2) -> (i,I::nil) <sc (j,Q1)
                                  \/ (i,I::nil) <sc (length Q1+j,Q2).
  Proof.
    intros (l & r & H1 & H2); simpl in *.
    apply list_app_cons_eq_inv in H1.
    destruct H1 as [ (m & G1 & G2) | (m & G1 & G2) ]; subst.
    + right; exists m, r; rew length; split; auto; omega.
    + left; exists l, m; rew length; split; auto; omega.
  Qed.

  Fact subcode_cons_invert_right j J Q i I :
        (i,I::nil) <sc (j,J::Q) -> i = j /\ I = J
                                \/ (i,I::nil) <sc (S j,Q).
  Proof.
    intros ([ | K l ] & r & H1 & H2); simpl in *.
    + inversion H1; left; split; auto; omega.
    + right; inversion H1; exists l, r; split; auto; omega.
  Qed.

  Variable Q : code.

  Fact subcode_app_inv i j a l r : j = i+length l -> (i,l++a++r) <sc Q -> (j,a) <sc Q.
  Proof.
    intro; apply subcode_trans.
    exists l, r; auto.
  Qed.

  Fact subcode_cons_inv i j a r : j = i -> (i,a++r) <sc Q -> (j,a) <sc Q.
  Proof.
    intro; apply subcode_app_inv with (l := nil); simpl; omega.
  Qed.

  Fact subcode_snoc_inv i j a l : j = i+length l -> (i,l++a) <sc Q -> (j,a) <sc Q.
  Proof.
    intros H.
    apply subcode_trans.
    exists l, nil; split; auto.
    solve list eq.
  Qed.

  Fact subcode_cons_invert_left i I l : (i,I::l) <sc Q -> (i,I::nil) <sc Q /\ (S i,l) <sc Q.
  Proof.
    intros H1; split.
    + revert H1; apply subcode_cons_inv with (a := _::nil); auto.
    + revert H1; apply subcode_snoc_inv with (l := _::nil); simpl; omega.
  Qed.

End subcode.

Arguments code_start {X} P /.
Arguments code_end {X} P /.
Arguments in_code {X} i P /.
Arguments out_code {X} i P /.
Arguments subcode {X} P Q /.

Infix "<sc" := subcode (at level 70, no associativity).

(* Solve many subcode goals looking for a solution into hyps *)

Ltac subcode_tac :=
       unfold fst, snd;
       try match goal with | H: subcode (_,?l) ?c |- subcode (_,?i) ?c
            => (match i with ?j::nil => match type of H with context[j] => apply subcode_trans with (2 := H) end end ||
                match type of H with context[i] => apply subcode_trans with (2 := H) end)
       end;
       match goal with
         | |- subcode (_,?i) (_,?c) => focus_goal i c
       end;
       match goal with
         | |- subcode (_,?i::nil) (_,?l++?i::?r) => exists l, r
         | |- subcode _ (_,?l++_++?r)            => exists l, r
         | |- subcode (_,?i) (_,?l++?i)          => exists l, nil
       end;
       split; auto; rew length; try omega.

(* Add it to auto so that fam sss * will try it to solve the subcode goal it generates *)

Hint Extern 4 (subcode _ _) => subcode_tac.


About existT.
Print existT.
Print Implicit existT.

Print eq_refl.
About eq_refl.
Print Implicit eq_refl.

Print Nat.add.
About Nat.add.
Print Implicit Nat.add.

About plus_n_O.

Arguments le_S {n} [m] _.
Print le_S.

About comparison.
Print comparison.

Definition foo := forall x, x = 0.
Parameter bar : foo.

Arguments bar [x].
About bar.
Print bar.

About Peano. (* Module *)
About sym_eq. (* Notation *)

Arguments eq_refl {A} {x}, {A} x.
Print eq_refl.

Definition newdef := fun x:nat => x.

Goal forall n:nat, n <> newdef n -> newdef n <> n -> False.
  intros n h h'.
  About n.                              (* search hypothesis *)
  About h.                              (* search hypothesis *)
Abort.

Goal forall n:nat, let g := newdef in n <> newdef n -> newdef n <> n -> False.
  intros n g h h'.
  About g.                              (* search hypothesis *)
  About h.                              (* search hypothesis *)
Abort.