  Require Export XD.Integers.

  Lemma Zplus_mult_distr_l : forall w x y,
    Zmult w (Zplus x y) = Zplus (Zmult w x) (Zmult w y).
  Proof.
    intros (wp,hw) (xp,hx) (yp,hy).
    unfold Zmult.
    unfold Zplus.
    unfold Zmake.
    apply proof_irrelevance.
    simpl.
    rewrite _Zmult_repr.
    rewrite <- _Zplus_repr.
    symmetry.
    rewrite _Zplus_comm.
    rewrite <- _Zplus_repr.
    destruct wp as [wf ws];
    destruct xp as [xf xs];
    destruct yp as [yf ys].
    simpl.
    unfold _Zcond in *.
    simpl in *.
    destruct hw;destruct hx;destruct hy;subst.
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmin_zero_r.
      repeat rewrite Nrest_zero_l.
      repeat rewrite Nrest_zero_r.
      rewrite <- Nplus_mult_distr_l.
      rewrite (Nplus_comm ys).
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nplus_zero_r.
      reflexivity.
    }
    {
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_r.
      repeat rewrite Nplus_zero_l.
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmin_zero_l.
      simpl.
      repeat rewrite Nrest_zero_r.
      rewrite <- Nplus_mult_distr_l.
      rewrite (Nplus_comm yf).
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmin_zero_l.
      simpl.
      repeat rewrite Nrest_zero_r.
      repeat rewrite Nplus_zero_r.
      rewrite <- Nplus_mult_distr_l.
      rewrite (Nplus_comm ys).
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_r.
      repeat rewrite Nplus_zero_l.
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nplus_zero_r.
      reflexivity.
    }
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_r.
      repeat rewrite Nmin_zero_r.
      repeat rewrite Nrest_zero_l.
      repeat rewrite Nrest_zero_r.
      rewrite <- Nplus_mult_distr_l.
      rewrite (Nplus_comm yf).
      reflexivity.
    }
  Qed.

  Lemma Zplus_mult_distr_r : forall w x y,
    Zmult (Zplus x y) w = Zplus (Zmult x w) (Zmult y w).
  Proof.
    intros w x y.
    rewrite Zmult_comm.
    rewrite Zplus_mult_distr_l.
    rewrite (Zmult_comm w).
    rewrite (Zmult_comm w).
    reflexivity.
  Qed.

  Lemma Zopp_intro : forall x y, x = y -> Zopp x = Zopp y.
  Proof.
    intros x y h. subst y. reflexivity.
  Qed.

  Lemma Zmult_elim_l : forall w x y : ZZ, w <> Zzero -> Zmult w x = Zmult w y -> x = y.
  Proof.
    intros ((wf,ws),hw) ((xf,xs),hx) ((yf,ys),hy).
    intro hneq.
    intro h.
    simpl in h.
    unfold Zmake in h.
    unfold _Zmake in h.
    inversion h as [h'];clear h;rename h' into h.
    unfold _Zcond in hw,hx,hy.
    simpl in hw,hx,hy.
    destruct hw;destruct hx;destruct hy;subst.
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nrest_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      repeat rewrite Nmin_zero_r in h.
      destruct (Neq_dec) in h.
      {
        symmetry in e. apply Nmult_zero in e.
        destruct e;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          repeat rewrite Nmult_zero_r in h.
          destruct (Neq_dec) as [d|d] in h.
          {
            symmetry in d. apply Nmult_zero in d.
            destruct d;subst.
            {
              contradiction hneq.
              apply proof_irrelevance;simpl. reflexivity.
            }
            { apply proof_irrelevance;simpl. reflexivity. }
          }
          { inversion h. contradiction. }
        }
      }
      {
        destruct (Neq_dec) as [d|d].
        {
          symmetry in d. apply Nmult_zero in d.
          destruct d;subst.
          {
            rewrite Nmult_zero_l in n.
            contradiction n. reflexivity.
          }
          {
            rewrite Nmult_zero_r in h.
            inversion h as [h']. symmetry in h'. contradiction.
          }
        }
        {
          apply proof_irrelevance;simpl.
          apply f_eq.
          inversion h as [h'].
          apply Nmult_elim_l with ws.
          {
            intro heq. subst.
            rewrite Nmult_zero_l in *.
            apply n. reflexivity.
          }
          { exact h'. }
        }
      }
    }
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nmin_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      repeat rewrite Nrest_zero_r in h.
      repeat rewrite Nmin_zero_l in h.
      destruct (Neq_dec) as [d|d].
      {
        simpl in h.
        symmetry in d. apply Nmult_zero in d.
        destruct d;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          rewrite Nmult_zero_r in h.
          inversion h.
          symmetry in H0.
          apply Nmult_zero in H0.
          destruct H0;subst.
          {
            contradiction hneq.
            apply proof_irrelevance;simpl. reflexivity.
          }
          { apply proof_irrelevance;simpl. reflexivity. }
        }
      }
      {
        simpl in h.
        inversion h as [(hl,hr)].
        symmetry in hl.
        contradiction.
      }
    }
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nmin_zero_l in h.
      repeat rewrite Nrest_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      repeat rewrite Nmin_zero_r in h.
      destruct (Neq_dec) as [d|d] in h at 2 .
      {
        simpl in h.
        symmetry in d.
        apply Nmult_zero in d.
        destruct d;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          rewrite Nmult_zero_r in h.
          inversion h as [hs].
          apply Nmult_zero in hs.
          destruct hs;subst.
          {
            contradiction hneq.
            apply proof_irrelevance;simpl. reflexivity.
          }
          { apply proof_irrelevance;simpl. reflexivity. }
        }
      }
      { simpl in h. inversion h as [(hf,hs)]. contradiction. }
    }
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nmin_zero_l in h.
      simpl in h.
      repeat rewrite Nrest_zero_r in h.
      inversion h as [hs].
      apply Nmult_elim_l in hs.
      {
        subst yf.
        apply proof_irrelevance;simpl. reflexivity.
      }
      {
        intro heq. subst ws.
        apply hneq.
        apply proof_irrelevance;simpl. reflexivity.
      }
    }
    {
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nmin_zero_l in h.
      simpl in h.
      repeat rewrite Nplus_zero_r in h.
      repeat rewrite Nrest_zero_r in h.
      inversion h as [hs].
      apply Nmult_elim_l in hs.
      {
        subst ys.
        apply proof_irrelevance;simpl. reflexivity.
      }
      {
        intro heq. subst wf. apply hneq.
        apply proof_irrelevance;simpl. reflexivity.
      }
    }
    {
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nplus_zero_r in h.
      repeat rewrite Nmin_zero_l in h.
      repeat rewrite Nmin_zero_r in h.
      repeat rewrite Nrest_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      destruct (Neq_dec) as [d|d] in h at 2.
      {
        symmetry in d.
        apply Nmult_zero in d.
        destruct d;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          simpl in h.
          rewrite Nmult_zero_r in h.
          inversion h as [hs].
          apply Nmult_zero in hs.
          destruct hs;subst.
          {
            contradiction hneq.
            apply proof_irrelevance;simpl. reflexivity.
          }
          { apply proof_irrelevance;simpl. reflexivity. }
        }
      }
      {
        simpl in h.
        inversion h as [(hf,hs)].
        contradiction.
      }
    }
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_l in h.
      repeat rewrite Nplus_zero_r in h.
      repeat rewrite Nmin_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      repeat rewrite Nrest_zero_r in h.
      repeat rewrite Nmin_zero_l in h.
      destruct (Neq_dec) as [d|d] in h.
      {
        simpl in h.
        symmetry in d.
        apply Nmult_zero in d.
        destruct d;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          rewrite Nmult_zero_r in h.
          inversion h as [hs].
          symmetry in hs.
          apply Nmult_zero in hs.
          destruct hs;subst.
          {
            contradiction hneq.
            apply proof_irrelevance;simpl. reflexivity.
          }
          { apply proof_irrelevance;simpl. reflexivity. }
        }
      }
      {
        simpl in h.
        inversion h as [(hf,hs)].
        symmetry in hf.
        contradiction.
      }
    }
    {
      repeat rewrite Nmult_zero_l in h.
      repeat rewrite Nmult_zero_r in h.
      repeat rewrite Nplus_zero_r in h.
      repeat rewrite Nmin_zero_r in h.
      repeat rewrite Nrest_zero_l in h.
      repeat rewrite Nrest_zero_r in h.
      destruct (Neq_dec) as [d|d].
      {
        symmetry in d.
        apply Nmult_zero in d.
        destruct d;subst.
        {
          contradiction hneq.
          apply proof_irrelevance;simpl. reflexivity.
        }
        {
          rewrite Nmult_zero_r in h.
          destruct (Neq_dec) as [d|d].
          {
            symmetry in d.
            apply Nmult_zero in d.
            destruct d;subst.
            {
              contradiction hneq.
              apply proof_irrelevance;simpl. reflexivity.
            }
            { apply proof_irrelevance;simpl. reflexivity. }
          }
          { inversion h as [hf]. contradiction. }
        }
      }
      {
        destruct (Neq_dec) as [d'|d'].
        {
          symmetry in d'.
          apply Nmult_zero in d'.
          destruct d';subst.
          {
            rewrite Nmult_zero_l in d.
            contradiction d. reflexivity.
          }
          {
            rewrite Nmult_zero_r in h.
            inversion h as [hf].
            symmetry in hf.
            contradiction.
          }
        }
        {
          inversion h as [hf].
          apply Nmult_elim_l in hf.
          {
            subst yf.
            apply proof_irrelevance;simpl. reflexivity.
          }
          {
            intro heq. subst.
            repeat rewrite Nmult_zero_l in *.
            contradiction.
          }
        }
      }
    }
  Qed.

  Lemma Zle_zero_mult : forall x y:ZZ, Zle Zzero x -> Zle Zzero y -> Zle Zzero (Zmult x y).
  Proof.
    intros ((xf,xs),hx) ((yf,ys),hy).
    unfold _Zcond in hx,hy.
    simpl in hx,hy.
    simpl.
    destruct hx;destruct hy;subst.
    {
      intros [_ hxs] [_ hys].
      apply Nle_zero_r in hxs,hys.
      subst.
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nmin_zero_r.
      repeat rewrite Nrest_zero_l.
      simpl.
      split;apply Nle_refl.
    }
    {
      intros [_ hxs] [hyf _].
      apply Nle_zero_r in hxs. subst.
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nplus_zero_r.
      repeat rewrite Nmin_zero_l.
      simpl.
      split. apply Nle_refl.
      unfold Nle. simpl. trivial.
    }
    {
      intros [hxf _] [_ hys].
      apply Nle_zero_r in hys. subst.
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_r.
      rewrite Nmin_cancel.
      simpl.
      split.
      apply Nle_refl.
      unfold Nle. simpl. trivial.
    }
    {
      intros [hxf _] [hyf _].
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nmult_zero_r.
      repeat rewrite Nplus_zero_l.
      repeat rewrite Nplus_zero_r.
      rewrite Nmin_zero_r.
      rewrite Nrest_zero_l.
      rewrite Nrest_zero_r.
      destruct (Neq_dec) as [d|d].
      {
        rewrite <- d.
        split;apply Nle_refl.
      }
      { split. apply Nle_zero_l. apply Nle_refl. }
    }
  Qed.

  Lemma Zopp_elim : forall x y, Zopp x = Zopp y -> x = y.
  Proof.
    intros x y h.
    apply Zopp_intro in h.
    rewrite Zopp_involutive in h.
    rewrite Zopp_involutive in h.
    exact h.
  Qed.

  Lemma Zplus_intro_l : forall w x y, x = y -> Zplus w x = Zplus w y.
  Proof.
    intros w x y h. subst y. reflexivity.
  Qed.

  Lemma Zplus_intro_r : forall w x y , x = y -> Zplus x w = Zplus y w.
  Proof.
    intros w x y h. subst y. reflexivity.
  Qed.

  Lemma Zmult_intro_l : forall w x y, x = y -> Zmult w x = Zmult w y.
  Proof.
    intros w x y h. subst y. reflexivity.
  Qed.

  Lemma Zmult_intro_r : forall w x y, x = y -> Zmult x w = Zmult y w.
  Proof.
    intros w x y h. subst y. reflexivity.
  Qed.

  Lemma Zplus_elim_r : forall w x y, Zplus x w = Zplus y w -> x = y.
  Proof.
    intros w x y h.
    apply (Zplus_intro_r (Zopp w)) in h .
    rewrite Zplus_assoc in h.
    rewrite Zplus_assoc in h.
    rewrite Zplus_opp_r in h.
    rewrite Zplus_zero_r in h.
    rewrite Zplus_zero_r in h.
    exact h.
  Qed.

  Lemma Zplus_elim_l : forall w x y, Zplus w x = Zplus w y -> x = y.
  Proof.
    intros w x y h.
    apply Zplus_elim_r with w.
    rewrite (Zplus_comm x).
    rewrite (Zplus_comm y).
    exact h.
  Qed.

  Lemma Zplus_zero : forall x y, Zplus x y = Zzero -> x = Zopp y.
  Proof.
    intros x y h.
    apply Zplus_elim_r with y.
    rewrite Zplus_opp_l.
    exact h.
  Qed.

  Lemma Zmult_elim_r : forall w x y : ZZ, w <> Zzero -> Zmult x w = Zmult y w -> x = y.
  Proof.
    intros w x y hneq heq.
    apply Zmult_elim_l with w.
    exact hneq.
    repeat rewrite (Zmult_comm w).
    exact heq.
  Qed.

  Lemma Zmult_zero : forall x y, Zmult x y = Zzero -> x = Zzero \/ y = Zzero.
  Proof.
    intros x y heq.
    destruct (Zeq_dec x Zzero) as [dx|dx].
    (* x = 0 : ok *)
    subst x. left. reflexivity.
    destruct (Zeq_dec y Zzero) as [dy|dy].
    (* y = 0 : ok *)
    subst y. right. reflexivity.
    (* x <> 0 and y <> 0 => contradiction *)
    contradiction dy.
    apply Zmult_elim_l with x.
    { exact dx. }
    {
      rewrite Zmult_zero_r.
      rewrite heq.
      reflexivity.
    }
  Qed.

  Lemma Zopp_zero : Zopp Zzero = Zzero.
  Proof.
    unfold Zopp. rewrite Zmult_zero_l. reflexivity.
  Qed.

  Lemma Zopp_one: Zopp Zone = Zone_opp.
  Proof.
    unfold Zopp.
    rewrite Zmult_one_l.
    reflexivity.
  Qed.

  Lemma Zopp_oneopp : Zopp Zone_opp = Zone.
  Proof.
    apply Zopp_elim.
    rewrite Zopp_involutive.
    rewrite Zopp_one.
    reflexivity.
  Qed.

  Lemma Zopp_plus_distr: forall x y:ZZ, Zopp (Zplus x y) = Zplus (Zopp x) (Zopp y).
  Proof.
    intros x y.
    unfold Zopp.
    rewrite Zplus_mult_distr_r.
    reflexivity.
  Qed.

  Lemma Zopp_mult_distr_l : forall x y:ZZ, Zopp (Zmult x y) = Zmult (Zopp x) y.
  Proof.
    intros x y.
    unfold Zopp.
    repeat rewrite Zmult_assoc.
    rewrite (Zmult_comm y).
    reflexivity.
  Qed.

  Lemma Zopp_mult_distr_r : forall x y:ZZ, Zopp (Zmult x y) = Zmult x (Zopp y).
  Proof.
    intros x y.
    rewrite Zmult_comm.
    rewrite Zopp_mult_distr_l.
    rewrite Zmult_comm.
    reflexivity.
  Qed.

  Lemma Ztrichotomy : forall x y:ZZ, Zlt x y \/ x = y \/ Zlt y x.
  Proof.
    intros x y.
    destruct (Zeq_dec x y).
    { subst y. right. left. reflexivity. }
    destruct (Zle_dec x y).
    { left. unfold Zlt. split;assumption. }
    {
      right. right. unfold Zlt. split.
      { assumption. }
      { unfold not. intro heq. subst y. contradiction. }
    }
  Qed.

