Require Import defns.

Require Import Arith.
Require Import List.

(** * Context shifting **)

(** decidability of context shifting **)

Lemma cs_nTy_dec:
  forall (A : nTy) (i : Ixc),
    { A' : nTy | cs_nTy A i A' }
with cs_nte_dec:
  forall (M : nte) (i : Ixc),
    {  M' : nte | cs_nte M i M' }.
Proof.
  - induction A; intros i.

    + eexists; constructor.
    + destruct IHA1 with i.
      destruct IHA2 with i.
      eexists; constructor; eauto.
    + destruct IHA with i.
      assert ({M' | cs_nte nte5 i M'})
        as [ ]
          by (apply cs_nte_dec).
      eexists; constructor; eauto.

  - (* cs_nte_dec *)
    induction M; intro i.

    + eexists; constructor.

    + (* case ixc *)
      assert ({i <= ixc} + {ixc < i})
        as [ ]
          by (apply le_lt_dec).
      * exists (termstar_nl_ixc (S ixc)).

          generalize dependent ixc.
          induction i.
          { intros; constructor. }
          {  intros.
             destruct ixc.
             - inversion l.
             - constructor.
               apply IHi.
               apply le_S_n; auto. }
      * exists (termstar_nl_ixc ixc).
          generalize dependent ixc.
          induction i.
          intros.
          { inversion l. }
          { intros.
            destruct ixc.
            - constructor.
            - constructor.
              apply IHi.
              apply lt_S_n; auto. }
    + eexists; constructor.
    + destruct IHM with i.
      assert ({A' | cs_nTy nTy5 i A'})
        as [ ]
          by (apply cs_nTy_dec).

      eexists; constructor; eauto.
    + destruct IHM1 with i.
      destruct IHM2 with i.
      eexists; constructor; eauto.

Qed.

(*
is not in fact needed?
Lemma cs_nK_dec:
  forall (L : nK) (i : Ixc),
    { L' : nK | cs_nK L i L' }.
Proof.
  intros.
  induction L.
  eexists.
  econstructor.
  destruct IHL.
  assert ({nTy5' : nTy | cs_nTy nTy5 i nTy5'}) by (apply cs_nTy_dec).
  destruct H.
  eexists.
  econstructor; eauto.
Qed.
 *)

Lemma cs_nctx_dec:
  forall (G : nctx) (i : Ixc) (A : nTy),
    (i <= length G) ->
    { G' : nctx | cs_nctx G i A G' }.
Proof.
  intros.
  generalize dependent A.
  generalize dependent i.
  induction G.
  - (* nil case *)
    intros.
    destruct i.
    + eexists; constructor.
    + exfalso.
      inversion H.
  - (* cons case *)
    intro i.
    generalize dependent a.
    generalize dependent G.
    induction i.

    + intros.
      assert ({G' : nctx | cs_nctx G 0 a G'})
        by (apply IHG; auto with arith).
      destruct H0.

      assert ({A' : nTy | cs_nTy A 0 A'}) by (apply cs_nTy_dec).
      destruct H0.

      eexists; econstructor; eauto.

    + intros.

      assert ( {G' : nctx | cs_nctx G i A G'})
        by (eapply IHG; auto with arith).
      destruct H0.

      assert ({a' : nTy | cs_nTy a i a'}) by (apply cs_nTy_dec).
      destruct H0.

      eexists; econstructor; eauto.
Qed.

(* * decidability of context shifting **)

