(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.

Require Import Xreal.
Require Import Basic.
Require Import Sig.
Require Import Interval.
Require Import Float.
Require Import Transcend.

Module FloatIntervalFull (F : FloatOps with Definition sensible_format := true) <: IntervalOps.

Module T := TranscendentalFloatFast F.
Include FloatInterval F.

Definition c3 := F.fromZ 3.
Definition c4 := F.fromZ 4.
Definition c8 := F.fromZ 8.

Definition pi prec :=
  mul2 prec (mul2 prec (T.pi4 prec)).

Lemma pi_correct :
  forall prec, contains (convert (pi prec)) (Xreal PI).
Proof.
intros prec.
unfold pi.
replace (Xreal PI) with (Xmul (Xreal (PI/4)) (Xreal (Raux.bpow radix2 2))).
change (Xreal (Raux.bpow _ _)) with (Xreal 2 * Xreal 2)%XR.
rewrite <-Xmul_assoc.
do 2 apply mul2_correct.
apply T.pi4_correct.
change (Raux.bpow _ _) with 4%R.
simpl.
apply f_equal.
field.
Qed.

(* accurate only for |xi| <= 2 * pi *)
Definition cos prec xi :=
  match abs xi with
  | Ibnd xl xu =>
    if F'.le' xu xl then T.cos_fast prec xl else
    let pi4 := T.pi4 prec in
    if F'.le' xu (F.mul_DN prec (lower pi4) c4) then
      bnd (lower (T.cos_fast prec xu)) (upper (T.cos_fast prec xl))
    else
      if F'.le' xu (F.mul_DN prec (lower pi4) c8) then
        if F'.le' (F.mul_UP prec (upper pi4) c4) xl then
          bnd (lower (T.cos_fast prec xl)) (upper (T.cos_fast prec xu))
        else
          bnd cm1 (F.max (upper (T.cos_fast prec xl)) (upper (T.cos_fast prec xu)))
      else
        let d := F.sub_UP prec xu xl in
        if F'.le' d c3 then
          let m := F.midpoint xl xu in
          let d := F.max (F.sub_UP prec xu m) (F.sub_UP prec m xl) in
          let c := T.cos_fast prec m in
          meet (bnd cm1 c1) (add prec c (bnd (F.neg d) d))
        else bnd cm1 c1
  | Inan => Inan
  end.

Lemma cos_correct :
  forall prec, extension Xcos (cos prec).
Proof.
intros prec xi x Hx.
unfold cos.
generalize (abs_correct xi x Hx) (abs_ge_0' xi).
destruct (abs xi) as [|xl xu]; [easy|].
destruct x as [|x].
{ now simpl; case (_ && _)%bool. }
unfold convert at 1.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hxl Hxu].
intros Hal.
simpl in Hal.
assert (H : not_empty (convert xi)).
{ now exists x. }
specialize (Hal H); clear H.
unfold Xbind.
replace (Rtrigo_def.cos x) with (Rtrigo_def.cos (Rabs x)).
2: now unfold Rabs ; case Rcase_abs ; intros _ ; try easy ; apply cos_neg.
clear Hx.
assert (Hcxl := T.cos_fast_correct prec xl).
assert (Hcxu := T.cos_fast_correct prec xu).
case_eq (F'.le' xu xl).
{ intros Hl.
  apply F'.le'_correct in Hl.
  destruct (F.toX xu) as [|xur] ; [easy|].
  destruct (F.toX xl) as [|xlr] ; [easy|].
  replace (Rabs x) with xlr.
  { exact Hcxl. }
  apply Rle_antisym.
  { easy. }
  now apply Rle_trans with (2 := Hl). }
intros _.
unfold cm1, c1, c3.
assert (Hlb'_cos : F.valid_lb (lower (T.cos_fast prec xl)) = true).
{ generalize Hcxl.
  unfold T.I.convert.
  case (T.cos_fast prec xl).
  { now simpl; rewrite F'.valid_lb_nan. }
  simpl.
  intros l u.
  case (F.valid_lb l); [easy|].
  now simpl; case F.toX; [|intros r [H0 H1]; lra]. }
assert (Hub'_cos : F.valid_ub (upper (T.cos_fast prec xu)) = true).
{ generalize Hcxu.
  unfold T.I.convert.
  case (T.cos_fast prec xu).
  { now simpl; rewrite F'.valid_ub_nan. }
  simpl.
  intros l u.
  rewrite Bool.andb_comm.
  case (F.valid_ub u); [easy|].
  now simpl; case F.toX; [|intros r [H0 H1]; lra]. }
assert (Hub_cos : F.valid_ub (upper (T.cos_fast prec xl)) = true).
{ generalize Hcxl.
  unfold T.I.convert.
  case (T.cos_fast prec xl).
  { now simpl; rewrite F'.valid_ub_nan. }
  simpl.
  intros l u; rewrite Bool.andb_comm.
  case (F.valid_ub u); [easy|].
  now simpl; case F.toX; [|intros r [H0 H1]; lra]. }
assert (Hlb_cos : F.valid_lb (lower (T.cos_fast prec xu)) = true).
{ generalize Hcxu.
  unfold T.I.convert.
  case (T.cos_fast prec xu).
  { now simpl; rewrite F'.valid_lb_nan. }
  simpl.
  intros l u.
  now case (F.valid_lb l); [|simpl; case Xcos; [|intros r [H0 H1]; lra]]. }
case_eq (F'.le' xu (F.mul_DN prec (lower (T.pi4 prec)) c4)).
{ intros Hu.
  apply F'.le'_correct in Hu.
  destruct (F.toX xu) as [|xur] ; try easy.
  assert (Hxur: (xur <= PI)%R).
  { revert Hu.
    elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 4)).
    2:{ unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg, F.is_non_pos.
      rewrite (F'.valid_ub_real (F.fromZ 4));
      [|rewrite F.real_correct..];
      (rewrite F.fromZ_correct; [|lia]); [|easy].
      generalize (T.pi4_correct prec).
      unfold T.I.convert.
      case T.pi4.
      { simpl; intros _; do 3 right; rewrite F'.valid_lb_nan, F'.nan_correct.
        repeat split; lra. }
      intros l u; simpl.
      rewrite F.valid_lb_correct.
      case F.classify; [..|intros [H0 H1]; lra]; intros _;
      (case F.toX; [now do 3 right; repeat split; lra|]; intro rl);
      (case (Rle_or_lt 0 rl); intro Hrl;
        [now left; repeat split; lra|do 3 right; repeat split; lra]). }
    intros Vmdn.
    unfold le_lower, le_upper.
    unfold c4.
    case F.toX; [easy|]; intro Rmdn; simpl.
    rewrite F.fromZ_correct; [|lia].
    generalize (T.pi4_correct prec).
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    { now rewrite F'.nan_correct. }
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    case F.toX; [easy|]; intro pi4r.
    simpl.
    intros [H _] Hu.
    apply Ropp_le_cancel in Hu.
    intro H'; apply (Rle_trans _ _ _ H'); clear H'.
    apply Rle_trans with (1 := Hu).
    lra. }
  clear Hu.
  unfold convert; simpl.
  rewrite Hlb_cos; simpl.
  rewrite Hub_cos; simpl.
  split.
  { destruct (T.cos_fast prec xu) as [|cu cu'] ; simpl.
    { now rewrite F'.nan_correct. }
    generalize Hcxu; unfold T.I.convert;
      case (_ && _)%bool; [|intros [H0 H1]; lra].
    intros [Hcu _].
    destruct (F.toX cu) as [|cur] ; [easy|].
    apply Rle_trans with (1 := Hcu).
    apply cos_decr_1 with (4 := Hxur).
    { apply Rabs_pos. }
    { now apply Rle_trans with xur. }
    { revert Hxu; apply Rle_trans, Rabs_pos. }
    exact Hxu. }
  generalize (T.cos_fast_correct prec xl).
  unfold T.I.convert.
  case_eq (T.cos_fast prec xl); [now simpl; rewrite F'.nan_correct|].
  intros cl' cl Hcl.
  generalize Hub_cos; rewrite Hcl; simpl=> ->.
  generalize Hlb'_cos; rewrite Hcl; simpl=> ->; simpl.
  destruct (F.toX xl) as [|xlr] ; [easy|].
  intros [_ Hl].
  destruct (F.toX cl) as [|clr] ; [easy|].
  apply Rle_trans with (2 := Hl).
  apply cos_decr_1 with (1 := Hal).
  { apply Rle_trans with (2 := Hxur).
    now apply Rle_trans with (Rabs x). }
  { apply Rabs_pos. }
  { now apply Rle_trans with xur. }
  apply Hxl. }
intros _.
case_eq (F'.le' xu (F.mul_DN prec (lower (T.pi4 prec)) c8)).
{ intros Hu.
  apply F'.le'_correct in Hu.
  destruct (F.toX xu) as [|xur] ; [easy|].
  assert (Hxur: (xur <= 2 * PI)%R).
  { revert Hu.
    elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 8)).
    2:{ unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg, F.is_non_pos.
      rewrite (F'.valid_ub_real (F.fromZ 8));
      [|rewrite F.real_correct..];
      (rewrite F.fromZ_correct; [|lia]); [|easy..].
      generalize (T.pi4_correct prec).
      unfold T.I.convert.
      case T.pi4.
      { simpl; intros _; do 3 right; rewrite F'.valid_lb_nan, F'.nan_correct.
        repeat split; lra. }
      intros l u; simpl.
      rewrite F.valid_lb_correct.
      case F.classify; [..|intros [H0 H1]; lra]; intros _;
      (case F.toX; [now do 3 right; repeat split; lra|]; intro rl);
      (case (Rle_or_lt 0 rl); intro Hrl;
        [now left; repeat split; lra|do 3 right; repeat split; lra]). }
    intros Vmdn.
    unfold le_lower, le_upper.
    unfold c8.
    case F.toX; [easy|]; intro rmdn; simpl.
    rewrite F.fromZ_correct; [|lia].
    generalize (T.pi4_correct prec).
    unfold T.I.convert.
    case T.pi4; [now simpl; rewrite F'.nan_correct|]; intros l u.
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    simpl.
    case F.toX; simpl; [easy|].
    intros rlpi4 [Hrlpi4 _].
    lra. }
  clear Hu.
  case_eq (F'.le' (F.mul_UP prec (upper (T.pi4 prec)) c4) xl).
  { intros Hl.
    apply F'.le'_correct in Hl.
    destruct (F.toX xl) as [|xlr].
    { now destruct (F.toX (F.mul_UP prec (upper (T.pi4 prec)) c4)). }
    assert (Hxlr: (PI <= xlr)%R).
    { revert Hl.
      elim (F.mul_UP_correct prec (upper (T.pi4 prec)) (F.fromZ 4)).
      2:{ unfold F.is_non_neg, F.is_non_pos, F.is_non_pos_real, F.is_non_neg_real.
        rewrite (F'.valid_ub_real (F.fromZ 4));
        [|rewrite F.real_correct..];
        (rewrite F.fromZ_correct; [|lia]); [|easy..].
        generalize (T.pi4_correct prec).
        unfold T.I.convert.
        case T.pi4.
        { simpl; intros _; left; rewrite F'.valid_ub_nan, F'.nan_correct.
          repeat split; lra. }
        intros l u; simpl.
        rewrite F.valid_ub_correct, Bool.andb_comm.
        case F.classify; [..|intros [H0 H1]; lra|]; intros _;
          (case F.toX; [now left; repeat split; lra|]; intro ru);
          (case (Rle_or_lt 0 ru); intro Hru;
           [now left; repeat split; lra|do 2 right; left; lra]). }
      intros Vmup.
      rewrite F.fromZ_correct; [|lia].
      unfold le_upper.
      unfold c4.
      case F.toX; [easy|]; intro rmup.
      generalize (T.pi4_correct prec).
      unfold T.I.convert.
      case T.pi4; [now simpl; rewrite F'.nan_correct|]; intros l u.
      case (_ && _)%bool; [|intros [H0 H1]; lra].
      simpl.
      case (F.toX u); simpl; [easy|].
      intros rupi4 [_ Hrupi4].
      lra. }
    clear Hl.
    simpl.
    rewrite Hlb'_cos, Hub'_cos.
    split.
    { destruct (T.cos_fast prec xl) as [|cl cl'] ; simpl.
      { now rewrite F'.nan_correct. }
      revert Hcxl.
      unfold T.I.convert.
      case (_ && _)%bool; [|intros [H0 H1]; lra].
      intros [Hcl _].
      destruct (F.toX cl) as [|clr] ; [easy|].
      apply Rle_trans with (1 := Hcl).
      apply cos_incr_1 with (1 := Hxlr) (5 := Hxl).
      { apply Rle_trans with (2 := Hxur).
        apply Rle_trans with (1 := Hxl) (2 := Hxu). }
      { apply Rle_trans with (1 := Hxlr) (2 := Hxl). }
      apply Rle_trans with (1 := Hxu) (2 := Hxur). }
    destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
    { now rewrite F'.nan_correct. }
    revert Hcxu.
    unfold T.I.convert.
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    intros [_ Hcu].
    destruct (F.toX cu) as [|cur] ; [easy|].
    apply Rle_trans with (2 := Hcu).
    apply cos_incr_1 with (4 := Hxur) (5 := Hxu).
    { apply Rle_trans with (1 := Hxlr) (2 := Hxl). }
    { apply Rle_trans with (1 := Hxu) (2 := Hxur). }
    apply Rle_trans with (1 := Hxlr).
    apply Rle_trans with (1 := Hxl) (2 := Hxu). }
  intros _.
  unfold convert.
  simpl; rewrite F'.valid_lb_real.
  2: now rewrite F.real_correct, F.fromZ_correct; [..|lia].
  generalize (F'.max_valid_ub _ _ Hub_cos Hub'_cos).
  intros [Vmax Hmax].
  rewrite Vmax, Hmax.
  split.
  { rewrite F.fromZ_correct; [|lia].
    apply COS_bound. }
  destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl.
  { now rewrite F'.nan_correct. }
  revert Hcxl.
  unfold T.I.convert; simpl.
  simpl in Hlb'_cos.
  rewrite Hlb'_cos.
  simpl in Hub_cos.
  rewrite Hub_cos.
  simpl.
  destruct (F.toX xl) as [|xlr] ; [easy|].
  intros [_ Hcl].
  destruct (F.toX cl) as [|clr] ; [easy|].
  destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
  { now rewrite F'.nan_correct. }
  revert Hcxu.
  unfold T.I.convert.
  simpl in Hub'_cos.
  rewrite Hub'_cos.
  simpl in Hlb_cos.
  rewrite Hlb_cos.
  simpl.
  intros [_ Hcu].
  destruct (F.toX cu) as [|cur] ; [easy|].
  destruct (Rle_dec (Rabs x) PI) as [Hx|Hx].
  { apply Rle_trans with (2 := Rmax_l _ _).
    apply Rle_trans with (2 := Hcl).
    apply cos_decr_1 with (1 := Hal) (3 := Rabs_pos _) (4 := Hx) (5 := Hxl).
    apply Rle_trans with (1 := Hxl) (2 := Hx). }
  apply Rle_trans with (2 := Rmax_r _ _).
  apply Rle_trans with (2 := Hcu).
  apply Rnot_le_lt, Rlt_le in Hx.
  apply cos_incr_1 with (1 := Hx) (4 := Hxur) (5 := Hxu).
  { apply Rle_trans with (1 := Hxu) (2 := Hxur). }
  apply Rle_trans with (1 := Hx) (2 := Hxu). }
intros _.
case_eq (F'.le' (F.sub_UP prec xu xl) (F.fromZ 3)).
{ intros Hd.
  apply F'.le'_correct in Hd.
  revert Hd.
  elim (F.sub_UP_correct prec xu xl); [|easy..].
  intros Vsup.
  unfold le_upper.
  case F.toX; [easy|]; intro rsup.
  rewrite F.fromZ_correct; [|lia].
  case_eq (F.toX xu) ; [easy|] ; intros xur Hur.
  case_eq (F.toX xl) ; [easy|] ; intros xlr Hlr.
  rewrite Hur in Hxu.
  rewrite Hlr in Hxl.
  intros Hsup Hrsup3.
  simpl in Hsup.
  apply meet_correct.
  { unfold convert, bnd.
    rewrite F'.valid_lb_real;
      [|now rewrite F.real_correct, F.fromZ_correct; [..|lia]].
    rewrite F'.valid_ub_real;
      [|now rewrite F.real_correct, F.fromZ_correct; [..|lia]].
    rewrite F.fromZ_correct; [|lia].
    rewrite F.fromZ_correct; [|lia].
    apply COS_bound. }
  elim (F.midpoint_correct xl xu);
    [|easy|now rewrite F.real_correct, ?Hlr, ?Hur..
     |now unfold F.toR; rewrite Hlr, Hur; apply (Rle_trans _ _ _ Hxl)].
  set (m := F.midpoint xl xu).
  intros Rm [Hlm Hum].
  replace (Xreal (Rtrigo_def.cos (Rabs x)))
      with (Xadd (Xcos (Xreal (F.toR m))) (Xreal (Rtrigo_def.cos (Rabs x) - Rtrigo_def.cos (F.toR m))))
      by (apply (f_equal Xreal) ; ring).
  apply add_correct.
  { generalize (T.cos_fast_correct prec m).
    now rewrite (F'.real_correct _ Rm). }
  simpl.
  rewrite F'.valid_lb_neg.
  rewrite F'.neg_correct.
  elim (F.sub_UP_correct prec xu m);
    [|easy|now generalize (F.classify_correct m); rewrite Rm, F.valid_lb_correct;
           case F.classify].
  intros Vsxum Hsxum.
  elim (F.sub_UP_correct prec m xl);
    [|now generalize (F.classify_correct m); rewrite Rm, F.valid_ub_correct;
      case F.classify|easy].
  intros Vsmxl Hsmxl.
  elim (F'.max_valid_ub _ _ Vsxum Vsmxl).
  intros Vm Hm.
  rewrite Vm, Hm.
  revert Hsxum Hsmxl.
  rewrite Hlr, Hur, (F'.real_correct _ Rm).
  unfold le_upper.
  case F.toX; [easy|]; simpl.
  intros rsxum Hrsxum.
  case F.toX; [easy|]; simpl.
  intros rsmxl Hrsmxl.
  apply Raux.Rabs_le_inv.
  destruct (MVT_abs Rtrigo_def.cos (fun t => Ropp (sin t)) (F.toR m) (Rabs x)) as [v [-> _]].
  { intros c _.
    apply derivable_pt_lim_cos. }
  apply Rle_trans with (1 * Rabs (Rabs x - (F.toR m)))%R.
  { apply Rmult_le_compat_r.
    apply Rabs_pos.
    rewrite Rabs_Ropp.
    apply Rabs_le, SIN_bound. }
  rewrite Rmult_1_l.
  case (Rle_lt_dec (Rabs x) (F.toR m)); intro Hxm.
  { refine (Rle_trans _ _ _ _ (Rmax_r _ _)).
    rewrite Rabs_minus_sym, Rabs_pos_eq; [|lra].
    apply (Rle_trans _ ((F.toR m) - xlr)); lra. }
  refine (Rle_trans _ _ _ _ (Rmax_l _ _)).
  rewrite Rabs_pos_eq; [|lra].
  apply (Rle_trans _ (xur - (F.toR m))); lra. }
intros _.
unfold convert, bnd.
rewrite F'.valid_lb_real;
  [|now rewrite F.real_correct, F.fromZ_correct; [..|lia]].
rewrite F'.valid_ub_real;
  [|now rewrite F.real_correct, F.fromZ_correct; [..|lia]].
rewrite F.fromZ_correct; [|lia].
rewrite F.fromZ_correct; [|lia].
apply COS_bound.
Qed.

(* accurate only for |xi| <= 5/2*pi *)
Definition sin prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le' xu xl then T.sin_fast prec xl else
    let pi4 := T.pi4 prec in
    let pi2 := F.mul_DN prec (lower pi4) c2 in
    match F'.le' (F.neg pi2) xl, F'.le' xu pi2 with
    | true, true =>
      bnd (lower (T.sin_fast prec xl)) (upper (T.sin_fast prec xu))
    | true, false =>
      cos prec (sub prec (mul2 prec pi4) xi)
    | _, _ =>
      neg (cos prec (add prec xi (mul2 prec pi4)))
    end
  | Inan => Inan
  end.

Theorem sin_correct :
  forall prec, extension Xsin (sin prec).
Proof.
intros prec [|xl xu]; [easy|].
intros [|x].
{ now simpl; case (_ && _)%bool. }
intro Hx; generalize Hx.
unfold convert at 1.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hxl Hxu].
unfold sin.
case_eq (F'.le' xu xl).
{ intros Hl.
  apply F'.le'_correct in Hl.
  assert (Hsxl := T.sin_fast_correct prec xl).
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  { exact Hsxl. }
  apply Rle_antisym with (1 := Hxl).
  now apply Rle_trans with (2 := Hl). }
intros _.
set (pi2 := F.mul_DN prec (lower (T.pi4 prec)) c2).
case_eq (F'.le' (F.neg pi2) xl).
{ intros Hpl.
  generalize (F'.le'_correct _ _ Hpl).
  xreal_tac xl.
  { now case (F.toX (F.neg pi2)). }
  clear Hpl. intros Hpl.
  case_eq (F'.le' xu pi2).
  { intros Hpu.
    generalize (F'.le'_correct _ _ Hpu).
    xreal_tac xu. easy.
    xreal_tac pi2. easy.
    clear Hpu. intros Hpu.
    revert Hpl.
    rewrite F'.neg_correct, X1.
    simpl.
    intros Hpl.
    elim (F.mul_DN_correct prec (lower (T.pi4 prec)) c2).
    2: { unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg, F.is_non_pos.
         unfold c2.
         rewrite (F'.valid_ub_real (F.fromZ 2)); [|rewrite F.real_correct];
         (rewrite F.fromZ_correct; [|lia]); [|easy].
      generalize (T.pi4_correct prec).
      unfold T.I.convert.
      case T.pi4.
      { intros _; do 3 right; simpl.
        rewrite F'.valid_lb_nan, F'.nan_correct; repeat split; lra. }
      intros pl pu; simpl.
      case (F.valid_lb pl); [|intros [H0 H1]; lra]; intros _.
      case F.toX; [do 3 right; repeat split; lra|].
      intro r'.
      case (Rle_or_lt 0 r'); intro Hr'; [left; split; lra|].
      do 3 right; repeat split; lra. }
    fold pi2.
    intros Vpi2.
    unfold le_lower, le_upper.
    unfold c2.
    rewrite X1, F.fromZ_correct; [|lia].
    simpl.
    generalize (T.pi4_correct prec).
    unfold T.I.convert.
    case T.pi4; [now simpl; rewrite F'.nan_correct|].
    intros pl pu.
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    simpl.
    case F.toX; [easy|].
    intros rpl [Hrpl _].
    simpl.
    intro Hrpl'.
    assert (Hpl' : (-(PI/2) <= r)%R) by lra.
    assert (Hpu' : (r0 <= PI/2)%R) by lra.
    cut (match F.toX (upper (T.sin_fast prec xu)) with
         | Xnan => True
         | Xreal r3 => (Rtrigo_def.sin x <= r3)%R
         end).
    { cut (match F.toX (lower (T.sin_fast prec xl)) with
           | Xnan => True
           | Xreal r3 => (r3 <= Rtrigo_def.sin x)%R
           end).
      { generalize (T.sin_fast_correct prec xu).
        generalize (T.sin_fast_correct prec xl).
        destruct (T.sin_fast prec xl) as [|yl yu]; simpl;
          [rewrite F'.valid_lb_nan|];
          (destruct (T.sin_fast prec xu) as [|zl zu]; simpl;
           [rewrite F'.valid_ub_nan|]); rewrite ?F'.nan_correct; [easy|..];
            try (case (F.valid_lb yl);
                 [|now simpl; case Xsin; [|intros rs [H0 H1]; lra]]);
            try (case (F.valid_ub zu);
                 [|now intros _;
                   rewrite Bool.andb_comm; case Xsin; [|intros rs [H0 H1]; lra]]);
            try (case (F.valid_ub yu);
                 [|now simpl; case Xsin; [|intros rs [H0 H1]; lra]]);
            try (case (F.valid_lb zl);
                 [|now intros _;
                   rewrite Bool.andb_comm; case Xsin; [|intros rs [H0 H1]; lra]]);
            now case Xsin. }
      generalize (T.sin_fast_correct prec xl).
      destruct (T.sin_fast prec xl) as [|yl yu].
      { simpl.
        now rewrite F'.nan_correct. }
      rewrite X.
      simpl.
      xreal_tac yl; [easy|].
      case (_ && _)%bool; [|intros [H0 H1]; lra].
      intros [Hy _].
      apply Rle_trans with (1 := Hy).
      assert (H' := Rle_trans _ _ _ Hxu Hpu').
      apply sin_incr_1; try easy.
      { now apply Rle_trans with x. }
      now apply Rle_trans with r. }
    generalize (T.sin_fast_correct prec xu).
    destruct (T.sin_fast prec xu) as [|yl yu].
    { simpl.
      now rewrite F'.nan_correct. }
    rewrite X0.
    simpl.
    xreal_tac yu; [easy|].
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    intros [_ Hy].
    apply Rle_trans with (2 := Hy).
    assert (H' := Rle_trans _ _ _ Hpl' Hxl).
    apply sin_incr_1; try easy.
    { now apply Rle_trans with r0. }
    now apply Rle_trans with x. }
  intros _.
  unfold Xsin.
  rewrite <- cos_shift.
   change (Xreal (Rtrigo_def.cos (PI / 2 - x))) with (Xcos (Xsub (Xreal (PI / 2)) (Xreal x))).
   apply cos_correct.
   apply sub_correct with (2 := Hx).
   replace (PI / 2)%R with (PI / 4 * 2)%R by field.
   change (Xreal (PI / 4 * 2)) with (Xreal (PI / 4) * Xreal 2)%XR.
   apply mul2_correct.
   apply T.pi4_correct. }
intros _.
rewrite <- (Ropp_involutive x).
unfold Xsin.
rewrite sin_neg.
apply (neg_correct _ (Xreal _)).
rewrite <- cos_shift.
replace (PI / 2 - - x)%R with (x + PI / 2)%R by ring.
change (Xreal (Rtrigo_def.cos (x + PI / 2))) with (Xcos (Xadd (Xreal x) (Xreal (PI / 2)))).
apply cos_correct.
apply (add_correct _ _ _ _ _ Hx).
replace (PI / 2)%R with (PI / 4 * 2)%R by field.
change (Xreal (PI / 4 * 2)) with (Xreal (PI / 4) * Xreal 2)%XR.
apply mul2_correct.
apply T.pi4_correct.
Qed.

(* meaningful only for |xi| <= pi/2 *)
Definition tan prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le' xu xl then T.tan_fast prec xl else
    let pi2 := F.mul_DN prec (lower (T.pi4 prec)) c2 in
    match F'.lt' (F.neg pi2) xl, F'.lt' xu pi2 with
    | true, true =>
      bnd (lower (T.tan_fast prec xl)) (upper (T.tan_fast prec xu))
    | _, _ => Inan
    end
  | Inan => Inan
  end.

Lemma tan_correct :
  forall prec, extension Xtan (tan prec).
Proof.
intros prec [|xl xu]; [easy|].
intros [|x].
{ now simpl; case (_ && _)%bool. }
intro Hx; generalize Hx.
unfold convert at 1.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hxl Hxu].
unfold tan.
case_eq (F'.le' xu xl).
{ intros Hl.
  apply F'.le'_correct in Hl.
  assert (Htxl := T.tan_fast_correct prec xl).
  unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx.
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  { exact Htxl. }
  apply Rle_antisym with (1 := proj1 Hx).
  apply Rle_trans with (2 := Hl).
  apply Hx. }
intros _.
case_eq (F'.lt' (F.neg (F.mul_DN prec (lower (T.pi4 prec)) c2)) xl) ; try easy.
intros Hlt1.
apply F'.lt'_correct in Hlt1.
case_eq (F'.lt' xu (F.mul_DN prec (lower (T.pi4 prec)) c2)) ; try easy.
intros Hlt2.
apply F'.lt'_correct in Hlt2.
generalize (T.tan_correct prec xl) (T.tan_correct prec xu).
unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx.
destruct (F.toX xl) as [|rl].
{ now destruct (F.toX (F.neg (F.mul_DN prec (lower (T.pi4 prec)) c2))). }
destruct (F.toX xu) as [|ru] ; try easy.
intros Hl Hu.
rewrite bnd_correct.
2: { generalize (T.tan_fast_correct prec xl).
  unfold T.I.convert.
  case T.tan_fast; [now simpl; unfold valid_lb; rewrite F'.valid_lb_nan|].
  intros l u; simpl; unfold valid_lb; case F.valid_lb; [easy|].
  now case Xtan; [|intros r [H0 H1]; lra]. }
2: { generalize (T.tan_fast_correct prec xu).
  unfold T.I.convert.
  case T.tan_fast; [now simpl; unfold valid_ub; rewrite F'.valid_ub_nan|].
  intros l u; rewrite Bool.andb_comm.
  simpl; unfold valid_ub; case F.valid_ub; [easy|].
  now case Xtan; [|intros r [H0 H1]; lra]. }
rewrite F'.neg_correct in Hlt1.
elim (F.mul_DN_correct prec (lower (T.pi4 prec)) c2).
2: { unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg, F.is_non_pos.
  unfold c2.
  rewrite (F'.valid_ub_real (F.fromZ 2)); [|rewrite F.real_correct];
  (rewrite F.fromZ_correct; [|lia]); [|easy].
  generalize (T.pi4_correct prec).
  unfold T.I.convert.
  case T.pi4.
  { intros _; do 3 right; simpl.
    rewrite F'.valid_lb_nan, F'.nan_correct; repeat split; lra. }
  intros pl pu; simpl.
  case (F.valid_lb pl); [|intros [H0 H1]; lra]; intros _.
  case F.toX; [do 3 right; repeat split; lra|].
  intro r'.
  case (Rle_or_lt 0 r'); intro Hr'; [left; split; lra|].
  do 3 right; repeat split; lra. }
intro Vmpi2.
unfold le_lower, le_upper.
unfold c2.
rewrite F.fromZ_correct; [|lia].
revert Hlt1 Hlt2.
unfold c2.
case F.toX; [easy|]; intro rpi2.
simpl.
intros Hlt1 Hlt2.
generalize (T.pi4_correct prec).
destruct (T.pi4 prec) as [|pi4l pi4u].
{ now simpl; rewrite F'.nan_correct. }
unfold T.I.convert.
case (_ && _)%bool; [|intros [H0 H1]; lra].
intros [Hpil _].
simpl.
destruct (F.toX pi4l) as [|pi4r] ; [easy|].
simpl.
intro Hmpi2.
apply (Rmult_le_compat_r 2) in Hpil; [|now apply IZR_le].
unfold Rdiv in Hpil.
replace (PI * /4 * 2)%R with (PI / 2)%R in Hpil by field.
assert (H1: (- PI / 2 < rl)%R) by lra.
assert (H2: (ru < PI / 2)%R) by lra.
unfold Xtan'.
simpl.
case is_zero_spec.
{ simpl in Hx.
  apply Rgt_not_eq, cos_gt_0.
  { apply Rlt_le_trans with (2 := proj1 Hx).
    unfold Rdiv.
    now rewrite <- Ropp_mult_distr_l_reverse. }
  now apply Rle_lt_trans with ru. }
unfold Xtan' in Hl, Hu.
intros _.
split.
- destruct (T.tan_fast prec xl) as [|tl tu].
  { simpl.
    now rewrite F'.nan_correct. }
  revert Hl.
  simpl.
  case (_ && _)%bool; [|now case is_zero; [|intros [H0' H1']; lra]].
  simpl.
  case is_zero_spec ; [easy|].
  intros _ [H _].
  destruct (F.toX tl) as [|rtl] ; try easy.
  apply Rle_trans with (1 := H).
  destruct (proj1 Hx) as [Hx'|Hx'].
  { apply Rlt_le.
    apply tan_increasing ; try easy.
    now apply Rle_lt_trans with ru. }
  rewrite Hx'.
  apply Rle_refl.
- destruct (T.tan_fast prec xu) as [|tl tu].
  { now simpl; rewrite F'.nan_correct. }
  revert Hu.
  simpl.
  case (_ && _)%bool; [|now case is_zero; [|intros [H0' H1']; lra]].
  simpl.
  case is_zero_spec ; [easy|].
  intros _ [_ H].
  destruct (F.toX tu) as [|rtu] ; try easy.
  apply Rle_trans with (2 := H).
  destruct (proj2 Hx) as [Hx'|Hx'].
  { apply Rlt_le.
    apply tan_increasing ; try easy.
    now apply Rlt_le_trans with rl. }
  rewrite Hx'.
  apply Rle_refl.
Qed.

Definition atan prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.atan_fast prec xl)
      else F.neg (F.mul_UP prec (upper (T.pi4 prec)) c2))
     (if F.real xu then upper (T.atan_fast prec xu)
      else F.mul_UP prec (upper (T.pi4 prec)) c2)
  | Inan => Inan
  end.

Lemma atan_correct :
  forall prec, extension Xatan (atan prec).
Proof.
intros prec [|xl xu]; [easy|].
intros [|x].
{ now simpl; case (_ && _)%bool. }
intro Hx; generalize Hx.
unfold convert at 1.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hxl Hxu].
assert (Hpi := T.pi4_correct prec).
simpl.
unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx.
elim (F.mul_UP_correct prec (upper (T.pi4 prec)) c2).
2: { unfold F.is_non_neg, F.is_non_pos, F.is_non_pos_real, F.is_non_neg_real.
  unfold c2.
  rewrite (F'.valid_ub_real (F.fromZ 2)); [|rewrite F.real_correct];
  (rewrite F.fromZ_correct; [|lia]); [|easy].
  generalize (T.pi4_correct prec).
  unfold T.I.convert.
  case T.pi4.
  { intros _; left; simpl.
    rewrite F'.valid_ub_nan, F'.nan_correct; repeat split; lra. }
  intros pl pu; simpl.
  rewrite Bool.andb_comm.
  case (F.valid_ub pu); [|intros [H0 H1]; lra]; intros _.
  case F.toX; [left; repeat split; lra|].
  intro r'.
  case (Rle_or_lt 0 r'); intro Hr'; [left; repeat split; lra|].
  do 2 right; left; repeat split; lra. }
intros Vmpi2 Hmpi2.
set (l := if F.real xl then _ else _).
set (u := if F.real xu then _ else _).
assert (Vl : F.valid_lb l = true).
{ unfold l; rewrite F.real_correct.
  generalize (T.atan_fast_correct prec xl).
  case F.toX.
  { now intros _; rewrite F'.valid_lb_neg. }
  intro r.
  unfold T.I.convert.
  case T.atan_fast; [now simpl; rewrite F'.valid_lb_nan|].
  intros l' u'.
  simpl.
  now case F.valid_lb; [|intros [H0 H1]; lra]. }
assert (Vu : F.valid_ub u = true).
{ unfold u; rewrite F.real_correct.
  generalize (T.atan_fast_correct prec xu).
  case F.toX; [easy|].
  intro r.
  unfold T.I.convert.
  case T.atan_fast; [now simpl; rewrite F'.valid_ub_nan|].
  intros l' u'.
  simpl.
  now rewrite Bool.andb_comm; case F.valid_ub; [|intros [H0 H1]; lra]. }
rewrite Vl, Vu; simpl.
unfold l, u.
rewrite 2!F.real_correct.
split.
- generalize (proj1 Hx). clear Hx.
  case_eq (F.toX xl).
  { intros _ _.
    rewrite F'.neg_correct.
    revert Hmpi2; unfold le_upper.
    case F.toX; [easy|]; intro rmpi2.
    unfold c2.
    rewrite F.fromZ_correct; [|lia].
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    { now rewrite F'.nan_correct. }
    revert Hpi; simpl.
    case (_ && _)%bool; [|intros [H0 H1]; lra]; simpl; intro Hpi.
    destruct (F.toX pi4u) as [|rpi4] ; [easy|].
    simpl.
    intro H.
    apply (Rle_trans _ _ _ (Ropp_le_contravar _ _ H)).
    apply Rlt_le.
    apply Rle_lt_trans with (2 := proj1 (atan_bound x)).
    lra. }
  intros rl Hl Hx.
  generalize (T.atan_correct prec xl).
  destruct (T.atan_fast prec xl) as [|al au].
  { intros _.
    simpl.
    now rewrite F'.nan_correct. }
  simpl.
  rewrite Hl.
  case (_ && _)%bool; [|intros [H0 H1]; lra].
  destruct (F.toX al) as [|ral] ; [easy|].
  intros [H _].
  apply Rle_trans with (1 := H).
  destruct Hx as [Hx|Hx].
  { now apply Rlt_le, atan_increasing. }
  rewrite Hx.
  apply Rle_refl.
- generalize (proj2 Hx). clear Hx.
  case_eq (F.toX xu).
  { intros _ _.
    revert Hmpi2.
    unfold le_upper.
    case F.toX; [easy|]; intro rmpi2.
    unfold c2.
    rewrite F.fromZ_correct; [|lia].
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    { now rewrite F'.nan_correct. }
    revert Hpi; simpl.
    case (_ && _)%bool; [|intros [H0 H1]; lra]; simpl; intro Hpi.
    destruct (F.toX pi4u) as [|rpi4] ; [easy|].
    simpl.
    apply Rle_trans.
    apply Rlt_le.
    apply Rlt_le_trans with (1 := proj2 (atan_bound x)).
    lra. }
  intros rl Hl Hx.
  generalize (T.atan_correct prec xu).
  destruct (T.atan_fast prec xu) as [|al au].
  { intros _.
    simpl.
    now rewrite F'.nan_correct. }
  simpl.
  rewrite Hl.
  case (_ && _)%bool; [|intros [H0 H1]; lra].
  destruct (F.toX au) as [|rau] ; [easy|].
  intros [_ H].
  apply Rle_trans with (2 := H).
  destruct Hx as [Hx|Hx].
  { now apply Rlt_le, atan_increasing. }
  rewrite Hx.
  apply Rle_refl.
Qed.

Definition exp prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.exp_fast prec xl) else F.zero)
     (if F.real xu then upper (T.exp_fast prec xu) else F.nan)
  | Inan => Inan
  end.

Theorem exp_correct :
  forall prec, extension Xexp (exp prec).
Proof.
intros prec [|xl xu]; [now trivial|].
intros [|x]; [now simpl; case (_ && _)%bool|].
unfold convert at 1.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hxl Hxu].
simpl.
set (l := if F.real xl then _ else _).
set (u := if F.real xu then _ else _).
assert (Vl : F.valid_lb l = true).
{ unfold l.
  rewrite F.real_correct.
  generalize (T.exp_fast_correct prec xl).
  case F.toX.
  { now simpl; rewrite F'.valid_lb_zero. }
  intro rxl.
  unfold T.I.convert.
  simpl.
  case T.exp_fast.
  { now simpl; rewrite F'.valid_lb_nan. }
  intros rl ru.
  simpl.
  now case F.valid_lb; [|intros [H0 H1]; lra]. }
assert (Vu : F.valid_ub u = true).
{ unfold u.
  rewrite F.real_correct.
  generalize (T.exp_fast_correct prec xu).
  case F.toX.
  { now rewrite F'.valid_ub_nan. }
  intro rxu.
  unfold T.I.convert.
  simpl.
  case T.exp_fast.
  { now simpl; rewrite F'.valid_ub_nan. }
  intros rl ru.
  simpl; rewrite Bool.andb_comm.
  now case F.valid_ub; [|intros [H0 H1]; lra]. }
rewrite Vl, Vu; unfold l, u.
split.
{ (* lower *)
  clear Hxu.
  rewrite F.real_correct.
  xreal_tac xl.
  { rewrite F.zero_correct.
    simpl.
    apply Rlt_le.
    apply exp_pos. }
  generalize (T.exp_fast_correct prec xl).
  destruct (T.exp_fast prec xl) as [|yl yu].
  { unfold lower.
    now rewrite F'.nan_correct. }
  rewrite X.
  unfold T.I.convert.
  case (_ && _)%bool; [|intros [H0 H1]; lra].
  intros (H, _).
  simpl.
  xreal_tac2.
  apply Rle_trans with (1 := H).
  now apply Raux.exp_le. }
(* upper *)
clear Hxl.
rewrite F.real_correct.
xreal_tac xu.
{ now rewrite F'.nan_correct. }
generalize (T.exp_fast_correct prec xu).
destruct (T.exp_fast prec xu) as [|yl yu].
{ unfold upper.
  now rewrite F'.nan_correct. }
rewrite X.
unfold T.I.convert.
case (_ && _)%bool; [|intros [H0 H1]; lra].
intros (_, H).
simpl.
xreal_tac2.
apply Rle_trans with (2 := H).
now apply Raux.exp_le.
Qed.

Definition ln prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.lt' F.zero xl then
      Ibnd
        (lower (T.ln_fast prec xl))
        (if F.real xu then upper (T.ln_fast prec xu) else F.nan)
    else Inan
  | Inan => Inan
  end.

Theorem ln_correct :
  forall prec, extension Xln (ln prec).
Proof.
intros prec [|xl xu]; [easy|].
unfold Xln'.
intros [|x]; [now unfold convert; case (_ && _)%bool|].
simpl.
case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra].
case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra].
intros Vxu Vxl [Hl Hu].
case_eq (F'.lt' F.zero xl) ; intros Hlt ; [|easy].
apply F'.lt'_correct in Hlt.
rewrite F.zero_correct in Hlt.
simpl.
set (l := lower _).
set (u := if F.real xu then _ else _).
assert (Vl : F.valid_lb l = true).
{ generalize (T.ln_fast_correct prec xl).
  unfold l, T.I.convert.
  case T.ln_fast; [now simpl; rewrite F'.valid_lb_nan|].
  intros rl ru.
  simpl.
  now case F.valid_lb; [|case Xln; [|intros r [H0 H1]; lra]]. }
assert (Vu : F.valid_ub u = true).
{ generalize (T.ln_fast_correct prec xu).
  unfold u, T.I.convert; simpl.
  rewrite F.real_correct.
  case F.toX; [now rewrite F'.valid_ub_nan|].
  intro r.
  case T.ln_fast; [now simpl; rewrite F'.valid_ub_nan|].
  intros rl ru.
  rewrite Bool.andb_comm; simpl.
  now case F.valid_ub; [|case Xln'; [|intros r' [H0 H1]; lra]]. }
rewrite Vl, Vu; unfold l, u; clear Vl l Vu u; simpl.
case is_positive_spec.
{ intros Hx.
  simpl.
  split.
  { generalize (T.ln_fast_correct prec xl).
    case T.ln_fast.
    { intros _.
      simpl.
      now rewrite F'.nan_correct. }
    intros l u.
    simpl.
    case_eq (Xln (F.toX xl)); [now intros _; case (_ && _)%bool|].
    intros lnx Hlnx.
    case (_ && _)%bool; [|intros [H0 H1]; lra].
    intros [H _].
    destruct (F.toX l) as [|lr]; [easy|].
    apply Rle_trans with (1 := H).
    destruct (F.toX xl) as [|xlr]; [easy|].
    revert Hlnx.
    unfold Xln'.
    simpl.
    case is_positive_spec.
    { intros _ H'.
      injection H'.
      intros <-.
      destruct Hl as [Hl|Hl].
      { now apply Rlt_le, ln_increasing. }
      rewrite Hl.
      apply Rle_refl. }
    easy. }
  rewrite F.real_correct.
  case_eq (F.toX xu).
  { now rewrite F'.nan_correct. }
  intros xur Hxu.
  rewrite Hxu in Hu.
  generalize (T.ln_fast_correct prec xu).
  case T.ln_fast.
  { intros _.
    simpl.
    now rewrite F'.nan_correct. }
  intros l u.
  simpl.
  rewrite Hxu.
  unfold Xln'.
  simpl.
  case (_ && _)%bool; [|now case is_positive; [intros [H0 H1]; lra|]].
  case is_positive_spec.
  { intros _.
    intros [_ H].
    destruct (F.toX u) as [|ur]; [easy|].
    apply Rle_trans with (2 := H).
    destruct Hu as [Hu|Hu].
    { now apply Rlt_le, ln_increasing. }
    rewrite Hu.
    apply Rle_refl. }
  easy. }
intros Hx.
destruct (F.toX xl) as [|xlr]; [easy|].
elim Rle_not_lt with (1 := Hx).
now apply Rlt_le_trans with xlr.
Qed.

End FloatIntervalFull.


Set Universe Polymorphism.
Require Import HoTT.

(** * Pointed partial order *)

(**

  A pointed partial order is a type [A] equipped with a partial order [≼]
  (reflexive, transitive relation) and a least element [bot] for that
  relation.

*)

Reserved Notation "x ≼ y" (at level 50).

(* =PartialOrder_pp= *)
Class IsPartialOrder_pp (A: Type) := {
    rel: A -> A -> HProp where "x ≼ y" := (rel x y);
    bot: A;
    rel_refl: forall x, x ≼ x;
    rel_trans: forall x y z, x ≼ y -> y ≼ z -> x ≼ z;
    rel_antisym: forall x y, x ≼ y -> y ≼ x -> x = y;
    bot_is_least: forall x, bot ≼ x;
}.
(* =end= *)

Arguments rel_trans {_ _ _ _ _} _ _.

Notation "x ≼ y" := (rel x y).

(* =partial_order_forall= *)
Instance IsPartialOrder_pp_fun (A: Type)(B: A -> Type)
    `{forall a, IsPartialOrder_pp (B a)}: IsPartialOrder_pp (forall a, B a) :=
  {| rel := fun f g => hprop (forall a, f a ≼ g a);
     bot := fun a => bot |}.
(* =end= *)
Proof.
  - simpl; intros. apply rel_refl.
  - simpl; intros f g h H1 H2 a. eapply rel_trans; auto.
  - simpl; intros f g H1 H2. apply funext. intro x. apply rel_antisym; auto.
  - simpl; intros f a. apply bot_is_least.
Defined.

(** A monotone function between two partial orders respects the partial order
and transports bottom to bottom. *)

(* =monotone_fun= *)
Record monotone_function A B `{IsPartialOrder_pp A} `{IsPartialOrder_pp B} :=
 Build_Mon {
     f_ord:> A -> B ;
    mon: forall x y, x ≼ y -> f_ord x ≼ f_ord y;
    p_mon: f_ord bot ≼ bot
  }.
Notation "A --> B" := (monotone_function A B)
(* =end= *)
                        (at level 10).

Arguments f_ord {_ _ _ _} _ _.
Arguments mon {_ _ _ _} _ {_ _} _.
Arguments Build_Mon {_ _ _ _} _ _ _.


(* Software Foundations *)
(* Exercise: 2 star, and_assoc *)

Inductive and(P Q: Prop): Prop:=
  conj: P -> Q -> (and P Q).

Notation "P /\ Q" := (and P Q): type_scope.
Theorem and_assoc : forall P Q R : Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
    intros P Q R H. inversion H as [HP [HQ HR]].
    split.
    split.
    apply HP.
    apply HQ.
    apply HR.
Qed.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp018 : (forall P Q R S : Prop, ((P \/ Q) /\ (P -> R) /\ (Q -> S) -> (R \/ S))).
1 subgoal

  ============================
  forall P Q R S : Prop, (P \/ Q) /\ (P -> R) /\ (Q -> S) -> R \/ S

exp018 < intros.
1 subgoal

  P, Q, R, S : Prop
  H : (P \/ Q) /\ (P -> R) /\ (Q -> S)
  ============================
  R \/ S

exp018 < destruct H.
1 subgoal

  P, Q, R, S : Prop
  H : P \/ Q
  H0 : (P -> R) /\ (Q -> S)
  ============================
  R \/ S

exp018 < destruct H0.
1 subgoal

  P, Q, R, S : Prop
  H : P \/ Q
  H0 : P -> R
  H1 : Q -> S
  ============================
  R \/ S

exp018 < tauto.
No more subgoals.

exp018 < Qed.
exp018 is defined


Require Export B8_Point_Def.

Section TRIANGLE_SPECIFICATION.

Lemma TriangleSpecPerm : forall A B C : Point,
	TriangleSpec (Distance A B) (Distance B C) (Distance C A) ->
	TriangleSpec (Distance B C) (Distance C A) (Distance A B) .
Proof.
	unfold TriangleSpec in |- *; intuition.
Qed.

Lemma ClockwiseTriangleSpec : forall A B C : Point,
	Clockwise A B C ->
	TriangleSpec (Distance A B) (Distance B C) (Distance C A).
Proof.
	unfold TriangleSpec in |- *; intuition.
	 rewrite (DistSym A B); apply TriangularIneq.
	   apply ClockwiseBCA; auto.
	 rewrite (DistSym B C); apply TriangularIneq.
	   apply ClockwiseCAB; auto.
	 rewrite (DistSym C A); apply TriangularIneq; auto.
Qed.

End TRIANGLE_SPECIFICATION.


From mathcomp Require Import all_ssreflect.

From GraphTheory Require Import edone preliminaries digraph sgraph.
From fourcolor Require Import hypermap geometry jordan color coloring combinatorial4ct.
From GraphTheory Require Import hmap_ops.

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

Definition kconnected_map (k : nat) (G : hypermap) :=
  k < fcard node G /\
  forall A : pred G, #|A| < k ->
    {in [predC fclosure node A]&, forall x y, connect (restrict [predC fclosure node A] glink) x y}.

Lemma closed_connect (T : finType) (e : rel T) (A : pred T) :
  closed e A -> {in A, subrel (connect e) (connect (restrict A e))}.
Proof.
move => clA x xA y.
case/connectP => p; elim: p x xA => [x _ _ -> //|z p IHp /= x xA /andP [xz pth_p] lst_p].
have zA: z \in A by rewrite -(clA _ _ xz).
by apply: connect_trans (IHp _ zA pth_p lst_p); apply:connect1; rewrite /= xA zA.
Qed.

Lemma in_connect_sym (T : finType) (e : rel T) (A : pred T) :
  closed e A -> connect_sym e -> {in A&, connect_sym (restrict A e)}.
Proof.
move => clA sym_e x y xA yA.
wlog suff : x y xA yA / connect (restrict A e) x y -> connect (restrict A e) y x.
{ by move => W; apply/idP/idP; apply: W. }
case/connectP => p; elim: p x xA => /= [x _ _ -> //| z p IHp x xA].
rewrite -!andbA => /and4P [_ zA x_z pth_p lst_p].
have {pth_p lst_p} IH := IHp _ zA pth_p lst_p. apply: connect_trans IH _.
have := (connect1 x_z); rewrite sym_e; exact: closed_connect.
Qed.

Lemma sub_restrict T (e1 e2 : rel T) (A : pred T) :
  {in A&, subrel e1 e2} -> subrel (restrict A e1) (restrict A e2).
Proof. move => sub x y /=/andP[/andP [xA yA] xy]. by rewrite xA yA sub. Qed.

Lemma glinkN (G : hypermap) : subrel (frel node) (@glink G).
Proof. move => x y. by rewrite /glink /= => ->. Qed.

Lemma sub_node_clink {G : hypermap} : subrel (frel (finv node)) (@clink G).
Proof. move => x y /eqP <-. by rewrite /clink/= eqxx. Qed.

Lemma in_clink_glink (G : hypermap) (A : pred G) (plainG : plain G) :
  fclosed node A -> {in A&, connect (restrict A clink) =2 connect (restrict A glink)}.
Proof.
move => clA x y xA yA. apply/idP/idP.
- case/connectP => [p]. elim: p x xA => [x xA _ -> //|z p IHp x xA /=].
  rewrite -!andbA => /and4P [_ zA xz pth_p lst_p].
  apply: connect_trans (IHp _ zA pth_p lst_p) => {pth_p lst_p}.
  case/clinkP : xz xA zA => [->|<-] => xA zA.
  + apply: connect_mono. apply: sub_restrict. apply: in2W. exact: glinkN.
    rewrite in_connect_sym // ?connect1 //=. exact: cnodeC.
  + by apply connect1; rewrite /= xA zA /glink/= eqxx.
- case/connectP => [p]. elim: p x xA => [x xA _ -> //|z p IHp x xA /=].
  rewrite -!andbA => /and4P [_ zA xz pth_p lst_p].
  apply: connect_trans (IHp _ zA pth_p lst_p) => {pth_p lst_p IHp}.
  gen have N,N': x z xA zA {xz} / node x == z -> connect (restrict A clink) x z.
  { move/eqP => E. rewrite -{}E in zA *.
    apply: connect_mono. apply: sub_restrict. apply: in2W. exact: sub_node_clink.
    rewrite in_connect_sym // ?connect1 //= ?xA ?zA ?finv_f ?eqxx //.
    * move => u v /eqP <-. by rewrite (clA (finv node u) u) //= f_finv.
    * by apply/fconnect_sym/finv_inj. }
  gen have F,F': x z xA zA {xz N N'} / face x == z -> connect (restrict A clink) x z.
  { move/eqP => E; rewrite -{}E in zA *. by apply: connect1; rewrite /= xA zA clinkF. }
  case/or3P : xz => //= {N' F'}.
  rewrite -plain_eq' => // /eqP => E; rewrite -{}E in zA *.
  have ? : face x \in A by rewrite (clA (face x) (node (face x))) //=.
  apply: connect_trans (N (face x) _ _ _ _) => //. exact: F.
Qed.

Definition avoid_one (G : hypermap) :=
  forall z x y : G , ~~ cnode z x -> ~~ cnode z y -> connect (restrict [predC cnode z] clink) x y.

Lemma two_connected_avoid (G : hypermap) (plainG : plain G) :
  kconnected_map 2 G -> avoid_one G.
Proof.
case => _ tcG z x y Hx Hy.
have:= tcG (pred1 z) _; rewrite card1 => /(_ isT) {tcG} tcG.
have Nz : cnode z =i fclosure node (pred1 z) by apply/closure1/cnodeC.
have PNz : [predC cnode z] =i [predC fclosure node (pred1 z)].
{ by move => u; rewrite inE /= Nz. }
rewrite in_clink_glink //; last exact/predC_closed/connect_closed/cnodeC.
apply: connect_restrict_mono (tcG x y _ _); rewrite -?PNz //.
apply/subsetP => u. by rewrite -PNz.
Qed.

Definition drestrict (G : diGraph) (A : pred G) := DiGraph (restrict A (--)).

Lemma upathPR (G : diGraph) (x y : G) A :
  reflect (exists p : seq G, @upath (drestrict A) x y p)
          (connect (restrict A (--)) x y).
Proof. exact: (@upathP (drestrict A)). Qed.

Lemma upath_rconsE (G: diGraph) (x y : G) p : x != y ->
    upath x y p -> path (--) x (rcons (behead (belast x p)) y) /\ uniq (rcons (belast x p) y).
Proof.
rewrite /upath/pathp; elim/last_ind : p x y => [x y /negbTE-> //|p z ? x y ?].
rewrite !belast_rcons last_rcons /= -andbA => /and4P [H1 H2 H3 /eqP<-].
by rewrite H1 H2 H3.
Qed.

Lemma drestrict_upath (G : diGraph) (x y : G) (A : pred G) (p : seq G) :
  @upath (@drestrict G A) x y p -> @upath G x y p.
Proof.
elim: p x => // z p IH x /upath_consE [/= /andP [_ u1] u2 u3].
rewrite upath_cons u1 u2 /=. exact: IH.
Qed.

(* TODO:
   - clean up digraph/sgraph connect/path lemmas
   - provide link between [p : Path x y] and [path e x (rcons q y)] *)
Lemma connect_inE (T : finType) (e : rel T) (A : pred T) (x y : T) :
  x != y -> connect (restrict A e) x y ->
  (exists p, [/\ path e x (rcons p y), uniq (x::rcons p y) & {subset x::rcons p y <= A}]).
Proof.
move => xDy. case/(@upathPR (DiGraph e)) => p U.
move/upath_rconsE : (drestrict_upath U) => -/(_ xDy) [P1 P2].
have E : last x p = y by case/andP : U => _; apply: pathp_last.
rewrite -E -lastI in P2.
exists (behead (belast x p)); split => //.
- suff -> : rcons (behead (belast x p)) y = p by [].
  destruct p; rewrite -?E -?lastI //=. by rewrite -E /= eqxx in xDy.
- move/upath_rconsE : (U) => /(_ xDy) => -[P _].
  apply/cons_subset; split; last exact: rpath_sub P.
  destruct p; simpl in *. by rewrite E eqxx in xDy.
  case/upath_consE : U => /=. by rewrite /edge_rel/=; case: (x \in A).
Qed.

Lemma sub_face_clink { G : hypermap } : @subrel G (frel face) clink.
Proof. by move => u v /eqP ?; apply/clinkP; right. Qed.

Lemma path_take_nth (T : eqType) (e : rel T) x s n :
  n < size s -> path e x s -> e (last x (take n s)) (nth x s n).
Proof.
elim: s x n => // a s IH x [|n] /=; first by case (e x a).
rewrite ltnS => ? /andP [_ ?]; by rewrite (set_nth_default a x) ?IH.
Qed.

Lemma path_take (T : eqType) (e : rel T) x s n :
  path e x s -> path e x (take n s).
Proof. by rewrite -{1}[s](cat_take_drop n) cat_path; case/andP. Qed.

Lemma disjoint_subpath (T : finType) (A B : pred T) (e : rel T) x y (p : seq T) :
  x \in A -> y \in B -> path e x (rcons p y) -> [disjoint A & B] ->
  exists u v q, [/\ u \in A, v \in B, path e u (rcons q v),
              subseq (u:: rcons q v) (x:: rcons p y) & [disjoint q & [predU A & B]]].
Proof.
have [m Hm] := ubnP (size p); elim: m x y p Hm => // n IH x y p p_n xA xB pth_p disAB.
case: (boolP [disjoint p & [predU A & B]]) => [?|]; first by exists x; exists y; exists p.
case/pred0Pn => z /andP[z_in_p z_in_AB].
case/splitP def_p : p _ _ / z_in_p pth_p p_n => [p1 p2].
rewrite rcons_cat cat_path last_rcons => /andP [pth_p1 pth_p2].
rewrite size_cat size_rcons addSn ltnS => size_p.
have {z_in_AB} [z_in_A|z_in_B] := orP z_in_AB.
- case:(IH z y p2) => //. apply: leq_ltn_trans size_p. exact: leq_addl.
  move => u [v] [q] [uA vB Q1 Q2 Q3]; exists u; exists v; exists q. split => //.
  apply: subseq_trans Q2 _. rewrite -(cats1 _ z) -catA cat1s -cat_cons.
  exact: suffix_subseq.
- case:(IH x z p1) => //. apply: leq_ltn_trans size_p. exact: leq_addr.
  move => u [v] [q] [uA vB Q1 Q2 Q3]; exists u; exists v; exists q. split => //.
  apply: subseq_trans Q2 _. exact: prefix_subseq.
Qed.

Lemma last_belast (T : eqType) (x : T) (s : seq T) :
  uniq (x :: s) -> last x s \in belast x s = false.
Proof.
elim: s x => //= y s IH x /andP [Hx ?]. rewrite inE IH // orbF.
apply: contraNF Hx => /eqP <-. exact: mem_last.
Qed.

Lemma last_head_behead (T : eqType) (x : T) (p : seq T) : last (head x p) (behead (rcons p x)) = x.
Proof. case: p => //= ? ?. exact: last_rcons. Qed.

Lemma last_memE (T : eqType) (x : T) (s : seq T) (a : pred T) :
  last x s \in a -> (x \in a) + { y | y \in s & y \in a}.
Proof.
elim/last_ind : s => [|s y _]; first by left.
by rewrite last_rcons; right;exists y => //; rewrite mem_rcons mem_head.
Qed.

Lemma index_finv (T : finType) (f : T -> T) x :
  findex f x (finv f x) = (order f x).-1.
Proof. by rewrite findex_iter // orderSpred. Qed.

Lemma bar (T : finType) (f : T -> T) x :
  injective f -> findex f (f x) x = (order f (f x)).-1.
Proof. move => inj_f. have := index_finv f (f x). by rewrite finv_f. Qed.

(** Every face of a two connected loopless plain graph is bounded by a
cycle. In the hypermap representation, this amounts to showing that
distinct nodes on an f-cycle belong to different n-cycles *)
(* TODO: simplify further (use [rot_to_arc] for f-cycle) *)
Lemma two_connected_cyle (G : hypermap) :
  avoid_one G -> plain G -> loopless G -> planar G ->
  forall x y : G, x != y -> cface x y -> ~~ cnode x y.
Proof.
move => tcG plainG llG planarG x y xDy cf_xy; apply/negP => cn_xy.
wlog [p [path_p uniq_p disj_p]] : x xDy cf_xy cn_xy /
  exists p, [/\ fpath (finv node) y (rcons p x), uniq p & [disjoint p & cface x]].
{ move => W.
  pose o := orbit (finv node) y; pose a := cface x.
  have [o' def_o] : exists o', o = y :: o' by rewrite /o/orbit -orderSpred /=; eexists.
  have has_x : has a o'; first (apply/hasP; exists x; last exact: connect0).
    suff: x \in o by rewrite def_o inE (negPf xDy).
    by rewrite -fconnect_orbit same_fconnect_finv // cnodeC.
  case/split_find def_o' : _ _ _ / has_x => [x' p q a_x' hasNp]; subst o'.
  have: uniq o by apply: orbit_uniq.
  have: fcycle (finv node) o by apply/cycle_orbit/finv_inj.
  have cf_x'y: cface x' y by apply: connect_trans cf_xy; rewrite cfaceC.
  rewrite def_o /= rcons_path cat_path -!andbA => /andP [path_p _].
  rewrite cat_uniq rcons_uniq -!andbA mem_cat mem_rcons inE !negb_or -!andbA eq_sym.
  move => /andP[? /and5P[_ _ _ uniq_p _]]; apply: (W x') => //.
  - rewrite cnodeC -same_fconnect_finv //; apply/connectP; exists (rcons p x') => //.
    by rewrite last_rcons.
  - exists p; split => //; rewrite disjoint_has // (eq_has (_ : cface x' =i cface x)) //.
    move=> z; rewrite !inE; apply: (same_connect cfaceC).
    by apply: connect_trans cf_x'y _; rewrite cfaceC. }
(* Exibiting the f-cycle *)
have := cycle_orbit faceI x; have := orbit_uniq face x.
have : y \in orbit face x by rewrite -fconnect_orbit.
case def_c : (orbit face x) => [//|x0 c].
move: (def_c).
have {def_c} -> : x0 = x by move: def_c; rewrite /orbit -orderSpred; case.
move => def_c y_in_c uniq_c cycle_c.
rewrite inE eq_sym (negbTE xDy) /= in y_in_c.
(* Splitting the f-cycle *)
case/splitP def_c' : {1}c _ _ / y_in_c => [c1 c2].
move: uniq_c. rewrite def_c' /= cat_uniq has_sym has_rcons mem_cat mem_rcons rcons_uniq.
rewrite !inE (negbTE xDy) !negb_or /= -disjoint_has -!andbA disjoint_sym.
case/and5P => x_c1 x_c2 y_c1 uniq_c1 /and3P [y_c2 dis_c1_c2 uniq_c2].
move: path_p; rewrite rcons_path /= => /andP [path_p /eqP lst_p].
(* Obtain contour connecting [c1] and [c2] *)
have [u [v] [q] [path_q u_c v_c uniq_q disj_q]]:
  exists u v q, [/\ path clink u (rcons q v), u \in c2, v \in c1, uniq q & [disjoint q & [predU cface x & p]]].
{  have [u [u_c1 Hu]] : exists u, u \in c1 /\ ~~ cnode x u. {
     destruct c1 as [|a ?]; move: cycle_c cn_xy; rewrite def_c'.
     - case/andP => /eqP <- _. by rewrite (negbTE (loopless_face _ _ _)).
     - rewrite rcons_cons /= rcons_path => /and3P [/eqP<- _ _].
       exists (face x). by rewrite mem_head loopless_face. }
   have [v [v_c2 Hv]] : exists v, v \in c2 /\ ~~ cnode x v. {
     elim/last_ind : c2 def_c' cycle_c cn_xy {x_c2 y_c2 dis_c1_c2 uniq_c2} => [|? a _] /= ->.
     - rewrite cats0 /= rcons_path last_rcons => /andP [_ /eqP <-].
       by rewrite cnodeC (negbTE (loopless_face _ _ _)).
     - rewrite !(rcons_path,cat_path) /= -!andbA last_cat !last_rcons => /and5P [_ _ _ _ /eqP E ?].
       exists (finv face x). by rewrite -E finv_f // mem_rcons mem_head cnodeC loopless_face. }
   have uDv : v != u.
   { apply: contraTneq dis_c1_c2 => ?; subst. by apply/pred0Pn; exists u. }
   have [q [pth_q uniq_q sub_q]] := @connect_inE _ _ _ _ _ uDv (tcG x v u Hv Hu).
   have [u0 [v0] [q0] [A B C D E]] := disjoint_subpath  v_c2 u_c1 pth_q dis_c1_c2.
   exists u0; exists v0; exists q0; split => //.
   - apply: subseq_uniq uniq_q. apply: subseq_trans D.
     exact: subseq_trans (subseq_rcons _ _) (subseq_cons _ _).
   - move/mem_subseq in D.
     apply/disjointP => z in_q0; apply/negP; rewrite !inE negb_or fconnect_orbit def_c.
     have Nz k : cnode y k -> z != k.
     { move => Nyk. have:= connect_trans cn_xy Nyk.
       apply contraTneq => <-. by apply/sub_q/D; rewrite !(inE,mem_rcons) in_q0. }
     rewrite def_c' !(inE,mem_rcons,mem_cat) !negb_or !Nz 1?cnodeC //= -negb_or orbC.
     move: (disjointFr E in_q0); rewrite inE => -> /=.
     apply: contraTN (eqxx z) => z_p; apply/Nz.
     rewrite -same_fconnect_finv //.
     move/path_connect in path_p. by apply/path_p; rewrite !inE z_p. }
case/splitP def_c2 : {1}c2 _ _ / (u_c) => [c21 c22].
pose mp := rcons p x ++ rcons c1 y ++ rcons c21 u ++ q.
suff: Moebius_path mp by apply/negP; exact: planarP.
move: path_q; rewrite rcons_path => /andP [path_q lst_q].
have/andP [dis_q_f dis_q_p] : [disjoint q & (x::c)] && [disjoint p & q].
{ move: disj_q. rewrite disjoint_sym disjointU => /andP [A ->]; rewrite andbT disjoint_sym.
  by apply: disjointWl A; apply/subsetP => ?; rewrite -def_c -fconnect_orbit. }
rewrite /mp headI /Moebius_path -{2}headI /=.
apply/and3P; split.
- suff: uniq (rcons p x ++ c ++ q).
  { apply: subseq_uniq. apply: cat_subseq => //. rewrite catA. apply: cat_subseq => //.
    rewrite def_c' def_c2. apply: cat_subseq => //. exact: prefix_subseq. }
  rewrite -cats1 -catA [[:: x] ++ _ ++ _]catA cat1s -def_c.
  rewrite cat_uniq has_cat negb_or -!disjoint_has uniq_p /=.
  rewrite ![[disjoint _ & p]]disjoint_sym dis_q_p (disjointWr _ disj_p).
  2: by apply/subsetP => z; rewrite -fconnect_orbit.
  rewrite cat_uniq orbit_uniq -disjoint_has disjoint_sym uniq_q /= andbT.
  by rewrite disjoint_sym def_c.
- rewrite !catA cat_path !last_cat last_rcons path_q andbT -catA.
  rewrite cat_path last_head_behead (_ : path _ _ _) /=.
  + move/(sub_path sub_face_clink) : cycle_c.
    by rewrite def_c' def_c2 !rcons_cat catA [in X in X -> _]cat_path => /andP [-> _].
  + move/(sub_path sub_node_clink): path_p lst_p. destruct p as [|z p] => //= /andP [A B] <-.
    by rewrite rcons_path B -{1}[last z p](f_finv nodeI) clinkN.
- rewrite 3!last_cat last_rcons.
  have -> : node (head x p) = y.
  { move: path_p lst_p. destruct p as [|z p]=> /= [_ <-|/andP[/eqP <- _] _]; exact: f_finv. }
  suff -> : finv node (last u q) = v.
  { by rewrite !mem2_cat (_ : mem2 (rcons c1 y) v y) // -cats1 mem2_cat v_c !inE eqxx. }
  case/clinkP: lst_q => [->|def_v]; first by rewrite ?finv_f.
  case: notF. (* the last step of [u::rcons q v] cannot be an f-step *)
  have: finv face v \in x::c1.
  { have : fpath face x c1.
    { move: cycle_c. rewrite def_c' -cat1s catA /= rcons_cat cat_path rcons_path. by case: (fpath _ _ c1). }
    case/splitP : v_c => [p1 p2 _]. rewrite cat_path !rcons_path last_rcons -andbA /=.
    case/and3P => _ /eqP <- _. by rewrite finv_f // -cats1 -catA /= -cat_cons mem_cat  mem_last. }
  rewrite -{}def_v finv_f //. case/last_memE => [|[z Z1]].
  + rewrite inE (disjointFr dis_c1_c2) // orbF => E. by rewrite -(eqP E) u_c in x_c2.
  + rewrite inE; case/predU1P => [?|H].
    * subst z. by rewrite (disjointFl dis_q_f) // mem_head in Z1.
    * by rewrite (disjointFl dis_q_f) // def_c' !(inE,mem_rcons,mem_cat) H in Z1.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(***********************************************************************
    Summation.v from Z to Z
 *********************************************************************)
Require Import Arith.
Require Import ArithRing.
Require Import ListAux.
Require Import ZArith.
Require Import Lia.
Require Import Iterator.
Require Import ZProgression.

Open Scope Z_scope.
(* Iterated Sum *)

Definition Zsum :=
   fun n m f =>
   if Zle_bool n m
     then iter 0 f Zplus (progression Z.succ n (Z.abs_nat  ((1 + m) - n)))
     else iter 0 f Zplus (progression Z.pred n (Z.abs_nat  ((1 + n) - m))).
Global Hint Unfold Zsum : core.

Lemma Zsum_nn: forall n f,  Zsum n n f = f n.
intros n f; unfold Zsum; rewrite Zle_bool_refl.
replace ((1 + n) - n) with 1; auto with zarith.
simpl; ring.
Qed.

Theorem permutation_rev: forall (A:Set) (l : list A),  permutation (rev l) l.
intros a l; elim l; simpl; auto.
intros a1 l1 Hl1.
apply permutation_trans with (cons a1 (rev l1)); [|auto].
change (permutation (rev l1 ++ (a1 :: nil)) (app (cons a1 nil) (rev l1))); auto.
Qed.

Lemma Zsum_swap: forall (n m : Z) (f : Z ->  Z),  Zsum n m f = Zsum m n f.
Proof.
  intros n m f; revert n m.
  cut (forall n m, n < m -> Zsum n m f = Zsum m n f).
  { intros L n m.
    destruct (Ztrichotomy n m) as [ LT | [ -> | GT ] ].
    - apply L, LT.
    - reflexivity.
    - symmetry; apply L, Z.gt_lt, GT. }
intros n m n_lt_m; unfold Zsum.
replace (m <=? n) with false by (symmetry; apply Z.leb_gt, n_lt_m).
replace (n <=? m) with true by (symmetry; apply Z.leb_le, Z.lt_le_incl, n_lt_m).
apply iter_permutation; auto with zarith.
apply permutation_trans
     with (rev (progression Z.succ n (Z.abs_nat  ((1 + m) - n)))).
apply permutation_sym; apply permutation_rev.
rewrite Zprogression_opp; auto with zarith.
replace (n + Z_of_nat (pred (Z.abs_nat  ((1 + m) - n)))) with m; auto.
replace (Z.abs_nat  ((1 + m) - n)) with (S (Z.abs_nat  (m - n))).
simpl.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
lia.
Qed.

Lemma Zsum_split_up:
 forall (n m p : Z) (f : Z ->  Z),
 ( n <= m < p ) ->  Zsum n p f = Zsum n m f + Zsum (m + 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq _ _ H); clear H; intros H.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
assert (H1: n < p).
apply Z.lt_trans with ( 1 := H ); auto with zarith.
assert (H2: m < 1 + p).
apply Z.lt_trans with ( 1 := H0 ); auto with zarith.
assert (H3: n < 1 + m).
apply Z.lt_trans with ( 1 := H ); auto with zarith.
assert (H4: n < 1 + p).
apply Z.lt_trans with ( 1 := H1 ); auto with zarith.
replace (Z.abs_nat  ((1 + p) - (m + 1)))
     with (minus (Z.abs_nat  ((1 + p) - n)) (Z.abs_nat  ((1 + m) - n))).
apply iter_progression_app. 1-3: auto with zarith.
apply inj_le_rev.
(repeat rewrite inj_Zabs_nat); auto with zarith.
(repeat rewrite Z.abs_eq); auto with zarith.
rewrite next_n_Z.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_eq_rev.
rewrite inj_minus1.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
apply inj_le_rev.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
subst m.
rewrite Zsum_nn; auto with zarith.
unfold Zsum; generalize (Zle_cases n p); generalize (Zle_cases (n + 1) p);
 case (Zle_bool n p); case (Zle_bool (n + 1) p); auto with zarith.
intros H1 H2.
replace (Z.abs_nat  ((1 + p) - n)) with (S (Z.abs_nat  (p - n))).
replace (n + 1) with (Z.succ n) by auto with zarith.
replace ((1 + p) - Z.succ n) with (p - n); auto with zarith.
apply inj_eq_rev.
rewrite inj_S; (repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_S_left:
 forall (n m : Z) (f : Z ->  Z), n < m ->  Zsum n m f = f n + Zsum (n + 1) m f.
intros n m f H; rewrite (Zsum_split_up n n m f); auto with zarith.
rewrite Zsum_nn; auto with zarith.
Qed.

Lemma Zsum_S_right:
 forall (n m : Z) (f : Z ->  Z),
 n <= m ->  Zsum n (m + 1) f = Zsum n m f  + f (m + 1).
intros n m f H; rewrite (Zsum_split_up n m (m + 1) f); auto with zarith.
rewrite Zsum_nn; auto with zarith.
Qed.

Lemma Zsum_split_down:
 forall (n m p : Z) (f : Z ->  Z),
 ( p < m <= n ) ->  Zsum n p f = Zsum n m f  + Zsum (m - 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq p (m - 1)); auto with zarith; intros H1.
pattern m at 1; replace m with ((m - 1) + 1) by auto with zarith.
repeat rewrite (Zsum_swap n).
rewrite (Zsum_swap (m - 1)).
rewrite Zplus_comm.
apply Zsum_split_up; auto with zarith.
subst p.
repeat rewrite (Zsum_swap n).
rewrite Zsum_nn.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
replace (Z.abs_nat   ((1 + n) - (m - 1))) with (S (Z.abs_nat   (n - (m - 1)))).
rewrite Zplus_comm.
replace (Z.abs_nat   ((1 + n) - m)) with (Z.abs_nat  (n - (m - 1))).
pattern m at 4; replace m with (Z.succ (m - 1)); auto with zarith.
apply f_equal with ( f := Z.abs_nat  ); auto with zarith.
apply inj_eq_rev.
rewrite inj_S.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_ext:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  f x = g x) ->  Zsum n m f = Zsum n m g.
intros n m f g HH H.
unfold Zsum; auto.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
apply iter_ext; auto with zarith.
intros a H1; apply H; auto; split.
apply Zprogression_le_init with ( 1 := H1 ).
cut (a < Z.succ m); auto with zarith.
replace (Z.succ m) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_add:
 forall (n m : Z) (f g : Z ->  Z),
  Zsum n m f  + Zsum n m g = Zsum n m (fun (i : Z) => f i + g i).
intros n m f g; unfold Zsum; case (Zle_bool n m); apply iter_comp;
 auto with zarith.
Qed.

Lemma Zsum_times:
 forall n m x f,  x * Zsum n m f = Zsum n m (fun i=> x * f i).
intros n m x f.
unfold Zsum. case (Zle_bool n m); intros; apply iter_comp_const with (k := (fun y : Z => x * y)); auto with zarith.
Qed.

Lemma inv_Zsum:
 forall (P : Z ->  Prop) (n m : Z) (f : Z ->  Z),
 n <= m ->
 P 0 ->
 (forall (a b : Z), P a -> P b ->  P (a + b)) ->
 (forall (x : Z), ( n <= x <= m ) ->  P (f x)) ->  P (Zsum n m f).
intros P n m f HH H H0 H1.
unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith; apply iter_inv; auto.
intros x H3; apply H1; auto; split.
apply Zprogression_le_init with ( 1 := H3 ).
cut (x < Z.succ m); auto with zarith.
replace (Z.succ m) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_pred:
 forall (n m : Z) (f : Z ->  Z),
  Zsum n m f = Zsum (n + 1) (m + 1) (fun (i : Z) => f (Z.pred i)).
intros n m f.
unfold Zsum.
generalize (Zle_cases n m); generalize (Zle_cases (n + 1) (m + 1));
 case (Zle_bool n m); case (Zle_bool (n + 1) (m + 1)); auto with zarith.
replace ((1 + (m + 1)) - (n + 1)) with ((1 + m) - n); auto with zarith.
intros H1 H2; cut (exists c , c = Z.abs_nat  ((1 + m) - n) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; eq_tac; auto with zarith.
eq_tac; unfold Z.pred; auto with zarith.
replace (Z.succ (n + 1)) with (Z.succ n + 1); auto with zarith.
exists (Z.abs_nat  ((1 + m) - n)); auto.
replace ((1 + (n + 1)) - (m + 1)) with ((1 + n) - m); auto with zarith.
intros H1 H2; cut (exists c , c = Z.abs_nat  ((1 + n) - m) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; (eq_tac; auto with zarith).
eq_tac; unfold Z.pred; auto with zarith.
replace (Z.pred (n + 1)) with (Z.pred n + 1); auto with zarith.
unfold Z.pred; auto with zarith.
exists (Z.abs_nat  ((1 + n) - m)); auto.
Qed.

Theorem Zsum_c:
 forall (c p q : Z), p <= q ->  Zsum p q (fun x => c) = ((1 + q) - p) * c.
intros c p q Hq; unfold Zsum.
rewrite Zle_imp_le_bool; auto with zarith.
pattern ((1 + q) - p) at 2.
 rewrite <- Z.abs_eq; auto with zarith.
 rewrite <- inj_Zabs_nat; auto with zarith.
cut (exists r , r = Z.abs_nat  ((1 + q) - p) );
 [intros [r H1]; rewrite <- H1 | exists (Z.abs_nat  ((1 + q) - p))]; auto.
generalize p; elim r; auto with zarith.
intros n H p0; replace (Z_of_nat (S n)) with (Z_of_nat n + 1).
simpl; rewrite H; ring.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zsum_Zsum_f:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
 i <= j ->
 k < l ->
  Zsum i j (fun x => Zsum k (l + 1) (fun y => f x y)) =
  Zsum i j (fun x => Zsum k l (fun y => f x y) + f x (l + 1)).
intros; apply Zsum_ext; intros; auto with zarith.
rewrite Zsum_S_right; auto with zarith.
Qed.

Theorem Zsum_com:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
  Zsum i j (fun x => Zsum k l (fun y => f x y)) =
  Zsum k l (fun y => Zsum i j (fun x => f x y)).
intros; unfold Zsum; case (Zle_bool i j); case (Zle_bool k l); apply iter_com;
 auto with zarith.
Qed.

Theorem Zsum_le:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  (f x <= g x )) ->
  (Zsum n m f <= Zsum n m g ).
intros n m f g Hl H.
unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith.
unfold Zsum;
 cut
  (forall x,
   In x (progression Z.succ n (Z.abs_nat  ((1 + m) - n))) ->  ( f x <= g x )).
elim (progression Z.succ n (Z.abs_nat  ((1 + m) - n))); simpl; auto with zarith.
intros x H1; apply H; split.
apply Zprogression_le_init with ( 1 := H1 ); auto.
cut (x < m + 1); auto with zarith.
replace (m + 1) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
Qed.

Theorem iter_le:
forall (f g: Z -> Z)  l, (forall a, In a l -> f a <= g a) ->
  iter 0 f Zplus l <= iter 0 g Zplus l.
intros f g l; elim l; simpl; auto with zarith.
Qed.

Theorem Zsum_lt:
 forall n m f g,
 (forall x, n <= x -> x <= m ->  f x <= g x) ->
 (exists x, n <= x /\ x <= m /\  f x < g x) ->
  Zsum n m f < Zsum n m g.
intros n m f g H (d, (Hd1, (Hd2, Hd3))); unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith.
cut (In d (progression  Z.succ n (Z.abs_nat  (1 + m - n)))).
cut (forall x, In x (progression Z.succ n (Z.abs_nat  (1 + m - n)))->  f x <= g x).
elim (progression  Z.succ n (Z.abs_nat  (1 + m - n))); simpl; auto with zarith.
intros a l Rec  H0 [H1 | H1]; subst; auto.
apply Z.le_lt_trans with (f d + iter 0 g Zplus l); auto with zarith.
apply Zplus_le_compat_l.
apply iter_le; auto.
apply Z.lt_le_trans with (f a + iter 0 g Zplus l); auto with zarith.
intros x H1; apply H.
apply Zprogression_le_init with ( 1 := H1 ); auto.
cut (x < m + 1); auto with zarith.
replace (m + 1) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end with ( 1 := H1 ); auto with arith.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply in_Zprogression.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
Qed.

Theorem Zsum_minus:
 forall n m f g,  Zsum n m f - Zsum n m g = Zsum n m (fun x => f x - g x).
intros n m f g; apply trans_equal with (Zsum n m f + (-1) * Zsum n m g); auto with zarith.
rewrite Zsum_times; rewrite Zsum_add; auto with zarith.
Qed.


Theorem ex1_4: forall a b c : Prop,
              forall B : (b -> c) -> (a -> b) -> a -> c,
              forall C : (a -> b -> c) -> b -> a -> c,
              forall W : (a -> a -> b) -> a -> b,
              ((a -> b -> c) -> (a -> b) -> a -> c).
Proof.
  intros. apply B. intro. apply C.
  assumption. assumption. assumption. apply W.
  intro. assumption. assumption.
Qed.

Print ex1_4.

Theorem ex2_2: forall A B C D : Prop,
               (A -> B) /\ (C -> D) /\
               (A \/ C) /\ ~(B /\ D) ->
               (B -> A) /\ (D -> C).
Proof.
  Require Import Coq.Program.Basics.
  intros. split. decompose [and] H.
  elim H1. apply const. intros.
  elim H4. split.
  assumption. apply (H2 H3).
  decompose [and] H. elim H1.
  intros. elim H4.
  split. apply (H0 H3). assumption.
  apply const.
Qed.

Theorem ex3_11: forall P Q R : Prop,
                (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros. repeat apply H || apply H0 || apply H1.
Qed.

Theorem ex3_12: forall P Q R : Prop,
                (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros. repeat apply H || apply H0 || apply H1.
Qed.

Theorem ex3_13: forall P Q R : Prop,
                (P -> R) -> P -> Q -> R.
Proof.
  intros. repeat apply H || apply H0 || apply H1.
Qed.

Theorem ex3_14: forall P Q : Prop,
                (P -> P -> Q) -> P -> Q.
Proof.
  intros. repeat apply H || apply H0 || apply H1.
Qed.

Theorem ex3_15: forall P Q : Prop,
                (P -> Q) -> (P -> P -> Q).
Proof.
  intros. repeat apply H || apply H0 || apply H1.
Qed.

Theorem ex3_16: forall P Q R S : Prop,
                (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
Proof.
  intros. repeat apply H || apply H0 || apply H1 || apply H2.
Qed.

Theorem ex3_17: forall P Q : Prop,
                ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros. repeat first [apply H1;intros | apply H0;intros | apply H;intros].
Qed.


(*

  Material para o encontro do
  dia 17/03/2023.

  Unicamp. GLM/Grupo_Coq.

  Autor: Renato Reis Leme
  Web: https://renatoleme.github.io/

  São Paulo, 16 de março de 2023.
*)

Require Import String.

Inductive string_or_nat :=
| String : string -> string_or_nat
| Nat : nat -> string_or_nat.

Check String "Hello World!".
Check Nat 23.

(* Record type (each of) *)

Inductive nat_string_pair :=
| Pair : (nat * string) -> nat_string_pair.

Open Scope string_scope.

Check Pair (23 , "Hello World!").

Close Scope string_scope.

(**)

Inductive dia : Type :=
| Segunda
| Terca
| Quarta
| Quinta
| Sexta
| Sabado
| Domingo.

Check Segunda.
Check Domingo.
Check Sexta.

Definition proximo_dia_util
  (d : dia) : dia :=
  match d with
  | Segunda => Terca
  | Terca => Quarta
  | Quarta => Quinta
  | Quinta => Sexta
  | Sexta => Segunda
  | Sabado => Segunda
  | Domingo => Segunda
  end.

Compute proximo_dia_util
(proximo_dia_util Quarta).

Example teste_proximo_dia_util :
  (proximo_dia_util
  (proximo_dia_util Terca)) = Quinta.
Proof.
  simpl. reflexivity.
Qed.

(**)

Inductive bool : Type := true | false.

Definition negb (b : bool) : bool :=
  match b with
    true => false
  | false => true
  end.

Definition andb (a b : bool) : bool :=
  match a with
    true => b
  | false => false
  end.

Definition orb (a b : bool) : bool :=
  match a with
    true => true
  | false => b
  end.

Example test_orb1:
(orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2:
(orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3:
(orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4:
(orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb_notation :
false || true || false ||
false || false = true.
Proof. simpl. reflexivity. Qed.

Definition negb' (b : bool) : bool :=
  if b then false
  else true.

Definition andb' (a b : bool) : bool :=
  if a then b
  else false.

Definition orb' (a b : bool) : bool :=
  if a then true
  else b.

Check true.
Check (negb true) : bool.

(**)

Inductive rgb : Type :=
| red
| green
| blue.

Inductive color : Type :=
| black
| white
| primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.


(**
 Written by Sosuke Moriguchi (@chiguri on Twitter)
             Kwansei Gakuin University
**)

(* 全体において、well-founded inductionを使わないことを目標とした *)
Section tpp2014.

Require Import Arith.

(********************************** (1)の準備 **************************************)
Fixpoint mod3 n :=
match n with
| S (S (S m)) => mod3 m
| S (S O) => 2
| S O => 1
| O => 0
end.

(* mod3の動きに基づく帰納法 *)
Lemma mod3_ind : forall P : nat -> Prop,
 P 0 ->
 P 1 ->
 P 2 ->
 (forall n, P n -> P (S (S (S n)))) ->
  forall n, P n.
intros P H0 H1 H2 H.
 fix f 1.
  intro.
   destruct n as [ | [ | [ | n]]].
    apply H0.
    apply H1.
    apply H2.
    apply H; apply f.
Qed.

Lemma tripleadd_mult3 : forall n, n + n + n = n * 3.
intro; rewrite mult_comm; simpl.
 rewrite plus_comm; f_equal.
  f_equal.
   rewrite plus_comm; auto.
Qed.

Lemma mod3_case : forall n, mod3 n = 0 \/ mod3 n = 1 \/ mod3 n = 2.
apply mod3_ind; auto.
Qed.

Lemma mult3_mod3 : forall n, mod3 (n * 3) = 0.
intro n; induction n; auto.
Qed.

Lemma mult3_add_mod3 : forall m n, mod3 (n * 3 + m) = mod3 m.
induction n; auto.
Qed.

Lemma mod3_add_mod3 : forall m n, mod3 (m + n) = mod3 (mod3 m + mod3 n).
intro n; apply mod3_ind with (n:=n); clear n; intros.
 simpl.
  case mod3_case with n; intro.
   rewrite H; auto.
   destruct H as [H | H]; rewrite H; auto.
 simpl (mod3 1).
  revert n; apply mod3_ind; auto.
 revert n; apply mod3_ind; auto.
 simpl; rewrite H; auto.
Qed.

(*  (1): a^2 mod 3 = 0 or 1 *)
Theorem Prob1 : forall a, mod3 (a * a) = 0 \/ mod3 (a * a) = 1.
apply mod3_ind; intros; auto; destruct H.
 left; simpl.
  rewrite plus_comm; simpl.
   rewrite plus_comm; simpl.
    rewrite plus_assoc; rewrite plus_comm; simpl.
     rewrite plus_comm; rewrite plus_assoc.
      rewrite tripleadd_mult3.
       rewrite mult3_add_mod3.
        rewrite mult_comm; simpl.
         repeat (rewrite plus_assoc).
          rewrite tripleadd_mult3.
           rewrite mult3_add_mod3.
            auto.
 right; simpl.
  rewrite plus_comm; simpl.
   rewrite plus_comm; simpl.
    rewrite plus_assoc; rewrite plus_comm; simpl.
     rewrite plus_comm; rewrite plus_assoc.
      rewrite tripleadd_mult3.
       rewrite mult3_add_mod3.
        rewrite mult_comm; simpl.
         repeat (rewrite plus_assoc).
          rewrite tripleadd_mult3.
           rewrite mult3_add_mod3.
            auto.
Qed.

(* 全く同じやり方なのでLtacにすればもっと簡単に終わる *)

(********************************** (2)の準備 **************************************)

Lemma square_mod3_0 : forall x, mod3 (x * x) = 0 -> mod3 x = 0.
intro x; apply mod3_ind with (n := x); intros; auto.
 simpl in H; discriminate.
 simpl in H0.
  rewrite plus_comm in H0; simpl in H0.
   rewrite plus_comm in H0; simpl in H0.
    rewrite plus_assoc in H0; rewrite plus_comm in H0; simpl in H0.
     rewrite plus_comm in H0; rewrite plus_assoc in H0.
      rewrite tripleadd_mult3 in H0.
       rewrite mult3_add_mod3 in H0.
        rewrite mult_comm in H0; simpl in *.
         repeat (rewrite plus_assoc in H0).
          rewrite tripleadd_mult3 in H0.
           rewrite mult3_add_mod3 in H0.
            auto.
Qed.

Lemma mod3_0_mult3 : forall n, mod3 n = 0 -> exists m, n = 3 * m.
intro n; apply mod3_ind with (n := n); intuition.
 exists 0; auto.
 simpl in H; discriminate.
 simpl in H; discriminate.
 destruct H1.
  exists (S x).
   rewrite H; simpl.
    f_equal.
     rewrite (plus_comm _ (S _)); simpl; f_equal.
      rewrite (plus_comm _ (S _)); simpl; f_equal.
       rewrite (plus_comm _ 0); simpl; apply plus_assoc.
Qed.

Lemma mult3_eq : forall m n, 3 * m = 3 * n -> m = n.
 (* もちろん3でなくても0でなければ成り立つ。使わないからこれだけ *)
intros m n; repeat (rewrite (mult_comm 3)); revert n; induction m; intros.
 destruct n.
  auto.
   simpl in H; inversion H.
 destruct n; simpl in H; inversion H.
  f_equal; auto.
Qed.

(*  (2)の一部： a^2 + b^2 = 3c^2ならば 3|a^2 かつ 3|b^2   めんどくさいのでNotationはなし *)
Lemma Prob2_ab : forall a b c, a * a + b * b = 3 * c * c -> mod3 (a * a) = 0 /\ mod3 (b * b) = 0.
intros.
 rewrite <- mult_assoc in H; rewrite (mult_comm 3) in H.
  assert (mod3 (a * a + b * b) = 0).
   rewrite H; apply mult3_mod3.
   rewrite mod3_add_mod3 in H0.
    case Prob1 with a; case Prob1 with b; intros; auto;
     rewrite H1 in H0; rewrite H2 in H0; simpl in H0; discriminate.
Qed.

(*  (2)の一部： a^2 + b^2 = 3c^2ならば 3|c^2 *)
Lemma Prob2_c : forall a b c, a * a + b * b = 3 * c * c -> mod3 (c * c) = 0.
intros.
 destruct (Prob2_ab a b c H).
  apply square_mod3_0 in H0.
   apply square_mod3_0 in H1.
    apply mod3_0_mult3 in H0.
      apply mod3_0_mult3 in H1.
       destruct H0; destruct H1; subst.
        repeat (rewrite <- mult_assoc in H).
         rewrite <- mult_plus_distr_l in H.
          apply mult3_eq in H.
           rewrite <- H.
            repeat (rewrite (mult_comm 3)).
             repeat (rewrite mult_assoc).
              repeat (rewrite <- (mult_comm 3)).
               rewrite <- mult_plus_distr_l.
                rewrite mult_comm.
                 apply mult3_mod3.
Qed.

(*  (2)  *)
Theorem Prob2 : forall a b c, a * a + b * b = 3 * c * c -> mod3 (a * a) = 0 /\ mod3 (b * b) = 0 /\ mod3 (c * c) = 0.
intros.
 destruct Prob2_ab with a b c as [H0 H1]; assert (H2 := Prob2_c _ _ _ H); auto.
Qed.

(********************************** (3)の準備 **************************************)

Fixpoint div3 n :=
match n with
| S (S (S m)) => S (div3 m)
| _ => 0
end.

Lemma div3_mod3 : forall n, n = (div3 n) * 3 + mod3 n.
apply mod3_ind; intros; auto.
 simpl.
  repeat f_equal; auto.
Qed.

(* div3に基づく帰納法の準備：なお、well-founded inductionを使うならば0<nでdiv3 n < nを示せば十分 *)
Fixpoint exp3 n :=
match n with
| O => 1
| S n' => 3 * exp3 n'
end.

(* 3で割って0になるまでの回数：この第二引数で帰納法を行う *)
Inductive div3num : nat -> nat -> Prop :=
| div3_O : div3num 0 0
| div3_n : forall m n, exp3 n <= m -> m < exp3 (S n) -> div3num m (S n).

Lemma exp3_not0 : forall n, exp3 n <> 0.
induction n.
 simpl; intro; inversion H.
 simpl.
  intro H; apply IHn.
   destruct (plus_is_O _ _ H); auto.
Qed.

Lemma exp3_lt : forall n, exp3 n < exp3 (S n).
intro; simpl.
 case_eq (exp3 n); intros.
  elim (exp3_not0 _ H).
  unfold lt.
   simpl.
    rewrite plus_comm; simpl.
     repeat (apply le_n_S).
      rewrite <- plus_assoc; apply le_plus_l.
Qed.

Lemma div3num_ex : forall n, exists m, div3num n m.
induction n.
 exists 0.
  constructor.
 destruct IHn.
  inversion H.
   exists 1.
    constructor; simpl; auto.
   unfold lt in H1.
    apply le_lt_or_eq in H1.
     subst; destruct H1.
      exists (S n0); constructor.
       apply le_trans with n; auto.
       auto.
      exists (S (S n0)).
       constructor.
        rewrite H1; auto.
        rewrite H1; apply exp3_lt.
Qed.

Lemma mult3_div3 : forall n, div3 (3 * n) = n.
apply mod3_ind; intros; auto.
 simpl.
  f_equal.
   rewrite plus_comm; simpl; f_equal.
    rewrite (plus_comm n); simpl; f_equal.
     rewrite (plus_comm n); simpl; rewrite tripleadd_mult3.
      rewrite mult_comm; auto.
Qed.

Lemma exp3_div3_pred : forall n, div3 (exp3 (S n)) = exp3 n.
intro; unfold exp3.
 apply mult3_div3.
Qed.

Lemma div3_le : forall m n, m <= n -> div3 m <= div3 n.
fix f 1; intros.
 destruct m as [ | [ | [ | m ]]]; try (apply le_O_n).
  destruct n.
   elim (le_Sn_O _ H).
   apply le_S_n in H; destruct n.
    elim (le_Sn_O _ H).
    apply le_S_n in H; destruct n.
     elim (le_Sn_O _ H).
     simpl; apply le_n_S.
      apply f.
       apply le_S_n; apply H.
Qed.

Lemma div3_mult3_S : forall m, div3 (m * 3) = div3 (S (m * 3)).
fix f 1.
 intro.
  destruct m.
   reflexivity.
    simpl.
     f_equal.
      apply f.
Qed.

Lemma div3_mult3_SS : forall m, div3 (m * 3) = div3 (S (S (m * 3))).
fix f 1.
 intro.
  destruct m.
   reflexivity.
    simpl.
     f_equal.
      apply f.
Qed.

Lemma div3_exp3_lt : forall m n, m < exp3 (S n) -> div3 m < exp3 n.
induction m; intros.
 case_eq (exp3 n); intros.
  elim (exp3_not0 _ H0).
  unfold lt; apply le_n_S; apply le_O_n.
 rewrite (div3_mod3 m).
  case (mod3_case m); intro.
   rewrite H0.
    rewrite plus_comm; simpl plus; rewrite <- div3_mult3_S.
     rewrite mult_comm; rewrite mult3_div3.
      apply IHm.
       apply lt_trans with (S m); auto.
   destruct H0.
    rewrite H0; rewrite plus_comm; simpl plus; rewrite <- div3_mult3_SS.
     rewrite mult_comm; rewrite mult3_div3.
      apply IHm.
       apply lt_trans with (S m); auto.
    rewrite H0; rewrite plus_comm; simpl.
     rewrite mult_comm; rewrite mult3_div3.
      assert (m < S m).
       auto.
       apply (lt_trans _ _ (exp3 (S n))) in H1; auto.
        apply IHm in H1.
         unfold lt in H1; apply le_lt_or_eq in H1.
          destruct H1; auto.
           unfold lt in H.
            rewrite (div3_mod3 m) in H.
             rewrite plus_comm in H; rewrite H0 in H; simpl plus in H.
              simpl exp3 in H; rewrite <- H1 in H.
               rewrite mult_comm in H; simpl in H.
                rewrite (plus_comm _ 0) in H; apply le_S_n in H.
                 rewrite (plus_comm _ (S _)) in H; simpl in H; apply le_S_n in H.
                  rewrite (plus_comm _ (S _)) in H.
                   rewrite <- plus_assoc in H.
                    simpl in H; apply le_S_n in H.
                     elim (le_Sn_n _ H).
Qed.

Lemma div3num_div3_decrease : forall m n, div3num n (S m) -> div3num (div3 n) m.
intros.
 inversion H.
  destruct m.
   unfold lt in *; simpl in *.
    destruct n as [ | [ | [ | n ]]]; try constructor.
     repeat (apply le_S_n in H3).
      elim (le_Sn_O n H3).
   constructor.
    rewrite <- exp3_div3_pred; apply div3_le; auto.
    apply div3_exp3_lt; auto.
Qed.

(* div3に基づく帰納法：割ったもので証明が作れる *)
Lemma div3_ind : forall P : nat -> Prop,
 P 0 ->
 (forall n, P (div3 n) -> P n) -> forall n, P n.
intros P H0 IH n.
 destruct (div3num_ex n).
  revert n H; induction x; intros.
   inversion H.
    auto.
   apply IH.
    apply div3num_div3_decrease in H.
     auto.
Qed.

(*  (3)の一部：a = 0のみ  *)
Lemma Prob3_a : forall a b c, a * a + b * b = 3 * c * c -> a = 0.
intro a; apply div3_ind with (n:=a); intros.
 auto.
 destruct (Prob2 n b c H0) as [H1 [H2 H3]].
  apply square_mod3_0 in H1;
     apply square_mod3_0 in H2;
     apply square_mod3_0 in H3.
   apply mod3_0_mult3 in H1;
       apply mod3_0_mult3 in H2;
       apply mod3_0_mult3 in H3.
    destruct H1;
        destruct H2;
        destruct H3.
     subst.
      rewrite mult3_div3 in H.
       assert (3 * x = 3 * 0 -> 3 * x = 0).
        auto.
        apply H1.
         f_equal.
          apply H with x0 x1.
           repeat (rewrite <- mult_assoc in H0).
            rewrite <- mult_plus_distr_l in H0.
             apply mult3_eq in H0.
              repeat (rewrite (mult_comm 3) in H0).
               repeat (rewrite mult_assoc in H0).
                repeat (rewrite (mult_comm _ 3) in H0).
                 rewrite <- mult_plus_distr_l in H0.
                  apply mult3_eq in H0.
                   rewrite H0; apply mult_assoc.
Qed.

(*  (3)の一部：b = 0のみ  *)
Lemma Prob3_b : forall a b c, a * a + b * b = 3 * c * c -> b = 0.
intros.
 rewrite (Prob3_a _ _ _ H) in H.
  clear a; revert c H; apply div3_ind with (n:=b); intros.
   auto.
   destruct (Prob2 _ _ _ H0) as [_ [H2 H3]].
    simpl plus in *.
     apply square_mod3_0 in H2;
         apply square_mod3_0 in H3.
      apply mod3_0_mult3 in H2;
          apply mod3_0_mult3 in H3.
       destruct H2; destruct H3.
        subst.
         rewrite mult3_div3 in H.
          repeat (rewrite <- mult_assoc in H0).
           apply mult3_eq in H0.
            repeat (rewrite mult_assoc in H0).
             repeat (rewrite (mult_comm _ 3) in H0).
              repeat (rewrite <- mult_assoc in H0).
               apply mult3_eq in H0.
                rewrite mult_assoc in H0.
                 apply H in H0.
                  rewrite H0; auto.
Qed.

(*  (3) a^2 + b^2 = 3c^2 ならば a = b = c = 0  *)
Theorem Prob3 : forall a b c, a * a + b * b = 3 * c * c -> a = 0 /\ b = 0 /\ c = 0.
intros.
 assert (H0 := Prob3_a _ _ _ H).
  assert (H1 := Prob3_b _ _ _ H).
   subst; split; auto.
    split; auto.
     simpl plus in H.
      destruct c; auto.
       simpl in H; inversion H.
Qed.

End tpp2014.


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Definition length1 (n : nat) (l : listn n) :=
  match l with
  | consn n _ (consn m _ _) => S (S m)
  | consn n _ _ => 1
  | _ => 0
  end.

Type
  (fun (n : nat) (l : listn n) =>
   match n return nat with
   | O => 0
   | S n => match l return nat with
            | niln => 1
            | l' => length1 (S n) l'
            end
   end).