Search Zle.

Lemma Zle_plus_intro_l: forall w x y : ZZ, Zle x y -> Zle (Zplus w x) (Zplus w y).
intros ((wf,ws),hw) ((xf,xs),hx) ((yf,ys),hy) [hl hr].
unfold _Zcond in hw,hx,hy.
simpl in hw,hx,hy.
simpl.
destruct hw,hx,hy;subst.
{
repeat rewrite Nplus_zero_l.
repeat rewrite Nmin_zero_l.
simpl.
repeat rewrite Nrest_zero_r.
split.
apply Nle_refl.
apply Nle_plus_intro_l.
exact hr.
}
{
repeat rewrite Nplus_zero_l.
repeat rewrite Nplus_zero_r.
repeat rewrite Nmin_zero_l.
simpl.
destruct (Neq_dec) as [d|d].
{
rewrite Nrest_zero_r.
apply Nmin_le in d.
split.
{ apply Nle_refl. }
{
apply Nle_nmk in d.
destruct d as [k heqk].
subst ws.
rewrite (Nplus_comm yf).
rewrite Nrest_plus_nmm.
rewrite <- Nplus_assoc.
pattern k at 1;rewrite <- Nplus_zero_r.
apply Nle_plus_intro_l.
apply Nle_zero_l.
}
}
{
split.
apply Nle_zero_l.
apply Nle_zero_l.
}
}
{
apply Nle_zero_r in hl.
apply Nle_zero_r in hr.
subst.
repeat rewrite Nplus_zero_l.
repeat rewrite Nplus_zero_r.
repeat rewrite Nmin_zero_l.
simpl.
rewrite Nrest_zero_r.
split.
{ apply Nle_refl. }
{ apply Nle_refl. }
}
{
repeat rewrite Nplus_zero_l.
repeat rewrite Nplus_zero_r.
destruct (Neq_dec) as [d1|d1].
{
apply Nmin_le in d1.
destruct (Neq_dec) as [d2|d2].
{
apply Nmin_le in d2.
split.
{ apply Nle_refl. }
{
clear hr.
apply Nle_nmk in d1. destruct d1 as [k1 heqk1].
apply Nle_nmk in d2. destruct d2 as [k2 heqk2].
pattern ws at 1;rewrite <- heqk2.
rewrite <- heqk1.
rewrite (Nplus_comm yf).
rewrite (Nplus_comm xf).
rewrite Nrest_plus_nmm.
rewrite Nrest_plus_nmm.
apply Nle_plus_elim_l with yf.
rewrite heqk2.
apply Nle_plus_elim_r with xf.
rewrite <- Nplus_assoc.
rewrite (Nplus_comm k1).
rewrite heqk1.
rewrite Nplus_comm.
apply Nle_plus_intro_r.
exact hl.
}
}
{
split.
apply Nle_zero_l.
apply Nle_zero_l.
}
}
{
clear hr.
apply Nmin_neq_le in d1.
destruct (Neq_dec) as [d2|d2].
{
apply Nmin_le in d2.
assert (heq:xf=yf).
{
eapply Nle_antisym.
apply hl.
eapply Nle_trans.
apply d2.
apply d1.
}
subst yf.
clear hl.
assert (heq:=Nle_antisym _ _ d1 d2).
subst xf.
rewrite Nrest_cancel.
split;apply Nle_refl.
}
{
apply Nmin_neq_le in d2.
split.
{
apply Nle_nmk in d1, d2.
destruct d1 as [k1 heqk1].
destruct d2 as [k2 heqk2].
rewrite <- heqk1.
rewrite <- heqk2.
repeat rewrite (Nplus_comm ws).
repeat rewrite Nrest_plus_nmm.
apply Nle_plus_elim_l with ws.
rewrite heqk1.
rewrite heqk2.
exact hl.
}
{ apply Nle_refl. }
}
}
}
{
clear hl.
repeat rewrite Nplus_zero_r.
repeat rewrite Nplus_zero_l.
destruct (Neq_dec) as [d1|d1].
{
apply Nmin_le in d1.
destruct (Neq_dec) as [d2|d2].
{
apply Nmin_le in d2.
split.
{ apply Nle_refl. }
{
apply Nle_nmk in d1,d2.
destruct d1 as [k1 heqk1].
destruct d2 as [k2 heqk2].
rewrite <- heqk1.
rewrite <- heqk2.
repeat rewrite (Nplus_comm wf).
repeat rewrite Nrest_plus_nmm.
apply Nle_plus_elim_l with wf.
rewrite heqk1,heqk2.
exact hr.
}
}
{
split;apply Nle_zero_l.
}
}
{
apply Nmin_neq_le in d1.
destruct (Neq_dec) as [d2|d2].
{
apply Nmin_le in d2.
assert (heq:xs=ys).
{
apply Nle_antisym.
eapply Nle_trans.
apply d1.
apply d2.
apply hr.
}
subst ys.
clear hr.
assert (heq:=Nle_antisym _ _ d1 d2).
subst xs.
rewrite Nrest_cancel.
split;apply Nle_refl.
}
{
apply Nmin_neq_le in d2.
split.
{
apply Nle_nmk in d1,d2.
destruct d1 as [k1 heqk1].
destruct d2 as [k2 heqk2].
pattern wf at 1;rewrite <- heqk1.
rewrite <- heqk2.
rewrite (Nplus_comm xs).
rewrite (Nplus_comm ys).
repeat rewrite Nrest_plus_nmm.
apply Nle_plus_elim_l with xs.
rewrite heqk1.
rewrite Nplus_comm.
apply Nle_plus_elim_l with ys.
rewrite Nplus_assoc.
rewrite heqk2.
rewrite Nplus_comm.
apply Nle_plus_intro_l.
exact hr.
}
{ apply Nle_refl. }
}
}
}
{
repeat rewrite Nplus_zero_r.
repeat rewrite Nplus_zero_l.
repeat rewrite Nmin_zero_r.
repeat rewrite Nrest_zero_l.
repeat rewrite Nrest_zero_r.
destruct (Neq_dec) as [d1|d1].
{
apply Nmin_le in d1.
destruct (Neq_dec) as [d2|d2].
{
symmetry in d2.
apply Nplus_zero in d2.
destruct d2.
subst wf yf.
split.
apply Nle_refl.
rewrite Nplus_zero_l.
rewrite Nrest_zero_r.
exact hr.
}
{
split;apply Nle_zero_l.
}
}
{
apply Nmin_neq_le in d1.
destruct (Neq_dec) as [d2|d2].
{
symmetry in d2.
apply Nplus_zero in d2.
destruct d2. subst wf yf.
apply Nle_zero_r in d1. subst xs.
rewrite Nrest_cancel.
rewrite Nplus_zero_l.
split;apply Nle_refl.
}
{
split.
{
apply Nle_nmk in d1.
destruct d1 as [k1 heqk1].
subst wf.
rewrite (Nplus_comm xs).
rewrite Nrest_plus_nmm.
rewrite <- Nplus_assoc.
pattern k1 at 1;rewrite <- Nplus_zero_r.
apply Nle_plus_intro_l.
apply Nle_zero_l.
}
{ apply Nle_refl. }
}
}
}
{
apply Nle_zero_r in hl,hr.
subst xf ys.
repeat rewrite Nplus_zero_l.
repeat rewrite Nplus_zero_r.
repeat rewrite Nmin_zero_r.
repeat rewrite Nrest_zero_l.
repeat rewrite Nrest_zero_r.
destruct (Neq_dec) as [d|d].
{ split;apply Nle_refl. }
{ split;apply Nle_refl. }
}
{
repeat rewrite Nplus_zero_l.
repeat rewrite Nmin_zero_r.
repeat rewrite Nrest_zero_l.
repeat rewrite Nrest_zero_r.
clear hr.
destruct (Neq_dec) as [d1|d1].
{
symmetry in d1.
apply Nplus_zero in d1.
destruct d1;subst.
repeat rewrite Nplus_zero_l.
destruct (Neq_dec) as [d2|d2].
{
subst yf.
split;apply Nle_refl.
}
{ split;apply Nle_zero_l. }
}
{
destruct (Neq_dec) as [d2|d2].
{
symmetry in d2.
apply Nplus_zero in d2.
destruct d2;subst.
repeat rewrite Nplus_zero_l.
split. assumption. apply Nle_refl.
}
{
split.
apply Nle_plus_intro_l. exact hl.
apply Nle_refl.
}
}
}
Qed.

  Lemma Zle_plus_intro_r: forall w x y : ZZ, Zle x y -> Zle (Zplus x w) (Zplus y w).
  Proof.
    intros w x y h.
    rewrite (Zplus_comm x).
    rewrite (Zplus_comm y).
    apply Zle_plus_intro_l.
    exact h.
  Qed.

  Lemma Zle_plus_elim_l: forall w x y : ZZ, Zle (Zplus x w) (Zplus y w) -> Zle x y.
  Proof.
    intros w x y h.
    pattern x;rewrite <- Zplus_zero_r.
    pattern y;rewrite <- Zplus_zero_r.
    rewrite <- Zplus_opp_r with w.
    repeat rewrite <- Zplus_assoc.
    apply Zle_plus_intro_r.
    exact h.
  Qed.

  Lemma Zle_plus_elim_r: forall w x y : ZZ, Zle (Zplus w x) (Zplus w y) -> Zle x y.
  Proof.
    intros w x y h.
    apply Zle_plus_elim_l with w.
    repeat rewrite (Zplus_comm _ w).
    exact h.
  Qed.

  Lemma Zle_zero_one : Zle Zzero Zone.
  Proof.
    simpl. split;apply Nle_zero_l.
  Qed.

  Lemma Zle_oneopp_zero : Zle Zone_opp Zzero.
  Proof.
    simpl. split;apply Nle_zero_l.
  Qed.

  Lemma Zle_zero_plus: forall x y:ZZ, Zle Zzero x -> Zle Zzero y -> Zle Zzero (Zplus x y).
  Proof.
    intros x y hx hy.
    apply (Zle_plus_intro_r y) in hx.
    rewrite Zplus_zero_l in hx.
    apply Zle_trans with y.
    exact hy.
    exact hx.
  Qed.

  Lemma Zle_mult_intro_l: forall w x y, Zle x y -> Zle Zzero w -> Zle (Zmult w x) (Zmult w y).
  Proof.
    intros ((wf,ws),hw) ((xf,xs),hx) ((yf,ys),hy).
    unfold _Zcond in hw,hx,hy.
    simpl in hw,hx,hy.
    simpl.
    intros [hl hr].
    intros [hwl hwr].
    apply Nle_zero_r in hwr. subst ws.
    repeat rewrite Nmult_zero_l.
    repeat rewrite Nplus_zero_r.
    destruct hw as [hw|hw];subst.
    {
      repeat rewrite Nmult_zero_l.
      repeat rewrite Nrest_cancel.
      repeat rewrite Nmin_zero_l.
      simpl.
      split;apply Nle_refl.
    }
    {
      clear hw.
      destruct hx;destruct hy;subst.
      {
        repeat rewrite Nmult_zero_r.
        repeat rewrite Nmin_zero_l.
        simpl.
        repeat rewrite Nrest_zero_r.
        split. apply Nle_refl.
        clear hl.
        apply Nle_mult_intro_l.
        exact hr.
      }
      {
        repeat rewrite Nmult_zero_r.
        repeat rewrite Nmin_zero_l.
        repeat rewrite Nmin_zero_r.
        repeat rewrite Nrest_zero_r.
        repeat rewrite Nrest_zero_l.
        destruct (Neq_dec) as [d|d] at 2 .
        {
          simpl.
          split. apply Nle_refl.
          symmetry in d.
          apply Nmult_zero in d.
          destruct d;subst.
          repeat rewrite Nmult_zero_l. apply Nle_refl.
          rewrite Nmult_zero_r. apply Nle_zero_l.
        }
        {
          simpl.
          split;apply Nle_zero_l.
        }
      }
      {
        apply Nle_zero_r in hl,hr. subst xf ys.
        repeat rewrite Nmult_zero_r.
        simpl.
        split. apply Nle_refl.
        apply Nle_refl.
      }
      {
        clear hr.
        repeat rewrite Nmult_zero_r.
        repeat rewrite Nmin_zero_r.
        repeat rewrite Nrest_zero_l.
        repeat rewrite Nrest_zero_r.
        destruct (Neq_dec) as [d1|d1].
        {
          symmetry in d1.
          apply Nmult_zero in d1.
          destruct d1;subst.
          {
            repeat rewrite Nmult_zero_l.
            simpl.
            split;apply Nle_refl.
          }
          {
            repeat rewrite Nmult_zero_r.
            destruct (Neq_dec) as [d|d].
            {
              symmetry in d.
              apply Nmult_zero in d.
              destruct d;subst.
              {
                rewrite Nmult_zero_l.
                split;apply Nle_refl.
              }
              {
                rewrite Nmult_zero_r.
                split;apply Nle_refl.
              }
            }
            { split;apply Nle_zero_l. }
          }
        }
        {
          destruct (Neq_dec) as [d2|d2].
          {
            symmetry in d2.
            apply Nmult_zero in d2.
            destruct d2;subst.
            { repeat rewrite Nmult_zero_l. split;apply Nle_refl. }
            {
              apply Nle_zero_r in hl. subst xf.
              repeat rewrite Nmult_zero_r.
              split;apply Nle_refl.
            }
          }
          {
            split.
            apply Nle_mult_intro_l. exact hl.
            apply Nle_refl.
          }
        }
      }
    }
  Qed.

  Lemma Zle_mult_intro_r: forall w x y, Zle x y -> Zle Zzero w -> Zle (Zmult x w) (Zmult y w).
  Proof.
    intros w x y hxy hw.
    repeat rewrite (Zmult_comm _ w).
    apply Zle_mult_intro_l.
    exact hxy. exact hw.
  Qed.

  Lemma Zle_mult_elim_l: forall w x y, Zlt Zzero w -> Zle (Zmult w x) (Zmult w y) -> Zle x y.