Lemma cs_nTy_dec_inverse:
  forall (A' : nTy) (i : Ixc),
    { A : nTy | cs_nTy A i A' } + { forall A : nTy, ~ cs_nTy A i A'}
with cs_nte_dec_inverse:
  forall (M' : nte) (i : Ixc),
    {  M : nte | cs_nte M i M' } + { forall M : nte, ~ cs_nte M i M'}.
Proof.
  intros.
  induction A'.
  left; eexists; constructor.

  destruct IHA'1; destruct IHA'2.
  destruct s; destruct s0.
  left; eexists; constructor; eauto.
  right; intros; intro.
  inversion H.
  eapply n; eauto.
  right; intros; intro.
  inversion H.
  eapply n; eauto.
  right; intros; intro.
  inversion H.
  eapply n; eauto.

  destruct IHA'.
  destruct s.
  assert ({M | cs_nte M i nte5 } + {forall M, ~ cs_nte M i nte5}) by (apply cs_nte_dec_inverse).
  destruct H.
  destruct s.
  left; eexists; constructor; eauto.
  right; intros; intro.
  inversion H.
  eapply n; eauto.
  right; intros; intro.
  inversion H.
  eapply n; eauto.

  (* lemma 2 *)
  intros.
  induction M'.
  left; eexists; constructor.
  (* case ixc *)

  assert ({ixc < i} + {ixc = i} + { i < ixc}) by (apply lt_eq_lt_dec).
  destruct H.
  destruct s.

  (* (ixc < i)  *)
  left.
  exists (termstar_nl_ixc ixc).
  generalize dependent ixc.
  induction i.
  intros.
  inversion l.
  intros.
  destruct ixc.
  constructor.
  eapply cs_nte_ixc_succ.
  apply IHi.
  apply lt_S_n; auto.

  (* (i = ixc)  *)
  rewrite e.
  clear e. clear ixc.
  right.
  induction i.
  intros.
  intro.
  inversion H.
  intros.
  intro.
  inversion H.
  eapply IHi; eauto.

  (* (i < ixc) *)
  destruct ixc.
  apply lt_le_S in l.
  apply le_n_0_eq in l.
  inversion l.
  left.
  exists (termstar_nl_ixc ixc).
  generalize dependent ixc.
  induction i.
  intros.
  constructor.
  intros.

  destruct ixc.
  apply lt_n_Sm_le in l.
  apply le_n_0_eq in l.
  inversion l.
  constructor.
  apply IHi.
  apply lt_S_n; auto.

  (* ixt *)
  left.
  exists (termstar_nl_ixt ixt).
  constructor.
  (* pi intro *)
  destruct IHM'.
  destruct s.
  assert ({A' | cs_nTy A' i nTy5 } + {forall A' , ~ cs_nTy A' i nTy5} ) by (apply cs_nTy_dec_inverse).
  destruct H.
  destruct s.
  left.
  exists (termstar_nl_pi_intro x0 x).
  constructor; eauto.

  right.
  intros; intro.
  inversion H.
  eapply n; eauto.

  right.
  intros; intro.
  inversion H.
  eapply n; eauto.

  destruct IHM'1.
  destruct s.
  destruct IHM'2.
  destruct s.
  left.
  exists (termstar_nl_pi_elim x x0).
  apply cs_nte_pi_elim; auto.

  right.
  intros; intro.
  inversion H.
  eapply n; eauto.

  right.
  intros; intro.
  inversion H.
  eapply n; eauto.
Qed.

(** determinacy of context shifting **)

Lemma cs_nTy_determinacy:
  forall (A B1 B2 : nTy) (i : Ixc),
    cs_nTy A i B1 -> cs_nTy A i B2 ->
    B1 = B2
with cs_nte_determinacy:
  forall (M N1 N2 : nte) (i : Ixc),
    cs_nte M i N1 -> cs_nte M i N2 ->
    N1 = N2.
Proof.
  intros.
  generalize dependent B2.
  induction H.
  intros.
  inversion H0; auto.
  intros; inversion H1.
  f_equal.
  apply IHcs_nTy1; auto.
  apply IHcs_nTy2; auto.
  intros.
  inversion H1.
  f_equal.
  apply IHcs_nTy; auto.
  eapply cs_nte_determinacy; eauto.
  (* cs_nte_determinacy lemma *)
  intros.
  generalize dependent N2.
  induction H.
  intros.
  inversion H0; auto.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  intros.
  inversion H0.

  assert (termstar_nl_ixc ixc'' = termstar_nl_ixc ixc''0).
  apply IHcs_nte; auto.
  f_equal; f_equal.
  inversion H5; auto.

  intros.
  inversion H0; auto.

  intros.
  inversion H1.
  f_equal.
  eapply cs_nTy_determinacy; eauto.
  apply IHcs_nte; auto.
  intros.
  inversion H1.
  f_equal.
  apply IHcs_nte1; auto.
  apply IHcs_nte2; auto.
Qed.

Lemma cs_nctx_determinacy:
  forall (G G1 G2 : nctx) (A : nTy) (i : Ixc),
    cs_nctx G i A G1 -> cs_nctx G i A G2 ->
    G1 = G2.
Proof.
  intros.
  generalize dependent G2.
  induction H.

  - intros.
    inversion H0; constructor.
  - intros.
    inversion H1; f_equal.
    eapply cs_nTy_determinacy; eauto.
    eapply IHcs_nctx; eauto.
  - intros.
    inversion H1; f_equal; eauto using cs_nTy_determinacy.
Qed.

(** surjectivity of context shifting **)

Lemma cs_nTy_surjectivity:
  forall (A1 A2 B : nTy) (i : Ixc),
    cs_nTy A1 i B -> cs_nTy A2 i B ->
    A1 = A2
with cs_nte_surjectivity:
  forall (M1 M2 N : nte) (i : Ixc),
    cs_nte M1 i N -> cs_nte M2 i N ->
    M1 = M2.
Proof.
  intros.
  generalize dependent A2.
  induction H.
  intros.
  inversion H0; auto.
  intros.
  inversion H1.
  f_equal.
  apply IHcs_nTy1; auto.
  apply IHcs_nTy2; auto.
  intros.
  inversion H1.
  f_equal.
  apply IHcs_nTy; auto.
  eapply cs_nte_surjectivity; eauto.
  (* cs_nte_determinacy lemma *)
  intros.
  generalize dependent M2.
  induction H.
  intros.
  inversion H0; auto.

  intros.
  inversion H0; auto.

  intros.
  inversion H0; auto.

  intros.
  inversion H0.
  assert (termstar_nl_ixc  ixc = termstar_nl_ixc ixc0).
  apply IHcs_nte; auto.
  inversion H5.
  f_equal; auto.

  intros.
  inversion H0; auto.

  intros.
  inversion H1.
  f_equal.
  eapply cs_nTy_surjectivity; eauto.
  apply IHcs_nte; auto.
  intros.
  inversion H1.
  f_equal.
  apply IHcs_nte1; auto.
  apply IHcs_nte2; auto.
Qed.

(** context shifting composes **)

Fixpoint cs_nTy_cs (A A' B B' : nTy) (i : Ixc) (H : cs_nTy A i B) {struct H}:
    cs_nTy B 0 B' -> cs_nTy A 0 A' ->
    cs_nTy A' (S i) B'
with cs_nte_cs (M M' N N' : nte) (i : Ixc) (H : cs_nte M i N) {struct H}:
    cs_nte N 0 N' -> cs_nte M 0 M' ->
    cs_nte M' (S i) N'.
Proof.
  (* lemma 1 *)
  intros.
  generalize dependent B'.
  generalize dependent A'.
  induction H.

  intros.
  inversion H0; inversion H1.
  constructor.

  intros.
  inversion H1; inversion H2.
  constructor.
  apply IHcs_nTy1; auto.
  apply IHcs_nTy2; auto.

  intros.
  inversion H1; inversion H2.
  constructor.
  apply IHcs_nTy; auto.
  eapply cs_nte_cs; eauto.

  (* lemma 2 *)
  intros.
  generalize dependent N'.
  generalize dependent M'.
  induction H.

  intros.
  inversion H0; inversion H1.
  constructor.

  intros.
  inversion H0; inversion H1.
  constructor.
  eapply cs_nte_ixc_gt.

  intros.
  inversion H0; inversion H1.
  constructor.
  constructor.

  intros.
  inversion H0; inversion H1.
  constructor.
  apply IHcs_nte; constructor.

  intros.
  inversion H0; inversion H1.
  constructor.

  intros.
  inversion H1; inversion H2.
  constructor.
  eapply cs_nTy_cs; eauto.
  apply IHcs_nte; auto.

  intros.
  inversion H1; inversion H2.
  constructor.
  apply IHcs_nte1; auto.
  apply IHcs_nte2; auto.
Qed.

(** cstu preservers cs **)

Fixpoint cs_nTy_cstu (B C B' C' : nTy) (i : Ixc) (H : cs_nTy B i C) {struct H}:
      cstu_nTy B 0 B' -> cstu_nTy C 0 C' ->
      cs_nTy B' (S i) C'
with cs_nte_cstu (M N M' N' : nte) (i : Ixc) (H : cs_nte M i N) {struct H}:
      cstu_nte M 0 M' -> cstu_nte N 0 N' ->
      cs_nte M' (S i) N'.
Proof.
  -  (* Lemma 1 *)
    intros.
    generalize dependent C'.
    generalize dependent B'.
    (* generalize dependent j.*)
    induction H.
    + (* tcon *)
      intros.
      inversion H0; inversion H1.
      constructor.
    +  (* pi_intro *)
      intros.
      inversion H1; inversion H2.
      apply cs_nTy_pi_intro.
      eapply IHcs_nTy1; eauto.
      eapply IHcs_nTy2; eauto.
    + (* pi_elim *)
      intros.
      inversion H1; inversion H2.
      apply cs_nTy_pi_elim.
      eapply IHcs_nTy; eauto.
      eapply cs_nte_cstu; eauto.
  - (* Lemma 2 *)
    intros.
    generalize dependent N'.
    generalize dependent M'.
    (* generalize dependent i. *)
    induction H.
    +  (* con *)
      intros.
      inversion H0; inversion H1.
      constructor.
    +  (* ixc S *)
      intros.
      inversion H0; inversion H1.
      constructor.
      constructor.
    +  (* ixc 0 S S *)
      intros.
      inversion H0; inversion H1.
      constructor.
      constructor.
    + (* ixc S ixc ~ S ixc' *)
      intros.
      inversion H0; inversion H1.
      constructor.
      eapply IHcs_nte.
      econstructor.
      econstructor.
    + (* ixt *)
      intros.
      destruct ixt.
      * inversion H0; inversion H1.
        (*generalize dependent j.*)
        generalize dependent N'.
        generalize dependent M'.
        induction ixc.
        {
          intros.
          constructor.
        }
        {
          intros.
          constructor.
        }
      *  (* S ixt *)
        inversion H0; inversion H1.
        constructor.
    +  (* pi_intro *)
      intros.
      inversion H1; inversion H2.
      constructor.
      eapply cs_nTy_cstu; eauto.
      eapply IHcs_nte; eauto.
    +  (* pi_elim *)
      intros.
      inversion H1; inversion H2.
      constructor.
      eapply IHcs_nte1; eauto.
      eapply IHcs_nte2; eauto.
Defined.

(** tuts preservers cs **)

Fixpoint cs_nTy_tuts (B C B' C' : nTy) (M M' : nte) (i : Ixc) (H : cs_nTy B i C) {struct H}:
      cs_nte M i M' -> tuts_nTy B M B' -> tuts_nTy C M' C' ->
      cs_nTy B' i C'
with cs_nte_tuts (M N M' N' P P' : nte) (i : Ixc) (H : cs_nte M i N)  {struct H}:
      cs_nte P i P' -> tuts_nte M P M' -> tuts_nte N P' N' ->
      cs_nte M' i N'.
Proof.
  (* Lemma 1 *)
  intros.
  generalize dependent C'.
  generalize dependent B'.
  induction H.
  (* tcon *)
  intros.
  inversion H1; inversion H2.
  constructor.
  (* pi_intro *)
  intros.
  inversion H2; inversion H3.
  apply cs_nTy_pi_intro.
  apply IHcs_nTy1; auto.
  apply IHcs_nTy2; auto.
  (* pi_elim *)
  intros.
  inversion H2; inversion H3.
  apply cs_nTy_pi_elim.
  apply IHcs_nTy; auto.
  eapply cs_nte_tuts.
  exact H1.
  exact H0.
  exact H9.
  exact H15.

  (* Lemma 2 *)
  intros.
  generalize dependent N'.
  generalize dependent M'.
  (* generalize dependent i. *)
  induction H.
  (* con *)
  intros.
  inversion H1; inversion H2.
  apply cs_nte_con.
  (* ixc S *)
  intros.
  inversion H1; inversion H2.
  constructor.
  (* ixc 0 S S *)
  intros.
  inversion H1.
  inversion H2.
  constructor.

  intros.
  inversion H1.
  inversion H2.
  constructor.
  auto.

  (* ixt *)
  intros.
  destruct ixt.

  inversion H1; inversion H2.
  rewrite <- H4; rewrite <- H6; auto.

  inversion H1; inversion H2.
  constructor.

  (* pi_intro *)
  intros.
  inversion H2; inversion H3.
  apply cs_nte_pi_intro.
  eapply cs_nTy_tuts; eauto.
  eapply IHcs_nte; eauto.
  (* pi_elim *)
  intros.
  inversion H2; inversion H3.
  eapply cs_nte_pi_elim.
  eapply IHcs_nte1; eauto.
  eapply IHcs_nte2; eauto.
Defined.

(** context shifting preserves context shifting in simple context **)

(*
not needed ?

Lemma cs_snctx_cs:
  forall (sG sG' : snctx) (i : Ixc) (tau tau' : snTy),
    cs_snctx sG i tau' sG' ->
    cs_snctx (tau :: sG) (S i) tau' (tau :: sG').
Proof.
  intros.
  generalize dependent tau.
  induction H.
  intros.
  constructor.
  intros.
  constructor.
  intros.
  constructor.
  constructor.
  exact H.
  intros.
  constructor.
  apply IHcs_snctx.
Qed.

(** context shifting prepends for zeroc **)

Lemma cs_snctx_zeroc:
  forall (sG sG' : snctx) (tau : snTy),
    cs_snctx sG 0 tau sG' ->
    sG' = tau :: sG.
Proof.
  intros.
  generalize dependent sG'.
  generalize dependent tau.
  induction sG.
  intros.
  inversion H; auto.

  intros.
  inversion H.
  f_equal.
  apply IHsG; auto.
Qed.

(** context shifting generalised constructors **)
Lemma cs_snctx_var:
  forall (sG : snctx) (tau : snTy),
    cs_snctx sG 0 tau (tau :: sG).
Proof.
  induction sG.
  intros; constructor.
  intros.
  constructor.
  apply IHsG.
Qed.
 *)

(**
   * Context unshifting
 **)

(** decidability of context unshifting **)

Lemma cu_nTy_dec:
  forall (A : nTy) (i : Ixc),
    { A' : nTy | cu_nTy A i A' } + {forall (A' : nTy), ~ cu_nTy A i A'}
with cu_nte_dec:
  forall (M : nte) (i : Ixc),
    {  M' : nte | cu_nte M i M' } + {forall (M' : nte), ~ cu_nte M i M'}.
Proof.
  { (* lemma 1 *)
    intros.
    induction A as [ a | A IH_A B IH_B | A IH_A M ].
    - left.
      eexists; constructor.
    - destruct IH_A as [ [A'] | ].
      + destruct IH_B as [ [B'] | ].
        * left; eexists; constructor; eauto.
        *  right; intros; intro.
           inversion H.
           eapply n; eauto.
      + right; intros; intro.
        inversion H.
        eapply n; eauto.
    - destruct IH_A as [ [A'] | ].
      + assert (H_M : {M' : nte | cu_nte M i M'} +
                      {(forall M' : nte, ~ cu_nte M i M')})
          by (apply cu_nte_dec).
        destruct H_M as [ [M'] | ].
        * left; eexists; constructor; eauto.
        * right; intros; intro.
          inversion H.
          eapply n; eauto.
      + right; intros; intro.
        inversion H.
        eapply n; eauto.
  }
  { (* lemma 2 *)
    intros.
    induction M as [ a |  | | A M | M IH_M N IH_N ].
    - intros; left.
      eexists; econstructor.
    - generalize dependent ixc.
      induction i.
      + intros.
        destruct ixc.
        * right; intros; intro.
          inversion H.
        * left; eexists; constructor.
      + intros.
        destruct ixc.
        * left; eexists; constructor.
        * assert ({M' : nte | cu_nte (termstar_nl_ixc ixc) i M'} +
                  {(forall M' : nte, ~ cu_nte (termstar_nl_ixc ixc) i M')})
            by (eapply IHi).
          destruct H as [ [M'] | ].
          { destruct M'.
            - exfalso; inversion c.
            - left; eexists; constructor; eauto.
            - exfalso; inversion c.
            - exfalso; inversion c.
            - exfalso; inversion c.
          }
          { right; intro; intro.
            inversion H.
            eapply n; eauto.
          }
    - destruct ixt.
      + left; eexists; constructor.
      + left; eexists; constructor.
    - destruct IHM as [ [M'] | ].
      + assert ({A' : nTy | cu_nTy A i A'} +
                {(forall A' : nTy, ~ cu_nTy A i A')})
          by (apply cu_nTy_dec).
        destruct H as [ [A'] | ].
        * left; eexists; constructor; eauto.
        * right; intros; intro.
          inversion H.
          eapply n; eauto.
      + right; intros; intro.
        inversion H.
        eapply n; eauto.
    - destruct IH_M as [ [M'] | ].
      destruct IH_N as [ [N'] | ].
      + left; eexists; constructor; eauto.
      + right; intros; intro.
        inversion H.
        eapply n; eauto.
      + right; intros; intro.
        inversion H.
        eapply n; eauto.
  }
Qed.

Lemma cu_nctx_dec:
  forall (G : nctx)  (i : Ixc),
    { G'A' : nctx * nTy | cu_nctx G i (fst G'A') (snd G'A')  }
    + {forall (A' : nTy) (G' : nctx), ~ cu_nctx G i G' A'}.
Proof.
  intros.
  generalize dependent G.
  induction i.
  - intros.
    induction G.
    + right; intros; intro.
      inversion H.
    + destruct IHG as [ [ [ ?G' ?A' ] ] | ].
      * assert ({a' | cu_nTy a 0 a'} + {forall a', ~ cu_nTy a 0 a'})
          by (apply cu_nTy_dec).
        destruct H as [ [a'] | ].
        { left.
          exists (A' :: G', a').
          apply cu_nctx_var_zeroc; auto. }
        { right; intros; intro.
          cbn in c.
          inversion H.
          rewrite <- H2 in c; inversion c.
          eapply n; eauto. }
      * destruct G.
        { left; exists (nil, a).
          cbn.
          constructor. }
        { right; intros; intro.
          inversion H.
          eapply n; eauto. }
  - intros.
    induction G.
    + intros.
      right; intros; intro.
      inversion H.
    + intros.
      assert ({G'A' : nctx * nTy | cu_nctx G i (fst G'A') (snd G'A')} +
              {(forall (A' : nTy) (G' : nctx), ~ cu_nctx G i G' A')})
             by (apply IHi).
      destruct H as [ [ [?G' ?A' ]  w  ] | ].
      *  cbn in w.

         assert ({a' | cu_nTy a i a'} + {forall a', ~ cu_nTy a i a'})
           by (apply cu_nTy_dec).
         destruct H as [[a'] | ].

         { left.
           exists (a' :: G' , A').
           constructor; auto. }
         { right; intros; intro.
           inversion H.
           eapply n; eauto. }
      * right; intros; intro.
        inversion H.
        eapply n; eauto.
Qed.

(*
Lemma cu_nctx_wf_dec:
  forall (S : nsgn) (G : nctx) (i : Ixc),
    wfctx_nl S G -> i < length G ->
    { G'A' : nctx * nTy | cu_nctx G i (fst G'A') (snd G'A')  }.
Proof.
  intros.
  generalize dependent G.
  induction i.
  - intro G.
    remember (length G).
    generalize dependent G.
    induction n; intros G Heq HwfG HlG. (* induction on length G! *)
    + exfalso.
      inversion HlG.
    + destruct G as [ | B ].
      * inversion Heq.
      * assert ({B' | cu_nTy B 0 B'})
        as [ B' ]
          by (admit). (* from wf? *)

        destruct G.

        { (* ctx = A :: nil *)
          exists (nil, B).
          cbn.
          apply cu_nctx_empty. }
 *)
        (*
      * destruct IHG as [ [ ?G' ?A' ]  ].
        { admit. (* induction on length G! *) }
        { cbn; auto with arith. }

        cbn in c0.
        exists (A' :: G', a').
        cbn.
        apply cu_nctx_var_zeroc; auto.

  - intros.
    induction G. (* length G *)
    + intros.
      exfalso.
      inversion H0.
    + intros.
      assert ({G'A' : nctx * nTy | cu_nctx G i (fst G'A') (snd G'A')})
        as [ [ ?G' ?A' ] w ].

      apply IHi.
      admit. (* induction on length G *)
      auto with arith.

      *  cbn in w.

         assert ({a' | cu_nTy a i a'})
           as [ a' ]
             by (admit).

         exists (a' :: G', A').
         constructor; auto.

Qed.
         *)

(** determinacy of context unshifting **)

Fixpoint cu_nTy_determinacy (A B1 B2 : nTy) (i : Ixc)
         (H : cu_nTy A i B1) {struct H}:
  cu_nTy A i B2 -> B1 = B2
with cu_nte_determinacy (M N1 N2 : nte) (i : Ixc)
                        (H :  cu_nte M i N1) {struct H}:
       cu_nte M i N2 -> N1 = N2.
Proof.
  (* lemma 1 *)
  - intros.
    generalize dependent B2.
    induction H.
    + intros.
      inversion H0; auto.
    + intros.
      inversion H1.
      f_equal; eauto using IHcu_nTy1 , IHcu_nTy2.
    + intros.
      inversion H1.
      f_equal; eauto using IHcu_nTy , cu_nte_determinacy.
  - intros.
    generalize dependent N2.
    induction H.
    + intros.
      inversion H0; auto.
    + intros.
      inversion H0; auto.
    + intros.
      inversion H0; auto.
    + intros.
      inversion H0.
      assert (termstar_nl_ixc ixc'' = termstar_nl_ixc ixc''0)
        by (eauto using IHcu_nte).
      inversion H5.
      rewrite <- H7; auto.
    + destruct ixt.
      * intros.
        inversion H0; auto.
      * intros.
        inversion H0; auto.
    + intros.
      inversion H1.
      f_equal; eauto using IHcu_nte, cu_nTy_determinacy.
    + intros.
      inversion H1.
      f_equal; eauto using IHcu_nte1, IHcu_nte2.
Qed.

Lemma cu_nctx_determinacy:
  forall (G G1 G2 : nctx) (A1 A2 : nTy) (i : Ixc),
    cu_nctx G i G1 A1 -> cu_nctx G i G2 A2 ->
    G1 = G2 /\ A1 = A2.
Proof.
  intros.
  generalize dependent G.
  generalize dependent G1.
  generalize dependent G2.
  generalize dependent A1.
  generalize dependent A2.
  induction i.
  - intros.
    generalize dependent G1.
    generalize dependent G2.
    generalize dependent A1.
    generalize dependent A2.
    induction G.
    + intros.
      inversion H.
    + intros.
      inversion H.
      * rewrite <- H3 in H0.
        inversion H0.
        rewrite H4 in H8.
        split; auto.
        inversion H8.
      * inversion H0.
        rewrite <- H9 in H4; inversion H4.
        split.
        f_equal; eapply IHG; eauto.
        eapply cu_nTy_determinacy; eauto.
  - intros.
    inversion H.
    inversion H0.
    rewrite <- H3 in H9; inversion H9.
    rewrite H14 in H10.
    rewrite H15 in H8.
    split.
    f_equal.
    eapply cu_nTy_determinacy; eauto.
    eapply IHi; eauto.
    eapply IHi; eauto.
Qed.

(** context unshifting is an inversion of context shifting **)

Lemma cu_nTy_inverse_cs:
  forall (A A' : nTy) {i : Ixc},
    cs_nTy A i A' -> cu_nTy A' i A
with cu_nte_inverse_cs:
  forall (M M' : nte) {i : Ixc},
    cs_nte M i M' -> cu_nte M' i M.
Proof.
  { (* lemma 1 *)
    intros.
    induction H.
    - constructor.
    - constructor; auto.
    - constructor; auto.
  }
  {
  (* lemma 2 *)
    intros.
    induction H.
    - constructor.
    - constructor.
    - constructor.
    - constructor.
      apply IHcs_nte.
    - constructor; auto.
    - constructor; auto.
    - constructor; auto.
  }
Qed.

Lemma cu_nctx_inverse_cs:
  forall (G G' : nctx) (A : nTy) (i : Ixc),
    cs_nctx G i A G' -> cu_nctx G' i G A.
Proof.
  intros.
  generalize dependent A.
  generalize dependent G.
  generalize dependent i.
  induction G'.
  - intros.
    inversion H.
  - intros.
    generalize dependent G.
    generalize dependent A.
    induction i.
    + intros.
      inversion H.
      * econstructor.
      * constructor.
        apply cu_nTy_inverse_cs; auto.
        apply IHG'; auto.
    + intros.
      inversion H.
      apply cu_nctx_var_succ.
      apply IHG'; auto.
      apply cu_nTy_inverse_cs; auto.
Qed.

(**
   * Context-shifting type-unshifting
 **)

(** decidability of cstu **)

Lemma cstu_nTy_dec:
  forall (A : nTy) (i : Ixc),
    { A' : nTy | cstu_nTy A i A' }
with cstu_nte_dec:
  forall (M : nte) (i : Ixc),
    {  M' : nte | cstu_nte M i M' }.
Proof.
  intros.
  induction A.
  (* case con *)
  eexists; constructor.
  (* case pi intro *)
  destruct IHA1; destruct IHA2.
  eexists; constructor; eauto.
  (* pi_elim *)
  destruct IHA.
  assert ({M' : nte |  cstu_nte nte5 i M'}) by (apply cstu_nte_dec).
  destruct H.
  eexists; constructor; eauto.
  (* lemma cstu_nte_dec *)
  intros.
  induction M.
  (* case con *)
  eexists; constructor.
  (* case ixc *)
  eexists; constructor.
  (* case ixt *)
  destruct ixt.
  eexists; constructor.
  eexists; constructor.
  (* case pi_intro *)
  destruct IHM.
  assert ({A' : nTy | cstu_nTy nTy5 i A'}) by (apply cstu_nTy_dec).
  destruct H.
  eexists; constructor; eauto.
  (* case pi elim *)
  destruct IHM1.
  destruct IHM2.
  eexists; constructor; eauto.
Defined.

Lemma cstu_nK_dec:
  forall (L : nK) (i : Ixc),
    { L' | cstu_nK L i L'}.
Proof.
  intros.
  induction L.
  (* base case *)
  exists kindstar_nl_type.
  apply cstu_K_type.
  (* step case *)
  assert ({A' : nTy | cstu_nTy nTy5 i A'}).
  apply cstu_nTy_dec.
  destruct IHL.
  destruct H.
  exists (kindstar_nl_pi_intro x0 x).
  auto using cstu_K_pi_intro.
Qed.

(** determinacy od cstu **)

Lemma cstu_nTy_determinacy:
  forall (A B1 B2 : nTy) (i : Ixc),
    cstu_nTy A i B1 -> cstu_nTy A i B2 ->
    B1 = B2
with cstu_nte_determinacy:
  forall (M N1 N2 : nte) (i : Ixc),
    cstu_nte M i N1 -> cstu_nte M i N2 ->
    N1 = N2.
Proof.
  intros.
  generalize dependent B2.
  induction H.
  intros.
  inversion H0; auto.
  intros.
  inversion H1; f_equal.
  apply IHcstu_nTy1; auto.
  apply IHcstu_nTy2; auto.
  (* elim *)
  intros.
  inversion H1; f_equal.
  eapply IHcstu_nTy; eauto.
  eapply cstu_nte_determinacy; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent N2.
  induction H.
  intros.
  inversion H0; auto.
  intros.
  inversion H0; auto.
  intros.
  inversion H0; auto.
  intros.
  inversion H0; auto.
  (* pi_intro *)
  intros.
  inversion H1; f_equal.
  eapply cstu_nTy_determinacy; eauto.
  apply IHcstu_nte; auto.
  (* pi_elim *)
  intros.
  inversion H1; f_equal.
  apply IHcstu_nte1; auto.
  apply IHcstu_nte2; auto.
Qed.

Lemma cstu_nK_determinacy:
  forall (L L1 L2 : nK) (i : Ixt),
    cstu_nK L i L1 -> cstu_nK L i L2 ->
    L1 = L2.
Proof.
  intros.
  generalize dependent L1.
  generalize dependent L2.
  induction L.
  intros.
  inversion H; inversion H0; trivial.
  intros.
  inversion H; inversion H0; f_equal.
  eapply cstu_nTy_determinacy; eauto.
  apply IHL; auto.
Qed.

(** context-shifting preserves cstu **)
(*
Fixpoint cstu_nTy_cs (A A' B B' : nTy) (i : Ixc) (H : cstu_nTy A i A') {struct H}:
         cs_nTy A B -> cs_nTy A' B' -> cstu_nTy B (S i) B'
with cstu_nte_cs (M M' N N' : nte) (i : Ixc) (H : cstu_nte M i M') {struct H}:
     cs_nte M N -> cs_nte M' N' -> cstu_nte N (S i) N'.
Proof.
  (* lemma 1 *)
  intros.
  generalize dependent B'.
  generalize dependent B.
  induction H.
  intros.
  inversion H0; inversion H1; constructor.
  intros.
  inversion H1; inversion H2; constructor; eauto.
  intros.
  inversion H1. inversion H2; econstructor.
  eauto.
  eapply cstu_nte_cs; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent N'.
  generalize dependent N.
  induction H.
  intros.
  inversion H0; inversion H1; constructor.
  intros.
  inversion H0; inversion H1; econstructor.
  intros.
  inversion H0; inversion H1; econstructor.
  intros.
  inversion H0; inversion H1; econstructor.
  intros.
  inversion H1; inversion H2; econstructor.
  eapply cstu_nTy_cs; eauto.
  eauto.
  intros.
  inversion H1; inversion H2; econstructor; eauto.
Defined.
*)
(**
   * Context-unshifitng type-shifting
**)

(** decidability of cuts **)

Lemma cuts_nTy_dec:
  forall (A : nTy),
    { A' | cuts_nTy A A' }
with cuts_nte_dec:
  forall (M : nte),
    { M' | cuts_nte M M' }.
Proof.
  - (* lemma 1 *)
    intros.
    induction A as [ a | A [ A' ]  B [ B' ] | A [ A' ] M ].
    + eexists; constructor.
    + eexists; constructor; eauto.
    + assert ({M' | cuts_nte M M'}) as [ M' ]
        by (apply cuts_nte_dec).
      eexists; constructor; eauto.
  - (* lemma 2 *)
    intros.
    induction M as [ c | |  | A M [M'] | M1 [M1'] M2 [M2'] ].
    + eexists; constructor.
    + destruct ixc.
      * eexists; constructor.
      * eexists; constructor.
    + eexists; constructor.
    + assert ({A' | cuts_nTy A A'}) as [ A' ]
          by (apply cuts_nTy_dec).
      eexists; constructor; eauto.
    + eexists; constructor; eauto.
Qed.

(** determinacy of cuts **)

Lemma cuts_nTy_determinacy:
  forall (A B1 B2 : nTy),
    cuts_nTy A B1 -> cuts_nTy A B2 ->
    B1 = B2
with cuts_nte_determinacy:
  forall (M N1 N2 : nte),
    cuts_nte M N1 -> cuts_nte M N2 ->
    N1 = N2.
Proof.
  intros.
  generalize dependent B2.
  induction H.
  intros.
  inversion H0; auto.
  intros; inversion H1; f_equal.
  apply IHcuts_nTy1; auto.
  apply IHcuts_nTy2; auto.
  (* elim *)
  intros.
  inversion H1; f_equal.
  apply IHcuts_nTy; auto.
  eapply cuts_nte_determinacy; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent N2.
  induction H.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  (* pi_intro *)
  intros.
  inversion H1; f_equal.
  eapply cuts_nTy_determinacy; eauto.
  apply IHcuts_nte; auto.
  (* pi_elim *)
  intros.
  inversion H1; f_equal.
  apply IHcuts_nte1; auto.
  apply IHcuts_nte2; auto.
Qed.

(**
   * Type-unshifting type-substitution
**)

(** decidability of tuts *)

Lemma tuts_nTy_dec:
  forall (A : nTy) (N : nte) ,
    { A' | tuts_nTy A N A' }
with tuts_nte_dec:
  forall (M N : nte),
    { M' | tuts_nte M N M' }.
Proof.
  intros.
  induction A.
  exists (typestar_nl_tcon tcon5).
  trivial using tuts_nTy_tcon.
  destruct IHA1.
  destruct IHA2.
  exists (typestar_nl_pi_intro x x0).
  auto using tuts_nTy_pi_intro.
  (* next case *)
  destruct IHA.
  assert ({M' | tuts_nte nte5 N M'}) by (apply tuts_nte_dec).
  destruct H.
  exists (typestar_nl_pi_elim x x0).
  auto using tuts_nTy_pi_elim.

  (* lemma tuts_nte_dec *)
  intros.
  induction M.
  (* case con *)
  exists (termstar_nl_con con5).
  auto using tuts_nte_con.
  (* case ixc *)
  exists (termstar_nl_ixc (ixc)).
  apply tuts_nte_ixc.
  (* case ixt *)
  destruct ixt.
  exists N.
  apply tuts_nte_ixt_zero.
  exists (termstar_nl_ixt ixt).
  apply tuts_nte_ixt_succ.
  (* case pi_intro *)
  destruct IHM.
  assert ({A' | tuts_nTy nTy5 N A'}) by (apply tuts_nTy_dec).
  destruct H.
  exists (termstar_nl_pi_intro x0 x).
  auto using tuts_nte_pi_intro.
  (* case pi elim *)
  destruct IHM1.
  destruct IHM2.
  exists (termstar_nl_pi_elim x x0).
  auto using tuts_nte_pi_elim.
Qed.

Lemma tuts_nK_dec:
  forall (L : nK) (N : nte) ,
    { L' | tuts_nK L N L' }.
Proof.
  intros.
  induction L as [ | A ] .
  - eexists; constructor.
  - destruct IHL as [ L' ].
    assert ({A' | tuts_nTy A N A'})
      by (apply tuts_nTy_dec).
    destruct H as [ A' ].
    eexists; constructor; eauto.
Qed.

(** determinacy of tuts *)

Lemma tuts_nTy_determinacy:
  forall (A B1 B2: nTy) (N : nte),
    tuts_nTy A N B1 -> tuts_nTy A N B2 ->
    B1 = B2
with tuts_nte_determinacy:
  forall (M N N1 N2 : nte),
    tuts_nte M N N1 -> tuts_nte M N N2 ->
    N1 = N2.
Proof.
  intros.
  generalize dependent B2.
  induction H.
  intros; inversion H0; auto.
  intros; inversion H1; f_equal.
  apply IHtuts_nTy1; auto.
  apply IHtuts_nTy2; auto.
  (* elim *)
  intros; inversion H1; f_equal.
  apply IHtuts_nTy; auto.
  eapply tuts_nte_determinacy; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent N2.
  induction H.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  intros; inversion H0; auto.
  (* pi_intro *)
  intros.
  inversion H1; f_equal.
  eapply tuts_nTy_determinacy; eauto.
  apply IHtuts_nte; auto.
  (* pi_elim *)
  intros.
  inversion H1; f_equal.
  apply IHtuts_nte1; auto.
  apply IHtuts_nte2; auto.
Qed.

Lemma tuts_nK_determinacy:
  forall (L L1 L2: nK) (N : nte),
    tuts_nK L N L1 -> tuts_nK L N L2 ->
    L1 = L2.
Proof.
  intros.
  generalize dependent L2.
  induction H.
  intros.
  inversion H0; auto.
  intros.
  inversion H1.
  f_equal.
  eapply tuts_nTy_determinacy; eauto.
  eapply IHtuts_nK; eauto.
Qed.

(** context shifting preserves tuts **)

Fixpoint tuts_nTy_cs (A B A' B': nTy) (N N' : nte) (H : tuts_nTy A N B) (i : Ixc) {struct H}:
    cs_nTy A i A' -> cs_nTy B i B' -> cs_nte N i N' -> tuts_nTy A' N' B'
with tuts_nte_cs (M M' N csM csM' csN : nte) (H : tuts_nte M N M') (i : Ixc) {struct H}:
    cs_nte M i csM -> cs_nte M' i csM' -> cs_nte N i csN -> tuts_nte csM csN csM'.
Proof.
  (* lemma 1 *)
  intros.
  generalize dependent B'.
  generalize dependent N'.
  generalize dependent A'.
  induction H.
  (* tcon *)
  intros; inversion H0; inversion H1; constructor.
  (* pi_intro *)
  intros; inversion H1; inversion H3; constructor.
  eapply IHtuts_nTy1; eauto.
  eapply IHtuts_nTy2; eauto.
  (* pi_elim *)
  intros; inversion H1; inversion H3; constructor.
  eapply IHtuts_nTy; eauto.
  eapply tuts_nte_cs; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent csN.
  generalize dependent csM'.
  generalize dependent csM.
  generalize dependent i.
  induction H.
  (* con *)
  intros; inversion H0; inversion H1; constructor.
  (* ixc *)
  intros.

  inversion H0.
  rewrite <- H4 in H1.
  inversion H1.
  constructor.

  rewrite <- H4 in H1.
  inversion H1.
  constructor.

  rewrite <- H3 in H; inversion H.

  rewrite <- H4 in H1; inversion H1.
  rewrite <- H in H7; inversion H7.

  destruct ixc; inversion H; inversion H6.
  rewrite H11 in H3.
  rewrite H12 in H8.

  assert (termstar_nl_ixc ixc'' = termstar_nl_ixc ixc''0).
  eapply cs_nte_determinacy; eauto.
  inversion H10.
  constructor.

  (* ixt 0 *)
  intros.
  inversion H0.
  assert (csN = csM') by (eauto using cs_nte_determinacy).
  rewrite H; constructor.
  (* ixt S i *)
  intros; inversion H0; inversion H1; constructor.
  (* pi case *)
  intros; inversion H1; inversion H2; constructor.
  eapply tuts_nTy_cs; eauto.
  eapply IHtuts_nte; eauto.
  (* pi elim case *)
  intros; inversion H1; inversion H2; constructor.
  eapply IHtuts_nte1; eauto.
  eapply IHtuts_nte2; eauto.
Defined.

(** context shifting preserves tuts in inverse **)

Fixpoint tuts_nTy_cs_inverse (nA nA' A A' : nTy) (nN N : nte) (H : tuts_nTy nA nN nA') (i : Ixc) {struct H}:
  cs_nTy A i nA -> cs_nte N i nN -> cs_nTy A' i nA' -> tuts_nTy A N A'
with tuts_nte_cs_inverse (nM nM' nN M N M' : nte) (H : tuts_nte nM nN nM') (i : Ixc) {struct H}:
       cs_nte M i nM -> cs_nte N i nN -> cs_nte M' i nM' ->    tuts_nte M N M'.
Proof.
  (* lemma 1 *)
  intros.
  generalize dependent N.
  generalize dependent A'.
  generalize dependent A.
  induction H.
  intros.
  inversion H0; inversion H2.
  constructor.
  intros.
  inversion H1; inversion H2.
  constructor.
  eapply IHtuts_nTy1; eauto.
  eapply IHtuts_nTy2; eauto.
  (* pi_elim *)
  intros.
  inversion H1; inversion H2.
  constructor.
  eapply IHtuts_nTy; eauto.
  eapply tuts_nte_cs_inverse; eauto.
  (* lemma 2 *)
  intros.
  generalize dependent N.
  generalize dependent M.
  generalize dependent M'.
  generalize dependent i.
  induction H.
  intros.
  inversion H0; inversion H2.
  constructor.
  intros.

  inversion H0.
  rewrite <- H3 in H2; inversion H2.
  rewrite <- H5 in H6; inversion H6.
  constructor.

  rewrite <- H3 in H2; rewrite <- H5 in H2; inversion H2.
  constructor.

  rewrite <- H4 in H2; rewrite <- H in H2; inversion H2.
  assert (termstar_nl_ixc ixc0 = termstar_nl_ixc ixc1) by (eapply cs_nte_surjectivity; eauto).
  inversion H10.
  constructor.

  (* ixt *)
  intros.
  inversion H0.
  assert (N = M').
  eapply cs_nte_surjectivity; eauto.
  rewrite H4.
  constructor.
  intros.
  inversion H0; inversion H2.
  constructor.
  intros.
  inversion H1; inversion H2.
  constructor.
  eapply tuts_nTy_cs_inverse; eauto.
  eapply IHtuts_nte; eauto.
  (* pi elim *)
  intros.
  inversion H1; inversion H2.
  constructor.
  eapply IHtuts_nte1; eauto.
  eapply IHtuts_nte2; eauto.
Defined.


(** * Properties of Binary Natural Numbers *)

From Coq Require Import
  NArith.NArith.
From DEZ.Has Require Export
  EquivalenceRelations Decisions OrderRelations
  Operations ArithmeticOperations.
From DEZ.Is Require Export
  TotalOrder Group Semiring.

From Coq Require Import
  Classes.DecidableClass Classes.Morphisms Lia NArith.NArith Setoids.Setoid.
From DEZ.Justifies Require Export
  PositiveTheorems.
From DEZ.Provides Require Import
  DatatypeTactics RewritingTactics.

#[local] Open Scope N_scope.

(** ** Hints Missing from the Standard Library *)

Create HintDb narith.

Definition Nsucc_eq_compat (n1 n2 : N) (a : n1 = n2) : N.succ n1 = N.succ n2.
Proof. apply N.succ_inj_wd. apply a. Qed.

#[global]
Hint Resolve
  N.succ_pred
  N.le_refl
  N.le_trans
(*   Nsucc_le_compat *)
  N.le_succ_diag_r
  N.le_le_succ_r
  N.eq_le_incl: narith.

#[global]
Hint Resolve N.le_refl N.add_comm N.add_assoc N.mul_comm N.mul_assoc N.add_0_l
  N.add_0_r N.mul_1_l
  N.mul_add_distr_r: narith.

#[global]
Hint Resolve
  (** ** Reversible simplification lemmas (no loss of information)      *)
  (** Should clearly be declared as hints                               *)

  (** Lemmas ending by eq *)
  Nsucc_eq_compat (* n = m -> N.succ n = N.succ m *)

  (** Lemmas ending by N.gt *)
(*   Nsucc_gt_compat (* m > n -> N.succ m > N.succ n *) *)
(*   Ngt_succ (* N.succ n > n *) *)
(*   Norder.Ngt_pos_0 (* N.pos p > 0 *) *)
(*   Nplus_gt_compat_l (* n > m -> p+n > p+m *) *)
(*   Nplus_gt_compat_r (* n > m -> n+p > m+p *) *)

  (** Lemmas ending by N.lt *)
(*   Pos2N.is_pos (* 0 < N.pos p *) *)
(*   N.lt_succ_diag_r (* n < N.succ n *) *)
(*   Nsucc_lt_compat (* n < m -> N.succ n < N.succ m *) *)
  N.lt_pred_l (* N.pred n < n *)
(*   Nplus_lt_compat_l (* n < m -> p+n < p+m *) *)
(*   Nplus_lt_compat_r (* n < m -> n+p < m+p *) *)

  (** Lemmas ending by N.le *)
(*   Nat2N.is_nonneg (* 0 <= N.of_nat n *) *)
(*   Pos2N.is_nonneg (* 0 <= N.pos p *) *)
  N.le_refl (* n <= n *)
  N.le_succ_diag_r (* n <= N.succ n *)
(*   Nsucc_le_compat (* m <= n -> N.succ m <= N.succ n *) *)
  N.le_pred_l (* N.pred n <= n *)
  N.le_min_l (* N.min n m <= n *)
  N.le_min_r (* N.min n m <= m *)
(*   Nplus_le_compat_l (* n <= m -> p+n <= p+m *) *)
(*   Nplus_le_compat_r (* a <= b -> a+c <= b+c *) *)
(*   N.abs_nonneg (* 0 <= |x| *) *)

  (** ** Irreversible simplification lemmas *)
  (** Probably to be declared as hints, when no other simplification is possible *)

  (** Lemmas ending by eq *)
(*   N_eq_mult (* y = 0 -> y*x = 0 *) *)
(*   Nplus_eq_compat (* n = m -> p = q -> n+p = m+q *) *)

  (** Lemmas ending by N.ge *)
(*   Norder.Nmult_ge_compat_r (* a >= b -> c >= 0 -> a*c >= b*c *) *)
(*   Norder.Nmult_ge_compat_l (* a >= b -> c >= 0 -> c*a >= c*b *) *)
(*   Norder.Nmult_ge_compat (* : *)
      a >= c -> b >= d -> c >= 0 -> d >= 0 -> a*b >= c*d *)

  (** Lemmas ending by N.lt *)
(*   Norder.Nmult_gt_0_compat (* a > 0 -> b > 0 -> a*b > 0 *) *)
  N.lt_lt_succ_r (* n < m -> n < N.succ m *)

  (** Lemmas ending by N.le *)
  N.mul_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x*y *)
(*   Norder.Nmult_le_compat_r (* a <= b -> 0 <= c -> a*c <= b*c *) *)
(*   Norder.Nmult_le_compat_l (* a <= b -> 0 <= c -> c*a <= c*b *) *)
  N.add_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x+y *)
  N.le_le_succ_r (* x <= y -> x <= N.succ y *)
  N.add_le_mono (* n <= m -> p <= q -> n+p <= m+q *)

  : narith.

(** These are not in [Z] either. What is going on? *)

#[local] Hint Resolve N.le_antisymm N.mul_1_r N.mul_0_r N.mul_add_distr_l : narith.

Ltac ecrush :=
  repeat (try typeclasses eauto; esplit);
  hnf in *; eauto with narith.

(** ** Decidable Total Ordering *)

#[export] Instance N_has_equiv_rel : HasEquivRel N := _=_.
#[export] Instance N_has_equiv_dec : HasEquivDec N := N.eq_dec.
#[export] Instance N_has_ord_rel : HasOrdRel N := N.le.

#[export] Instance N_le_is_refl : IsRefl N.le.
Proof. ecrush. Qed.

#[export] Instance N_le_is_trans : IsTrans N.le.
Proof. ecrush. Qed.

#[export] Instance N_le_is_connex : IsConnex N.le.
Proof.
  intros x y.
  pose proof N.le_gt_cases x y as a.
  pose proof N.lt_le_incl y x as b.
  intuition.
Qed.

#[export] Instance N_le_is_preord : IsPreord N.le.
Proof. ecrush. Qed.

#[export] Instance N_le_is_antisym : IsAntisym _=_ N.le.
Proof. ecrush. Qed.

#[export] Instance N_le_is_part_ord : IsPartOrd _=_ N.le.
Proof. ecrush. Qed.

#[export] Instance N_le_is_tot_ord : IsTotOrd _=_ N.le.
Proof. ecrush. Qed.

(** ** Additive Group *)

Module Additive.

#[export] Instance N_has_null_op : HasNullOp N := 0.
#[export] Instance N_has_bin_op : HasBinOp N := N.add.

End Additive.

#[export] Instance N_add_is_assoc : IsAssoc _=_ N.add.
Proof. ecrush. Qed.

#[export] Instance N_add_is_semigrp : IsSemigrp _=_ N.add.
Proof. ecrush. Qed.

#[local] Instance N_add_is_unl_elem_l : IsUnlElemL _=_ 0 N.add.
Proof. ecrush. Qed.

#[local] Instance N_add_is_unl_elem_r : IsUnlElemR _=_ 0 N.add.
Proof. ecrush. Qed.

#[export] Instance N_add_is_unl_elem : IsUnlElem _=_ 0 N.add.
Proof. ecrush. Qed.

#[export] Instance N_add_is_mon : IsMon _=_ 0 N.add.
Proof. ecrush. Qed.

#[export] Instance N_add_is_comm_bin_op : IsCommBinOp _=_ N.add.
Proof. ecrush. Qed.

(** ** Multiplicative Group *)

Module Multiplicative.

#[export] Instance N_has_null_op : HasNullOp N := 1.
#[export] Instance N_has_bin_op : HasBinOp N := N.mul.

End Multiplicative.

#[export] Instance N_mul_is_assoc : IsAssoc _=_ N.mul.
Proof. ecrush. Qed.

#[export] Instance N_mul_is_semigrp : IsSemigrp _=_ N.mul.
Proof. ecrush. Qed.

#[local] Instance N_mul_is_unl_elem_l : IsUnlElemL _=_ 1 N.mul.
Proof. ecrush. Qed.

#[local] Instance N_mul_is_unl_elem_r : IsUnlElemR _=_ 1 N.mul.
Proof. ecrush. Qed.

#[export] Instance N_mul_is_unl_elem : IsUnlElem _=_ 1 N.mul.
Proof. ecrush. Qed.

#[export] Instance N_mul_is_mon : IsMon _=_ 1 N.mul.
Proof. ecrush. Qed.

#[export] Instance N_mul_is_comm_bin_op : IsCommBinOp _=_ N.mul.
Proof. ecrush. Qed.

(** ** Ring *)

#[export] Instance N_has_zero : HasZero N := 0.
#[export] Instance N_has_add : HasAdd N := N.add.
#[export] Instance N_has_one : HasOne N := 1.
#[export] Instance N_has_mul : HasMul N := N.mul.

#[local] Instance N_is_distr_l : IsDistrL _=_ N.mul N.add.
Proof. ecrush. Qed.

#[local] Instance N_is_distr_r : IsDistrR _=_ N.mul N.add.
Proof. ecrush. Qed.

#[export] Instance N_is_distr : IsDistr _=_ N.mul N.add.
Proof. ecrush. Qed.

#[export] Instance N_is_semiring : IsSemiring _=_ 0 N.add 1 N.mul.
Proof. ecrush. Qed.

Module N.

(** We extend the [N] module here. *)

Export BinNat.N.

(* #[local] Open Scope positive_scope.

#[global] Instance lt_well_founded : WellFounded Pos.lt.
Proof. hnf. intros n.
  constructor. intros p.
  revert p; induction n as [q a | q a |]; intros p l.
  3:{ lia. }
  { constructor. intros r l'. apply a. clear a. assert (l'' : r < xO q) by lia. }
  { constructor. intros r l'. apply a. clear a. } Defined. *)

#[local] Open Scope N_scope.

(* #[global] Instance lt_well_founded : WellFounded lt := lt_wf_0. *)

#[global] Instance lt_well_founded : WellFounded lt.
Proof.
  intros n.
  constructor.
  induction n as [| q a] using peano_ind; intros p l.
  - lia.
  - constructor. intros r l'. apply a. clear a. lia.
Defined.

(** This incomplete set of corollaries
    would be generated by the equations plugin. *)

Corollary succ_equation_1 : succ 0 = 1.
Proof. reflexivity. Qed.

Corollary succ_equation_2 (p : positive) : succ (Npos p) = Npos (Pos.succ p).
Proof. reflexivity. Qed.

#[export] Hint Rewrite @succ_equation_1 @succ_equation_2 : succ.

Corollary pred_equation_1 : pred 0 = 0.
Proof. reflexivity. Qed.

Corollary pred_equation_2 (p : positive) : pred (Npos p) = Pos.pred_N p.
Proof. reflexivity. Qed.

#[export] Hint Rewrite @pred_equation_1 @pred_equation_2 : pred.

(** Whether the given number is a power of two or not. *)

Equations bin (n : N) : bool :=
  bin N0 := false;
  bin (Npos p) := Pos.bin p.

(** These lemmas are missing from the standard library. *)

Lemma pos_shiftl_succ_r' (a : positive) (b : N) :
  Pos.shiftl a (succ b) = xO (Pos.shiftl a b).
Proof.
  destruct b as [| p].
  - reflexivity.
  - simp succ. unfold Pos.shiftl.
    rewrite Pos.iter_succ.
    reflexivity.
Qed.

(** These instances are missing from the standard library. *)

Global Program Instance Decidable_equiv_N (x y : N) : Decidable (x = y) := {
  Decidable_witness := eqb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply eqb_eq. Qed.

Global Program Instance Decidable_le_N (x y : N) : Decidable (x <= y) := {
  Decidable_witness := leb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply leb_le. Qed.

Global Program Instance Decidable_lt_N (x y : N) : Decidable (x < y) := {
  Decidable_witness := ltb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply ltb_lt. Qed.

Global Instance le_add_wd : Proper (le ==> le ==> le) add.
Proof. intros n p l n' p' l'. apply add_le_mono; [lia |]. lia. Qed.

Global Instance le_mul_wd : Proper (le ==> le ==> le) mul.
Proof. intros n p l n' p' l'. apply mul_le_mono; [lia |]. lia. Qed.

Global Instance le_div2_wd : Proper (le ==> le) div2.
Proof.
  intros n p l. do 2 rewrite div2_div.
  apply div_le_mono; [lia |]. lia.
Qed.

Global Instance le_sqrt_wd : Proper (le ==> le) sqrt.
Proof. intros n p l. apply sqrt_le_mono. lia. Qed.

(** Distance between two natural numbers. *)

Definition dist (n p : N) : N :=
  max n p - min n p.

Arguments dist _ _ : assert.

Lemma dist_eqn (n p : N) : dist n p =
  if n <=? p then p - n else n - p.
Proof. cbv [dist]. destruct (leb_spec n p) as [l | l]; lia. Qed.

(** Distance is commutative. *)

Lemma dist_comm (n p : N) : dist n p = dist p n.
Proof. cbv [dist]. lia. Qed.

(** A specialization of [seq] for [N]. *)

Fixpoint seq (n : N) (p : nat) : list N :=
  match p with
  | O => nil
  | S q => n :: seq (succ n) q
  end.

(** Division, rounding down. *)

Definition pos_div (n : N) (p : positive) : N :=
  match n with
  | N0 => 0
  | Npos q => fst (pos_div_eucl q (Npos p))
  end.

Arguments pos_div !_ _.

(** Division, rounding up. *)

Definition pos_div_up (n : N) (p : positive) : N :=
  match n with
  | N0 => 0
  | Npos q =>
    match peanoView q with
    | PeanoOne => 1
    | PeanoSucc r _ => succ (fst (pos_div_eucl r (Npos p)))
    end
  end.

Arguments pos_div_up !_ _ : simpl nomatch.

(** Binary logarithm, rounding down.
    Sequence A000523. *)

Fixpoint pos_log2 (n : positive) : N :=
  match n with
  | xI p => succ (pos_log2 p)
  | xO p => succ (pos_log2 p)
  | xH => 0
  end.

Arguments pos_log2 !_.

(** Binary logarithm, rounding up.
    Sequence A029837. *)

Definition pos_log2_up (n : positive) : N :=
  match peanoView n with
  | PeanoOne => 0
  | PeanoSucc p _ => succ (pos_log2 p)
  end.

Arguments pos_log2_up _ : simpl nomatch.

(** Binary logarithm, with a remainder. *)

Fixpoint pos_log2rem (n : positive) : N * N :=
  match n with
  | xI p => let (l, m) := pos_log2rem p in (succ l, succ (double m))
  | xO p => let (l, m) := pos_log2rem p in (succ l, double m)
  | xH => (0, 0)
  end.

Arguments pos_log2rem !_.

Definition log2rem (n : N) : N * N :=
  match n with
  | N0 => (0, 0)
  | Npos p => pos_log2rem p
  end.

Arguments log2rem !_.

(** Specification for [pos_log2rem].
    Analogous in structure to [sqrtrem_spec]. *)

Lemma pos_log2rem_spec (n : positive) :
  let (l, m) := pos_log2rem n in Npos n = 2 ^ l + m /\ m < 2 ^ l.
Proof.
  induction n as [p ei | p ei |].
  - cbn. destruct (pos_log2rem p) as [q r] eqn : e. split.
    + destruct ei as [e0 e1].
      rewrite pow_succ_r by lia.
      rewrite (double_spec r).
      replace (2 * 2 ^ q + succ (2 * r))
      with (1 + 2 * (2 ^ q + r)) by lia.
      rewrite <- e0. lia.
    + destruct ei as [e0 e1].
      rewrite pow_succ_r by lia.
      rewrite (double_spec r). lia.
  - cbn. destruct (pos_log2rem p) as [q r] eqn : e. split.
    + destruct ei as [e0 e1].
      rewrite pow_succ_r by lia.
      rewrite (double_spec r).
      replace (2 * 2 ^ q + 2 * r)
      with (2 * (2 ^ q + r)) by lia.
      rewrite <- e0. lia.
    + destruct ei as [e0 e1].
      rewrite pow_succ_r by lia.
      rewrite (double_spec r).
      lia.
  - cbn. lia.
Qed.

(** Specification for [log2rem].
    Analogous in structure to [sqrtrem_spec]. *)

Lemma log2rem_spec (n : N) (l : 0 < n) :
  let (l, m) := log2rem n in n = 2 ^ l + m /\ m < 2 ^ l.
Proof.
  destruct n as [| p].
  - lia.
  - cbv [log2rem]. apply (pos_log2rem_spec p).
Qed.

(** Definition of [div] as an equation.
    Analogous in structure to [sqrtrem_sqrt]. *)

Lemma div_eucl_div (a b : N) : fst (div_eucl a b) = a / b.
Proof. reflexivity. Qed.

(** More elaborate specification for [div_eucl] than [div_eucl_spec].
    Analogous in structure to [sqrtrem_spec]. *)

Lemma div_eucl_spec' (n p : N) :
  let (q, r) := div_eucl n p in n = p * q + r /\ (p <> 0 -> r < p).
Proof.
  destruct n as [| n], p as [| p]; cbv [div_eucl] in *.
  - lia.
  - lia.
  - lia.
  - pose proof pos_div_eucl_spec n (pos p) as enp.
    pose proof pos_div_eucl_remainder n (pos p) as lnp.
    destruct (pos_div_eucl n (pos p)) as [q r]; cbv [fst snd] in *. lia.
Qed.

Ltac destruct_div_eucl' a' b' eab' ea' e0ab' l1ab' :=
  let aab' := fresh "a" a' b' in
  match goal with
  | |- context [div_eucl ?x ?y] =>
    pose proof div_eucl_spec' x y as aab';
    destruct (div_eucl x y) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (div_eucl_div x y))
      (f_equal fst eab')) as ea';
    destruct aab' as [e0ab' l1ab']
  | h : context [div_eucl ?x ?y] |- _ =>
    pose proof div_eucl_spec' x y as aab';
    destruct (div_eucl x y) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (div_eucl_div x y))
      (f_equal fst eab')) as ea';
    destruct aab' as [e0ab' l1ab']
  end.

(** Replace a call to [div_eucl] with its specification
    in the goal and hypotheses. *)

Tactic Notation "destruct_div_eucl"
  ident(a') ident(b') ident(eab') ident(ea') ident(e0ab') ident(l1ab') :=
  destruct_div_eucl' a' b' eab' ea' e0ab' l1ab'.

(** Perform [destruct_div_eucl] with fresh variable names. *)

Ltac destruct_div_eucl_fresh :=
  let a' := fresh "a" in
  let b' := fresh "b" in
  let eab' := fresh "e" a' b' in
  let ea' := fresh "e" a' in
  let e0ab' := fresh "e0" a' b' in
  let l1ab' := fresh "l1" a' b' in
  destruct_div_eucl a' b' eab' ea' e0ab' l1ab'.

Ltac destruct_sqrtrem' a' b' eab' ea' e0ab' l1ab' :=
  let aab' := fresh "a" a' b' in
  match goal with
  | |- context [sqrtrem ?x] =>
    pose proof sqrtrem_spec x as aab';
    destruct (sqrtrem x) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (sqrtrem_sqrt x))
      (f_equal fst eab')) as ea';
    destruct aab' as [e0ab' l1ab']
  | h : context [sqrtrem ?x] |- _ =>
    pose proof sqrtrem_spec x as aab';
    destruct (sqrtrem x) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (sqrtrem_sqrt x))
      (f_equal fst eab')) as ea';
    destruct aab' as [e0ab' l1ab']
  end.

(** Replace a call to [sqrtrem] with its specification
    in the goal and hypotheses. *)

Tactic Notation "destruct_sqrtrem"
  ident(a') ident(b') ident(eab') ident(ea') ident(e0ab') ident(l1ab') :=
  destruct_sqrtrem' a' b' eab' ea' e0ab' l1ab'.

(** Perform [destruct_sqrtrem] with fresh variable names. *)

Ltac destruct_sqrtrem_fresh :=
  let a' := fresh "a" in
  let b' := fresh "b" in
  let eab' := fresh "e" a' b' in
  let ea' := fresh "e" a' in
  let e0ab' := fresh "e0" a' b' in
  let l1ab' := fresh "l1" a' b' in
  destruct_sqrtrem a' b' eab' ea' e0ab' l1ab'.

(** Minimum with a remainder.
    Analogous in structure to [div_eucl] and [sqrtrem]. *)

Definition min_max (n p : N) : N * N :=
  if n <? p then (n, p) else (p, n).

Arguments min_max _ _ : assert.

(** Specification for [min_max].
    Analogous in structure to [min_spec] and [max_spec]. *)

Lemma min_max_spec (n p : N) :
  n < p /\ min_max n p = (n, p) \/
  p <= n /\ min_max n p = (p, n).
Proof. cbv [min_max]. destruct (ltb_spec n p); auto. Qed.

(** Definition of [min] as an equation.
    Analogous in structure to [sqrtrem_sqrt]. *)

Lemma min_max_min (a b : N) : fst (min_max a b) = min a b.
Proof.
  destruct (min_max_spec a b) as [[l e] | [l e]],
  (min_spec a b) as [[l' e'] | [l' e']].
  - rewrite e, e'. auto.
  - rewrite e, e'. lia.
  - rewrite e, e'. lia.
  - rewrite e, e'. auto.
Qed.

(** Definition of [max] as an equation.
    Analogous in structure to [sqrtrem_sqrt]. *)

Lemma min_max_max (a b : N) : snd (min_max a b) = max a b.
Proof.
  destruct (min_max_spec a b) as [[l e] | [l e]],
  (max_spec a b) as [[l' e'] | [l' e']].
  - rewrite e, e'. auto.
  - rewrite e, e'. lia.
  - rewrite e, e'. lia.
  - rewrite e, e'. auto.
Qed.

Ltac destruct_min_max' a' b' eab' ea' eb' l0ab' e1ab' :=
  let aab' := fresh "a" a' b' in
  match goal with
  | |- context [min_max ?x ?y] =>
    pose proof min_max_spec x y as aab';
    destruct (min_max x y) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (min_max_min x y))
      (f_equal fst eab')) as ea';
    pose proof (eq_trans (z := b') (eq_sym (min_max_max x y))
      (f_equal snd eab')) as eb';
    destruct aab' as [[l0ab' e1ab'] | [l0ab' e1ab']]
  | h : context [min_max ?x ?y] |- _ =>
    pose proof min_max_spec x y as aab';
    destruct (min_max x y) as [a' b'] eqn : eab';
    pose proof (eq_trans (z := a') (eq_sym (min_max_min x y))
      (f_equal fst eab')) as ea';
    pose proof (eq_trans (z := b') (eq_sym (min_max_max x y))
      (f_equal snd eab')) as eb';
    destruct aab' as [[l0ab' e1ab'] | [l0ab' e1ab']]
  end.

(** Replace a call to [min_max] with its specification
    in the goal and hypotheses. *)

Tactic Notation "destruct_min_max"
  ident(a') ident(b') ident(eab') ident(ea') ident(eb') ident(l0ab') ident(e1ab') :=
  destruct_min_max' a' b' eab' ea' eb' l0ab' e1ab'.

(** Perform [destruct_min_max] with fresh variable names. *)

Ltac destruct_min_max_fresh :=
  let a' := fresh "a" in
  let b' := fresh "b" in
  let eab' := fresh "e" a' b' in
  let ea' := fresh "e" a' in
  let eb' := fresh "e" b' in
  let l0ab' := fresh "l0" a' b' in
  let e1ab' := fresh "e1" a' b' in
  destruct_min_max a' b' eab' ea' eb' l0ab' e1ab'.

(** These lemmas are missing from the standard library. *)

Lemma shiftl_1_r (a : N) : shiftl a 1 = a * 2.
Proof. rewrite shiftl_mul_pow2. rewrite pow_1_r. reflexivity. Qed.

Lemma shiftr_1_l (n : N) : shiftr 1 n = 1 / 2 ^ n.
Proof. rewrite shiftr_div_pow2. reflexivity. Qed.

Lemma shiftr_1_r (a : N) : shiftr a 1 = a / 2.
Proof. rewrite <- div2_spec. rewrite div2_div. reflexivity. Qed.

(** If we admit that subtraction is saturative (by [sub_0_l]),
    we might as well admit that division and binary logarithm are total
    (by [div_0_r] and [log2_0] respectively). *)

Lemma div_0_r (a : N) : a / 0 = 0.
Proof. destruct a as [| p]; reflexivity. Qed.

Lemma log2_0 : log2 0 = 0.
Proof. reflexivity. Qed.

(** Eliminate all occurrences of
    [shiftl], [double], [succ], [shiftr], [div2] and [pred]. *)

Ltac eliminate :=
  (** Eliminate [shiftl 0 _].
      This shortcut is equivalent to [shiftl_mul_pow2]
      followed by [mul_0_l]. *)
  repeat rewrite shiftl_0_l in *;
  (** Eliminate [shiftl _ 0].
      This shortcut is equivalent to [shiftl_mul_pow2]
      followed by [pow_0_r] and [mul_1_r]. *)
  repeat rewrite shiftl_0_r in *;
  (** Eliminate [shiftl 1 _] into [2 ^ _].
      This shortcut is equivalent to [shiftl_mul_pow2]
      followed by [mul_1_l]. *)
  repeat rewrite shiftl_1_l in *;
  (** Eliminate [shiftl _ 1] into [_ * 2].
      This shortcut is equivalent to [shiftl_mul_pow2]
      followed by [pow_1_r]. *)
  repeat rewrite shiftl_1_r in *;
  (** Eliminate [shiftl _ _] into [_ * 2 ^ _]. *)
  repeat rewrite shiftl_mul_pow2 in *;
  (** Eliminate [double _] into [2 * _]. *)
  repeat rewrite double_spec in *;
  (** Eliminate [succ _] into [1 + _]. *)
  repeat rewrite <- add_1_l in *;
  (** Eliminate [shiftr 0 _].
      This shortcut is equivalent to [shiftr_div_pow2]
      followed by [div_0_l] with [pow_nonzero]. *)
  repeat rewrite shiftr_0_l in *;
  (** Eliminate [shiftr _ 0].
      This shortcut is equivalent to [shiftr_div_pow2]
      followed by [pow_0_r] and [div_1_r]. *)
  repeat rewrite shiftr_0_r in *;
  (** Eliminate [shiftr 1 _] into [1 / 2 ^ _].
      This shortcut is equivalent to [shiftr_div_pow2]. *)
  repeat rewrite shiftr_1_l in *;
  (** Eliminate [shiftr _ 1] into [_ / 2].
      This shortcut is equivalent to [shiftr_div_pow2]
      followed by [pow_1_r]. *)
  repeat rewrite shiftr_1_r in *;
  (** Eliminate [shiftr _ _] into [_ / 2 ^ _]. *)
  repeat rewrite shiftr_div_pow2 in *;
  (** Eliminate [div2 _] into [_ / 2]. *)
  repeat rewrite div2_div in *;
  (** Eliminate [pred] into [_ - 1]. *)
  repeat rewrite <- sub_1_r in *;
  idtac.

(** Simplify occurrences of
    [_ ^ _], [_ * _], [_ + _], [log2], [_ / _] and [_ - _].
    Rewrite rules that produce subgoals will fail,
    unless they can be immediately proven with [force]. *)

Ltac simplify_by force :=
  (** Reduce [_ ^ _], [_ * _], [_ + _], [log2], [_ / _] and [_ - _]. *)
  (** Try to eliminate [0 ^ _]. *)
  repeat rewrite pow_0_l in * by force;
  (** Eliminate [_ ^ 0]. *)
  repeat rewrite pow_0_r in *;
  (** Eliminate [1 ^ _]. *)
  repeat rewrite pow_1_l in *;
  (** Eliminate [_ ^ 1]. *)
  repeat rewrite pow_1_r in *;
  (** Do not try to eliminate [_ ^ _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  (** Eliminate [0 * _]. *)
  repeat rewrite mul_0_l in *;
  (** Eliminate [_ * 0]. *)
  repeat rewrite mul_0_r in *;
  (** Eliminate [1 * _]. *)
  repeat rewrite mul_1_l in *;
  (** Eliminate [_ * 1]. *)
  repeat rewrite mul_1_r in *;
  (** Do not try to eliminate [_ * _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  (** Eliminate [0 + _]. *)
  repeat rewrite add_0_l in *;
  (** Eliminate [_ + 0]. *)
  repeat rewrite add_0_r in *;
  (** Do not try to eliminate [_ + _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  (** Eliminate [log2 0].
      This is specific to the way [log2] is defined. *)
  repeat rewrite log2_0 in *;
  (** Eliminate [log2 1]. *)
  repeat rewrite log2_1 in *;
  (** Eliminate [log2 2]. *)
  repeat rewrite log2_2 in *;
  (** Do not eliminate [log2 _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  (** Try to eliminate [0 / _]. *)
  repeat rewrite div_0_l in * by force;
  (** Eliminate [_ / 0].
      This is specific to the way [div] is defined. *)
  repeat rewrite div_0_r in *;
  (** Try to eliminate [1 / _]. *)
  repeat rewrite div_1_l in * by force;
  (** Eliminate [_ / 1]. *)
  repeat rewrite div_1_r in *;
  (** Do not try to eliminate [_ / _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  (** Eliminate [0 - _].
      This is specific to the way [sub] is defined. *)
  repeat rewrite sub_0_l in *;
  (** Eliminate [_ - 0]. *)
  repeat rewrite sub_0_r in *;
  (** Do not try to eliminate [_ - _],
      because it would be impossible. *)
  (* repeat rewrite _ in *; *)
  idtac.

(** Prepare for reduction or reduce occurrences of
    [_ ^ _], [_ * _], [_ + _], [log2], [_ / _] and [_ - _].
    Rewrite rules that produce subgoals will fail,
    unless they can be immediately proven with [force]. *)

Ltac preduce :=
  (** Reduce [_ ^ _], [_ * _], [_ + _], [log2], [_ / _] and [_ - _]. *)
  repeat reduce_2 is_N is_N pow;
  repeat reduce_2 is_N is_N mul;
  repeat reduce_2 is_N is_N add;
  repeat reduce_1 is_N log2;
  repeat reduce_2 is_N is_N div;
  repeat reduce_2 is_N is_N sub;
  (** Commute [_ * _] and [_ + _],
      so that constants always appear on the left side
      (corresponding to the structurally recursive parameter). *)
  repeat recomm_2_0 is_N mul mul_comm;
  repeat recomm_2_0 is_N add add_comm;
  (** Associate [_ * _] and [_ + _],
      so that constants always appear on the deeper level
      (and thus reduce). *)
  repeat reassoc_2 is_N mul mul_assoc;
  repeat reassoc_2 is_N add add_assoc;
  idtac.

(** Convert expressions involving bit manipulation
    into expressions involving basic arithmetic.

    The conversion repeats three steps
    until they no longer make progress in the proof.
    In the first step, we eliminate occurrences of
    [shiftl], [double], [succ], [shiftr], [div2] and [pred], and
    in the remaining steps, we simplify and reduce occurrences of
    [_ ^ _], [_ * _], [_ + _], [log2], [_ / _] and [_ - _].

    After the conversion,
    we expect two kinds of properties to hold.
    Most importantly,
    no occurrence of [_ * _] or [_ + _]
    will have constants appear on the right side,
    no occurrence of [_ ^ _], [_ / _] or [_ - _]
    will have constants appear on both sides and
    no occurrence of [log2] will have constants appear anywhere.
    Less importantly,
    no occurrence of [0], [1] or [2] should be unnecessary
    according to the algebraic structure of the operations. *)

Ltac arithmetize_by force := eliminate; repeat (simplify_by force; preduce).

(** Specialization of [arithmetize_by] using [lia]. *)

Ltac arithmetize := arithmetize_by lia.

(** Dividing an even number by two. *)

Lemma div_Even (n : N) : 2 * n / 2 = n.
Proof.
  induction n as [| p ei] using peano_ind; arithmetize.
  - reflexivity.
  - replace (2 * (1 + p)) with (1 * 2 + 2 * p) by lia.
    rewrite div_add_l by lia. rewrite ei. lia.
Qed.

(** Dividing an odd number by two. *)

Lemma div_Odd (n : N) : (1 + 2 * n) / 2 = n.
Proof.
  induction n as [| p ei] using peano_ind; arithmetize.
  - reflexivity.
  - replace (1 + 2 * (1 + p)) with (1 * 2 + (1 + 2 * p)) by lia.
    rewrite div_add_l by lia. rewrite ei. lia.
Qed.

(** Sum of two consecutive natural numbers is odd. *)

Lemma Odd_add_consecutive (n : N) : Odd (n + (1 + n)).
Proof.
  induction n as [| p xi] using peano_ind; arithmetize.
  - exists 0. reflexivity.
  - destruct xi as [q e]. exists (1 + q). lia.
Qed.

(** Product of two consecutive natural numbers is even. *)

Lemma Even_mul_consecutive (n : N) : Even (n * (1 + n)).
Proof.
  destruct (Even_or_Odd n) as [x | x].
  - destruct x as [p e]. exists (p * (1 + 2 * p)). lia.
  - destruct x as [p e]. exists ((2 * p + 1) * (1 + p)). lia.
Qed.

End N.


Require Import PyLevelLang.Language.
Require Import coqutil.Map.Interface coqutil.Map.SortedListString.

Local Open Scope Z_scope.

Fixpoint interp_type (t : type) :=
  match t with
  | TInt => Z
  | TBool => bool
  | TString => string
  | TPair _ t1 t2 => prod (interp_type t1) (interp_type t2)
  | TList t' => list (interp_type t')
  | TEmpty => unit
  end.

Fixpoint default_val (t : type) : interp_type t :=
  match t as t' return interp_type t' with
  | TInt => 0
  | TBool => false
  | TString => EmptyString
  | TPair _ t1 t2 => (default_val t1, default_val t2)
  | TList t' => nil
  | TEmpty => tt
  end.

Fixpoint eval_range (lo : Z) (len : nat) : list Z :=
  match len with
  | 0%nat => nil
  | S n => lo :: eval_range (lo + 1) n
  end.

Definition proj_expected (t_expected : type) (v : {t_actual & interp_type t_actual}) :
  interp_type t_expected :=
  match type_eq_dec (projT1 v) t_expected with
  | left H => cast H _ (projT2 v)
  | _ => default_val t_expected
  end.

Definition eqb_values {t : type} (H : can_eq t = true) :
  interp_type t -> interp_type t -> bool.
Proof.
  refine (
  match t as t' return can_eq t' = true -> interp_type t' -> interp_type t' -> bool with
  | TInt => fun _ => Z.eqb
  | TString => fun _ => String.eqb
  | TBool => fun _ => Bool.eqb
  | TEmpty => fun _ => fun _ _ => true
  | _ => _
  end H); easy.
Defined.

Section WithMap.
  Context {locals: map.map string {t & interp_type t}} {locals_ok: map.ok locals}.

  Definition get_local (l : locals) {t : type} (x : string) : interp_type t :=
    match map.get l x with
    | Some v => proj_expected _ v
    | None => default_val _
    end.

  Definition set_local (l : locals) {t : type} (x : string) (v : interp_type t) :
    locals := map.put l x (existT _ _ v).

  Definition interp_atom {t : type} (a : atom t) : interp_type t :=
    match a with
    | AInt n => n
    | ABool b => b
    | AString s => s
    | ANil t => nil
    | AEmpty => tt
    end.

  Definition interp_unop {t1 t2 : type} (o : unop t1 t2) :
    interp_type t1 -> interp_type t2 :=
    match o in unop t1 t2 return interp_type t1 -> interp_type t2 with
    | ONeg => Z.sub 0
    | ONot => negb
    | OLength _ => fun x => Z.of_nat (length x)
    | OLengthString => fun x => Z.of_nat (String.length x)
    | OFst _ _ _ => fst
    | OSnd _ _ _ => snd
    end.

  Definition interp_binop {t1 t2 t3: type} (o : binop t1 t2 t3) :
    interp_type t1 -> interp_type t2 -> interp_type t3 :=
    match o in binop t1 t2 t3
    return interp_type t1 -> interp_type t2 -> interp_type t3 with
    | OPlus =>  Z.add
    | OMinus => Z.sub
    | OTimes => Z.mul
    | ODiv => Z.div
    | OMod => Z.modulo
    | OAnd => andb
    | OOr => orb
    | OConcat _ => fun a b => app a b
    | OConcatString => String.append
    | OLess => Z.ltb
    | OEq _ H => eqb_values H
    | ORepeat _ => fun l n => concat (repeat l (Z.to_nat n))
    | OPair _ _ _ => pair
    | OCons _ => cons
    | ORange => fun s e => eval_range s (Z.to_nat (e - s))
    end.

  Fixpoint interp_expr (l : locals) {t : type} (e : expr t) : interp_type t :=
    match e in (expr t0) return (interp_type t0) with
    | EVar _ x | ELoc _ x => get_local l x
    | EAtom a => interp_atom a
    | EUnop o e1 => interp_unop o (interp_expr l e1)
    | EBinop o e1 e2 => interp_binop o (interp_expr l e1) (interp_expr l e2)
    | EFlatmap l1 x fn => flat_map (fun y => interp_expr (set_local l x y) fn) (interp_expr l l1)
    | EIf e1 e2 e3 => if interp_expr l e1 then interp_expr l e2 else interp_expr l e3
    | EFold l1 a x y fn => let l1' := interp_expr l l1 in
                             let a' := interp_expr l a in
                             let fn' := fun v acc => interp_expr (set_local (set_local l x v) y acc) fn in
                             fold_right fn' a' l1'
    | ELet x e1 e2 => interp_expr (set_local l x (interp_expr l e1)) e2
    end.

  Fixpoint interp_command (l : locals) (c : command) : locals :=
    match c with
    | CSkip => l
    | CSeq c1 c2 => interp_command (interp_command l c1) c2
    | CLet x e c1 | CLetMut x e c1 => let l' := interp_command (set_local l x (interp_expr l e)) c1 in
                                      map.update l' x (map.get l x)
    | CGets x e => set_local l x (interp_expr l e)
    | CIf e c1 c2 => if interp_expr l e then interp_command l c1 else interp_command l c2
    | CForeach x e c1 => let l' := fold_left (fun l' v => interp_command (set_local l' x v) c1) (interp_expr l e) l in
                         map.update l' x (map.get l x)
    end.
End WithMap.


Set Implicit Arguments.

Require Import Decidable.
Require Import Bool.
Require Import Arith.
Require Export MSetInterface.
Require Export MSetProperties.
(* Require Export Iteration. *)

Module Aux (M: S).

Import M.

Module Props := Properties M.
Import Props.
Module Facts := Props.FM.
Import Facts.

Theorem compat_bool_mem: forall S: M.t, compat_bool E.eq (fun q => mem q S).
Proof.
  intros. unfold compat_bool. simpl_relation. elim Props.In_dec with x S.
    intros. replace (mem x S) with true. replace (mem y S) with true. reflexivity.
      symmetry. apply mem_1. apply In_1 with x. apply H. apply a.
      symmetry. apply mem_1. apply a.
    intros. replace (mem x S) with false. replace (mem y S) with false. reflexivity.
      symmetry. apply not_true_is_false. intro. apply b. apply In_1 with y. symmetry. apply H. apply mem_2. apply H0.
      symmetry. apply not_true_is_false. intro. apply b. apply mem_2. apply H0.
Qed.

Theorem compat_bool_and: forall (S: M.t) (f g: M.E.t -> bool),
   compat_bool E.eq f -> compat_bool E.eq g -> compat_bool E.eq (fun q => f q && g q).
Proof.
   intros. unfold compat_bool. simpl_relation.
     elim (H x y H1). elim (H0 x y H1). reflexivity.
Qed.

Theorem compat_bool_existsb: forall (f: E.t -> M.t -> bool) (l: list (M.t)),
  (forall S: M.t, compat_bool E.eq (fun p => f p S)) -> compat_bool E.eq (fun p => existsb (f p) l).
Proof.
  intros. unfold compat_bool. simpl_relation.
  induction l.
     simpl. trivial.
     simpl. apply eq_bool_prop_intro. split.
        intros. apply orb_prop_intro. elim (orb_prop_elim (f x a) (existsb (f x) l)).
           intros. left. rewrite (H a y x). apply H2. symmetry. apply H0.
           intros. right. rewrite <- IHl. apply H2.
           apply H1.
        intros. apply orb_prop_intro. elim (orb_prop_elim (f y a) (existsb (f y) l)).
            intros. left. rewrite (H a x y). apply H2. apply H0.
            intros. right. rewrite IHl. apply H2.
           apply H1.
Qed.

Lemma and_sum: forall A B, ({A} + {~A}) -> ({B} + {~B}) ->
  {A /\ B} + {~(A /\ B)}.
Proof.
  intros. destruct H. destruct H0.
    left. split. apply a. apply b.
    right. intro. apply n. apply (proj2 H).
    right. intro. apply n. apply (proj1 H).
Qed.

Lemma not_sum: forall A, ({A} + {~A}) ->
  {~A} + {~~A}.
Proof.
  intros. destruct H.
    right. intro. apply H. apply a.
    left. apply n.
Qed.

Theorem Forall_dec: forall (S: M.t) (P: M.E.t -> Prop),
   (forall c: M.E.t, (P c) + {~P c}) -> compat_P E.eq P ->
   {For_all (fun c => P c) S} + {~For_all (fun c => P c) S}.
Proof.
  intros. induction S using Props.set_induction.
    left. unfold For_all. intros. absurd (In x S). apply H0. apply H1.
    elim IHS1.
      intros. elim (X x). intros. left. unfold For_all. intros. elim H1 with x0. intros. elim (H3 H2).
        intros. apply H with x. apply H5. apply a0.
        intros. apply a. apply H5.
      intros. right. intro. apply b. apply H2. elim H1 with x. intros. apply H4. left. apply E.eq_equiv.
   intros. right. intro. apply b. unfold For_all. intros. apply H2. elim H1 with x0.
   intros. apply H5. right. apply H3.
Qed.

Theorem Exists_dec: forall (S: M.t) (P: M.E.t -> Prop),
  (forall c: M.E.t, {P c} + {~P c}) -> compat_P E.eq P ->
  {Exists (fun c => P c) S} + {~Exists (fun c => P c) S}.
Proof.
  intros. induction S using Props.set_induction.
    right. intro. unfold Exists in H1. destruct H1 as [x [Hx1 Hx2]]. apply (H0 x). apply Hx1.
    destruct IHS1.
      left. destruct e. exists x0. split. apply H1. right. apply (proj1 H2). apply (proj2 H2).
      destruct (X x).
        left. exists x. split. apply H1. left. reflexivity. apply p.
        right. intro. destruct H2. destruct (proj1 (H1 x0) (proj1 H2)).
          apply n0. apply H with x0. symmetry. apply H3. apply (proj2 H2).
          apply n. exists x0. split. apply H3. apply (proj2 H2).
Qed.

Theorem not_forall_exists: forall P f, compat_P E.eq f ->
    (forall c, {f c} + {~f c}) -> ~For_all f P ->
    Exists (fun c => ~f c) P.
Proof.
   intros P f H H0 H1. induction P using set_induction.
     elim H1. unfold For_all. intros. absurd (In x P). apply H2. apply H3.
     elim (H0 x).
       intros. elim IHP1. intros. destruct H4. exists x0. split.
         elim (H3 x0). intros. apply H7. right. apply H4. apply H5.
       intro. apply H1. unfold For_all. intros. elim (H3 x0).
         intros. elim (H6 H5).
           intros. apply H with x. apply H8. apply a. apply H4.
       intros. exists x. split.
         elim (H3 x). intros. apply H5. left. reflexivity.
         apply b.
Qed.

Theorem forall_not_exists: forall P f,
   For_all (fun c => ~f c) P ->
   ~Exists f P.
Proof.
  intros. unfold Exists. induction P using set_induction.
    intro. destruct H1. destruct H1. absurd (In x P). apply H0. apply H1.
    intro. destruct H2. destruct H2. apply (H x0). apply H2. apply H3.
Qed.

Definition monotone (f: M.t -> M.t) :=
  forall P: M.t, P [<=] f P.

Definition StrictSubset (S S': M.t) :=
   S [<=] S' /\ ~(S [=] S').
Notation "S [<] T" := (StrictSubset S T) (at level 70, no associativity).

Add Morphism StrictSubset with signature M.eq ==> M.eq ==> iff as StrictSubset_m.
Proof.
  intros. split.
    intros. destruct H1. split. rewrite <- H. rewrite <- H0. apply H1.
    intro. apply H2. rewrite H. rewrite H0. apply H3.
    intros. destruct H1. split. rewrite H. rewrite H0. apply H1.
    intro. apply H2. rewrite <- H. rewrite <- H0. apply H3.
Qed.

Definition strict_subset (S S': M.t): bool :=
  subset S S' && negb (equal S S').

Lemma strict_subset_1: forall S S', StrictSubset S S' -> strict_subset S S' = true.
Proof.
  intros. destruct H. unfold strict_subset. apply <- andb_true_iff. split.
    apply subset_1. apply H.
    apply eq_true_not_negb. intro. apply H0. apply equal_2. apply H1.
Qed.

Lemma strict_subset_2: forall S S', strict_subset S S' = true -> StrictSubset S S'.
Proof.
  intros. symmetry in H. destruct (andb_true_eq _ _ H). split.
    apply subset_2. symmetry. apply H0.
    intro. apply negb_prop_elim with (equal S S'). apply Is_true_eq_right. apply H1.
    apply Is_true_eq_left. apply equal_1. apply H2.
Qed.

Theorem empty_no_subset: forall S E: M.t, Empty E -> ~(S [<] E).
Proof.
  intros. intro. destruct H0. apply H1. split.
     intros. apply H0. apply H2.
     intros. absurd (In a E). apply H. apply H2.
Qed.

Theorem not_empty_subset: forall S: M.t, ~(Empty S) -> (exists S': M.t, S' [<] S).
Proof.
  intros. induction S using set_induction.
    absurd (~Empty S). intro. apply H1. apply H0. apply H.
    exists S1. split.
      unfold Subset. intros. elim (H1 a). intros. apply H4. right. apply H2.
      intro. apply H0. elim (H1 x). intros. rewrite H2. apply H4. left. reflexivity.
Qed.

Theorem strict_subset_trans
: forall S S' S'': M.t, S [<] S' -> S' [<] S'' -> S [<] S''.
Proof.
  intros. destruct H. destruct H0. split. apply subset_trans with S'. apply H. apply H0.
  intro. assert (S' [<=] S). intro. intros. rewrite (H3 a). apply H0. apply H4.
  assert (S [=] S'). apply subset_antisym. apply H. apply H4. apply H1. apply H5.
Qed.

Lemma remove_equal2: forall (s: M.elt) (S: M.t), In s S -> ~(remove s S [=] S).
Proof.
  intro s. induction S using set_induction.
    intros. absurd (In s S). apply H. apply H0.
    intros. elim (H0 s). intros. intro. apply (remove_1 (x:=s) (y:=s) (s:=S2)). apply E.eq_equiv.
    elim (H4 s). intros. apply H6. apply H1.
Qed.

Lemma remove_transpose: transpose Equal remove.
Proof.
  unfold transpose. intros. split.
    intros. apply remove_2. intro. rewrite remove_iff in H. destruct H. rewrite remove_iff in H.
     destruct H. apply H2. apply H0.
     apply remove_2. intro. rewrite remove_iff in H. destruct H. apply H1. apply H0.
     apply remove_3 with y. apply remove_3 with x. apply H.
    intros. apply remove_2. intro. rewrite remove_iff in H. destruct H. rewrite remove_iff in H.
     destruct H. apply H2. apply H0.
     apply remove_2. intro. rewrite remove_iff in H. destruct H. apply H1. apply H0.
     apply remove_3 with x. apply remove_3 with y. apply H.
Qed.

Theorem not_empty_exists: forall S: M.t, ~Empty S -> exists a: M.elt, In a S.
Proof.
  induction S using set_induction.
  intros. elim H0. apply H. intros. exists x. elim H0 with x. intros. apply H3. left. apply E.eq_equiv.
Qed.

Lemma empty_dec:
  forall S: M.t, { Empty S } + { ~Empty S }.
Proof.
  intros. induction S using set_induction.
    left. apply H.
    right. elim (H0 x). intros. intro. absurd (~In x S2). intro. apply H4. apply H2. left. apply E.eq_equiv. apply H3.
Qed.

Lemma elements_empty:
   forall S: M.t, Empty S -> forall a: elt, ~List.In a (elements S).
Proof.
  intros. intro. apply (H a). apply elements_2. apply In_InA. intros. apply E.eq_equiv. apply H0.
Qed.

Theorem add_strict_subset: forall (S1 S2: M.t), (exists x: M.elt, ~In x S1 /\ Add x S1 S2) -> S1 [<] S2.
Proof.
 intros. elim H. intros. destruct H0. split.
     unfold Subset. intros. elim (H1 a). intros. apply H4. right. apply H2.
     intro. apply H0. rewrite (H2 x). elim (H1 x). intros. apply H4. left. apply E.eq_equiv.
Qed.

Theorem strict_subset_equal_or_subset: forall P Q: M.t, P [<=] Q -> P [<] Q \/ P [=] Q.
Proof.
   intros. elim (M.eq_dec P Q). intros. right. apply a.
   intros. left. split.  apply H. apply b.
Qed.

Lemma strict_subset_trans_subset1: forall P Q R: M.t, P [<] Q -> Q [<=] R -> P [<] R.
Proof.
  intros. destruct H. split.
     apply subset_trans with Q. apply H. apply H0.
     intro. apply H1. apply subset_antisym. apply H. rewrite H2. apply H0.
Qed.

Lemma strict_subset_trans_subset2: forall P Q R: M.t, P [<=] Q -> Q [<] R -> P [<] R.
Proof.
  intros. destruct H0. split.
    apply subset_trans with Q. apply H. apply H0.
    intro. apply H1. apply subset_antisym. apply H0. rewrite <- H2. apply H.
Qed.

Lemma strict_subset_irrefl:
  forall S S', S [<] S' -> ~(S' [<] S).
Proof.
  intros. destruct H.
  intro. destruct H1. apply H0. split.
    intro. apply H. apply H3. intro. apply H1. apply H3.
Qed.

Lemma strict_subset_weak:
  forall S S', S [<] S' -> S [<=] S'.
Proof.
  intros. destruct H. apply H.
Qed.

Lemma strict_subset_not_subset:
  forall S S', S [<] S' -> ~S' [<=] S.
Proof.
  intros. intro. destruct H. apply H1. split. apply H. apply H0.
Qed.

Lemma add_inv:
  forall (P: M.t) (x y: M.elt), In x (add y P) -> M.E.eq y x \/ In x P.
Proof.
  intros. elim (M.E.eq_dec y x).
    intros. left. apply a.
    intros. right. apply add_3 with y. intro. apply b. apply H0.
    apply H.
Qed.

Lemma add_eq:
  forall (P Q R: M.t) (x: M.elt), P [=] Q -> Add x P R -> Add x Q R.
Proof.
  intros. split.
    intros. elim (H0 y). intros. rewrite <- H. apply H2. apply H1.
     intros. rewrite <- H in H1. elim (H0 y). intros. apply H3. apply H1.
Qed.

Lemma included_add: forall (X A: M.t) (x: M.elt),
  X [<=] (add x A) -> X [<=] A \/ exists A', X [=] add x A' /\ A' [<=] A.
Proof.
   intros. elim (In_dec x X).
      intros. right. exists (remove x X). split.
        rewrite add_remove. reflexivity. apply a.
        unfold Subset. intros. assert (~(E.eq x a0)).
        intro. apply (remove_1 H1 H0).
        apply (add_3 H1). apply H. apply remove_3 with x. apply H0.
   intros. left. unfold Subset. intros. apply add_3 with x. intro. apply b. rewrite H1. apply H0.
   apply H. apply H0.
Qed.

Theorem strict_subset_induction:
   forall P : t -> Prop,
     (forall X Y: t, X [=] Y -> (P X <-> P Y)) ->
     (forall X: t,
         (forall Y: t, Y [<] X -> P Y) -> P X) ->
     forall X: t, P X.
Proof.
   intros P Heq H X. generalize P Heq H. clear H Heq P.
   induction X using set_induction.
     intros P Heq H0. apply H0. intros. absurd (Y [<] X). apply empty_no_subset. apply H. apply H1.
     intros P Heq H3. cut (forall Y:t, Y [<=] (add x X1) -> P Y).
        intros. apply H1. apply subset_equal. rewrite <- Add_Equal. apply H0.
        generalize H. apply IHX1. intros. split.
          intros. apply H2. intro. apply H4. rewrite <- H1. assumption. rewrite H1. apply H5.
          intros. apply H2. rewrite <- H1. apply H4. rewrite <- H1. apply H5.
        intros X H5 L Y H6. apply H3.
        intros Y0 H7. elim strict_subset_trans_subset1 with Y0 Y (add x X).
           intros H2 H4. elim (included_add H2).
             intros H14. elim strict_subset_equal_or_subset with Y0 X.
                 intros H9. apply H5 with Y0. apply H9. intro. apply L. apply H14.  apply H1. apply subset_add_2. apply subset_refl.
                 intros H9. rewrite (Heq Y0 X). apply H3.
                 intros Y1 H8. elim H8.
                   intros H10 H11. apply H5 with Y1. apply H8. intro. apply L. apply H10. apply H1.
                   apply subset_add_2. apply subset_refl.
                   apply H9. apply H14.
              intros H14. elim H14. intros A' E. elim E. intros H15 H16. clear E H14.
              elim strict_subset_equal_or_subset with A' X.
                 intro H8. apply H5 with (Y := A'). apply H8. intro. apply L. destruct H8. apply H8. apply H1.
                 apply subset_equal. apply H15.
                 intros H8. elim H7.
                    intros H9 H10. elim H10. rewrite <- H8 in H6. rewrite <- H15 in H6. apply subset_antisym. apply H9. apply H6.
                    apply H16. apply H7. apply H6.
Qed.

Theorem wf_strict_subset: well_founded StrictSubset.
Proof.
   intro. apply strict_subset_induction.
      intros. split. intros. split. intros. apply Acc_inv with X. apply H0. destruct H1. split.
         rewrite H. apply H1. rewrite H. apply H2.
      intros. split. intros. apply Acc_inv with Y. apply H0. destruct H1. split.
         rewrite <- H. apply H1. rewrite <- H. apply H2.
      intros. split.  apply H.
Qed.

Lemma subset_add:
   forall P Q: t, P [<=] Q -> forall x: elt, add x P [<=] add x Q.
Proof.
  intros. unfold Subset. intros.
     elim add_inv with P a x.
     intros. apply add_1. apply H1.
     intros. apply add_2. apply H. apply H1.
     apply H0.
Qed.

Lemma subset_inter:
  forall P Q R: t, P [<=] Q -> inter R P [<=] inter R Q.
Proof.
  intros. unfold Subset. intros.
    apply inter_3.
      apply inter_1 with P. apply H0.
      apply H. apply inter_2 with R. apply H0.
Qed.

(* Function iter (n: nat) (C: M.t -> M.t) (g: M.t) {struct n}: M.t :=
  match n with
  | O => g
  | S n' => C (iter n' C g)
  end.

Theorem equal_iter_equal: forall f, (forall P Q, P [=] Q -> f P [=] f Q) -> forall (P Q: M.t) (n: nat),
  P [=] Q -> iter n f P [=] iter n f Q.
Proof.
  intros. induction n.
      simpl. apply H0.
      simpl. apply H. apply IHn.
Qed.

Theorem iter_subset: forall f R, (forall P, f P [<=] R) -> forall P, P [<=] R -> forall (n: nat), iter n f P [<=] R.
Proof.
  intros. induction n.
     simpl. apply H0.
     simpl. apply H.
Qed.

Theorem iter_equal_always_equal:
  forall f, (forall P Q, P [=] Q -> f P [=] f Q) -> forall (P: t) (n: nat), iter n f P [=] iter (S n) f P -> forall k: nat, iter n f P [=] iter (n+k) f P.
Proof.
   intros. induction k.
       intros. rewrite plus_0_r. reflexivity.
       rewrite <- plus_Snm_nSm. rewrite H0. simpl. apply H. apply IHk.
Qed. *)

Theorem subset_dec: forall P Q: M.t, {P [<=] Q} + {~P [<=] Q}.
Proof.
  intros. induction P using set_induction.
     left. rewrite (empty_is_empty_1 H). apply subset_empty.
     elim IHP1.
        intros. elim (In_dec x Q).
           intros. left. rewrite Add_Equal in H0. rewrite H0. unfold Subset. intros.
              elim (add_inv H1).
                 intros. rewrite <- H2. apply a0.
                 apply a.
  intros. right. intro. apply b. apply H1. elim (H0 x). intros. apply H3. left. reflexivity.
  intros. right. intro. apply b. unfold Subset. intros. apply H1. elim (H0 a). intros. apply H4. right. apply H2.
Qed.

Theorem strict_subset_dec: forall P Q: M.t, {P [<] Q} + {~P [<] Q}.
Proof.
  intros. unfold StrictSubset.
  elim (subset_dec P Q).
    intros. elim (M.eq_dec P Q).
      intros. right. intro. destruct H. apply H0. apply a0.
      intros. left. split. apply a. apply b.
    intros. right. intro. destruct H. apply b. apply H.
Qed.

Theorem strict_subset_difference: forall P Q: M.t, P [<] Q -> exists x: M.elt, In x Q /\ ~In x P.
Proof.
   intros. destruct H. elim (not_and (P [<=] Q) (Q [<=] P)). intros.
      absurd (~(P [<=] Q)). intro. apply H1. apply H. apply H1.
      intros. unfold Subset in H1. elim not_forall_exists with Q (fun a => In a P).
      intros. destruct H2. exists x. split. apply H2. apply H3.
      unfold compat_P. simpl_relation. rewrite <- H2. apply H3.
      intros. elim In_dec with c P. intros. left. apply a. intros. right. apply b.
      unfold For_all. intro. apply H1. intros. apply not_not. elim In_dec with a P. left. apply a0. intros. right. apply b.
      intro. apply H4. apply H2. apply H3.
      elim (subset_dec P Q). intros. left. apply a. intros. right. apply b.
      intro. apply H0. destruct H1. apply subset_antisym. apply H1. apply H2.
Qed.

Theorem strict_subset_cardinal: forall P Q: M.t, P [<] Q -> cardinal P < cardinal Q.
Proof.
  intros. elim H. intros.
  induction P using set_induction.
     rewrite (empty_is_empty_1 H2). rewrite empty_cardinal. apply neq_O_lt. intro. apply H1.
     assert (Empty Q). apply cardinal_inv_1. symmetry. apply H3. rewrite (empty_is_empty_1 H4). apply empty_is_empty_1. apply H2.
     elim (strict_subset_difference H). intros. destruct H4.
     apply subset_cardinal_lt with x0.
        apply H0.
        apply H4.
        apply H5.
Qed.

Lemma fold_left_init:
  forall (f: M.t -> M.t -> M.t), (forall x (P: M.t), P [<=] f P x) -> forall (Q: M.t) l (q: M.elt), In q Q -> In q (fold_left f l Q).
Proof.
  intros. generalize l Q H0. clear H0 Q l. induction l.
    simpl. trivial.
    simpl. intros. apply IHl. apply H. apply H0.
Qed.

Theorem fold_left_init2: forall P Q l (f: M.t -> M.t -> M.t), (forall x P Q, P [<=] Q -> f P x [<=] f Q x) -> P [<=] Q -> fold_left f l P [<=] fold_left f l Q.
Proof.
  intros. generalize P Q H0. clear H0 Q P. induction l.
     simpl. trivial.
     simpl. intros. apply IHl. apply H. apply H0.
Qed.

Theorem fold_left_init_equal: forall P Q l (f: M.t -> M.t -> M.t), (forall x P Q, P [=] Q -> f P x [=] f Q x) -> P [=] Q -> fold_left f l P [=] fold_left f l Q.
Proof.
  intros. generalize P Q H0. clear H0 Q P. induction l.
    simpl. trivial.
    simpl. intros. apply IHl. apply H. apply H0.
Qed.

Theorem fold_left_init3: forall (A B: Set) (x: B) (l: list A) (f: A -> B) i,
  List.In x i ->
  List.In x (fold_left (fun acc r => (f r)::acc) l i).
Proof.
  intros. generalize x i H. clear H i x. induction l.
    intros. simpl. apply H.
    intros. simpl. apply IHl. simpl. right. apply H.
Qed.

Theorem fold_left_init4: forall (A B: Set) (x y: B) (f: A -> B) i j l,
  (forall n, List.In n i -> List.In n j) ->
  List.In x (fold_left (fun acc r => (f r)::acc) l i) ->
  List.In x (fold_left (fun acc r => (f r)::acc) l j).
Proof.
  intros. generalize H. clear H. generalize i j H0. clear H0 j i. induction l.
  intros. simpl. simpl in H0. apply H. apply H0.
  intros. simpl. simpl in H0. apply (IHl (f a::i)).
  apply H0. intros. simpl. elim H1.
    intros. left. apply H2. right. apply H. apply H2.
Qed.

Theorem fold_left_in: forall (A B: Set) (p: A) (l: list A) (f: A -> B) i,
  (forall x y, x = y -> f x = f y) ->
  List.In p l ->
  List.In (f p) (fold_left (fun acc r => (f r)::acc) l i).
Proof.
  intros. induction l.
    absurd (List.In p nil). apply in_nil. apply H0.
    simpl. elim H0.
      intros. apply fold_left_init3. simpl. left. apply H. apply H1.
      intros. apply fold_left_init4 with i. apply (f p). intros. right. apply H2.
      apply IHl. apply H1.
Qed.

Theorem fold_in: forall (f: M.t -> M.t -> M.t) (l: list M.t) (a: M.t) (x: M.elt), (forall P Q x, In x (f P Q) -> In x P \/ In x Q) -> In x (fold_left f l a) -> In x a \/ exists z: M.t, List.In z l /\ In x z.
Proof.
  intros. generalize a H0. clear H0 a. induction l.
    simpl. intros. left. assumption.
    simpl. intros.
      elim (IHl (f a0 a)).
        intros. elim (H a0 a x).
          intros. left. exact H2.
          intros. right. exists a. split. left. reflexivity. exact H2.
        exact H1.
        intros. right. elim H1. intros. destruct H2. exists x0. split. right. exact H2. exact H3.
        exact H0.
Qed.

Theorem fold_init_subset: forall f, compat_op E.eq Equal f -> transpose Equal f -> (forall x P Q, P [<=] Q -> f x P [<=] f x Q) -> forall (R: M.t) (P Q: M.t), P [<=] Q -> fold f R P [<=] fold f R Q.
Proof.
  intros f H H0 H1. induction R using set_induction.
     intros P Q H3. rewrite (Props.fold_1 _ (s:=R)). rewrite (Props.fold_1 _ (s:=R)). apply H3. apply H2. apply H2.
     intros P Q H4.
        rewrite (Props.fold_2 _ (s:=R1) (s':=R2) (x:=x) P H H0 H2 H3).
        rewrite (Props.fold_2 _ (s:=R1) (s':=R2) (x:=x) Q H H0 H2 H3).
        intro. intros H5. apply (H1 x (fold f R1 P)). apply IHR1. apply H4. apply H5.
Qed.

Theorem fold_in_init: forall f, compat_op E.eq Equal f -> transpose Equal f -> (forall x P, P [<=] f x P) -> forall R P, P [<=] fold f R P.
Proof.
  intros. induction R using set_induction.
     rewrite (fold_equal _ H H0 P (empty_is_empty_1 H2)). rewrite fold_empty. apply subset_equal. reflexivity.
     rewrite Add_Equal in H3. rewrite (fold_equal _ H H0 P H3). rewrite (fold_add _ H H0). apply subset_trans with (fold f R1 P). apply IHR1. apply H1. apply H2.
Qed.

Theorem fold_init_add: forall f P Q x, compat_op E.eq Equal f -> transpose Equal f -> (forall x x0 P, f x (add x0 P) [=] add x0 (f x P)) -> (forall x P Q, P [=] Q -> f x P [=] f x Q) -> fold f P (add x Q) [=] add x (fold f P Q).
Proof.
  intros. induction P using set_induction.
    rewrite (fold_equal _ H H0 Q (empty_is_empty_1 H3)).
    rewrite (fold_empty).
    rewrite (fold_equal _ H H0 (add x Q) (empty_is_empty_1 H3)).
    rewrite (fold_empty).
    reflexivity.
   rewrite (fold_2 _ (s:=P1) (s':=P2) (x:=x0) (add x Q) H H0 H3 H4).
   rewrite (fold_2 _ (s:=P1) (s':=P2) (x:=x0) Q H H0 H3 H4).
  rewrite (H2 x0 (fold f P1 (add x Q)) (add x (fold f P1 Q))). rewrite H1. reflexivity. apply IHP1.
Qed.

Lemma inter_repetitive: forall P Q, inter P (inter P Q) [=] inter P Q.
Proof.
  intros. split.
    intros. apply inter_3.
      apply inter_1 with (inter P Q). apply H.
      apply inter_2 with P. apply inter_2 with P. apply H.
    intros. apply inter_3.
       apply inter_1 with Q. apply H.
       apply H.
Qed.

Theorem cardinal_singleton: forall S, cardinal S = 1 -> exists x, S [=] singleton x.
Proof.
  intros. elim cardinal_inv_2 with S 0.
    intros. exists x. induction S using set_induction.
      absurd (In x S). apply H0. apply p.
      rewrite Add_Equal in H1. rewrite H1 in H.
      assert (cardinal S1 = 0). apply eq_add_S. rewrite <- H. rewrite add_cardinal_2. reflexivity. apply H0. assert (Empty S1). rewrite cardinal_Empty. apply H2. rewrite (empty_is_empty_1 H3) in H1. rewrite <- (singleton_equal_add x0) in H1.
      assert (E.eq x0 x). apply singleton_1. rewrite H1 in p. apply p.
      rewrite H1. rewrite H4. reflexivity.
      apply H.
Qed.

Lemma fold_forall_and: forall (c: M.t) (f: E.t -> bool),
  (forall a b, E.eq a b -> (f a) = (f b)) ->
  (fold (fun a b => f a && b) c true = true <-> For_all (fun x => f x = true) c).
Proof.
  intros. split.
  unfold For_all. intros.
  induction c using set_induction.
    (* empty *) absurd (In x c). apply H2. apply H1.
    (* x0 c1 *) elim (andb_true_iff (f x0) (fold (fun a b => f a && b) c1 true)).
      intros. elim H4. intros.
      elim (H3 x). intros. elim (H8 H1). intros. rewrite <- (H x0 x H10). apply H6.
      intros. apply IHc1. apply H7. apply H10.
      rewrite fold_2 in H0. apply H0.
      split.
        apply flip_Reflexive. apply flip_Symmetric. apply eq_equivalence. apply flip_Transitive. apply eq_equivalence.
        simpl_relation. apply eq_true_iff_eq. split.
          intros. rewrite (H x1 y H6). apply H7.
          intros. rewrite <- (H x1 y H6).  apply H7.
      unfold transpose. intros. unfold Basics.flip. apply eq_true_iff_eq. split.
        intros. apply Is_true_eq_true.
        elim (andb_true_iff (f y) (f x1 && z)). intros. elim (H7 H6). intros.
        elim (andb_true_iff (f x1) z). intros. elim (H11 H10). intros.
        apply andb_prop_intro. split. apply Is_true_eq_left. apply H13. apply andb_prop_intro.
        split. apply Is_true_eq_left. apply H9. apply Is_true_eq_left. apply H14.
        intros. apply Is_true_eq_true.
        elim (andb_true_iff (f x1) (f y && z)). intros. elim (H7 H6). intros.
        elim (andb_true_iff (f y) z). intros. elim (H11 H10). intros.
        apply andb_prop_intro. split. apply Is_true_eq_left. apply H13. apply andb_prop_intro.
        split. apply Is_true_eq_left. apply H9. apply Is_true_eq_left. apply H14.
      apply H2.
      apply H3.
  intros. unfold For_all in H0. induction c using set_induction.
  rewrite Props.fold_1. trivial. apply eq_equivalence. apply H1.
  rewrite Props.fold_2. apply Is_true_eq_true. apply andb_prop_intro. split.
    apply Is_true_eq_left. apply (H0 x). elim (H2 x). intros. apply H4. left. reflexivity.
    apply Is_true_eq_left. apply IHc1. intros. apply H0.
    elim (H2 x0). intros. apply H5. right. apply H3.
    apply eq_equivalence.
    simpl_relation. rewrite (H x0 y). reflexivity. apply H3.
    unfold transpose. intros. apply eq_true_iff_eq. split.
    intros.
    elim (andb_true_iff (f x0) (f y && z)). intros. elim (H4 H3). intros.
    elim (andb_true_iff (f y) z). intros. elim (H8 H7). intros.
    apply Is_true_eq_true. apply andb_prop_intro. split. apply Is_true_eq_left. apply H10.
    apply andb_prop_intro. split. apply Is_true_eq_left. apply H6. apply Is_true_eq_left. apply H11.
    intros.
    elim (andb_true_iff (f y) (f x0 && z)). intros. elim (H4 H3). intros.
    elim (andb_true_iff (f x0) z). intros. elim (H8 H7). intros.
    apply Is_true_eq_true. apply andb_prop_intro. split. apply Is_true_eq_left. apply H10.
    apply andb_prop_intro. split. apply Is_true_eq_left. apply H6. apply Is_true_eq_left. apply H11.
    apply H1.
    apply H2.
Qed.

Lemma fold_forall_or: forall (c: M.t) (f: E.t -> bool),
  (forall a b, E.eq a b -> (f a) = (f b)) ->
  (fold (fun a b => f a || b) c false = false <-> For_all (fun x => f x = false) c).
Proof.
  intros. split.
  unfold For_all. intros.
  induction c using set_induction.
    (* empty *) absurd (In x c). apply H2. apply H1.
    (* x0 c1 *) rewrite fold_2 in H0. elim (orb_false_elim (f x0) (fold (fun a b => f a || b) c1 false)).
      elim (H3 x). intros. elim (H4 H1). intros. rewrite <- (H x0 x H8). apply H6.
      intros. apply IHc1. apply H7. apply H8. apply H0.
      split. apply flip_Reflexive. apply flip_Symmetric. apply eq_equivalence. apply flip_Transitive. apply eq_equivalence.
      simpl_relation. rewrite (H x1 y H4). reflexivity.
      unfold transpose. intros. unfold Basics.flip. apply eq_true_iff_eq. split.
        intros. elim (orb_true_elim (f y) (f x1 || z)).
          intros. rewrite a. rewrite orb_true_l. rewrite orb_true_r. reflexivity.
          intros. elim (orb_true_elim (f x1) z).
            intros. rewrite a. rewrite orb_true_l. reflexivity.
            intros. rewrite b0. rewrite orb_true_r. rewrite orb_true_r. reflexivity.
            apply b. apply H4.
        intros. elim (orb_true_elim (f x1) (f y || z)).
          intros. rewrite a. rewrite orb_true_l. rewrite orb_true_r. reflexivity.
          intros. elim (orb_true_elim (f y) z).
            intros. rewrite a. rewrite orb_true_l. reflexivity.
            intros. rewrite b0. rewrite orb_true_r. rewrite orb_true_r. reflexivity.
            apply b. apply H4.
        apply H2.
        apply H3.
  intros. unfold For_all in H0. induction c using set_induction.
    rewrite Props.fold_1. reflexivity. apply eq_equivalence. apply H1.
    rewrite Props.fold_2. apply orb_false_intro.
      apply (H0 x). elim (H2 x). intros. apply H4. left. reflexivity.
      apply IHc1. intros. apply H0. elim (H2 x0). intros. apply H5. right.
      apply H3.
      apply eq_equivalence.
      simpl_relation. rewrite (H x0 y H3). reflexivity.
      unfold transpose. intros. apply eq_true_iff_eq. split.
        intros. elim (orb_true_elim (f x0) (f y || z)).
          intros. rewrite a. rewrite orb_true_l. rewrite orb_true_r. reflexivity.
          intros. elim (orb_true_elim (f y) z).
            intros. rewrite a. rewrite orb_true_l. reflexivity.
            intros. rewrite b0. rewrite orb_true_r. rewrite orb_true_r. reflexivity.
          apply b. apply H3.
        intros. elim (orb_true_elim (f y) (f x0 || z)).
          intros. rewrite a. rewrite orb_true_l. rewrite orb_true_r. reflexivity.
          intros. elim (orb_true_elim (f x0) z).
            intros. rewrite a. rewrite orb_true_l. reflexivity.
            intros. rewrite b0. rewrite orb_true_r. rewrite orb_true_r. reflexivity.
          apply b. apply H3.
    apply H1. apply H2.
Qed.

Theorem union_subset_6: forall A B C D: t,
  A [<=] B -> C [<=] D -> union A C [<=] union B D.
Proof.
  intros. induction A using set_induction.
    induction B using set_induction.
    rewrite (empty_union_1 _ H1). rewrite (empty_union_1 _ H2).
    apply H0.
    rewrite (empty_union_1 _ H1). apply subset_trans with (union B1 D).
    apply subset_trans with (union A C). apply union_subset_2. apply IHB1. rewrite (empty_is_empty_1 H1). apply subset_empty.
    apply union_subset_4. unfold Subset. intros. elim (H3 a). intros. apply H6. right. apply H4.
    rewrite Add_Equal in H2. rewrite H2. rewrite union_add.
    apply subset_add_3. apply union_2. apply H. rewrite H2. apply add_1. apply E.eq_equiv.
    apply IHA1. apply subset_trans with A2. unfold Subset. intros.
    rewrite H2. apply add_2. apply H3.
    apply H.
Qed.

Theorem subset_add_1: forall (x: elt) (A B: t),
  A [<=] B -> add x A [<=] add x B.
Proof.
  intros. unfold Subset. intros.
  elim (add_inv H0).
    intros. apply add_1. apply H1.
    intros. apply add_2. apply H. apply H1.
Qed.

Lemma lt_not_eq: forall n m: nat, n < m -> n <> m.
Proof.
  double induction n m.
  intros. inversion H.
  intros. discriminate.
  intros. discriminate.
  intros. injection. apply H0. apply lt_S_n. apply H1.
Qed.

Lemma cardinal_subset_equal:
  forall P R: t,
  cardinal P = cardinal R ->
  P [<=] R ->
  P [=] R.
Proof.
  intros. split.
    intros. apply H0. apply H1.
    intros.
       apply not_not. elim (In_dec a P). intros. left. assumption. right. assumption.
       intro. apply (lt_not_eq (subset_cardinal_lt H0 H1 H2)). apply H.
Qed.

Lemma s_ss: forall (p: elt) (R: t), In p R -> singleton p [<=] R.
Proof.
  intros.  unfold Subset. intros. assert (E.eq p a). apply singleton_1. apply H0. rewrite <- H1. apply H.
Qed.

Lemma not_empty_element:
  forall S: t, ~Empty S -> exists e: elt, In e S.
Proof.
  intros. induction S using set_induction.
  absurd (Empty S). apply H. apply H0.
  exists x. elim (H1 x). intros. apply H3. left. apply E.eq_equiv.
Qed.

Lemma filter_add_1:
  forall R1 R2 x f, compat_bool E.eq f -> Add x R1 R2 -> f x = false \/ Add x (filter f R1) (filter f R2).
Proof.
  intros. elim (bool_dec (f x) true).
    intros. right. intro. elim (H0 y). intros. split.
    intros.
      elim (H1 (filter_1 H H3)).
      intros. left. assumption.
      intros. right. apply (filter_3 H). apply H4. apply (filter_2 H H3).
    intros. apply (filter_3 H).
      apply H2. elim H3.
      intros. left. assumption.
      intros. right. apply (filter_1 H H4).
    elim (H3). intros. rewrite <- (H x). assumption. apply H4.
    intros. apply (filter_2 H H4).
  intros. left. apply not_true_is_false. apply b.
Qed.

Lemma filter_add_2:
  forall R1 R2 x f, compat_bool E.eq f -> Add x R1 R2 -> In x (filter f R2) -> In x (filter f R1) \/ f x = true.
Proof.
  intros.
  elim (H0 x). intros.
    elim (H2 (filter_1 H H1)).
    intros. right. apply (filter_2 H H1).
    intros. left. apply (filter_3 H H4). apply (filter_2 H H1).
Qed.

Lemma empty_nor_singleton:
  forall P x, In x P -> cardinal P <> 1 -> exists y, In y P /\ ~E.eq x y.
Proof.
  intros.
  elim (cardinal_inv_2b (s:=P)). intros.
  elim (cardinal_inv_2b (s:=remove x P)). intros. exists x1.
  rewrite remove_iff in p0. apply p0.
    intro. apply H0. transitivity (S (cardinal (remove x P))).
        symmetry. apply remove_cardinal_1. apply H.
        rewrite H1. trivial.
   intro. apply (cardinal_inv_1 H1 H).
Qed.

Section SetList.
Parameter equiv_set: list E.t -> M.t.

Axiom equiv_set_1: forall x l, List.In x l -> In x (equiv_set l).
Axiom equiv_set_2: forall x l, In x (equiv_set l) -> List.In x l.
End SetList.

End Aux.