intros w x y hw hle.
unfold Zlt in hw.
destruct hw as [hlew hneqw].
destruct w as [ [wf ws ] hw];
destruct x as [ [xf xs ] hx];
destruct y as [ [yf ys ] hy].
simpl.
unfold _Zcond in hw,hx,hy.
simpl in hw,hx,hy.
simpl in hlew.
simpl in hle.
destruct hlew as [hlewf hlews].
apply Nle_zero_r in hlews.
subst ws.
repeat rewrite Nmult_zero_l in hle.
repeat rewrite Nplus_zero_r in hle.
destruct hw as [hw|hw].
{
subst wf.
repeat rewrite Nmult_zero_l in hle.
repeat rewrite Nmin_zero_r in hle.
simpl in hle.
clear hle.
clear hlewf.
contradiction hneqw.
apply proof_irrelevance.
simpl.
reflexivity.
}
{
clear hlewf.
destruct hx as [hx|hx];destruct hy as [hy|hy].
{
subst xf yf.
repeat rewrite Nmult_zero_r in hle.
repeat rewrite Nmin_zero_l in hle.
simpl in hle.
destruct hle as [_ hle].
repeat rewrite Nrest_zero_r in hle.
apply Nle_mult_elim_l in hle.
split. apply Nle_refl. exact hle.
intro heq. subst wf. apply hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst xf ys.
split;apply Nle_zero_l.
}
{
subst xs yf.
repeat rewrite Nmult_zero_r in hle.
repeat rewrite Nmin_zero_r in hle.
repeat rewrite Nrest_zero_l in hle.
repeat rewrite Nrest_zero_r in hle.
repeat rewrite Nmin_zero_l in hle.
destruct (Neq_dec) as [d|d] in hle .
{
symmetry in d.
apply Nmult_zero in d.
destruct d as [d|d].
{
subst wf.
contradiction hneqw.
apply proof_irrelevance. simpl. reflexivity.
}
{
subst xf.
repeat rewrite Nmult_zero_r in hle.
simpl in hle.
destruct hle as [_ hle].
apply Nle_zero_r in hle.
apply Nmult_zero in hle.
destruct hle as [hle|hle].
{
subst wf. contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst ys. split;apply Nle_refl.
}
}
}
{
simpl in hle.
destruct hle as [hlel hler].
apply Nle_zero_r in hlel, hler.
apply Nmult_zero in hlel, hler.
destruct hlel as [hlel|hlel].
{
subst wf. contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst xf.
rewrite Nmult_zero_r in d.
contradiction d.
}
}
}
{
subst xs ys.
repeat rewrite Nmult_zero_r in hle.
repeat rewrite Nmin_zero_r in hle.
repeat rewrite Nrest_zero_l in hle.
repeat rewrite Nrest_zero_r in hle.
destruct (Neq_dec) as [d1|d1].
{
symmetry in d1.
apply Nmult_zero in d1.
destruct d1 as [d1|d1].
{
subst wf. contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst xf.
split;apply Nle_zero_l.
}
}
{
destruct (Neq_dec) as [d2|d2].
{
symmetry in d2.
apply Nmult_zero in d2.
destruct d2 as [d2|d2].
{
subst wf. contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst yf.
rewrite Nmult_zero_r in hle.
destruct hle as [hle _].
apply Nle_zero_r in hle.
apply Nmult_zero in hle.
destruct hle as [hle|hle].
{
subst wf. contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
{
subst xf.
split;apply Nle_refl.
}
}
}
{
destruct hle as [hle _].
apply Nle_mult_elim_l in hle.
split.
exact hle.
apply Nle_refl.
intro heq. subst wf.
contradiction hneqw. apply proof_irrelevance. simpl. reflexivity.
}
}
}
}
Qed.

  Lemma Zle_mult_elim_r: forall w x y, Zlt Zzero w -> Zle (Zmult x w) (Zmult y w) -> Zle x y.
  Proof.
    intros w x y hlt hle.
    apply Zle_mult_elim_l with w.
    exact hlt.
    repeat rewrite (Zmult_comm w).
    exact hle.
  Qed.

  Definition Zabs x := if Zle_dec Zzero x then x else Zopp x.

  Lemma  Zle_opp : forall x y, Zle x y -> Zle (Zopp y) (Zopp x).
  Proof.
    intros ((xf,xs),hx) ((yf,ys),hy) h.
    unfold Zopp.
    destruct Zone_opp as ((xof,xos),xoh) eqn:heqxo.
    red in hx,hy.
    simpl in hx,hy.
    inversion heqxo.
    subst xof xos.
    simpl.
    repeat rewrite Nmult_zero_r.
    repeat rewrite Nplus_zero_l.
    repeat rewrite Nmult_one_r.
    repeat rewrite Nplus_zero_r.
    clear heqxo. clear xoh.
    simpl in h.
    destruct hx;destruct hy;subst.
    {
      repeat rewrite Nmin_zero_r.
      repeat rewrite Nrest_zero_l.
      repeat rewrite Nrest_zero_r.
      destruct (Neq_dec) as [d|d] at 2.
      {
        subst xs.
        destruct h as [_ h].
        apply Nle_zero_r in h.
        subst ys.
        simpl.
        split;apply Nle_refl.
      }
      {
        destruct (Neq_dec) as [dy|dy].
        { subst. split;apply Nle_zero_l. }
        { destruct h as [_ h]. split. exact h. apply Nle_refl. }
      }
    }
    {
      clear h.
      repeat rewrite Nmin_zero_r.
      repeat rewrite Nmin_zero_l.
      repeat rewrite Nrest_zero_r.
      repeat rewrite Nrest_zero_l.
      destruct (Neq_dec) as [d|d] at 2.
      { subst xs. simpl. split;apply Nle_zero_l. }
      { simpl. split;apply Nle_zero_l. }
    }
    {
      destruct h as [hl hr].
      apply Nle_zero_r in hl,hr.
      subst.
      repeat rewrite Nmin_zero_l.
      simpl.
      split;apply Nle_refl.
    }
    {
      destruct h as [h _].
      repeat rewrite Nmin_zero_l.
      simpl.
      repeat rewrite Nrest_zero_r.
      split.
      apply Nle_refl.
      exact h.
    }
  Qed.

  Lemma Zabs_pos : forall x:ZZ, Zle Zzero (Zabs x).
  Proof.
    intro x.
    unfold Zabs.
    destruct (Zle_dec) as [d|d].
    { exact d. }
    {
      rewrite <- Zopp_zero.
      apply Zle_opp.
      exact d.
    }
  Qed.

  Definition _NtoZ (n:NN) : (PairOf NN) := pair n Nzero.

  Lemma _NtoZ_ok : forall (n:NN), _Zcond (_NtoZ n).
  Proof.
    intro n.
    red.
    unfold _NtoZ.
    simpl.
    right.
    reflexivity.
  Qed.

  Definition NtoZ (n:NN) : ZZ := exist _ (_NtoZ n) (_NtoZ_ok n).

  Lemma NtoZ_pos : forall n:NN, Zle Zzero (NtoZ n).
  Proof.
    intro n.
    unfold NtoZ.
    simpl.
    split;apply Nle_zero_l.
  Qed.

  Definition ZtoN (x:ZZ) : NN := first (proj1_sig (Zabs x)).

  Lemma NtoZtoN : forall n:NN, n = ZtoN (NtoZ n).
  Proof.
    intro n.
    unfold NtoZ.
    unfold ZtoN.
    unfold Zabs.
    destruct (Zle_dec) as [d|d].
    {
      simpl.
      reflexivity.
    }
    {
      simpl in d.
      destruct d as [d _].
      apply Nle_zero_r in d.
      subst n.
      simpl.
      reflexivity.
    }
  Qed.

  Lemma ZtoNtoZ : forall x:ZZ, Zle Zzero x -> x = NtoZ (ZtoN x).
  Proof.
    intros ((xf,xs),hx) hle.
    simpl in hle.
    destruct hle as [hl hr].
    apply Nle_zero_r in hr.
    subst xs.
    apply proof_irrelevance.
    simpl.
    unfold _NtoZ.
    f_equal.
    red in hx.
    simpl in hx.
    unfold ZtoN.
    unfold Zabs.
    destruct (Zle_dec) as [d|d].
    {
      simpl. reflexivity.
    }
    {
      simpl in d.
      destruct d as [d _].
      apply Nle_zero_r in d.
      subst xf.
      simpl.
      reflexivity.
    }
  Qed.

  Definition Zsign (x:ZZ) := if Zle_dec Zzero x then Zone else Zone_opp.

  Lemma Zabs_sign : forall x:ZZ, x = Zmult (Zsign x) (Zabs x).
  Proof.
    intros x.
    unfold Zsign.
    unfold Zabs.
    destruct (Zle_dec) as [d|d].
    {
      rewrite Zmult_one_l.
      reflexivity.
    }
    {
      unfold Zopp.
      rewrite (Zmult_comm x).
      rewrite <- Zmult_assoc.
      rewrite Zmult_oneopp.
      rewrite Zmult_one_l.
      reflexivity.
    }
  Qed.

  Lemma Nle_neq_lt : forall x y, Nle x y -> x <> y -> Nlt x y.
Proof.
intro x.
induction x as [|x ih] using Ninduction.
{
intros y _ hneq.
red.
induction y as [|y _] using Ninduction.
{ contradiction hneq. reflexivity. }
{ apply Nle_next_intro. apply Nle_zero_l. }
}
{
intro y.
induction y as [|y _] using Ninduction.
{ intro h. inversion h. }
{
intros hle hneq.
apply Nle_next_elim in hle.
red.
apply Nle_next_intro.
apply ih.
exact hle.
intro heq. subst y. contradiction hneq. reflexivity.
}
}
Qed.

  Definition _NEuclidPair := @Pair NN NN.

  Definition _NEuclidLe (p1 p2:_NEuclidPair) :=
    let (pf1,ps1) := p1 in
    let (pf2,ps2) := p2 in
    Nle pf1 pf2 /\ Nle ps1 ps2.

  Definition _NEuclidLt (p1 p2:_NEuclidPair) :=
    let (pf1,ps1) := p1 in
    let (pf2,ps2) := p2 in
    _NEuclidLe p1 p2 /\ (pf1 <> pf2 \/ ps1 <> ps2 ).

  Lemma pair_neq:forall a b c d:NN, pair a b <> pair c d ->
    (a <> c /\ b = d) \/
    (a = c /\ b <> d) \/
    (a <> c /\ b <> d).
  Proof.
    intros a b c d hneq.
    destruct (Neq_dec a c) as [df|df];
    destruct (Neq_dec b d) as [ds|ds].
    { subst. contradiction hneq. reflexivity. }
    { right. left. split;assumption. }
    { left. split;assumption. }
    { right. right. split;assumption. }
  Qed.

  Lemma Nnext_neq : forall x, x = Nnext x -> False.
  Proof.
    intro x.
    induction x as [|x ih] using Ninduction.
    { intro heq. inversion heq. }
    { intro heq. apply Nnext_elim in heq. apply ih. exact heq. }
  Qed.

  Lemma _NEuclidLt_wf: well_founded _NEuclidLt.
  Proof.
    red.
    intros (xf,xs).
    generalize dependent xs.
    induction xf as [|xf ih] using Ninduction.
    {
      intros xs.
      induction xs as [|xs ih] using Ninduction.
      {
        constructor.
        intros (yf,ys) [ [hyf hys] hyneq].
        apply Nle_zero_r in hyf,hys.
        subst yf ys.
        destruct hyneq as [ hyneq  | hyneq ] .
        contradiction hyneq. reflexivity.
        contradiction hyneq. reflexivity.
      }
      {
        constructor.
        intros (yf,ys)  [ [ hyf hys ] hyneq ].
        apply Nle_zero_r in hyf.
        subst yf.
        destruct hyneq as [ hyneq | hyneq ] .
        { contradiction hyneq. reflexivity. }
        assert (hylt:=Nle_neq_lt _ _ hys hyneq).
        clear hys hyneq. red in hylt. apply Nle_next_elim in hylt.
        constructor. intros (zf,zs) [ [ hzf hzs ] hzneq ].
        apply Nle_zero_r in hzf. subst zf.
        destruct hzneq as [ hzneq | hzneq ] .
        { contradiction hzneq. reflexivity. }
        assert (hzlt:=Nle_neq_lt _ _ hzs hzneq).
        clear hzs hzneq. red in hzlt.
        inversion ih as [ih']. clear ih.
        apply ih'. red. split. red. split.
        apply Nle_refl.
        apply Nle_trans with (Nnext zs). apply Nle_next.
        apply Nle_trans with ys. exact hzlt. exact hylt.
        right. intro heq. subst zs.
        apply (Nlt_irrefl xs). red.
        apply Nle_trans with ys. exact hzlt. exact hylt.
      }
    }
    (* xf induction *)
    {
      intros xs.
      (* xs induction *)
      induction xs as [|xs ihs] using Ninduction.
      (* xs = 0 *)
      {
        constructor.
        intros (yf,ys) [ [ hyf hys ] hyneq ].
        apply Nle_zero_r in hys.
        subst ys.
        (* y left side not equal *)
        destruct hyneq as [hyneq|hyneq].
        {
          assert (hylt:=Nle_neq_lt _ _ hyf hyneq). clear hyf hyneq.
          red in hylt.
          constructor.
          intros (zf,zs) [ [ hzf hzs ] hzneq ].
          apply Nle_zero_r in hzs.
          subst zs.
          destruct hzneq as [ hzneq | hzneq ].
          (* z lef side not equal *)
          {
            assert (hzlt:=Nle_neq_lt _ _ hzf hzneq).
            clear hzf hzneq.
            red in hzlt.
            specialize (ih Nzero).
            inversion ih as [ih'].
            clear ih.
            apply ih'.
            clear ih'.
            red. split. red. split.
            {
              apply Nle_next_elim in hylt.
              apply Nle_trans with (Nnext zf).
              apply Nle_next.
              apply Nle_trans with yf.
              exact hzlt.
              exact hylt.
            }
            { apply Nle_refl. }
            {
              left.
              intro heq.
              subst zf.
              apply Nle_next_elim in hylt.
              apply (Nlt_irrefl xf).
              red.
              apply Nle_trans with yf.
              exact hzlt.
              exact hylt.
            }
          }
          (* z right side not equal (clamped to 0 because xs = 0 *)
          { contradiction hzneq.  reflexivity. }
        }
        (* y right side not equal (clamped to 0 because xs = 0 *)
        { contradiction hyneq. reflexivity. }
      }
      (* xs induction *)
      {
        inversion ihs as [ihs'].
        clear ihs.
        constructor.
        intros (yf,ys) [ [hyf hys] hyneq].
        destruct hyneq as [hyneq|hyneq].
        (* y left side not equal *)
        {
          assert (hylt:=Nle_neq_lt _ _ hyf hyneq).
          clear hyf hyneq.
          red in hylt.
          apply Nle_next_elim in hylt.
          constructor.
          intros (zf,zs) [ [ hzf hzs ] hzneq ].
          destruct hzneq as [ hzneq | hzneq ].
          (* z left side not equal *)
          {
            assert (hzlt:=Nle_neq_lt _ _ hzf hzneq).
            clear hzf hzneq.
            red in hzlt.
            specialize (ih zs).
            inversion ih as [ih'].
            clear ih.
            apply ih'.
            clear ih'.
            red. split. red. split.
            {
              apply Nle_trans with (Nnext zf).
              apply Nle_next.
              apply Nle_trans with yf.
              exact hzlt.
              exact hylt.
            }
            { apply Nle_refl. }
            {
              left.
              intro heq.
              subst zf.
              apply (Nlt_irrefl xf).
              red.
              apply Nle_trans with yf.
              exact hzlt.
              exact hylt.
            }
          }
          (* z right side not equal *)
          {
            assert (hzlt:=Nle_neq_lt _ _ hzs hzneq).
            clear hzs hzneq.
            red in hzlt.
            specialize (ih (Nnext zs)).
            inversion ih as [ih'].
            clear ih.
            apply ih'.
            clear ih'.
            red. split. red. split.
            {
              apply Nle_trans with yf.
              exact hzf.
              exact hylt.
            }
            { apply Nle_next. }
            {
              right.
              intro heq.
              apply Nnext_neq in heq.
              contradiction heq.
            }
          }
        }
        (* y right side not equal *)
        {
          assert (hylt:=Nle_neq_lt _ _ hys hyneq).
          clear hys hyneq.
          red in hylt.
          apply Nle_next_elim in hylt.
          constructor.
          intros (zf,zs) [ [ hzf hzs ] hzneq ].
          destruct hzneq as [hzneq|hzneq].
          (* z left side not equal *)
          {
            assert (hzlt:=Nle_neq_lt _ _ hzf hzneq).
            clear hzf hzneq.
            red in hzlt.
            specialize (ih (Nnext zs)).
            inversion ih as [ih'].
            clear ih.
            apply ih'.
            clear ih'.
            red. split. red. split.
            {
              apply Nle_next_elim.
              apply Nle_trans with yf.
              exact hzlt.
              exact hyf.
            }
            { apply Nle_next. }
            {
              right.
              intro heq.
              apply Nnext_neq in heq.
              contradiction heq.
            }
          }
          (* z right side not equal *)
          {
            assert (hzlt:=Nle_neq_lt _ _ hzs hzneq).
            clear hzs hzneq.
            red in hzlt.
            apply ihs'.
            red. split. red. split.
            {
              apply Nle_trans with yf.
              exact hzf.
              exact hyf.
            }
            {
              apply Nle_trans with (Nnext zs).
              apply Nle_next.
              apply Nle_trans with ys.
              exact hzlt.
              exact hylt.
            }
            {
              right.
              intro heq.
              subst zs.
              apply Nlt_irrefl with xs.
              red.
              apply Nle_trans with ys.
              exact hzlt.
              exact hylt.
            }
          }
        }
      }
    }
    Qed.

(*
  if Neq_dec Zzero a then b
  else if Neq_dec Zzero b then a
  else if Neq_dec a b then a
  else if Nle_dec a b then
    gcd a (Nrest a b)
  else
    gcd (Nrest a b) b

*)

d = (Ngcd (ZtoN x) (ZtoN y))


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

(** * Theorems about trunctions *)

Require Import HoTT.Basics HoTT.Truncations HoTT.Types.Bool.
Require Import Metatheory.Core Metatheory.FunextVarieties.

(** ** We can construct an interval type as [Trunc -1 Bool] *)

Local Definition interval := Trunc (-1) Bool.

Local Definition interval_rec (P : Type) (a b : P) (p : a = b)
: interval -> P.
Proof.
  unfold interval; intro x.
  cut { pt : P | pt = b }.
  { apply pr1. }
  { strip_truncations.
    refine (if x then a else b; _).
    destruct x; (reflexivity || assumption). }
Defined.

Local Definition seg : tr true = tr false :> interval
  := path_ishprop _ _.

(** ** From an interval type, and thus from truncations, we can prove function extensionality. *)

Definition funext_type_from_trunc : Funext_type
  := WeakFunext_implies_Funext (NaiveFunext_implies_WeakFunext
    (fun A P f g p =>
      let h := fun (x:interval) (a:A) =>
        interval_rec _ (f a) (g a) (p a) x
        in ap h seg)).


(** Use some very basic facilities of mathcomp library *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype seq div prime ssrfun.

Unset Printing All.
Print rel.
Definition id A (a : A) : A := a.
Check (id nat 3).
Check (id _ 3).

Arguments id {A} a.
Compute @id nat 3.

Check (fun x => @id nat x).

Lemma prime_gt1 p :
  prime p -> 1 < p.
Proof.
Admitted.

(* fun m n : nat => leq_trans (n:=m.+1) (m:=m) (p:=n) (leqnSn m) *)
(*      : forall m n : nat, m < n -> m <= n *)
(* Unset Printing Notations. *)
Lemma example q : prime q -> 0 < q.
Proof.
  move=> pr_q.
  have q_gt1 := @prime_gt1 _ pr_q.
  exact: ltnW q_gt1.
Qed.

(* Для задания неявных аргументов для лемм также используется ключевое слово Arguments. *)
Arguments prime_gt1 {p}.

Lemma example' q : prime q -> 0 < q.
Proof.
  move=> pr_q.
  have q_gt1 := prime_gt1 pr_q.
  exact: ltnW q_gt1.
Qed.

Module induct.
  Inductive eqType : Type :=
    Pack sort of sort -> sort -> bool.

  Definition sort (c : eqType) : Type :=
    let: Pack t _ := c in t.

  Definition eq_op (c : eqType) : sort c -> sort c -> bool :=
    let: Pack _ f := c in f.

  Print eqType.
End induct.

Record eqType : Type := Pack
{
  sort : Type;
  eq_op : sort -> sort -> bool
}.

Check eq_op.
Definition nat_eqType : eqType := Pack nat eqn.
Eval simpl in sort nat_eqType.
Compute sort nat_eqType.
Eval simpl in eq_op nat_eqType.

Check (eq_op nat_eqType 3 4).

Definition eqb (a b : bool) := if a then b else ~~ b.
Definition bool_eqType := Pack bool eqb.

Notation "x == y" := (@eq_op _ x y).
Locate "==".
Check (@eq_op bool_eqType true false).

Definition prod_cmp eqA eqB x y :=
  @eq_op eqA x.1 y.1 && @eq_op eqB x.2 y.2.

(* Check (3 == 4). *)

Canonical nat_eqType.
Canonical bool_eqType.

Check (3 == 4).
Check (true == false).
Compute false == false.
Compute false == true.

(* Check [law of addn]. *)

Print ltnW.
Lemma prime_gt1


From BraidsT Require Import CpdtTactics.
From BraidsT Require Import supp.

Require Import Bool PeanoNat List Nat.
Set Implicit Arguments.
Set Asymmetric Patterns.

(* Unset Strict Implicit. *)
(* Unset Printing Implicit Defensive. *)

Require Import ProofIrrelevance.

Require Import ZArith.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Require Import Coq.Program.Equality.

Import ListNotations.

Hint Rewrite app_nil_r : core.

Inductive BNat : nat ->  Set :=
| BZero : forall {n}, BNat (S n)
| BSucc : forall {n}, BNat n -> BNat (S n).

Lemma NoBNatZero : forall (b : (BNat 0)), False.
  intros b.
  refine (match b with | @BZero n => _ | @BSucc n _ => _ end); crush.
Qed.

Module Braids.

Section Theory.

Variable N : nat.
Hypothesis large_enough : 10 < N.

Definition free_braidlike_monoid := list (BNat (pred N)).

Definition mult_fbm : free_braidlike_monoid -> free_braidlike_monoid -> free_braidlike_monoid := app (A:=_).

Hint Unfold mult_fbm : core.

Notation "x * y" := (mult_fbm x y).

Lemma braids_has_1 : exists e : free_braidlike_monoid, forall x, x * e = x /\ e * x = x.
Proof.
  unfold "*";
  exists [];
  crush.
Qed.

Lemma braids_assoc : forall (x y z : free_braidlike_monoid), (x * y) * z = x * (y * z).
Proof.
  unfold "*";
  crush.
Qed.

Definition ns_list (n:nat) := rev ((fix F n :=
  match n with
  | 0 => []
  | S n' => n :: (F n')
  end) n).

Lemma ns_list_len : forall n, length(ns_list n) = n.
Proof.
  intros.
  induction n.
  - trivial.
  - unfold ns_list. rewrite rev_length.
    unfold ns_list in IHn. rewrite rev_length in IHn.
    simpl. rewrite IHn. trivial.
Qed.

Hint Rewrite ns_list_len.

Eval compute in ns_list 10.

Definition braid_perm := { perm : list nat | Permutation perm (ns_list N) }.

Lemma braid_perm_size : forall bp : braid_perm, length (proj1_sig bp) = N.
Proof.
  intros.
  destruct bp as [perm P].
  simpl. apply Permutation_length in P. rewrite ns_list_len in P. apply P.
Qed.

Lemma braid_list_len : forall l, Permutation l (ns_list N) -> length l = N.
Proof.
  intros l Hl.
  crush.
Qed.

Hint Rewrite braid_perm_size.
(* Hint Rewrite braid_list_len. *)
Hint Constructors Permutation : core.

Lemma Permutation_rev__l : forall {A} (l : list A), Permutation (rev l) l.
Proof.
  intros A.
  intros l.
  replace l with (rev (rev l)) at 2.
  apply Permutation_rev.
  apply rev_involutive.
Qed.

Print braid_perm.
Check exist.

(* Lemma no_empty {T} : forall i, S (S i) <= length(@nil T) -> False.
Proof.
  simpl. intros.
  inversion H.
Qed.

Lemma no_single {T} : forall i (x:T), S (S i) <= length([x]) -> False.
Proof.
  simpl. intros.
  inversion H. inversion H1.
Qed.

Lemma no_emptyT {T} : forall n : BNat (pred (length [] (A:=T))),  False.
Proof.
  simpl. intros [n H]. inversion H.
Qed.

Lemma no_singleT {T} : forall (x:T) (n : BNat (pred (length [x]))), False.
Proof.
  simpl. intros _ [n H].
  inversion H.
Qed. *)

Notation "[[ x ]]" := (exist _ x _).
Notation "[[ x | P ]]" := (exist _ x P).

Program Fixpoint transpose_if_lt (l : list nat) (i : BNat (pred (length l))) : list nat :=
  match l with
  | [] | [_] => _
  | x::y::xs =>
    match i with
    | BZero _   => if (x <? y) then y :: x :: xs else x :: y :: xs
    | BSucc _ i =>
      x :: (transpose_if_lt (y::xs) i)
    end
  end.
Next Obligation. inversion i. Defined.
Next Obligation. inversion i. Defined.
(* Next Obligation. *)
(*   intros i. simpl in i. *)
(*   refine ((match i in BNat (S n) return ( *)
(*                    match (S n) with | 0 => IDProp | S n' => n = (length xs) -> list nat end) *)
(*            with *)
(*            | BZero n' =>  fun Heq => _ *)
(*            | BSucc n' i' => fun Heq => _ *)
(*            end) eq_refl). *)
(*   + exact (if (x <? y) then y :: x :: xs else x :: y :: xs). *)
(*   + subst n'. *)
(*     exact (x :: (transpose_if_lt (y::xs) i')). *)
(* Defined. *)

Print transpose_if_lt.

Lemma transpose_if_lt_Sn (x y : nat) (l : list nat)
           (n : BNat (pred (length (y::l)))) :
  transpose_if_lt (x::y::l) (BSucc n) = x :: (transpose_if_lt (y::l) n).
Proof. reflexivity. Qed.

(*
Definition transpose_if_lt (l : list nat) (i:BNat (pred (length l))) : list nat.
  destruct i as [i Hi].
  refine (let fix F l (i:nat) Hi {struct i}: list nat := _ in F l i Hi); clear l0 i0 Hi0.
  refine ((match l as l' return (forall i (Hi: i < (pred (length l'))), _) with
          | [] => _
          | [x] => _
          | (x::y::xs) => _
          end) i Hi); clear l i Hi.
  - intros n Hn. destruct (no_emptyT [[n | Hn]]).
  - intros n Hn. destruct (no_singleT [[n | Hn]]).
  - intros n Hn. generalize Hn; clear Hn. refine (match n with 0 => _ | S n => _ end).
    + exact (fun _ => if (x <? y) then y :: x :: xs else x :: y :: xs).
    + refine (fun Hn => F (y::xs) n _). crush.
Defined.

Print transpose_if_lt.

 *)

Lemma transpose_if_lt_ind : forall (P : forall (l : list nat) (i : BNat (pred (length l))), Prop)
                            (H0 : (forall (x y : nat) (l : list nat), P (x::y::l) BZero))
                            (HSn : (forall (x y : nat) (l : list nat) (n : BNat (pred (length (y::l)))),
                                     P (y :: l) n -> P (x::y::l) (BSucc n))),
    forall (l : list nat) (i : BNat (pred (length l))), P l i.
Proof.
  intros.
  refine (let fix F l i {struct i} : P l i := _ in F l i); clear l0 i0.
  generalize i; clear i.
  refine (match l with | [] => _ | [x] => _ | (x::y::xs) => _ end).
  - simpl. intros i. exfalso. apply (NoBNatZero i).
  - simpl. intros i. exfalso. apply (NoBNatZero i).
  - intros i.
    Print eq_rect.
    refine (match i as m in BNat n
                  return (forall pf : n = pred (length (x :: y :: xs)),
                             eq_rect n BNat m (pred (length (x :: y :: xs))) pf = i ->
                             P (x :: y :: xs) i
                  )
            with
            | BZero n' => _
            | BSucc n' i' => _
            end eq_refl eq_refl).
    + intros pf H'. Check eq_nat_dec.
      inversion pf. subst.
      rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
      simpl.
      apply H0.
    + intros pf H. inversion pf. subst. rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
      apply HSn. apply F.
Qed.

Lemma transpose_if_lt_perm (l : list nat) (i:BNat (pred (length l))) :
  Permutation l (transpose_if_lt l i).
Proof.
  apply (transpose_if_lt_ind (fun l i => Permutation l (transpose_if_lt l i))).
  - simpl. intros.
    destruct (Nat.ltb_spec x y).
    { constructor. }
    { apply Permutation_refl. }
  - intros x y l0 n HInd.
    rewrite transpose_if_lt_Sn. constructor. apply HInd.
Qed.

Corollary transpose_if_lt_len l i : length (transpose_if_lt l i) = length l.
  apply Permutation_length. apply Permutation_sym. apply (transpose_if_lt_perm l i).
Qed.

(*
Inductive transpose_if_ltR : forall (l:list nat) (l':list nat) (i:nat), Prop :=
| transpose_if_lt_step x xs l' n (H: transpose_if_ltR xs l' n) : transpose_if_ltR (x::xs) (x::l') (S n)
| transpose_if_lt_swap x y xs (H: x < y) : transpose_if_ltR (x::y::xs) (y::x::xs) 0
| transpose_if_lt_noswap x y xs (H: ~(x < y)) : transpose_if_ltR (x::y::xs) (x::y::xs) 0.

Lemma transpose_if_lt_FtR : forall (l:list nat) (bi:BNat (pred (length l))),
  let (i, _) := bi in
  let (l', _) := transpose_if_lt l bi in
  transpose_if_ltR l l' i.
Proof.
  intros l bi.
  destruct bi as [i Hi].
  generalize dependent l.
  induction i; intros l;
  refine ((match l as m return (l = m -> _)
      with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl);
  try solve [intros Hl Hi; exfalso; subst l; crush].
  Guarded.
  2:{
    intros Hl Hi. clear Hl; clear l0.
    destruct (transpose_if_lt (x::y::xs) [[ S i | Hi ]]) eqn:Heq.
    cbn in Heq.
    apply transpose_if_lt_step. *)

Definition transpose_braid (bp : braid_perm) (i:BNat (pred N))
  : braid_perm.
  destruct bp as [bp Hbp].
  assert (length bp = N).
  { apply (braid_list_len Hbp). }
  refine ((match H in (_ = len) return (BNat (pred len) -> braid_perm) with
           | eq_refl => fun i => [[transpose_if_lt bp i]] end) i).
  apply Permutation_sym.
  apply perm_trans with bp.
  - apply Permutation_sym. assumption.
  - apply transpose_if_lt_perm.
Defined.

Print transpose_braid.

Definition pi_braid (b : free_braidlike_monoid) : braid_perm.
  refine (let fix pi_braid_sup (b : free_braidlike_monoid) (ini : braid_perm) : braid_perm := _ in
          pi_braid_sup b [[ns_list N]]).
  { trivial. }
  Unshelve.
  refine (match b with | [] => _ | (x::xs) => _ end).
  { exact ini. }
  exact (pi_braid_sup xs (transpose_braid ini x)).
Defined.

Print pi_braid.

Notation "'fbm'" := free_braidlike_monoid.

Notation "x <- e1 ;; e2" := (match e1 with [[x]] => e2 end) (at level 100).

Program Definition twice_transpose_if_ltRT (l : list nat) (n : BNat (pred (length l)))
  : Prop :=
  let f_once := transpose_if_lt l n in
  f_once = transpose_if_lt f_once n.
  (* let f_twice := transpose_if_lt f_once n in *)
  (* f_once = f_twice. *)
Next Obligation.
  apply f_equal_pred. rewrite transpose_if_lt_len. auto.
Defined.

Print twice_transpose_if_ltRT.

Locate "<?".

Lemma twice_transpose_if_lt l n : twice_transpose_if_ltRT l n.
Proof.
  generalize dependent n.
  apply transpose_if_lt_ind; intros.
  2: { red. simpl in *.
       unfold twice_transpose_if_ltRT_obligation_1.
       simpl in *.
       assert (length (transpose_if_lt (y :: l0) n) = S (length l0)) as AA.
       { admit. }
       rewrite AA.

       2: admit.
       rewrite <- eq_rect_eq.

       rewrite rew_const.
       replace (eq_rect (S (length l0)) (fun H0 : nat => BNat H0) (BSucc n)
                        (length (transpose_if_lt (y :: l0) n))
                        (twice_transpose_if_ltRT_obligation_1 (x :: y :: l0) (BSucc n)))
               with (BSucc n).

rewrite transpose_if_lt_Sn.

  { red. simpl in *. unfold transpose_if_lt.

  generalize dependent n. induction l.
  { inversion n. }
  intros. red.

  inv n.
  {

  apply transpose_if_lt_ind; intros.
  { red. simpl in *. unfold transpose_if_lt.

destruct (classic (x <? y)).

destruct (Nat.ltb_spec x y).

  unfold twice_transpose_if_ltRT.
  generalize l n; clear l n.
  apply transpose_if_lt_ind.
  - intros x y l.
    destruct (Nat.ltb_spec x y).
    {

Definition twice_transpose_if_ltRT (l:list nat) (n:BNat (pred (length l))) : Prop.
  refine (let l1 := @transpose_if_lt l n in _).
  destruct l1 as [l1 Hl1].
  refine (let l2 := @transpose_if_lt l n in _).
  destruct l2 as [l2 Hl2].
  destruct n as [n Hn].
  refine (let l3 := @transpose_if_lt l2 [[n]] in _).
  destruct l3 as [l3 Hl3].
  exact (l1 = l3).
  Unshelve.
  apply Permutation_length in Hl2. rewrite Hl2. assumption.
Defined.

Print twice_transpose_if_ltRT.

Lemma twice_transpose_if_lt : forall l n, twice_transpose_if_ltRT l n.
Proof.
  unfold twice_transpose_if_ltRT.
  refine (fix F l : forall n, twice_transpose_if_ltRT l n := _).
  refine (match l with
          | [] => _
          | [x] => _
          | (x::y::xs) => _
          end).
  - intros n. exfalso.
    apply (no_emptyT n).
  - intros n. exfalso.
    apply (no_singleT n).
  - simpl. unfold twice_transpose_if_ltRT. intros [n Hn]. destruct n. {
    unfold transpose_if_lt at 1. unfold transpose_if_lt at 1. simpl.
    destruct (Nat.ltb_spec x y).
    + unfold transpose_if_lt. simpl. destruct (Nat.ltb_spec y x); crush.
    + unfold transpose_if_lt. simpl. destruct (Nat.ltb_spec x y); crush. }
  {

  unfold twice_transpose_if_ltRT.
  destruct n as [n Hn].
  refine (match l with
          | [] => _
          | [x] => _
          | (x::y::xs) => _
          end).

  refine ((match l as m return (l = m -> _) with
    | [] => _
    | [x] => _
    | (x::y::xs) => _
    end) eq_refl).
  - intros. exfalso. assert (2 <= length (l)); crush.
  - intros. exfalso. assert (2 <= length (l)); crush.
  -

    refine ((match n as m return (n = m -> _) with
      | 0 => _
      | S n' => _
      end) eq_refl).
  2: { intros. .

 - intros. crush. try solve [clear F; crush].

Lemma twice_transpose_braid_0 : forall l n,
  transpose_braid l n = (transpose_braid (transpose_braid l n) n).
Proof.
  assert (
    forall l n,
      let (lhs, _) := transpose_if_lt (l:=l) n in
      let (rhs, _) := (let (l', _) := transpose_if_lt (l:=l) n in
        (transpose_if_lt (l:=l') (_ n))) in
      lhs = rhs).

  intros [l Hl] [n Hn].
  generalize dependent l.
  induction n; intros l Hl.
  - refine ((match l as l' return (l' = l -> _) with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl).
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. subst l. destruct (x <? y) eqn:Heq.
    * unfold transpose_braid. unfold transpose_if_lt. simpl. rewrite Heq.
      assert ((y <? x) = false). { apply (lt_antisymm Heq). } rewrite H.
      apply subset_eq_compat. trivial.
    * unfold transpose_braid. unfold transpose_if_lt. simpl. rewrite Heq. rewrite Heq.
      apply subset_eq_compat. trivial.
  - refine ((match l as l' return (l' = l -> _) with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl).
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. subst l.
      unfold transpose_braid.
      apply transpose_if_lt_ind with .

(* Definition twice_transpose l (i : BNat (pred (length l)))
  : { l' : list nat | Permutation l' l }.
  refine (l' <- transpose_if_le l i;; _).
  refine (_ (transpose_if_le l' (_ i))).
  { intros k. destruct k as [k Hk]. exists k. apply Permutation_trans with l'; assumption. }
  { intros k. destruct k as [k Hk]. exists k. rewrite (Permutation_length p). assumption. }
Defined.

Print twice_transpose.

Lemma twice_transpose_n : forall l i,
  transpose_if_le l i = twice_transpose l i.
  intros l i. destruct i as [i Hi].
  induction i.
  - refine ((match l as l' return (l' = l -> _) with [] => _ | [x] => _ | (x::y::xs) => _ end) eq_refl).
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros. exfalso. assert (2 <= length (l)); crush.
    + intros Heq. subst l. clear l0. unfold transpose_if_le. unfold twice_transpose.
      destruct (x <=? y) eqn:Heq. simpl. rewrite Heq. *)

Definition sub_b : BNat (pred N) -> BNat (pred N) -> BNat (pred N).
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exists (n - m).
  crush.
Defined.

Definition le_b : BNat (pred N) -> BNat (pred N) -> Prop.
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exact (n <= m).
Defined.

Definition lt_b : BNat (pred N) -> BNat (pred N) -> Prop.
  intros n m.
  destruct n as [n Hn]. destruct m as [m Hm].
  exact (n < m).
Defined.

Lemma lt_1_N : 1 < pred N.
Proof.
  crush.
Qed.

Inductive braid_eq : fbm -> fbm -> Prop :=
| braid_eq_refl : forall x, braid_eq x x
| braid_eq_symm : forall x y, braid_eq x y -> braid_eq y x
| braid_eq_trans : forall x y z, braid_eq x y -> braid_eq y z -> braid_eq x z
| braid_eq_idemp : forall i, braid_eq [i; i] [i]
| braid_eq_farcomm : forall i j : BNat (pred N), lt_b [[1 | lt_1_N ]] (sub_b j i) ->
      braid_eq [i; j] [j; i]
| braid_eq_braid : forall i j : (BNat (pred N)), [[1 | lt_1_N]] = (sub_b j i) ->
      braid_eq [i; j; i] [j; i; j].

Theorem braid_eq__pi_eq : forall b1 b2, braid_eq b1 b2 -> pi_braid b1 = pi_braid b2.
Proof.
  intros.
  induction H; try solve [crush].
  - unfold pi_braid.
  assert (forall l, transpose_braid (transpose_braid l i) i =
    transpose_braid l i).
  intros. unfold transpose_braid.

End braids.


(********************************************************************************)
(* Quicksort (subset types) *)

From sortalgs Require Import sorted.

Open Scope list_scope.
Import List.ListNotations.

Require Import Program.

Lemma lem_partition `{DecTotalOrder} :
  forall x l1 l2, Sorted l1 -> Sorted l2 -> GeLst x l1 -> LeLst x l2 ->
                  Sorted (l1 ++ x :: l2).
Proof.
  induction l1.
  - inversion 4; sauto lq: on.
  - inversion 1; inversion 2; hauto use: lem_sorted_tail ctrs: Sorted.
Qed.

Program Fixpoint partition {A} `{DecTotalOrder A} (x : A) (l : list A)
  {measure (length l)} :
  { (l1, l2) : list A * list A |
    GeLst x l1 /\ LeLst x l2 /\ Permutation l (l1 ++ l2) } :=
  match l with
  | [] => ([], [])
  | h :: t =>
    match partition x t with
    | (t1, t2) =>
      if leb_total_dec h x then
        (h :: t1, t2)
      else
        (t1, h :: t2)
    end
  end.
Solve Obligations with sauto use: Permutation_middle.

Program Fixpoint qsort {A} `{DecTotalOrder A} (l : list A) {measure (length l)}
  : {l' | Sorted l' /\ Permutation l l'} :=
  match l with
  | [] => []
  | h :: t =>
    match partition h t with
    | (t1, t2) => qsort t1 ++ [h] ++ qsort t2
    end
  end.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  hauto use: Permutation_length db: list.
Qed.
Next Obligation.
  hauto use: Permutation_length db: list.
Qed.
Next Obligation.
  destruct_sigma; simp_hyps; split.
  - eauto using lem_gelst_perm, lem_lelst_perm, lem_partition.
  - eauto using perm_trans, perm_skip, Permutation_middle, Permutation_app.
Qed.


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

Require Import Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_nat.

Set Implicit Arguments.

Section iter.

  Variable (X : Type) (f : X -> X).

  Fixpoint iter n x :=
    match n with
      | 0   => x
      | S n => f (iter n x)
    end.

  Fact iter_plus n m x : iter (n+m) x = iter n (iter m x).
  Proof. induction n; simpl; f_equal; auto. Qed.

  Fact iter_S n x : iter (S n) x = iter n (f x).
  Proof. replace (S n) with (n+1) by lia; apply iter_plus. Qed.

End iter.

Section prim_min.

  Variable (X : Type) (f : nat -> nat).

  Let min_f n : f n = 0 -> { k | k <= n /\ f k = 0 /\ forall i, i < k -> f i <> 0 }.
  Proof.
    intros Hn.
    destruct first_which with (P := fun i => f i = 0) as (k & H1 & H2).
    + intros; apply eq_nat_dec.
    + exists n; auto.
    + exists k; split; auto.
      destruct (le_lt_dec k n); auto.
      destruct (H2 n); auto.
  Qed.

  Let g i := match f i with 0 => i | _ => S i end.

  Let prim_min_rec n a := iter g n a.

  Let prim_min_rec_spec_0 n a : (forall i, i < n -> f (i+a) <> 0) -> forall i, i <= n -> prim_min_rec i a = i+a.
  Proof.
    unfold prim_min_rec.
    revert a; induction n as [ | n IHn ]; intros a Hn.
    + intros i Hi; replace i with 0 by lia; auto.
    + intros [ | i ] Hi; auto.
      * rewrite iter_S.
        unfold g at 2.
        generalize (Hn 0); simpl; intros E.
        destruct (f a); try lia.
        rewrite IHn; try lia.
        intros j Hj.
        replace (j+S a) with (S j+a) by lia.
        apply Hn; lia.
  Qed.

  Let prim_min_rec_spec_1 n a : f a = 0 -> prim_min_rec n a = a.
  Proof.
    intros Ha; unfold prim_min_rec.
    induction n as [ | n IHn ]; auto.
    rewrite iter_S.
    unfold g at 2; rewrite Ha; auto.
  Qed.

  Definition prim_min n := prim_min_rec n 0.

  Fact prim_min_spec n : f n = 0 -> f (prim_min n) = 0 /\ forall i, i < prim_min n -> f i <> 0.
  Proof.
    intros Hn.
    destruct (min_f Hn) as (k & H1 & H2 & H3).
    assert (prim_min n = k) as H4.
    { unfold prim_min.
      unfold prim_min_rec.
      replace n with (n-k+k) by lia.
      rewrite iter_plus.
      fold (prim_min_rec k 0).
      rewrite prim_min_rec_spec_0 with (n := k) (a := 0); auto.
      rewrite Nat.add_comm; apply prim_min_rec_spec_1; auto.
      intros; apply H3; lia. }
    rewrite H4; auto.
  Qed.

End prim_min.


From mathcomp Require Import all_ssreflect.

(* ここでは ModusPonens は使いません。 *)

  (**

## 論理ゲーム(2)

前提 HABC : A -> B -> C のとき、あるいは、ゴールのスタックトップが A -> B -> C のとき。

### ゴールへの適用

ゴール C に適用すると、ふたつのサブゴール A と B に分岐する。

これに対して、H : (A -> B) -> C を ゴール C に適用すると、ゴールは A -> B になる。

### 前提への適用

HA : A
HB : B
HABC : A -> B -> C

HABC HA : B -> C
HABC HA HB : C

証明図はどちらも同じ。

サブ2   サブ1
-----  ------
          A   A -> B -> C
       -------------------
  B                B -> C
--------------------------
                        C

### まとめて intro、generaralize

- move=> H1 H2 スタックトップを前提H1、H2に移す。intro とも。
- move: H1 H2 前提H1、H2をスタックトップに移す。generaralize とも。
- apply スタックトップをゴールの残りの部分に適用する。

- move: H2; move: H1; move; move=> H1; move=> H2 は、move: H1 H2 => H1 H2 とかける。

### 適用について (その2)

- apply/H ゴール全体への適用、ビュー付き。
- move/H スタックトップへの適用、ビュー付き。
   *)

Section HilbertSAxiom.

  Variables A B C : Prop.

  (* 前提への適用を使う例 *)

  (* A->B->C -> A->B->C を求める例 *)

  Theorem HS3 : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    move=> AtoBtoC_is_true.
    move=> AtoB_is_true.
    move=> A_is_true.
    move: (AtoB_is_true A_is_true).        (* スタックに B を積む。 *)
    move: A_is_true.                       (* スタックに A を積む。 *)
      by [].                               (* Goal A -> B -> C *)

    Undo 3.
      by move: A_is_true (AtoB_is_true A_is_true).

    Undo 1.
    move: (A_is_true).     (* スタックに Aを積む。 *)
    move/AtoB_is_true.     (* スタックに B : AtoB_is_true A_is_true *)
    move: A_is_true.       (* スタックに Aを積む。 *)
      by [].
  Qed.

  (* C -> C を求める例 *)

  Theorem HS3' : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    move=> AtoBtoC_is_true.
    move=> AtoB_is_true.
    move=> A_is_true.
      by move: (AtoBtoC_is_true A_is_true (AtoB_is_true A_is_true)).
  Qed.

  (* ゴールへの適用を使う例 *)

  Theorem HS4 : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    (* 前提の「->」の右と、Goalが一致するまで intros する。 *)
    move=> AtoBtoC_is_true.
    move=> AtoB_is_true.
    move=> A_is_true.

    (* Goal : C *)
    apply: AtoBtoC_is_true. (* 「->」の右とGoalが一致した前提を apply する。 *)

    (* ふたつのサブゴールに分岐する。 *)
    (* Goal : A *)
    - by [].               (* Goalと前提が一致なので done *)

    (* Goal : B *)
    - apply: AtoB_is_true. (* 「->」の右とGoalが一致した前提を apply する。 *)

        (* Goal : A *)
        by [].             (* Goalと前提が一致なので done *)
  Qed.

  (* じつは auto タクティクの動作とおなじ。導出原理という自動証明の技法。 *)
  (* CPDT の Chapter 12 論理プログラミングによる証明探索 を参照してください。 *)

  Theorem HS5 : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    debug auto.
    (*
Debug: (* debug auto: *)
Debug: * assumption. (*fail*)
Debug: * intro. (*success*)
Debug: * assumption. (*fail*)
Debug: * intro. (*success*)
Debug: * assumption. (*fail*)
Debug: * intro. (*success*)
Debug: * assumption. (*fail*)
Debug: * intro. (*fail*)
Debug: * simple apply H. (*success*)
Debug: ** assumption. (*success*)
Debug: ** assumption. (*fail*)
Debug: ** intro. (*fail*)
Debug: ** simple apply H0. (*success*)
Debug: *** assumption. (*success*)
     *)

    Restart.
    intro H.
    intro H0.
    intro H1.
    apply H.
    assumption.
    apply H0.
    assumption.
  Qed.

  Theorem HS : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    move=> AtoBtoC_is_true AtoB_is_true A_is_true.
      by apply: AtoBtoC_is_true;  [ | apply: AtoB_is_true].
  Qed.

End HilbertSAxiom.

(* END *)


From Hammer Require Import Hammer.

Require Import VectorDef.
Require Import VectorSpec.
Import VectorNotations.

Section BEQ.

Variables (A: Type) (A_beq: A -> A -> bool).
Hypothesis A_eqb_eq: forall x y, A_beq x y = true <-> x = y.

Definition eqb:
forall {m n} (v1: t A m) (v2: t A n), bool :=
fix fix_beq {m n} v1 v2 :=
match v1, v2 with
|[], [] => true
|_ :: _, [] |[], _ :: _ => false
|h1 :: t1, h2 :: t2 => A_beq h1 h2 && fix_beq t1 t2
end%bool.

Lemma eqb_nat_eq: forall m n (v1: t A m) (v2: t A n)
(Hbeq: eqb v1 v2 = true), m = n.
Proof. hammer_hook "VectorEq" "VectorEq.eqb_nat_eq".
intros m n v1; revert n.
induction v1; destruct v2;
[now constructor | discriminate | discriminate | simpl].
intros Hbeq; apply andb_prop in Hbeq; destruct Hbeq.
f_equal; eauto.
Qed.

Lemma eqb_eq: forall n (v1: t A n) (v2: t A n),
eqb v1 v2 = true <-> v1 = v2.
Proof. hammer_hook "VectorEq" "VectorEq.eqb_eq".
refine (@rect2 _ _ _ _ _); [now constructor | simpl].
intros ? ? ? Hrec h1 h2; destruct Hrec; destruct (A_eqb_eq h1 h2); split.
+ intros Hbeq. apply andb_prop in Hbeq; destruct Hbeq.
f_equal; now auto.
+ intros Heq. destruct (cons_inj Heq). apply andb_true_intro.
split; now auto.
Qed.

Definition eq_dec n (v1 v2: t A n): {v1 = v2} + {v1 <> v2}.
Proof. hammer_hook "VectorEq" "VectorEq.eq_dec".
case_eq (eqb v1 v2); intros.
+ left; now apply eqb_eq.
+ right. intros Heq. apply <- eqb_eq in Heq. congruence.
Defined.

End BEQ.

Section CAST.

Definition cast: forall {A m} (v: t A m) {n}, m = n -> t A n.
Proof. hammer_hook "VectorEq" "VectorEq.cast".
refine (fix cast {A m} (v: t A m) {struct v} :=
match v in t _ m' return forall n, m' = n -> t A n with
|[] => fun n => match n with
| 0 => fun _ => []
| S _ => fun H => False_rect _ _
end
|h :: w => fun n => match n with
| 0 => fun H => False_rect _ _
| S n' => fun H => h :: (cast w n' (f_equal pred H))
end
end); discriminate.
Defined.

End CAST.