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

(* ** Object-level encoding of bounded universal quantification *)

Require Import Arith Lia List Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list sums bounded_quantification.

From Undecidability.H10.Matija
  Require Import cipher.

From Undecidability.H10.Dio
  Require Import dio_logic dio_cipher dio_elem.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).

(* We show the elimination of bounded universal quantification. The proof is
    based on the paper

       "A new technique for obtaining Diophantine representations via
        elimination of bounded universal quantifiers" by Matiyasevich (1997)

    with two noticable differences

    a) I use r = 2^(4*q) instead of r = 2^(2*q).

       2*q could work but I think the proof that cc = aa * bb is simulated
       (implied by the paper -- the proof is not given) does not work well
       because masked digits can be of the form f i * g j + f j * g i
       and f _ < 2^q,  g _ < 2^q implies f _ * g _ < 2^(2*q) which is
       good but *does not* imply  f _ * g _ + g _ * f _ < 2^(2*q) !!

       The argument could still work though it is going to be much
       more complicated to establish formally, so I raised 2*q to 4*q
       to solve straightforwardly the overflow problem of masked digits
       Anyway, this 2*q value was arbitrary so it only impacts the
       proof in minor ways.

    b) The arguments outlined between (26) and (31) are flawed I think
       One should first split the k_i's in

                 0 <= k_2 < .... < k_d <= 2^l+1 < .... < k_{m+1}

       to do the computation. The upper k_i's are masked out and then you
       can show that d must be m+1 with the other constraints.
*)

Section dio_rel_bounded_fall.

  Section dio_bounded_elem.

    Variable (k : nat).

    (* ω : nat -> nat
       for i < k, ω represents the cipher of the corresponding variable x_i
       for i = k, ω represents the cipher of <0,...,l-1>
       for i = k+1, ω contains the value q
       for i = k+2, ω contains the value l
       for k+2 < i, ω represents the value of parameter i-k-2>0  *)

    Notation iq := (k+1).  (* The index of q in ω *)
    Notation il := (k+2).  (* The index of l in ω *)

    Let dc_Code (c : dio_constraint) ω :=
      match c with
       | (u, dee_nat n)           => Const (ω il) (ω iq) n (ω u)
       | (u, dee_var v)           => ω u = ω v
       | (u, dee_par 0)           => ω u = ω k
       | (u, dee_par (S p))       => Const (ω il) (ω iq) (ω (k+2+p)) (ω u)
       | (u, dee_comp do_add v w) => Code_plus (ω u) (ω v) (ω w)
       | (u, dee_comp do_mul v w) => Code_mult (ω il) (ω iq) (ω u) (ω v) (ω w)
      end.

    Local Fact dio_rel_dc_Code c : 𝔻R (dc_Code c).
    Proof.
      destruct c as (u & [ n | v | [] | [] v w ]); unfold dc_Code; dio auto.
    Defined.

    Hint Resolve dio_rel_dc_Code : dio_rel_db.

   (*

      Eval compute in df_size_Z (proj1_sig (dio_rel_dc_Code (0,dee_comp do_mul 1 2))).

    *)

    (* Case of do_mul gives the overall bound

    Let dc_Code_size_Z c : (df_size_Z (proj1_sig (dio_rel_dc_Code c)) <= 203468)%Z.
    Proof.
      destruct c as (u & [ n | v | [] | [] v w ]); compute; discriminate.
    Qed. *)

    (*  ω         | (φ _)    ~  π    |  ν
        i < k     | i        |  i    |
        i = k     | <0,..,l> |  ?    |
        i = k+1   |          |  q    |
        i = k+2   |          |  l    |  0
        i > k+2   |          |       |  i-(k+2)
     *)

    Local Fact dc_Code_spec c φ π ν ω :
          (forall i, i < k -> is_cipher_of (ν 0) (π iq) (φ i) (π i))
       -> (is_cipher_of (ν 0) (π iq) (fun n => n) (π k))
       -> (forall x, dc_vars c x -> x < k)
       -> (forall i, i < il -> ω i = π i)
       -> (forall i, il <= i -> ω i = ν (i-il))
       -> dc_Code c ω
      <-> forall j, j < ν 0 -> dc_eval (fun i => φ i j) (j·ν) c.
    Proof.
      intros G1 G2 G3 G4 G5.
      assert (ω il = ν 0) as G0.
      { rewrite G5; try lia; f_equal; lia. }
      destruct c as (u & [ n | v | [ | p ] | [] v w ]); simpl.
      + assert (u < k) as Hu. { apply G3; left; auto. }
        rewrite G0, G4, G4; try lia.
        specialize (G1 _ Hu).
        unfold dc_eval; simpl; split.
        * intros (g & Hg1 & Hg4).
          generalize (is_cipher_of_inj G1 Hg1); intros G6.
          intros; rewrite G6, Hg4; auto; lia.
        * intros; exists (φ u); split; auto.
      + assert (u < k) as Hu. { apply G3; cbv; auto. }
        assert (v < k) as Hv. { apply G3; cbv; auto. }
        do 2 (rewrite G4; try lia).
        unfold dc_eval; simpl.
        apply G1 in Hu.
        apply G1 in Hv.
        apply (is_cipher_of_equiv Hu Hv).
      + assert (u < k) as Hu. { apply G3; cbv; auto. }
        do 2 (rewrite G4; try lia).
        unfold dc_eval; simpl.
        apply G1 in Hu.
        apply (is_cipher_of_equiv Hu G2).
      + rewrite G0, G4; try lia.
        rewrite G5; try lia.
        replace (il+p-il) with p by lia.
        assert (u < k) as Hu. { apply G3; cbv; auto. }
        rewrite G4; try lia.
        apply G1 in Hu.
        unfold dc_eval; simpl; split.
        * intros (g & Hg1 & Hg2).
          generalize (proj1 (is_cipher_of_equiv Hu Hg1) eq_refl); intros G6.
          intros; rewrite G6, Hg2; auto.
        * intro; exists (φ u); auto.
      + assert (Hu : u < k). { apply G3; cbv; auto. }
        assert (Hv : v < k). { apply G3; cbv; auto. }
        assert (Hw : w < k). { apply G3; cbv; auto. }
        do 3 (rewrite G4; try lia).
        apply G1 in Hu; apply G1 in Hv; apply G1 in Hw.
        rewrite Code_plus_spec with (1 := Hu) (2 := Hv) (3 := Hw).
        unfold dc_eval; simpl; tauto.
      + assert (Hu : u < k). { apply G3; cbv; auto. }
        assert (Hv : v < k). { apply G3; cbv; auto. }
        assert (Hw : w < k). { apply G3; cbv; auto. }
        rewrite G0; do 4 (rewrite G4; try lia).
        apply G1 in Hu; apply G1 in Hv; apply G1 in Hw.
        rewrite Code_mult_spec with (1 := Hu) (2 := Hv) (3 := Hw).
        unfold dc_eval; simpl; tauto.
    Qed.

    Local Definition dc_list_Code ll ν := fold_right (fun c P => dc_Code c ν /\ P) True ll.

    Local Fact dio_rel_dc_list_Code ll : 𝔻R (dc_list_Code ll).
    Proof. induction ll; unfold dc_list_Code; simpl; dio auto. Qed.

    Hint Resolve dio_rel_dc_list_Code : dio_rel_db.

    Local Fact dc_list_Code_spec ll φ π ν ω :
          (forall i, i < k -> is_cipher_of (ν 0) (π iq) (φ i) (π i))
       -> (is_cipher_of (ν 0) (π iq) (fun n => n) (π k))
       -> (forall c, In c ll -> forall x, dc_vars c x -> x < k)
       -> (forall i, i < il  -> ω i = π i)
       -> (forall i, il <= i -> ω i = ν (i-il))
       -> dc_list_Code ll ω
      <-> forall j, j < ν 0 -> Forall (dc_eval (fun i => φ i j) (j·ν)) ll.
    Proof.
      intros G1 G2 G3 G4 G5; revert G3.
      rewrite <- Forall_forall.
      induction 1 as [ | c ll F1 F2 IF2 ]; simpl.
      + split; auto.
      + rewrite IF2, dc_Code_spec; auto.
        split.
        * intros (E1 & E2) j Hj; constructor; auto.
        * intros E1; split; intros j Hj; specialize (E1 _ Hj);
            rewrite Forall_cons_inv in E1; tauto.
    Qed.

    Local Definition ciphers ν :=
             CodeNat (ν il) (ν iq) (ν k)
          /\ forall i, i < k -> Code (ν il) (ν iq) (ν i).

    Local Fact dio_rel_ciphers : 𝔻R ciphers.
    Proof.
      unfold ciphers; dio auto.
      apply dio_rel_finite_conj; intros; dio auto.
    Defined.

    Hint Resolve dio_rel_ciphers : dio_rel_db.

    Local Fact ciphers_spec ν :
           ciphers ν <-> is_cipher_of (ν il) (ν iq) (fun n => n) (ν k)
                      /\ exists φ, forall i, i < k -> is_cipher_of (ν il) (ν iq) (φ i) (ν i).
    Proof.
      unfold ciphers, Code, CodeNat.
      split; intros (H1 & H2); split; auto; clear H1.
      + apply fmap_reifier_default in H2; auto.
      + destruct H2 as (phi & Hphi).
        intros i Hi; exists (phi i); auto.
    Qed.

    Variables (ll : list dio_constraint)
              (Hll : forall c x, In c ll -> dc_vars c x -> x < k).

    Let Hll' : forall c, In c ll -> forall x, dc_vars c x -> x < k.
    Proof. intros c ? x ?; apply (@Hll c x); auto. Qed.

    Let pre_quant ν := ν il+1 < ν iq /\ ciphers ν /\ dc_list_Code ll ν.

    Let dio_rel_pre_quant : 𝔻R pre_quant.
    Proof. unfold pre_quant; dio auto. Defined.

    Let dc_list_bfall ν := exists π, pre_quant (fun i => if le_lt_dec il i then ν (i-il) else π i).

    Let dc_list_bfall_spec_1 ν :
            dc_list_bfall ν
        <-> exists q φ, ν 0+1 < q
                    /\ (forall i j, i < k -> j < ν 0 -> φ i j < power q 2)
                    /\  forall j, j < ν 0 -> Forall (dc_eval (fun i => φ i j) (j·ν)) ll.
    Proof.
      split.
      + intros (pi & G0 & G1 & G4).
        rewrite ciphers_spec in G1.
        destruct (le_lt_dec il k) as [ ? | _ ]; try lia.
        destruct (le_lt_dec il il) as [ _  | ? ]; try lia.
        destruct (le_lt_dec il iq) as [ ? | _ ]; try lia.
        replace (il-il) with 0 in * by lia.
        destruct G1 as (G1 & phi & G3).
        assert (forall i, i < k -> is_cipher_of (ν 0) (pi iq) (phi i) (pi i)) as G2.
        { intros i Hi; generalize (G3 _ Hi); destruct (le_lt_dec il i); auto; lia. }
        clear G3.
        rewrite dc_list_Code_spec with (π := pi) (φ := phi) (ν := ν) in G4; auto.
        2,3: intros i Hi; destruct (le_lt_dec il i) as [ H | H ]; auto; try lia.
        exists (pi iq), phi; repeat (split; auto).
        intros i j Hi Hj; destruct (G2 _ Hi) as (_ & G3 & _); auto.
      + intros (q & phi & Hq & Hphi1 & Hphi2).
        assert (q <= power q 2) as Hq' by (apply power_ge_n; auto).
        destruct (the_cipher (fun i => i) Hq) as (u & Hu). { intros; lia. }

        set (pi i := match lt_eq_lt_dec i k with
                     | inleft (left H)  => proj1_sig (the_cipher (phi i) Hq (fun j Hj => Hphi1 _ _ H Hj))
                     | inleft (right H) => u
                     | inright H        => q
                   end).
        assert (Hpi_k : pi k = u).
        { unfold pi; destruct (lt_eq_lt_dec k k) as [ [] | ]; auto; try lia. }
        assert (forall i, i < k -> is_cipher_of (ν 0) q (phi i) (pi i)) as Hpi.
        { unfold pi; intros i Hi.
          destruct (lt_eq_lt_dec i k) as [ [H | ] | ]; try lia.
          apply (proj2_sig (the_cipher (phi i) Hq (fun j Hj => Hphi1 _ _ H Hj))). }
        assert (Hpi_q : pi iq = q).
        { unfold pi; destruct (lt_eq_lt_dec iq k) as [ [H | ] | ]; try lia. }
        generalize pi Hpi_k Hpi_q Hpi; clear pi Hpi_k Hpi Hpi_q.
        intros pi Hpi_k Hpi_q Hpi; subst u.

        exists pi; red.
        rewrite ciphers_spec.
        destruct (le_lt_dec il k) as [ ? | _ ]; try lia.
        destruct (le_lt_dec il il) as [ _ | ? ]; try lia.
        destruct (le_lt_dec il iq) as [ ? | _ ]; try lia.
        rewrite Nat.sub_diag.
        subst q; repeat (split; auto).
        * exists phi; intros i Hi.
          destruct (le_lt_dec il i); try lia; auto.
        * rewrite dc_list_Code_spec with (π := pi) (φ := phi); auto;
            intros i Hi; destruct (le_lt_dec il i); auto; lia.
    Qed.

    Let dc_list_bfall_spec ν :
            (forall i, i < ν 0 -> exists φ, Forall (dc_eval φ i·ν) ll)
        <-> dc_list_bfall ν.
    Proof.
      rewrite dc_list_bfall_spec_1; split.
      + intros H.
        apply fmmap_reifer_bound  with (p := k) in H.
        - destruct H as (m & phi & Hf).
          set (q := power (ν 0+2+m) 2).
          assert (ν 0+1 < q) as Hlq.
          { apply Nat.lt_le_trans with (ν 0+2+m); try lia.
            apply power_ge_n; auto. }
          assert (m <= power q 2) as Hmq.
          { apply Nat.le_trans with q.
            apply Nat.le_trans with (ν 0+2+m); try lia.
            apply power_ge_n; auto.
            apply power_ge_n; auto. }
          exists q, (fun i j => phi j i); split; [ | split ]; auto.
          * intros i j Hi Hj; apply Nat.lt_le_trans with m; auto; apply Hf; auto.
          * intros; apply Hf; auto.
        - intros x f g Hfg.
          apply Forall_impl.
          intros c Hc; apply dc_eval_ext; auto.
          intros z Hz; symmetry; apply Hfg, Hll with c; auto.
      + intros (q & phi & Hq & H1 & H2) j Hj.
        exists (fun i => phi i j); auto.
    Qed.

    Local Theorem dio_rel_dc_list_bfall : 𝔻R (fun ν => forall i, i < ν 0 -> exists φ, Forall (dc_eval φ i·ν) ll).
    Proof using Hll.
      dio by lemma dc_list_bfall_spec; unfold dc_list_bfall.
      destruct dio_rel_pre_quant as (f & Hf).
      exists (df_mexists il f).
      abstract (intros; rewrite df_mexists_spec; split;
        intros (phi & H); exists phi; revert H; rewrite <- Hf; auto).
    Defined.

  End dio_bounded_elem.

  Local Theorem dio_rel_bounded_fall R : 𝔻R R -> 𝔻R (fun ν => forall i, i < ν 0 -> R i·ν).
  Proof.
    intros (f & Hf).
    destruct (dio_formula_elem f) as (ll & H1 & H2 & H3).
    revert H2; generalize (4*df_size f); intros k H2.
    generalize (dio_rel_dc_list_bfall _ H2); apply dio_rel_equiv.
    abstract (intros v; split; intros H i Hi; generalize (H _ Hi); rewrite <- Hf, H3; auto).
  Defined.

End dio_rel_bounded_fall.

(* Composition and renaming to get the desired result,
    ie Matiyasevich theorem of 1997 stating the

      "Diophantine admissibility of
           bounded universal quantification"

    ie bounded universal quantification is a
    Diophantine shape
*)

Theorem dio_rel_fall_lt a (R : nat -> (nat -> nat) -> Prop) :
           𝔻F a
   -> 𝔻R (fun ν => R (ν 0) ν⭳)
   -> 𝔻R (fun ν => forall x, x < a ν -> R x ν).
Proof.
  intros Ha H.
  by dio equiv (fun ν => exists y, y = a ν /\ forall x, x < y -> R x ν).
  + abstract(intros v; split;
      [ exists (a v); auto
      | intros (? & -> & ?); auto ]).
  + set (T v := R (v 0) v⭳⭳).
    by dio equiv (fun v => forall x, x < v 0 -> T (x·v)).
    * abstract (intros v; unfold T; simpl; tauto).
    * apply dio_rel_bounded_fall; unfold T; simpl.
      revert H; apply dio_rel_ren
        with (ρ := fun n => match n with 0 => 0 | S n => S (S n) end).
Defined.

#[export] Hint Resolve dio_rel_fall_lt : dio_rel_db.

(* Two variants *)

Corollary dio_rel_fall_lt_bound a (R : nat -> nat -> (nat -> nat) -> Prop) :
           𝔻F a
   -> 𝔻R (fun ν => R (ν 0) (a ν⭳) ν⭳)
   -> 𝔻R (fun ν => forall x, x < a ν -> R x (a ν) ν).
Proof. intros; dio auto. Defined.

Corollary dio_rel_fall_le a (R : nat -> (nat -> nat) -> Prop) :
           𝔻F a
   -> 𝔻R (fun ν => R (ν 0) ν⭳)
   -> 𝔻R (fun ν => forall x, x <= a ν -> R x ν).
Proof.
  intros Ha HK.
  by dio equiv (fun v => forall x, x < 1+a v -> R x v).
  abstract (intros v; split; intros H x Hx; apply H; lia).
Defined.

#[export] Hint Resolve dio_rel_fall_lt_bound
             dio_rel_fall_le : dio_rel_db.


Require Import ZArith.
Local Open Scope Z_scope.
Require Import compcert.lib.Integers.

Fixpoint repeat_op_nat{T: Type}(n: nat)(start: T)(op: T -> T): T := match n with
| O => start
| S m => op (repeat_op_nat m start op)
end.

Definition repeat_op{T: Type}(n: Z)(start: T)(op: T -> T): T := repeat_op_nat (Z.to_nat n) start op.

Lemma repeat_op_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op (i + 1) start op = op (repeat_op i start op).
Proof.
  intros. unfold repeat_op. rewrite Z2Nat.inj_add by omega.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Definition times2(x: int): int :=
  Int.and
    (Int.xor (Int.shl x (Int.repr 1))
             (if Int.eq (Int.and x (Int.repr 128)) Int.zero then Int.zero else Int.repr 27))
    (Int.repr 255).

Definition pow2(e: Z): int := repeat_op e (Int.repr 1) times2.

Definition times3(x: int): int :=
  Int.and
    (Int.xor x (Int.xor (Int.shl x (Int.repr 1))
                        (if Int.eq (Int.and x (Int.repr 128)) Int.zero then Int.zero else Int.repr 27)))
    (Int.repr 255).

Definition pow3(e: Z): int := repeat_op e (Int.repr 1) times3.

Fixpoint log3_nat(p: int)(n: nat): Z :=
  if Int.eq p (pow3 (Z.of_nat n)) then Z.of_nat n
  else match n with
  | O => -1 (* illegal argument *)
  | S m => log3_nat p m
  end.

(* Note: For (log3 1), we have two possible return values: 0 and 255.
   We choose 255, because then both the domain and the codomain of log3 are 1..255. *)
Definition log3(p: int): Z := log3_nat p 255.

Definition mul(x y: int): int :=
  if Int.eq x Int.zero then Int.zero else
  if Int.eq y Int.zero then Int.zero else
  pow3 (Int.unsigned (Int.mods (Int.repr (log3 x + log3 y)) (Int.repr 255))).

Lemma pow3_not0: forall i, pow3 i <> Int.zero.
Admitted.

Lemma pow3log3: forall j,
  1 <= j < 256 ->
  Int.unsigned (pow3 (log3 (Int.repr j))) = j.
Admitted.

Lemma log3range: forall j,
  1 <= j < 256 ->
  1 <= log3 (Int.repr j) < 256.
Admitted.

Lemma mod_range: forall i m,
  0 <= i ->
  0 < m ->
  0 <= Int.unsigned (Int.mods (Int.repr i) (Int.repr m)) < m.
Admitted.

Lemma pow2_range: forall e,
  0 <= e ->
  0 <= Int.unsigned (pow2 e) < 256.
Admitted.

Lemma pow3_range: forall e,
  0 <= e ->
  0 <= Int.unsigned (pow3 e) < 256.
Admitted.

Lemma pow3_inj: forall (i j : Z),
  pow3 i = pow3 j -> Int.eqmod 255 i j.
Admitted.

Lemma invert_pow3: forall i,
  1 <= i < 256 ->
  exists j, 1 <= j < 256 /\ i = (Int.unsigned (pow3 j)).
Admitted.


Inductive term : Type :=
| ttrue : term
| tfalse : term
| tif : term -> term -> term -> term.

Inductive eval : term -> term -> Prop :=
| E_IfTrue : forall (t2 t3: term), eval (tif ttrue t2 t3) t2
| E_IfFalse : forall (t2 t3: term), eval (tif tfalse t2 t3) t3
| E_If : forall (t1 t1' t2 t3: term), eval t1 t1' -> eval (tif t1 t2 t3) (tif t1' t2 t3).

Notation "t1 --> t2" := (eval t1 t2) (at level 60).

Example s := tif ttrue tfalse tfalse.

Lemma one_step_s : eval s tfalse.
Proof.
  apply E_IfTrue.
Qed.

Theorem determinancy_of_one_step : forall t t' t'', (t --> t') -> (t --> t'') -> t' = t''.
Proof.
  intros.
  generalize dependent t''.
  induction H; intros; inversion H0; subst.
  - reflexivity.
  - inversion H4.
  - reflexivity.
  - inversion H4.
  - inversion H.
  - inversion H.
  - apply IHeval in H5.
    rewrite H5.
    reflexivity.
Qed.

Inductive value : term -> Prop :=
| vtrue : value ttrue
| vfalse : value tfalse.

Definition normal_form (t: term): Prop :=
  ~ exists t', t --> t'.

Theorem value_is_normal_form : forall t, value t -> normal_form t.
Proof.
  intros.
  unfold normal_form.
  unfold not.
  induction H; intros; inversion H; inversion H0.
Qed.

Proposition PNNP: forall p: Prop, p -> ~ ~p.
Proof.
  unfold not.
  now intros p H notH.
Qed.

Theorem tif_is_not_normal : forall t0 t1 t2, ~ (normal_form (tif t0 t1 t2)).
Proof.
  unfold normal_form.
  intros.
  apply PNNP.
  generalize dependent t2.
  generalize dependent t1.
  induction t0.
  - intros.
    exists t1.
    constructor.
  - intros.
    exists t2.
    constructor.
  - intros.
    specialize IHt0_1 with t0_2 t0_3.
    destruct IHt0_1.
    exists (tif x t1 t2).
    constructor.
    assumption.
Qed.

Theorem normal_form_is_value : forall t, normal_form t -> value t.
Proof.
  intros.
  destruct t; try constructor.
  absurd (normal_form (tif t1 t2 t3)).
  - apply tif_is_not_normal.
  - assumption.
Qed.

Inductive multi_eval : term -> term -> Prop :=
| M_Eval : forall t1 t2, eval t1 t2 -> multi_eval t1 t2
| M_Refl : forall t1, multi_eval t1 t1
| M_Trans : forall t1 t2 t3, multi_eval t1 t2 -> multi_eval t2 t3 -> multi_eval t1 t3.

Notation "t1 -->* t2" := (multi_eval t1 t2) (at level 60).

Lemma one_step_is_multistep : forall t0 t1, t0 --> t1 -> t0 -->* t1.
Proof.
  intros.
  now constructor.
Qed.

Inductive multi_eval' : term -> term -> Prop :=
| M_Eval' : forall t1 t2, eval t1 t2 -> multi_eval' t1 t2
| M_Refl' : forall t1, multi_eval' t1 t1
| M_Trans' : forall t1 t2 t3, eval t1 t2 -> multi_eval' t2 t3 -> multi_eval' t1 t3.

Notation "t1 ->->* t2" := (multi_eval' t1 t2) (at level 60).

Lemma multi_eval'_transitive : forall t1 t2 t3, multi_eval' t1 t2 -> multi_eval' t2 t3 -> multi_eval' t1 t3.
Proof.
  intros.
  induction H.
  - apply M_Trans' with (t1 := t1) in H0. assumption. assumption.
  - assumption.
  - apply IHmulti_eval' in H0.
    apply M_Trans' with (t1 := t1) in H0.
    + assumption.
    + assumption.
Qed.

Lemma multi_eval_iff_multi_eval' : forall t1 t2, t1 ->->* t2 <-> t1 -->* t2.
Proof.
  intros.
  split.
  - intros.
    induction H.
    + now apply M_Eval in H.
    + constructor; constructor.
    + apply M_Eval in H.
      apply M_Trans with (t1 := t1) in IHmulti_eval'.
      * assumption.
      * assumption.
  - intros.
    induction H; subst.
    + now apply M_Eval' in H.
    + constructor; constructor.
    + apply multi_eval'_transitive with (t2 := t2).
      * assumption.
      * assumption.
Qed.

Theorem muti_eval_uniqueness_of_normal_form : forall t u u', t -->* u -> t -->* u' -> normal_form u -> normal_form u' -> u = u'.
Proof.
  intros.
  apply multi_eval_iff_multi_eval' in H.
  apply multi_eval_iff_multi_eval' in H0.
  induction H.
  - induction H0.
    + now apply determinancy_of_one_step with (t := t1) (t' := t2) (t'' := t0).
    + destruct H2. now exists t2.
    + induction H3.
      * apply IHmulti_eval'.
        apply determinancy_of_one_step with (t' := t2) in H0.
        rewrite <- H0 in H3.
        destruct H1.
        exists t3.
        assumption.
        assumption.
        assumption.
      * apply determinancy_of_one_step with (t' := t0) in H.
        symmetry. assumption. assumption.
      * apply determinancy_of_one_step with (t' := t0) in H.
        rewrite <- H in H1.
        destruct H1.
        exists t3.
        assumption.
        assumption.
  - induction H0.
    + destruct H1.
      now exists t2.
    + reflexivity.
    + destruct H1.
      now exists t2.
  - induction H0.
    + apply determinancy_of_one_step with (t' := t2) in H0.
      * rewrite H0 in IHmulti_eval'. destruct IHmulti_eval'.
        apply M_Refl'. assumption. reflexivity.
      * assumption.
    + destruct H2.
      now exists t2.
    + apply determinancy_of_one_step with (t' := t2) in H0.
      * rewrite H0 in IHmulti_eval'. destruct IHmulti_eval'. assumption. assumption. reflexivity.
      * assumption.
Qed.

Lemma meval_if : forall t1 t1' t2 t3, t1 -->* t1' -> tif t1 t2 t3 -->* tif t1' t2 t3.
Proof.
intros.
induction H.
- constructor.
  constructor.
  assumption.
- apply M_Refl.
- apply M_Trans with (t2 := tif t0 t2 t3).
  * assumption.
  * assumption.
Qed.

Theorem termination_of_evaluation : forall t, exists t', (normal_form t' /\ t -->* t').
Proof.
  intros.
  induction t.
  - exists ttrue. split.
    * apply value_is_normal_form. constructor.
    * apply M_Refl.
  - exists tfalse. split.
    * apply value_is_normal_form. constructor.
    * apply M_Refl.
  - destruct IHt1 as [v1 [IH1n IH1e]].
    apply normal_form_is_value in IH1n.
    inversion IH1n; subst.
    * destruct IHt2 as [v2 [IH2n IH2e]].
      exists v2. constructor. assumption.
      assert (tif t1 t2 t3 -->* tif ttrue t2 t3). {
        apply meval_if. assumption.
      }
      assert (tif ttrue t2 t3 -->* t2). {
        constructor.
        constructor.
      }
      assert (tif t1 t2 t3 -->* t2). {
        apply M_Trans with (t2 := tif ttrue t2 t3).
        - assumption.
        - assumption.
      }
      apply M_Trans with (t2 := t2).
      + assumption.
      + assumption.
    * destruct IHt3 as [v3 [IH3n IH3e]].
      exists v3; constructor.
      assumption.
      assert (tif t1 t2 t3 -->* tif tfalse t2 t3). {
        apply meval_if. assumption.
      }
      assert (tif tfalse t2 t3 -->* t3). {
        constructor.
        constructor.
      }
      assert (tif t1 t2 t3 -->* t3). {
        apply M_Trans with (t2 := tif tfalse t2 t3).
        - assumption.
        - assumption.
      }
      apply M_Trans with (t2 := t3).
      assumption.
      assumption.
Qed.


(* $Id: Max_AbsIR.v,v 1.6 2003/03/13 12:06:25 lcf Exp $ *)

Require Export CauchySeq.

Section Maximum.

Section Max_function.
(* Tex_Prose
\subsection{The actual max function}

\begin{convention}
Let \verb!x! and \verb!y! be reals
(we will define the maximum of \verb!x! and \verb!y!).
\end{convention}
*)

Variable x,y:IR.

(* Tex_Prose
\verb!Max_seq i! corresponds with $s_i$ in informal Definition~\ref{defmax}.
*)
(* Begin_Tex_Verb *)
Definition Max_seq : nat->IR.
(* End_Tex_Verb *)
Intro i.
Elim (cotrans_less_unfolded IR Zero (one_div_succ i)) with x[-]y.
  3: Apply one_div_succ_pos.
 Intro H; Apply x.
Intro H; Apply y.
Defined.

(* Begin_Tex_Verb *)
Lemma Max_seq_char : (n:nat)
  ((Zero[<]x[-]y)*{(Max_seq n)[=]x})+
  ((x[-]y[<](one_div_succ n))*{(Max_seq n)[=]y}).
(* End_Tex_Verb *)
Intros.
Unfold Max_seq.
Elim cotrans_less_unfolded; Intro H; Simpl.
 Left; Split; Algebra.
Right; Split; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_Max_seq : (Cauchy_prop Max_seq).
(* End_Tex_Verb *)
Apply Cauchy_prop1_prop.
Intro k.
Exists k; Intros m H.
Unfold Max_seq.
Elim cotrans_less_unfolded; Intro Hm; Simpl; Elim cotrans_less_unfolded; Intro Hk; Simpl.

Stepr (Zero::IR); Split; Apply less_leEq.
 Stepr [--](Zero::IR); Apply inv_resp_less; Apply one_div_succ_pos.
Apply one_div_succ_pos.

Apply leEq_imp_AbsSmall; Apply less_leEq; Auto.

Apply AbsSmall_minus.
Apply leEq_imp_AbsSmall; Apply less_leEq; Auto.
Apply less_leEq_trans with (!one_div_succ IR m); Auto.
Apply one_div_succ_resp_leEq; Auto.

Stepr (Zero::IR); Split; Apply less_leEq.
 Stepr [--](Zero::IR); Apply inv_resp_less; Apply one_div_succ_pos.
Apply one_div_succ_pos.
Qed.

(* Begin_Tex_Verb *)
Definition Max_CauchySeq : CauchySeqR.
(* End_Tex_Verb *)
Unfold CauchySeqR.
Apply Build_CauchySeq with Max_seq.
Exact Cauchy_Max_seq.
Defined.

(* Begin_Tex_Verb *)
Definition MAX : IR.
(* End_Tex_Verb *)
Apply Lim.
Exact Max_CauchySeq.
Defined.

(* Tex_Prose
Constructively, the elementary properties of the maximum function are:
\begin{itemize}
\item $x\leq \maxx (x,y)$,
\item $x\leq \maxx (x,y)$,
\item $z<\maxx(x,y) \Rightarrow z<x \vee z<y$.
\end{itemize}
(This can be more concisely expressed as
 $z<\maxx(x,y) \Leftrightarrow z<x \vee z<y$).
From these elementary properties we can prove all other properties, including
strong extensionality.
With strong extensionality, we can make the binary {\em operation} \verb!Max!.
(So \verb!Max! is \verb!MAX! coupled with some proofs.)
*)

(* Begin_Tex_Verb *)
Lemma lft_leEq_MAX : x[<=]MAX.
(* End_Tex_Verb *)
Stepr Zero[+]MAX; Apply shift_leEq_plus.
Red; Apply approach_zero_weak.
Intros e He.
Apply leEq_wdl with (Lim (Cauchy_const x))[-]MAX.
 2: Apply cg_minus_wd; [Apply eq_symmetric_unfolded; Apply Lim_const | Algebra].
Unfold MAX.
EApply leEq_wdl.
 2: Apply Lim_minus.
Simpl.
Elim (Archimedes One[/]e[//](pos_ap_zero ?? He)); Intros n Hn.
Cut Zero[<](!nring IR n).
Intro posn.
Apply str_seq_leEq_so_Lim_leEq.
Exists n; Intros i Hi.
Simpl.
Unfold Max_seq.
Elim cotrans_less_unfolded; Intro H; Simpl.
 Step (Zero::IR); Apply less_leEq; Auto.
Apply less_leEq; EApply less_transitive_unfolded.
Apply H.
Unfold one_div_succ Snring; Apply shift_div_less.
 Apply pos_nring_S.
Apply shift_less_mult' with (pos_ap_zero ?? He).
 Auto.
EApply leEq_less_trans.
 Apply Hn.
Apply nring_less; Auto with arith.

EApply less_leEq_trans.
 2: Apply Hn.
Apply recip_resp_pos; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma rht_leEq_MAX : y[<=]MAX.
(* End_Tex_Verb *)
Unfold MAX.
Apply leEq_seq_so_leEq_Lim.
Intro i; Simpl.
Unfold Max_seq.
Elim cotrans_less_unfolded; Intro H; Simpl.
 2: Apply leEq_reflexive.
Apply less_leEq; Step Zero[+]y.
Apply shift_plus_less; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma less_MAX_imp : (z:IR)(z[<]MAX) -> (z[<]x) + (z[<]y).
(* End_Tex_Verb *)
Intros.
Unfold MAX in H.
Elim (less_Lim_so_less_seq ?? H).
Intros N HN.
Simpl in HN.
Elim (Max_seq_char N); Intro Hseq; Inversion_clear Hseq;
 [Left | Right]; Stepr (Max_seq N); Auto with arith.
Qed.

End Max_function.

(* Begin_Tex_Verb *)
Lemma MAX_strong_ext : (bin_op_strong_ext ? MAX).
(* End_Tex_Verb *)
Unfold bin_op_strong_ext.
Unfold bin_fun_strong_ext.
Intros x1 x2 y1 y2 H.
Generalize (ap_imp_less ? ? ? H); Intro.
Elim H0; Intro H1.
 Generalize (less_MAX_imp ? ? ? H1); Intro H2.
 Elim H2; Intro H3.
  Left.
  Apply less_imp_ap.
  Apply leEq_less_trans with (MAX x1 y1); Auto.
  Apply lft_leEq_MAX.
 Right.
 Apply less_imp_ap.
 Apply leEq_less_trans with (MAX x1 y1); Auto.
 Apply rht_leEq_MAX.
Generalize (less_MAX_imp ? ? ? H1); Intro H2.
Elim H2; Intro.
 Left.
 Apply Greater_imp_ap.
 Apply leEq_less_trans with (MAX x2 y2); Auto.
 Apply lft_leEq_MAX.
Right.
Apply Greater_imp_ap.
Apply leEq_less_trans with (MAX x2 y2); Auto.
Apply rht_leEq_MAX.
Qed.

(* Begin_Tex_Verb *)
Lemma MAX_well_def : (bin_op_well_def IR MAX).
(* End_Tex_Verb *)
Unfold bin_op_well_def.
Apply  bin_fun_strong_ext_imp_well_def.
Exact MAX_strong_ext.
Qed.

Section properties_of_Max.

(* Tex_Prose
\subsection{Properties of Max}
*)

(* Begin_Tex_Verb *)
Definition Max := (Build_CSetoid_bin_op ? MAX MAX_strong_ext).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma max_wd_unfolded : (x,y,x',y':IR)
  (x[=]x')->(y[=]y')->(Max x y)[=](Max x' y').
(* End_Tex_Verb *)
Cut (bin_op_well_def ? MAX); [Intro | Apply MAX_well_def].
Red in H.
Red in H.
Intros; Apply H; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma lft_leEq_Max : (x,y:IR)x [<=] (Max x y).
(* End_Tex_Verb *)
Unfold Max.
Simpl.
Exact lft_leEq_MAX.
Qed.

(* Begin_Tex_Verb *)
Lemma rht_leEq_Max : (x,y:IR)y [<=] (Max x y).
(* End_Tex_Verb *)
Unfold Max.
Simpl.
Exact rht_leEq_MAX.
Qed.

(* Begin_Tex_Verb *)
Lemma less_Max_imp : (x,y,z:IR)(z[<](Max x y)) -> (z[<]x) + (z[<]y).
(* End_Tex_Verb *)
Unfold Max.
Simpl.
Exact less_MAX_imp.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_leEq : (x,y,z:IR)(x[<=]z) -> (y[<=]z) -> (Max x y)[<=]z.
(* End_Tex_Verb *)
Unfold Max.
Simpl.
Intros.
Unfold leEq.
Intro.
Generalize (less_MAX_imp ? ? ? H1); Intro.
Elim H2; Intros.
Elim H.
Assumption.
Elim H0.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_less : (x,y,z:IR)(x [<] z) -> (y [<] z) -> (Max x y) [<] z.
(* End_Tex_Verb *)
Intros.
Elim (smaller ? z[-]x z[-]y). Intro e. Intros H1 H2. Elim H2. Clear H2. Intros H2 H3.
Cut z[-]e[/]TwoNZ [<] z. Intro H4.
Elim (cotrans_less_unfolded ??? H4 (Max x y)); Intros H5.
Elim (less_Max_imp ? ? ? H5); Intros H6.
Cut (Not (e[/]TwoNZ [<] z[-]x)). Intro. Elim H7.
Apply less_leEq_trans with e; Auto.
Apply pos_div_two'; Auto.
Apply less_antisymmetric_unfolded.
Apply shift_minus_less. Apply shift_less_plus'. Auto.
Cut (Not (e[/]TwoNZ [<] z[-]y)). Intro. Elim H7.
Apply less_leEq_trans with e; Auto.
Apply pos_div_two'; Auto.
Apply less_antisymmetric_unfolded.
Apply shift_minus_less. Apply shift_less_plus'. Auto.
Auto.
Apply shift_minus_less. Step z[+]Zero.
Apply plus_resp_less_lft. Apply pos_div_two. Auto.
Apply shift_less_minus. Step x. Auto.
Apply shift_less_minus. Step y. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma equiv_imp_eq_max : (x,x',m:IR)
  ((y:IR)(x [<] y) -> (x' [<] y) -> (m [<] y)) ->
  ((y:IR)(m [<] y) -> (x [<] y)) ->
  ((y:IR)(m [<] y) -> (x' [<] y)) ->
    (Max x x') [=] m.
(* End_Tex_Verb *)
Intros.
Apply lt_equiv_imp_eq; Intros.
Apply H.
Apply leEq_less_trans with (Max x x').
Apply lft_leEq_Max. Auto.
Apply leEq_less_trans with (Max x x').
Apply rht_leEq_Max. Auto.
Apply Max_less; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_id : (x:IR)(Max x x) [=] x.
(* End_Tex_Verb *)
Intros.
Apply equiv_imp_eq_max; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_comm : (x,y:IR)(Max x y)[=](Max y x).
(* End_Tex_Verb *)
Cut (x,y:IR)(Max x y)[<=](Max y x).
Intros.
Apply leEq_imp_eq.
Apply H.
Apply H.
Intros.
Apply Max_leEq.
Apply rht_leEq_Max.
Apply lft_leEq_Max.
Qed.

(* Tex_Prose
\begin{lemma} \label{lemmaxgeq}
$\forall x,y\in\RR[ x\leq y \leftrightarrow \maxx(x,y) = y]$.
\end{lemma}
*)

(* Begin_Tex_Verb *)
Lemma leEq_imp_Max_is_rht : (x,y:IR)(x [<=] y) -> (Max x y) [=] y.
(* End_Tex_Verb *)
Intros.
Apply leEq_imp_eq.
Apply Max_leEq.
Assumption.
Apply leEq_reflexive.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_is_rht_imp_leEq : (x,y:IR)((Max x y) [=] y) -> (x [<=] y).
(* End_Tex_Verb *)
Intros.
Unfold leEq.
Intro.
Generalize (less_leEq ? ? ? H0); Intro.
Generalize (leEq_imp_Max_is_rht ? ? H1); Intro.
Cut y[=]x.
Intro.
Elim (less_irreflexive_unfolded ? x).
Step y.
Assumption.
Step (Max x y).
Stepr (Max y x).
Apply Max_comm.
Qed.

(* Begin_Tex_Verb *)
Lemma Max_minus_eps_leEq : (x,y:IR)(e:IR)
  (Zero[<]e)->({((Max x y)[-]e)[<=]x}+{((Max x y)[-]e)[<=]y}).
(* End_Tex_Verb *)
Intros.
Cut (((Max x y)[-]e)[<]x)+(((Max x y)[-]e)[<]y).
Intro; Elim H0; Intros; Clear H0.
Left; Apply less_leEq; Assumption.
Right; Apply less_leEq; Assumption.
Apply less_Max_imp.
Apply shift_minus_less.
Apply shift_less_plus'.
Step (Zero::IR); Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma max_one_ap_zero : (x:IR)(Max x One)[#]Zero.
(* End_Tex_Verb *)
Intros.
Apply ap_symmetric_unfolded.
Apply less_imp_ap.
Apply less_leEq_trans with (One::IR).
Apply pos_one.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma pos_max_one : (x:IR)(Zero[<](Max x One)).
(* End_Tex_Verb *)
Intro.
Apply less_leEq_trans with (One::IR); [Apply pos_one | Apply rht_leEq_Max].
Qed.

(* Begin_Tex_Verb *)
Lemma x_div_Max_leEq_x : (x,y:IR)(Zero[<]x)->
  (x[/](Max y One)[//](max_one_ap_zero ?))[<=]x.
(* End_Tex_Verb *)
Intros.
Apply shift_div_leEq'.
Apply pos_max_one.
Step One[*]x.
Apply mult_resp_leEq_rht; [Apply rht_leEq_Max | Apply less_leEq; Assumption].
Qed.

End properties_of_Max.

End Maximum.

Hints Resolve Max_id : algebra.

Section Minimum.

(* Tex_Prose
\subsection{Mininum}

The minimum is defined by the formula $\min(x,y)=-\max(-x,-y)$.
*)

(* Begin_Tex_Verb *)
Definition MIN [x,y:IR] : IR := [--](Max [--]x [--]y).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma min_wd_unfolded : (x,y,a,b:IR)
  (((x[=]a)/\(y[=]b))->
    ([--](Max [--]x [--]y)[=][--](Max [--]a [--]b))).
(* End_Tex_Verb *)
Intros.
Apply un_op_wd_unfolded.
Apply bin_op_wd_unfolded; Apply un_op_wd_unfolded; Elim H; Trivial.
Qed.

(* Begin_Tex_Verb *)
Lemma min_wd : (bin_op_well_def ? MIN).
(* End_Tex_Verb *)
Red.
Red.
Intro.
Unfold MIN.
Intros.
Apply min_wd_unfolded.
Split; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma min_strext_unfolded : (x,y,a,b:IR)
  (([--](Max [--]x [--]y)[#][--](Max [--]a [--]b))->((x[#]a)+(y[#]b))).
(* End_Tex_Verb *)
Intros.
Cut ([--]x[#][--]a)+([--]y[#][--]b).
Intros.
Elim H0.
Intro.
Left; Apply un_op_strext_unfolded with (!cg_inv IR); Assumption.
Intro.
Right; Apply un_op_strext_unfolded with (!cg_inv IR); Assumption.
Apply bin_op_strext_unfolded with Max.
Apply un_op_strext_unfolded with (!cg_inv IR); Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma min_strext : (bin_op_strong_ext ? MIN).
(* End_Tex_Verb *)
Red.
Red.
Unfold MIN.
Intros.
Apply min_strext_unfolded.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Definition Min : (CSetoid_bin_op IR) :=
  (Build_CSetoid_bin_op IR [x,y:IR]([--](Max [--]x [--]y)) min_strext).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Min_leEq_lft : (x,y:IR) (Min x y)[<=]x.
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
RStepr ([--][--]x).
Apply inv_resp_leEq.
Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_leEq_rht : (x,y:IR) (Min x y)[<=]y.
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
RStepr [--][--]y.
Apply inv_resp_leEq.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_less_imp : (x,y,z:IR)((Min x y)[<]z)->(x[<]z)+(y[<]z).
(* End_Tex_Verb *)
Unfold Min; Simpl.
Intros.
Cut ([--]z[<][--]x)+([--]z[<][--]y).
Intros.
Elim H0; Intro.
Left.
Apply inv_cancel_less; Assumption.
Right.
Apply inv_cancel_less; Assumption.
Apply less_Max_imp.
Apply inv_cancel_less.
Apply less_wdr with z.
Assumption.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma leEq_Min : (x,y,z:IR)((z[<=]x)->(z[<=]y)->(z[<=](Min x y))).
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
RStep [--][--]z.
Apply inv_resp_leEq.
Apply Max_leEq; Apply inv_resp_leEq; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma less_Min : (x,y,z:IR)((z[<]x)->(z[<]y)->(z[<](Min x y))).
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
RStep [--][--]z.
Apply inv_resp_less.
Apply Max_less; Apply inv_resp_less; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma equiv_imp_eq_min : (x,x',m:IR)
  ((y:IR)(y[<]x)->(y[<]x')->(y[<]m))->
  ((y:IR)(y[<]m)->(y[<]x))->
  ((y:IR)(y[<]m)->(y[<]x'))->
  (Min x x')[=]m.
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
Stepr [--][--]m.
Apply un_op_wd_unfolded.
Apply equiv_imp_eq_max.
Intros.
RStepr [--][--]y.
Apply inv_resp_less.
Apply H.
RStepr [--][--]x.
Apply inv_resp_less.
Assumption.
RStepr [--][--]x'.
Apply inv_resp_less.
Assumption.
Intros.
RStepr [--][--]y.
Apply inv_resp_less.
Apply H0.
RStepr [--][--]m.
Apply inv_resp_less.
Assumption.
Intros.
RStepr [--][--]y.
Apply inv_resp_less.
Apply H1.
RStepr [--][--]m.
Apply inv_resp_less.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_id : (x:IR)((Min x x)[=]x).
(* End_Tex_Verb *)
Intro.
Unfold Min; Simpl.
Stepr [--][--]x.
Apply un_op_wd_unfolded; Apply Max_id.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_comm : (x,y:IR)((Min x y)[=](Min y x)).
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
Apply un_op_wd_unfolded; Apply Max_comm.
Qed.

(* Begin_Tex_Verb *)
Lemma leEq_imp_Min_is_lft : (x,y:IR)((x[<=]y)->((Min x y)[=]x)).
(* End_Tex_Verb *)
Intros.
Unfold Min; Simpl.
Stepr [--][--]x.
Apply un_op_wd_unfolded.
Apply eq_transitive_unfolded with (Max [--]y [--]x).
Apply Max_comm.
Apply leEq_imp_Max_is_rht.
Apply inv_resp_leEq.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_is_lft_imp_leEq : (x,y:IR)(((Min x y)[=]x)->(x[<=]y)).
(* End_Tex_Verb *)
Unfold Min; Simpl.
Intros.
RStep [--][--]x.
RStepr [--][--]y.
Apply inv_resp_leEq.
Apply Max_is_rht_imp_leEq.
Step [--][--](Max [--]y [--]x).
Apply eq_transitive_unfolded with [--][--](Max [--]x [--]y).
Apply un_op_wd_unfolded; Apply un_op_wd_unfolded; Apply Max_comm.
Apply un_op_wd_unfolded; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma leEq_Min_plus_eps : (x,y:IR)(e:IR)(Zero[<]e)->
  ({x[<=]((Min x y)[+]e)}+{y[<=]((Min x y)[+]e)}).
(* End_Tex_Verb *)
Intros.
Cut (x[<]((Min x y)[+]e))+(y[<]((Min x y)[+]e)).
Intro; Elim H0; Intros; Clear H0.
Left; Apply less_leEq; Assumption.
Right; Apply less_leEq; Assumption.
Apply Min_less_imp.
Apply shift_less_plus'.
Step (Zero::IR); Assumption.
Qed.

(* Begin_Tex_Verb *)
Variables a,b:IR.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Min_leEq_Max : (Min a b)[<=](Max a b).
(* End_Tex_Verb *)
Intros.
Apply leEq_transitive with a; [Apply Min_leEq_lft | Apply lft_leEq_Max].
Qed.

(* Begin_Tex_Verb *)
Lemma Min_leEq_Max' : (z:IR)(Min a z)[<=](Max b z).
(* End_Tex_Verb *)
Intros; Apply leEq_transitive with z.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Min3_leEq_Max3 : (c:IR)(Min (Min a b) c)[<=](Max (Max a b) c).
(* End_Tex_Verb *)
Intros; EApply leEq_transitive.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_less_Max : (c,d:IR)(a[<]b)->(Min a c)[<](Max b d).
(* End_Tex_Verb *)
Intros.
Apply leEq_less_trans with a.
Apply Min_leEq_lft.
Apply less_leEq_trans with b.
Assumption.
Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma ap_imp_Min_less_Max : (a[#]b)->(Min a b)[<](Max a b).
(* End_Tex_Verb *)
Intro Hap; Elim (ap_imp_less ??? Hap); (Intro H;
  [EApply leEq_less_trans; [Idtac | EApply less_leEq_trans; [Apply H | Idtac]]]).
Apply Min_leEq_lft.
Apply rht_leEq_Max.
Apply Min_leEq_rht.
Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Min_less_Max_imp_ap : ((Min a b)[<](Max a b))->a[#]b.
(* End_Tex_Verb *)
Intro.
Elim (Min_less_imp ??? H); Clear H; Intro H; Elim (less_Max_imp ??? H); Intro H0.
ElimType False; Exact (less_irreflexive ?? H0).
Apply less_imp_ap; Auto.
Apply Greater_imp_ap; Auto.
ElimType False; Exact (less_irreflexive ?? H0).
Qed.

End Minimum.

(***********************************)
Section Absolute.
(***********************************)

(* Tex_Prose
\section{Absolute value}
*)

(* Begin_Tex_Verb *)
Definition ABSIR := [x:IR](Max x ([--]x)) : IR -> IR.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma ABSIR_strong_ext : (un_op_strong_ext ? ABSIR).
(* End_Tex_Verb *)
Unfold un_op_strong_ext.
Unfold fun_strong_ext.
Unfold ABSIR.
Intros.
Generalize (csbf_strext ? ? ? Max); Intro.
Unfold bin_fun_strong_ext in H0.
Generalize (H0 ? ? ? ? H); Intro.
Elim H1.
Intro.
Assumption.
Intro H2.
Apply zero_minus_apart.
Generalize (minus_ap_zero ? ? ? H2); Intro.
Generalize (inv_resp_ap_zero ? ? H3); Intro.
Cut x[-]y [=] [--]([--]x[-][--]y).
Intro.
Step [--]([--]x[-][--]y).
Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma ABSIR_well_def : (un_op_well_def ? ABSIR).
(* End_Tex_Verb *)
Unfold un_op_well_def.
Apply fun_strong_ext_imp_well_def.
Exact ABSIR_strong_ext.
Qed.

(* Begin_Tex_Verb *)
Definition AbsIR := (Build_CSetoid_un_op ? ABSIR ABSIR_strong_ext)
                 :  (CSetoid_un_op IR).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma AbsIR_wd: (x,y:IR) (x[=]y)->(AbsIR x) [=] (AbsIR y).
(* End_Tex_Verb *)
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Abs_wd_lft_unfolded : (x,y,e:IR)(x[=]y) -> ((AbsIR x)[<]e) ->
((AbsIR y)[<]e).
(* End_Tex_Verb *)
Proof.
Intros.
Apply less_wdl with (AbsIR x).
Assumption.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Abs_wd_rht_unfolded : (x,y,e:IR)(x[=]y) -> (e[<](AbsIR x)) ->
(e[<](AbsIR y)).
(* End_Tex_Verb *)
Proof.
Intros.
Apply less_wdr with (AbsIR x).
Assumption.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIRz_isz :(AbsIR Zero)[=]Zero.
(* End_Tex_Verb *)
Intros. Unfold AbsIR. Simpl. Unfold ABSIR.
Step_final (Max Zero Zero).
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_nonneg : (x:IR)(Zero[<=](AbsIR x)).
(* End_Tex_Verb *)
Intro; Intro.
Cut (Zero[<](Zero::IR)).
Apply less_irreflexive.
Apply less_wdl with (AbsIR x); Auto.
EApply eq_transitive_unfolded.
2: Apply AbsIRz_isz.
Apply AbsIR_wd.
Unfold AbsIR in H; Simpl in H; Unfold ABSIR in H.
Apply leEq_imp_eq; Apply less_leEq.
Apply leEq_less_trans with (Max x [--]x).
Apply lft_leEq_Max.
Assumption.
Apply inv_cancel_less.
Apply leEq_less_trans with (Max x [--]x).
Apply rht_leEq_Max.
Stepr (Zero::IR); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_pos : (x:IR)(x[#]Zero)->Zero[<](AbsIR x).
(* End_Tex_Verb *)
Intros.
Cut (x[<]Zero)+(Zero[<]x).
2: Apply ap_imp_less; Assumption.
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR.
Elim H0.
Intro.
Apply less_leEq_trans with [--]x.
Step [--](Zero::IR).
Apply inv_resp_less.
Assumption.
Apply rht_leEq_Max.
Intro.
Apply less_leEq_trans with x.
Assumption.
Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_cancel_ap_zero : (x:IR)(((AbsIR x)[#]Zero)->(x[#]Zero)).
(* End_Tex_Verb *)
Intros.
Apply un_op_strext_unfolded with AbsIR.
Apply ap_well_def_rht_unfolded with (Zero::IR).
Assumption.
Apply eq_symmetric_unfolded; Apply AbsIRz_isz.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_resp_ap_zero : (x:IR)(x[#]Zero)->(AbsIR x)[#]Zero.
(* End_Tex_Verb *)
Intros.
Apply ap_symmetric_unfolded; Apply less_imp_ap.
Apply AbsIR_pos; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma leEq_AbsIR : (x:IR)(x[<=](AbsIR x)).
(* End_Tex_Verb *)
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR; Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma inv_leEq_AbsIR : (x:IR)([--]x[<=](AbsIR x)).
(* End_Tex_Verb *)
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR; Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsSmall_e : (e:IR)(x:IR)(AbsSmall e x)->(Zero[<=]e).
(* End_Tex_Verb *)
Intros.
Red in H.
Cut [--]e[<=]e.
2: Inversion_clear H; Apply leEq_transitive with x; Assumption.
Intro.
Apply mult_cancel_leEq with (Two::IR); Step (Zero::IR).
Apply pos_two.
RStepr e[+]e.
Apply shift_leEq_plus; Step [--]e.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsSmall_imp_AbsIR : (x,y:IR) (AbsSmall y x)->((AbsIR x)[<=]y).
(* End_Tex_Verb *)
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR.
Inversion_clear H.
Apply Max_leEq.
Assumption.
Apply inv_cancel_leEq.
Stepr x; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_eq_AbsSmall :(x,e:IR)([--]e [<=] x) -> (x [<=] e) ->
	(AbsSmall e x).
(* End_Tex_Verb *)
Intros.
Unfold AbsSmall.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_imp_AbsSmall : (x,y:IR) ((AbsIR x)[<=]y)->(AbsSmall y x).
(* End_Tex_Verb *)
Intros.
Unfold AbsSmall.
Simpl in H.
Unfold ABSIR in H.
Simpl in H.
Split.
Generalize (rht_leEq_Max x [--]x).
Intro H1.
Generalize (leEq_transitive ? ? (MAX x [--]x) ? H1 H).
Intro H2.
RStepr [--][--]x.
Apply inv_resp_leEq.
Assumption.
Generalize (lft_leEq_Max x [--]x).
Intro H1.
Generalize (leEq_transitive ? ? (MAX x [--]x) ? H1 H).
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsSmall_transitive : (e:IR)(x,y:IR)(AbsSmall e x)->
  ((AbsIR y)[<=](AbsIR x))->(AbsSmall e y).
(* End_Tex_Verb *)
Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_transitive.
Apply H0.
Apply AbsSmall_imp_AbsIR; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma zero_less_AbsIR_plus_one : (q:IR)(Zero[<](AbsIR q)[+]One).
(* End_Tex_Verb *)
Intros.
Apply less_leEq_trans with (Zero[+](One::IR)).
RStepr (One::IR); Apply pos_one.
Apply plus_resp_leEq; Apply AbsIR_nonneg.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_inv : (x:IR)(AbsIR x)[=](AbsIR [--]x).
(* End_Tex_Verb *)
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR.
Apply eq_transitive_unfolded with (Max [--][--]x [--]x).
Apply bin_op_wd_unfolded; Algebra.
Apply Max_comm.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_minus : (x,y:IR)(AbsIR x[-]y)[=](AbsIR y[-]x).
(* End_Tex_Verb *)
Intros.
EApply eq_transitive_unfolded.
Apply AbsIR_inv.
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_eq_x : (x:IR)(Zero[<=]x)->(AbsIR x)[=]x.
(* End_Tex_Verb *)
Intros.
Unfold AbsIR; Simpl; Unfold ABSIR.
Apply eq_transitive_unfolded with (Max [--]x x).
Apply Max_comm.
Apply leEq_imp_Max_is_rht.
Apply leEq_transitive with (Zero::IR).
2: Assumption.
Stepr [--](Zero::IR).
Apply inv_resp_leEq.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_eq_inv_x : (x:IR)(x[<=]Zero)->(AbsIR x)[=][--]x.
(* End_Tex_Verb *)
Intros.
Apply eq_transitive_unfolded with (AbsIR [--]x).
Apply AbsIR_inv.
Apply AbsIR_eq_x.
Step [--](Zero::IR).
Apply inv_resp_leEq.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma less_AbsIR : (x,y:IR)(Zero[<]x)->(x[<](AbsIR y))->((x[<]y)+(y[<][--]x)).
(* End_Tex_Verb *)
Intros.
Simpl in H0.
Unfold ABSIR in H0.
Cut (x[<]y)+(x[<][--]y).
Intro; Inversion_clear H1.
Left; Assumption.
Right; Step [--][--]y; Apply inv_resp_less; Assumption.
Apply less_Max_imp; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma leEq_distr_AbsIR : (x,y:IR)(Zero[<]x)->
  (x[<=](AbsIR y))->{x[<=]y}+{y[<=][--]x}.
(* End_Tex_Verb *)
Intros.
Cut x[*](Three[/]FourNZ)[<](AbsIR y); Intros.
Elim (less_AbsIR x[*](Three[/]FourNZ) y); Intros; [Left | Right | Idtac | Auto].
Stepr Zero[+]y; Apply shift_leEq_plus.
Red; Apply approach_zero.
Cut (e:IR)(Zero[<]e)->(e[<]x[/]TwoNZ)->(x[-]y)[<]e; Intros.
Cut x[/]FourNZ[<]x[/]TwoNZ; Intros.
2: RStep (x[/]TwoNZ)[/]TwoNZ; Apply pos_div_two'; Apply pos_div_two; Auto.
Elim (cotrans_less_unfolded ??? H4 e); Intro.
Apply leEq_less_trans with x[/]FourNZ; Auto.
Apply less_leEq.
Apply shift_minus_less; Apply shift_less_plus'.
RStep x[*](Three[/]FourNZ); Auto.
Apply H2; Auto.
Apply shift_minus_less; Apply shift_less_plus'.
Cut x[-]e[<](AbsIR y); Intros.
2: Apply less_leEq_trans with x; Auto.
2: Apply shift_minus_less; Apply shift_less_plus'; Step (Zero::IR); Auto.
Elim (less_AbsIR x[-]e y); Auto.
Intro; ElimType False.
Apply (less_irreflexive_unfolded ? y).
EApply leEq_less_trans.
2: Apply a.
Apply less_leEq; EApply less_transitive_unfolded.
Apply b.
Step Zero[-](x[-]e).
Apply shift_minus_less.
Stepr (x[*](Three[/]FourNZ)[+]x)[-]e.
Apply shift_less_minus; Step e.
EApply less_leEq_trans.
Apply H3.
Apply less_leEq.
RStep x[*](Zero[+]Zero[+]One[/]TwoNZ); RStepr x[*](One[+]One[/]FourNZ[+]One[/]TwoNZ).
Apply mult_resp_less_lft; Auto.
Apply plus_resp_less_rht; Apply plus_resp_less_leEq.
Apply pos_one.
Apply less_leEq; Apply pos_div_four; Apply pos_one.
Apply shift_less_minus; Step e.
EApply less_leEq_trans.
Apply H3.
Apply less_leEq; Apply pos_div_two'; Auto.
Stepr Zero[+][--]x; Apply shift_leEq_plus.
Apply leEq_wdl with y[+]x.
2: Unfold cg_minus; Algebra.
Red; Apply approach_zero.
Cut (e:IR)(Zero[<]e)->(e[<]x[/]TwoNZ)->(y[+]x)[<]e; Intros.
Cut x[/]FourNZ[<]x[/]TwoNZ; Intros.
2: RStep (x[/]TwoNZ)[/]TwoNZ; Apply pos_div_two'; Apply pos_div_two; Auto.
Elim (cotrans_less_unfolded ??? H4 e); Intro.
Apply leEq_less_trans with x[/]FourNZ; Auto.
Apply less_leEq; Apply shift_plus_less.
RStepr [--](x[*](Three[/]FourNZ)); Auto.
Apply H2; Auto.
Cut x[-]e[<](AbsIR y); Intros.
2: Apply less_leEq_trans with x; Auto.
2: Apply shift_minus_less; Apply shift_less_plus'; Step (Zero::IR); Auto.
Elim (less_AbsIR x[-]e y); Auto.
Intro; ElimType False.
Apply (less_irreflexive_unfolded ? y).
EApply leEq_less_trans.
2: Apply a.
Apply less_leEq; EApply less_transitive_unfolded.
Apply b.
Apply shift_less_minus; Apply shift_plus_less'.
EApply less_transitive_unfolded.
Apply H3.
RStep x[*](Zero[+]Zero[+]One[/]TwoNZ); RStepr x[*](One[+]One[/]FourNZ[+]One[/]TwoNZ).
Apply mult_resp_less_lft; Auto.
Apply plus_resp_less_rht; Apply plus_resp_less_leEq.
Apply pos_one.
Apply less_leEq; Apply pos_div_four; Apply pos_one.
Intro.
RStep y[-][--]x.
Apply shift_minus_less.
RStepr [--](x[-]e); Auto.
Apply shift_less_minus; Step e.
EApply less_leEq_trans.
Apply H3.
Apply less_leEq; Apply pos_div_two'; Auto.
Step (Zero::IR)[*](Three[/]FourNZ).
Apply mult_resp_less; Auto.
Apply pos_div_four; Apply pos_three.
Apply less_leEq_trans with x; Auto.
Stepr x[*]One.
Stepr x[*](Four[/]FourNZ).
Apply mult_resp_less_lft; Auto.
Apply div_resp_less.
Apply pos_four.
Apply three_less_four.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_approach_zero : (x:IR)((e:IR)(Zero[<]e)->(AbsIR x)[<=]e)->x[=]Zero.
(* End_Tex_Verb *)
Intros.
Apply leEq_imp_eq.
Red; Apply approach_zero_weak.
Intros.
EApply leEq_transitive; [Apply leEq_AbsIR | Exact (H e H0)].
Step [--](Zero::IR); Stepr [--][--]x; Apply inv_resp_leEq.
Red; Apply approach_zero_weak.
Intros.
EApply leEq_transitive; [Apply inv_leEq_AbsIR | Exact (H e H0)].
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_eq_zero : (x:IR)((AbsIR x)[=]Zero)->(x[=]Zero).
(* End_Tex_Verb *)
Intros.
Apply AbsIR_approach_zero; Intros.
Step (Zero::IR); Apply less_leEq; Auto.
Qed.
(* Begin_Tex_Verb *)

Lemma Abs_Max : (a,b:IR)(AbsIR a[-]b)[=](Max a b)[-](Min a b).
(* End_Tex_Verb *)
Intros.
Apply leEq_imp_eq.
Apply leEq_wdl with (Max a[-]b b[-]a).
2: Simpl; Unfold ABSIR.
2: Apply max_wd_unfolded; Rational.
Apply Max_leEq.
Unfold cg_minus; Apply plus_resp_leEq_both.
Apply lft_leEq_Max.
Apply inv_resp_leEq; Apply Min_leEq_rht.
Unfold cg_minus; Apply plus_resp_leEq_both.
Apply rht_leEq_Max.
Apply inv_resp_leEq; Apply Min_leEq_lft.
Stepr Zero[+](AbsIR a[-]b).
Apply shift_leEq_plus.
Red; Apply approach_zero_weak.
Intros.
Do 2 Apply shift_minus_leEq.
EApply leEq_wdr.
2: Apply plus_assoc.
Apply shift_leEq_plus'.
Elim (Max_minus_eps_leEq a b e H); Intro.
Apply leEq_transitive with a.
Assumption.
Apply shift_leEq_plus'.
Apply leEq_Min.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Step (Zero::IR); Apply AbsIR_nonneg.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Apply leEq_AbsIR.
Apply leEq_transitive with b.
Assumption.
Apply shift_leEq_plus'.
Apply leEq_Min.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
RStep [--](a[-]b); Apply inv_leEq_AbsIR.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Step (Zero::IR); Apply AbsIR_nonneg.
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_str_bnd : (a,b,e:IR)
  ((AbsIR a[-]b)[<]e)->(b[<]a[+]e).
(* End_Tex_Verb *)
Intros.
Apply shift_less_plus'.
Apply leEq_less_trans with (AbsIR a[-]b); Auto.
EApply leEq_wdr; [Apply leEq_AbsIR | Apply AbsIR_minus].
Qed.

(* Begin_Tex_Verb *)
Lemma AbsIR_bnd : (a,b,e:IR)
  ((AbsIR a[-]b)[<=]e)->(b[<=]a[+]e).
(* End_Tex_Verb *)
Intros.
Apply shift_leEq_plus'.
Apply leEq_transitive with (AbsIR a[-]b); Auto.
EApply leEq_wdr; [Apply leEq_AbsIR | Apply AbsIR_minus].
Qed.

End Absolute.

Hints Resolve AbsIRz_isz : algebra.

Section Part_Function_Abs.

(* Tex_Prose
\subsection{Functional Operators}

The existence of these operators allows us to lift them to functions.  We will only define the absolute value, but maximum and minimum of two partial functions could easily be similarly defined.

\begin{notation} \verb!(PartFunct IR}! is denoted by {\tt\hypertarget{Syntactic_33}{PartIR}}.

On predicates, {\tt\hypertarget{Syntactic_34}{ProjIR1}} and {\tt\hypertarget{Syntactic_35}{ProjIR2}} will denote the first and second projections of a conjunction.
\end{notation}

\begin{convention} Let \verb!F:PartIR! and denote by \verb!P! its domain.
\end{convention}
*)

Variables F,G:(PartFunct IR).

Local P := (Pred F).

(* Begin_Tex_Verb *)
Lemma part_function_AbsIR_strext : (x,y:IR)(Hx,Hy:?)
  (((AbsIR (F x Hx))[#](AbsIR (F y Hy)))->(x[#]y)).
(* End_Tex_Verb *)
Intros.
Apply pfstrx with F Hx Hy.
Apply un_op_strext_unfolded with AbsIR.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Definition FAbs := (Build_PartFunct IR ?
  (pfprwd ??)
  [x:IR][Hx:(P x)](AbsIR (F x Hx))
  part_function_AbsIR_strext).
(* End_Tex_Verb *)

End Part_Function_Abs.


From Hammer Require Import Hammer.

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A).
Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b.
End EuclidSpec.

Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.

Module ZEuclidProp
(Import A : ZAxiomsSig')
(Import B : ZMulOrderProp A)
(Import C : ZSgnAbsProp A B)
(Import D : ZEuclid A).

Infix "/" := D.div : euclid.
Infix "mod" := D.modulo : euclid.
Local Open Scope euclid.

Module Import Private_NZDiv := Nop <+ NZDivProp A D B.

Lemma mod_eq :
forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_eq".
intros.
rewrite <- add_move_l.
symmetry. now apply div_mod.
Qed.

Ltac pos_or_neg a :=
let LT := fresh "LT" in
let LE := fresh "LE" in
destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
0<=r1<abs b -> 0<=r2<abs b ->
b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_mod_unique".
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
pos_or_neg b.
rewrite abs_eq in * by trivial.
apply div_mod_unique with b; trivial.
rewrite abs_neq' in * by auto using lt_le_incl.
rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial.
rewrite 2 mul_opp_l.
rewrite add_move_l, sub_opp_r.
rewrite <-add_assoc.
symmetry. rewrite add_move_l, sub_opp_r.
now rewrite (add_comm r2), (add_comm r1).
Qed.

Theorem div_unique:
forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_unique".
intros a b q r Hr EQ.
assert (Hb : b~=0).
pos_or_neg b.
rewrite abs_eq in Hr; intuition; order.
rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

Theorem mod_unique:
forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_unique".
intros a b q r Hr EQ.
assert (Hb : b~=0).
pos_or_neg b.
rewrite abs_eq in Hr; intuition; order.
rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_opp_r".
intros. symmetry.
apply div_unique with (a mod b).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_opp_r".
intros. symmetry.
apply mod_unique with (-(a/b)).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
(-a)/b == -(a/b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_opp_l_z".
intros a b Hb Hab. symmetry.
apply div_unique with (-(a mod b)).
rewrite Hab, opp_0. split; [order|].
pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order.
now rewrite mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
(-a)/b == -(a/b)-sgn b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_opp_l_nz".
intros a b Hb Hab. symmetry.
apply div_unique with (abs b -(a mod b)).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
(-a) mod b == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_opp_l_z".
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)).
split; [order|now rewrite abs_pos].
now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
(-a) mod b == abs b - (a mod b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_opp_l_nz".
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)-sgn b).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
(-a)/(-b) == a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_opp_opp_z".
intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive.
Qed.

Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
(-a)/(-b) == a/b + sgn(b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_opp_opp_nz".
intros. rewrite div_opp_r, div_opp_l_nz by trivial.
now rewrite opp_sub_distr, opp_involutive.
Qed.

Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
(-a) mod (-b) == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_opp_opp_z".
intros. now rewrite mod_opp_r, mod_opp_l_z.
Qed.

Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
(-a) mod (-b) == abs b - a mod b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_opp_opp_nz".
intros. now rewrite mod_opp_r, mod_opp_l_nz.
Qed.

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_same".
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
now nzsimpl.
Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_same".
intros.
rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
Qed.

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_small".   exact div_small. Qed.

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_small".   exact mod_small. Qed.

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_0_l".
intros. pos_or_neg a. apply div_0_l; order.
apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l.
Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_0_l".
intros; rewrite mod_eq, div_0_l; now nzsimpl.
Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_1_r".
intros. symmetry. apply div_unique with 0.
assert (H:=lt_0_1); rewrite abs_pos; intuition; order.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_1_r".
intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
apply neq_sym, lt_neq; apply lt_0_1.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_1_l".   exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_1_l".   exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_mul".
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_mul".
intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_unique_exact".
intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul.
Qed.

Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_le".
intros. pos_or_neg b. apply mod_le; order.
rewrite <- mod_opp_r by trivial. apply mod_le; order.
Qed.

Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_pos".   exact div_pos. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_str_pos".   exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_small_iff".
intros a b Hb.
split.
intros EQ.
rewrite (div_mod a b Hb), EQ; nzsimpl.
now apply mod_always_pos.
intros. pos_or_neg b.
apply div_small.
now rewrite <- (abs_eq b).
apply opp_inj; rewrite opp_0, <- div_opp_r by trivial.
apply div_small.
rewrite <- (abs_neq' b) by order. trivial.
Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_small_iff".
intros.
rewrite <- div_small_iff, mod_eq by trivial.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_lt".   exact div_lt. Qed.

Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_le_mono".
intros a b c Hc Hab.
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
[|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; trivial.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_always_pos b c); try order.
rewrite abs_eq in *; order.
rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order.
Qed.

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_div_le".
intros.
rewrite (div_mod a b) at 2; trivial.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l.
now destruct (mod_always_pos a b).
Qed.

Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_succ_div_gt".
intros.
nzsimpl.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite abs_eq in *; order.
Qed.

Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_pred_div_gt".
intros a b Hb.
rewrite mul_pred_r, <- add_opp_r.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
Qed.

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_exact".
intros.
rewrite (div_mod a b) at 1; try order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

Theorem div_lt_upper_bound:
forall a b q, 0<b -> a < b*q -> a/b < q.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_lt_upper_bound".
intros.
rewrite (mul_lt_mono_pos_l b) by trivial.
apply le_lt_trans with a; trivial.
apply mul_div_le; order.
Qed.

Theorem div_le_upper_bound:
forall a b q, 0<b -> a <= b*q -> a/b <= q.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_le_upper_bound".
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem div_le_lower_bound:
forall a b q, 0<b -> b*q <= a -> q <= a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_le_lower_bound".
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_le_compat_l".   exact div_le_compat_l. Qed.

Lemma mod_add : forall a b c, c~=0 ->
(a + b * c) mod c == a mod c.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_add".
intros.
symmetry.
apply mod_unique with (a/c+b); trivial.
now apply mod_always_pos.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, c~=0 ->
(a + b * c) / c == a / c + b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_add".
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, b~=0 ->
(a * b + c) / b == a + c / b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_add_l".
intros a b c. rewrite (add_comm _ c), (add_comm a).
now apply div_add.
Qed.

Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c ->
(a*c)/(b*c) == a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_mul_cancel_r".
intros.
symmetry.
apply div_unique with ((a mod b)*c).

rewrite abs_mul, (abs_eq c) by order.
rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial.
now apply mod_always_pos.

rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c ->
(c*a)/(c*b) == a/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_mul_cancel_l".
intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c ->
(c*a) mod (c*b) == c * (a mod b).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_mod_distr_l".
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l by trivial.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c ->
(a*c) mod (b*c) == (a mod b) * c.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_mod_distr_r".
intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

Theorem mod_mod: forall a n, n~=0 ->
(a mod n) mod n == a mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_mod".
intros. rewrite mod_small_iff by trivial.
now apply mod_always_pos.
Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
((a mod n)*b) mod n == (a*b) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_mod_idemp_l".
intros a b n Hn. symmetry.
rewrite (div_mod a n) at 1 by order.
rewrite add_comm, (mul_comm n), (mul_comm _ b).
rewrite mul_add_distr_l, mul_assoc.
rewrite mod_add by trivial.
now rewrite mul_comm.
Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
(a*(b mod n)) mod n == (a*b) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_mod_idemp_r".
intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
Qed.

Theorem mul_mod: forall a b n, n~=0 ->
(a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mul_mod".
intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
((a mod n)+b) mod n == (a+b) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.add_mod_idemp_l".
intros a b n Hn. symmetry.
rewrite (div_mod a n) at 1 by order.
rewrite <- add_assoc, add_comm, mul_comm.
now rewrite mod_add.
Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
(a+(b mod n)) mod n == (a+b) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.add_mod_idemp_r".
intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
Qed.

Theorem add_mod: forall a b n, n~=0 ->
(a+b) mod n == (a mod n + b mod n) mod n.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.add_mod".
intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
Qed.

Lemma div_div : forall a b c, 0<b -> c~=0 ->
(a/b)/c == a/(b*c).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_div".
intros a b c Hb Hc.
apply div_unique with (b*((a/b) mod c) + a mod b).

rewrite abs_mul.
destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order.
split.
apply add_nonneg_nonneg; trivial.
apply mul_nonneg_nonneg; order.
apply lt_le_trans with (b*((a/b) mod c) + abs b).
now rewrite <- add_lt_mono_l.
rewrite (abs_eq b) by order.
now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.

rewrite (div_mod a b) at 1 by order.
rewrite add_assoc, add_cancel_r.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
Qed.

Lemma mod_mul_r : forall a b c, 0<b -> c~=0 ->
a mod (b*c) == a mod b + b*((a/b) mod c).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_mul_r".
intros a b c Hb Hc.
apply add_cancel_l with (b*c*(a/(b*c))).
rewrite <- div_mod by (apply neq_mul_0; split; order).
rewrite <- div_div by trivial.
rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
rewrite <- div_mod by order.
apply div_mod; order.
Qed.

Theorem div_mul_le:
forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.div_mul_le".   exact div_mul_le. Qed.

Lemma mod_divides : forall a b, b~=0 ->
(a mod b == 0 <-> (b|a)).
Proof. hammer_hook "ZDivEucl" "ZDivEucl.ZEuclidProp.mod_divides".
intros a b Hb. split.
intros Hab. exists (a/b). rewrite mul_comm.
rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
intros (c,Hc). rewrite Hc. now apply mod_mul.
Qed.

End ZEuclidProp.


(* This module is designed to *not* be Import'ed, only Require'd. *)

Require Import
  Coq.QArith.Qabs CoRN.model.ordfields.Qordfield CoRN.model.structures.Qpossec Coq.QArith.Qminmax Coq.setoid_ring.Ring Coq.Program.Program.

Require CoRN.model.structures.QnonNeg.
Import QnonNeg.notations QnonNeg.coercions.

Local Hint Resolve Qle_refl.

Local Open Scope Q_scope.

(* Some generic utilities: *)

Definition pred_eq {X} (p q: X -> Prop): Prop := forall x, p x <-> q x.

#[global]
Instance: forall X, Equivalence (@pred_eq X) := {}.

(* Some facts about Q: *)

Lemma Qplus_wiggle (x y z : Q):
  0 <= x -> 0 <= y -> x + y < z -> exists e: Qpos, x + e + y < z.
Proof with auto.
 intros ?? E.
 destruct (Qpos_lt_plus E) as [e F].
 exists ((1#2) * e)%Qpos.
 rewrite F.
 simpl. ring_simplify.
 apply Qplus_lt_l.
 do 2 rewrite (Qplus_comm x).
 apply Qplus_lt_l.
 rewrite <- (Qmult_1_l e) at 2.
 apply Qmult_lt_compat_r...
 reflexivity.
Qed.

Lemma Qmult_wiggle (x y z : Q):
  0 <= x -> 0 <= y -> x * y < z -> exists e : Qpos, (x + e) * y < z.
Proof with auto with *.
 intros xnn ynn xyz.
 destruct (Qdec_sign y) as [[A|B]|C].
   exfalso. apply Qle_not_lt with 0 y...
  destruct (Qpos_lt_plus xyz) as [e E].
  exists (e / ((2#1) * exist (Qlt 0) y B))%Qpos.
  rewrite E.
  rewrite Qmult_plus_distr_l.
  do 2 rewrite (Qplus_comm (x * y)).
  apply Qplus_lt_l.
  simpl.
  setoid_replace (e * / ((2 # 1) * y) * y) with (/ (2 # 1) * e) by (simpl; field)...
  rewrite <- (Qmult_1_l e) at 2.
  apply Qmult_lt_compat_r...
 exists (1#1)%Qpos. revert xyz.
 rewrite C, Qmult_0_r, Qmult_0_r...
Qed.

Lemma Qmid (x y: Q): x < y ->
 let mid := (1#2)%Qpos*(x+y) in
  x < mid /\ mid < y.
Proof with auto; try reflexivity.
 intros. subst mid.
 split.
  setoid_replace x with (x * (1#2) + x * (1#2)) at 1 by (simpl; ring).
  setoid_replace ((1 # 2) * (x + y)) with (y * (1 # 2) + x * (1 # 2)) by (simpl; ring).
  apply Qplus_lt_l.
  apply Qmult_lt_compat_r...
 setoid_replace y with (y * (1#2) + y * (1#2)) at 2 by (simpl; ring).
 setoid_replace ((1 # 2) * (x + y)) with (x * (1 # 2) + y * (1 # 2)) by (simpl; ring).
 apply Qplus_lt_l.
 apply Qmult_lt_compat_r...
Qed.

Lemma QnonNeg_mid (x y: QnonNeg): ` x < ` y ->
 let mid := ((1#2) * (x + y))%Qnn in
  ` x < ` mid /\ ` mid < ` y.
Proof.
 intros. subst mid. simpl.
 apply Qmid. assumption.
Qed.

Lemma Qmult_le_compat: forall x y x' y' : Q, 0 <= x <= x' -> 0 <= y <= y' -> x * y <= x' * y'.
Proof.
 intros.
 apply Qle_trans with (x * y').
  do 2 rewrite (Qmult_comm x).
  apply Qmult_le_compat_r; intuition.
 apply Qmult_le_compat_r. intuition.
 apply Qle_trans with y; intuition.
Qed.

Local Hint Resolve Qlt_le_weak.

(* Next up, the actual data type for non-negative upper cuts: *)

Record T := make
  { is_bound: QnonNeg -> Prop
  ; bound: QnonNeg
  ; closed_le: forall q q', `q <= `q' -> is_bound q -> is_bound q'
  ; bound_is_bound: is_bound bound }.

(* Note that we don't enforce closedness or openness of the cut in this definition.
Instead, we write le and eq so that they only depend on non-lowest upper bounds. *)

(* The bound and bound_is_bound fields are just there to rule out an empty cut. A
weaker way to accomplish this is by replacing the two with a field of type

   ~ forall q, ~ is_bound q

Maybe this is better. A preliminary experiment did reveal a complication in the proof
of mult_0_l, because it uses the bound. Possible solutions there include (1) requiring
is_bound stability so that the negated forall above can be classically flipped to
an exists, or (2) using a separate inductively defined cut predicate for multiplication
which has an additional constructor for the multiplication-by-0 case. *)

#[global]
Hint Immediate bound_is_bound.

#[global]
Instance is_bound_Proper: forall (x: T), Proper (QnonNeg.eq ==> iff) (is_bound x).
Proof with auto.
 unfold QnonNeg.eq. intros x y z E.
 split; intro.
  apply closed_le with y... rewrite E...
 apply closed_le with z... rewrite E...
Qed.

Definition le (x y: T): Prop := forall q, is_bound y q -> forall r, `q < `r -> is_bound x r.

Local Infix "<=" := le.

Lemma le_refl (x: T): x <= x.
Proof. repeat intro. apply closed_le with q; auto. Qed.

Lemma le_trans (x y z: T): x <= y -> y <= z -> x <= z.
Proof with auto.
 intros xley ylez q zq r qr.
 destruct (QnonNeg_mid q r qr).
 apply (xley ((1#2)*(q+r))%Qnn)...
 apply (ylez q)...
Qed.

Definition eq (x y: T): Prop := x <= y /\ y <= x.

Local Infix "==" := eq.

Global Instance: Proper (eq ==> eq ==> iff) le.
Proof with intuition.
 unfold eq. intros x y ? a b ?.
 split; intro.
  apply le_trans with x...
  apply le_trans with a...
 apply le_trans with y...
 apply le_trans with b...
Qed.

Global Instance: Equivalence eq.
Proof with intuition.
 unfold eq.
 split; repeat intro...
    apply le_refl.
   apply le_refl.
  apply le_trans with y...
 apply le_trans with y...
Qed.

Module Export coercions.

Global Program Coercion inject_Qnn (q: QnonNeg): T := make (Qle q) q _ _.

Next Obligation. apply Qle_trans with (q0); assumption. Qed.

Global Instance: Proper (QnonNeg.eq ==> eq) inject_Qnn.
Proof with auto.
 unfold eq, le.
 intros ?? H.
 unfold QnonNeg.eq in H.
 split; simpl; intros.
  rewrite H. apply Qle_trans with (`q)...
 rewrite <- H. apply Qle_trans with (`q)...
Qed.

End coercions.

Definition bound_doesnt_matter (q: QnonNeg) b H H' U U':
  make (fun x => Qle (proj1_sig q) (proj1_sig x)) b H U
  == make (fun x => Qlt (proj1_sig q) (proj1_sig x)) b H' U'.
Proof with auto.
 unfold eq, le in *. simpl.
 split; intros e ???.
  apply Qle_trans with (`e)...
 apply Qle_lt_trans with (`e)...
Qed.

Section binop. (* used for addition and multiplication *)

  Variables
    (o: Q -> Q -> Q) (u: Q) (u_ok: (0 <= u)%Q)
    (o_ok: (forall x y, 0 <= x -> 0 <= y -> 0 <= o x y)%Q)
    (o_comm: (forall x y, o x y == o y x)%Q)
    (o_assoc: (forall x y z, o x (o y z) == o (o x y) z)%Q)
    (o_le_compat: (forall x y x' y', 0 <= x <= x' -> 0 <= y <= y' -> o x y <= o x' y')%Q)
    (o_u_left: (forall x, o u x == x)%Q)
    (o_sneaky: (forall (x y z: Q), 0 <= x -> 0 <= y -> o x y < z -> exists e: Qpos, o (x + e) y < z)%Q).
      (* todo: use monoid or something *)

  Definition u_nn: QnonNeg := exist _ _ u_ok.

  Definition o_nn := QnonNeg.binop o o_ok.

  Inductive BinopBound (x y: QnonNeg -> Prop): (QnonNeg -> Prop) :=
    is_binop_bound (q q': QnonNeg): x q -> y q' ->
      forall (r: QnonNeg), (o (` q) (` q') <= ` r)%Q -> BinopBound x y r.
        (* using <= instead of == makes closed_le automatic. using ==/<= at all makes wd automatic. *)

  Lemma BinopBound_le x y a b: (`a <= `b)%Q -> BinopBound x y a -> BinopBound x y b.
  Proof with auto.
   intros E B. revert B E.
   intros [v w xv yw r F] E.
   apply (is_binop_bound x y v w)...
   apply Qle_trans with (`r)...
  Qed.

  Instance BinopBound_Proper: Proper (pred_eq ==> pred_eq ==> QnonNeg.eq ==> iff) BinopBound.
  Proof with auto.
   unfold Proper, respectful.
   cut (forall x y x0 y0 x1 y1, pred_eq x y -> pred_eq x0 y0 ->
     (`x1 == `y1)%Q -> BinopBound x x0 x1 -> BinopBound y y0 y1).
    split; apply H; auto; symmetry...
   intros ?????? U V A B. revert B A.
   intros [v w xv yw r F] E.
   apply (is_binop_bound _ _ v w).
     apply U...
    apply V...
   apply Qle_trans with (`r)...
   rewrite E...
  Qed.

  Lemma BinopBound_sym x y: pred_eq (BinopBound x y) (BinopBound y x).
  Proof with auto.
   split; intros [a b xa yb r E].
    apply (is_binop_bound y x b a yb xa). rewrite o_comm...
   apply (is_binop_bound x y b a yb xa). rewrite o_comm...
  Qed.

  Lemma BinopBound_assoc (n m p: T) (q: QnonNeg):
    BinopBound (is_bound n) (BinopBound (is_bound m) (is_bound p)) q ->
    BinopBound (BinopBound (is_bound n) (is_bound m)) (is_bound p) q.
  Proof with auto.
   intros [a b na [v w z x y E] c F].
   apply BinopBound_le with (o_nn (o_nn a v) w).
    simpl.
    apply Qle_trans with (o (`a) (`y))...
    rewrite <- o_assoc.
    apply o_le_compat; split...
   apply is_binop_bound with (o_nn a v) w...
   apply is_binop_bound with a v...
  Qed.

  Program Definition binop (x y: T): T :=
    make (BinopBound (is_bound x) (is_bound y)) (o_nn (bound x) (bound y)) _ _.

  Next Obligation. (* closed_le *)
   apply BinopBound_le with (exist _ q H2); auto.
  Qed.

  Next Obligation. (* bound_is_bound *)
   apply (is_binop_bound (is_bound x) (is_bound y) (bound x) (bound y)); auto.
  Qed.

  Lemma binop_comm (x y: T): binop x y == binop y x.
  Proof with auto.
   cut (forall a b, binop a b <= binop b a).
    intro H. split; apply H.
   unfold eq, le.  simpl. intros.
   inversion H. subst. clear H.
   apply BinopBound_sym.
   apply is_binop_bound with q0 q'...
   apply Qle_trans with (`q)...
  Qed.

  Lemma binop_le_compat_l (x y z: T): x <= y -> binop x z <= binop y z.
  Proof with auto.
   unfold le. simpl. intros H q [v w yv zw r E] s rs.
   specialize (H _ yv).
   assert (o (`v) (`w) < `s) as os. apply Qle_lt_trans with (`r)...
   destruct (o_sneaky _ _ _ (proj2_sig _) (proj2_sig _) os).
   apply (is_binop_bound (is_bound x) (is_bound z)) with (v + from_Qpos x0)%Qnn w...
   apply H. simpl.
   rewrite Qplus_comm. rewrite <- Qplus_0_l at 1. apply Qplus_lt_l...
  Qed.

  Lemma binop_le_compat (x y: T) (v w: T): x <= y -> v <= w -> binop x v <= binop y w.
  Proof.
   intros. apply le_trans with (binop x w);
    [do 2 rewrite (binop_comm x) |]; apply binop_le_compat_l; auto.
  Qed.

  Global Instance binop_Proper: Proper (eq ==> eq ==> eq) binop.
  Proof. unfold eq. repeat intro. split; apply binop_le_compat; intuition. Qed.

  Lemma binop_assoc (n m p: T): binop n (binop m p) == binop (binop n m) p.
  Proof with auto.
   unfold eq, le. simpl.
   split; intros.
    apply BinopBound_sym.
    apply BinopBound_assoc.
    apply BinopBound_sym.
    apply BinopBound_assoc.
    apply BinopBound_sym...
    apply BinopBound_le with q...
   apply BinopBound_assoc.
   apply BinopBound_le with q...
  Qed.

  Lemma binop_unit_left (x: T): binop u_nn x == x.
  Proof with auto.
   unfold eq, le. simpl.
   split.
    intros.
    apply (is_binop_bound) with u_nn q...
    simpl. rewrite o_u_left...
   intros q [q0 q' H1 H2 v H3] r vr.
   apply closed_le with q'...
   apply Qle_trans with (`v)...
   rewrite <- (o_u_left (`q')).
   apply Qle_trans with (o (`q0) (`q'))...
  Qed.

End binop.

Definition plus := binop Qplus QnonNeg.Qplus_nonneg.
Definition mult := binop Qmult Qmult_le_0_compat.

Local Infix "+" := plus.
Local Infix "*" := mult.

#[global]
Instance: Proper (eq ==> eq ==> eq) plus.
Proof binop_Proper Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_wiggle.

#[global]
Instance: Proper (eq ==> eq ==> eq) mult.
Proof binop_Proper Qmult Qmult_le_0_compat Qmult_comm Qmult_wiggle.

Lemma plus_0_l: forall x, 0%Qnn + x == x.
Proof.
 refine (binop_unit_left Qplus 0 (Qle_refl _) QnonNeg.Qplus_nonneg _ Qplus_0_l).
 intros. apply Qplus_le_compat; intuition.
Qed.

Lemma plus_comm: forall x y, x + y == y + x.
Proof binop_comm Qplus QnonNeg.Qplus_nonneg Qplus_comm.

Lemma plus_assoc: forall n m p, n + (m + p) == (n + m) + p.
Proof.
 apply (binop_assoc Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_assoc).
 intros. apply Qplus_le_compat; intuition.
Qed.

Lemma plus_le_compat: forall x y a b, x <= y -> a <= b -> x + a <= y + b.
Proof binop_le_compat Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_wiggle.

Lemma Qle_0_1: (0 <= 1)%Q.
Proof. discriminate. Qed.

Lemma mult_1_l: forall x, 1%Qnn * x == x.
Proof binop_unit_left Qmult 1 Qle_0_1 Qmult_le_0_compat Qmult_le_compat Qmult_1_l.

Lemma mult_comm: forall x y, x * y == y * x.
Proof binop_comm Qmult Qmult_le_0_compat Qmult_comm.

Lemma mult_assoc: forall n m p, n * (m * p) == (n * m) * p.
Proof binop_assoc Qmult Qmult_le_0_compat Qmult_comm Qmult_assoc Qmult_le_compat.

Lemma mult_plus_distr n m p: (n + m) * p == n * p + m * p.
Proof with auto; simpl.
 unfold eq. split.
  intros _ [_ _ [e d ?? b ?][g f ?? c ?]a ?] r ? ...
  apply BinopBound_le with (e * d + g * f)%Qnn...
   apply Qle_trans with (`b + `c)%Q...
    apply Qplus_le_compat...
   apply Qle_trans with (`a)...
  apply is_binop_bound with (e + g)%Qnn (QnonNeg.min d f)...
    apply is_binop_bound with e g...
   apply QnonNeg.min_case...
   apply (is_bound_Proper p)...
  rewrite Qmult_plus_distr_l.
  apply Qplus_le_compat...
   do 2 rewrite (Qmult_comm (`e)).
   apply Qmult_le_compat_r...
   apply Q.le_min_l.
  do 2 rewrite (Qmult_comm (`g)).
  apply Qmult_le_compat_r...
  apply Q.le_min_r.
 intros q [a b [c d ?? e ?] ? r1 ?] r E...
 apply BinopBound_le with ((c + d) * b)%Qnn...
  apply Qle_trans with (`e * `b)%Q...
   apply Qmult_le_compat_r...
  apply Qle_trans with (`r1)...
 apply is_binop_bound with (c * b)%Qnn (d * b)%Qnn.
   apply is_binop_bound with c b...
  apply is_binop_bound with d b...
 simpl. ring_simplify...
Qed.

Lemma le_closed (e x: T): (forall d: Qpos, x <= e + from_Qpos d) -> x <= e.
Proof with auto.
 unfold le. simpl. intros H q H0 r qr.
 destruct (Qpos_lt_plus qr) as [d E].
 apply (H ((1#2)*d)%Qpos (q + (2#3)*from_Qpos d)%Qnn).
  apply (is_binop_bound Qplus) with q ((1#2)*from_Qpos d)%Qnn...
  simpl.
  apply Qplus_le_compat...
  apply Qmult_le_compat_r...
  discriminate.
 simpl.
 rewrite E.
 do 2 rewrite (Qplus_comm (`q)).
 apply Qplus_lt_l.
 simpl.
 rewrite <- (Qmult_1_l d).
 apply Qmult_lt_compat_r...
 reflexivity.
Qed.

Lemma le_0 x: 0%Qnn <= x.
Proof. unfold le. simpl. auto. Qed.

#[global]
Hint Immediate le_0.

Lemma le_0_eq x: x <= 0%Qnn -> x == 0%Qnn.
Proof. split. assumption. apply le_0. Qed.

Lemma mult_0_l (x: T): 0%Qnn * x == 0%Qnn.
Proof with auto.
 split... unfold le. simpl. intros.
 apply (is_binop_bound) with 0%Qnn (bound x)...
 simpl. rewrite Qmult_0_l...
Qed.

Lemma plus_homo (x y: QnonNeg): (x + y)%Qnn == x + y.
Proof with auto.
 unfold eq, le. simpl.
 split; intros.
  inversion H. subst. clear H.
  apply Qle_trans with (`q)...
  apply Qle_trans with (`q0 + `q')%Q...
  apply Qplus_le_compat...
 apply (is_binop_bound Qplus) with x y...
 apply Qle_trans with (`q)...
Qed.

Lemma semi_ring: semi_ring_theory (R:=T) 0%Qnn 1%Qnn plus mult eq.
Proof.
 constructor.
        apply plus_0_l.
       apply plus_comm.
      apply plus_assoc.
     apply mult_1_l.
    apply mult_0_l.
   apply mult_comm.
  apply mult_assoc.
 apply mult_plus_distr.
Qed.

Add Ring cut_ring: semi_ring.

Module notations.

  Delimit Scope NNUpperR_scope with Rnnu.

  Global Infix "<=" := le: NNUpperR_scope.
  Global Infix "==" := eq: NNUpperR_scope.
  Global Infix "+" := plus: NNUpperR_scope.
  Global Infix "*" := mult: NNUpperR_scope.

  Global Notation NNUpperR := T.

End notations.

(* To show concretely that we've actually gotten beyond mere rationals, here's the square of two: *)

Program Definition sqrt2: T :=
  make (fun x => (2#1) <= x*x)%Q (2#1)%Qnn _ _.

Next Obligation. Proof with auto.
 simpl in *.
 apply Qle_trans with (q * q)%Q...
 apply Qmult_le_compat...
Qed.

(* For its correctness, I assume (because I'm lazy and couldn't find this in the stdlib) that square roots
 can be over-approximated to arbitrary precision: *)

Lemma sqrt2_correct
  (Qsqrt_overapprox: forall (x: QnonNeg) (e: Qpos), { r: QnonNeg | ` x <= ` r * ` r /\ ` r * ` r < ` x + e }%Q):
    sqrt2 * sqrt2 == (2#1)%Qnn.
Proof with auto.
 unfold eq, le. simpl.
 split; intros.
  destruct (Qpos_lt_plus H0).
  destruct (Qsqrt_overapprox (2#1)%Qnn x).
  destruct a.
  apply (is_binop_bound Qmult) with x0 x0...
  rewrite q0.
  apply Qle_trans with ((2 # 1)%Q + x)%Q...
  apply Qplus_le_compat...
 inversion_clear H.
 destruct (Qlt_le_dec (`q0) (`q')).
  apply Qle_trans with (`q0*`q0)%Q...
  apply Qle_trans with (`q0*`q')%Q...
   apply Qmult_le_compat...
  apply Qle_trans with (`q)...
 apply Qle_trans with (`q'*`q')%Q...
 apply Qle_trans with (`q0*`q')%Q...
  apply Qmult_le_compat...
 apply Qle_trans with (`q)...
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_squareparallelogram.

Section Euclid.

Context `{Ax1:euclidean_euclidean}.

Lemma lemma_squareunique :
   forall A B C D E,
   SQ A B C D -> SQ A B C E ->
   eq E D.
Proof.
intros.
assert (PG A B C D) by (conclude lemma_squareparallelogram).
let Tf:=fresh in
assert (Tf:exists M, (Midpoint A M C /\ Midpoint B M D)) by (conclude lemma_diagonalsbisect);destruct Tf as [M];spliter.
assert (BetS B M D) by (conclude_def Midpoint ).
assert (BetS A M C) by (conclude_def Midpoint ).
assert (Per D A B) by (conclude_def SQ ).
assert (Per E A B) by (conclude_def SQ ).
assert (nCol D A B) by (conclude lemma_rightangleNC).
assert (nCol E A B) by (conclude lemma_rightangleNC).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Cong A B D A) by (conclude_def SQ ).
assert (Cong A B E A) by (conclude_def SQ ).
assert (Cong E A A B) by (conclude lemma_congruencesymmetric).
assert (Cong E A D A) by (conclude lemma_congruencetransitive).
assert (Cong A E A D) by (forward_using lemma_congruenceflip).
assert (CongA E A B D A B) by (conclude lemma_Euclid4).
assert ((Cong E B D B /\ CongA A E B A D B /\ CongA A B E A B D)) by (conclude proposition_04).
assert (CongA A B D A B E) by (conclude lemma_equalanglessymmetric).
assert (neq B E) by (forward_using lemma_NCdistinct).
assert (neq B M) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists N, (Out B E N /\ Cong B N B M)) by (conclude lemma_layoff);destruct Tf as [N];spliter.
assert (Cong B M B N) by (conclude lemma_congruencesymmetric).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (neq B A) by (forward_using lemma_NCdistinct).
assert (Out B A A) by (conclude lemma_ray4).
assert (Out B M D) by (conclude lemma_ray4).
assert (Out B D M) by (conclude lemma_ray5).
assert (nCol A B D) by (forward_using lemma_NCorder).
assert (CongA A B D A B D) by (conclude lemma_equalanglesreflexive).
assert (CongA A B D A B M) by (conclude lemma_equalangleshelper).
assert (CongA A B M A B D) by (conclude lemma_equalanglessymmetric).
assert (CongA A B M A B E) by (conclude lemma_equalanglestransitive).
assert (nCol A B E) by (forward_using lemma_NCorder).
assert (CongA A B E A B E) by (conclude lemma_equalanglesreflexive).
assert (CongA A B E A B N) by (conclude lemma_equalangleshelper).
assert (CongA A B M A B N) by (conclude lemma_equalanglestransitive).
assert (Cong B A B A) by (conclude cn_congruencereflexive).
assert (Cong A M A N) by (conclude proposition_04).
assert (Per B C D) by (conclude_def SQ ).
assert (Per B C E) by (conclude_def SQ ).
assert (CongA B C E B C D) by (conclude lemma_Euclid4).
assert (Cong A B C D) by (conclude_def SQ ).
assert (Cong A B C E) by (conclude_def SQ ).
assert (Cong C E A B) by (conclude lemma_congruencesymmetric).
assert (Cong C E C D) by (conclude lemma_congruencetransitive).
assert (nCol B C E) by (conclude lemma_rightangleNC).
assert (nCol B C D) by (conclude lemma_rightangleNC).
assert (Cong C B C B) by (conclude cn_congruencereflexive).
assert ((Cong B E B D /\ CongA C B E C B D /\ CongA C E B C D B)) by (conclude proposition_04).
assert (neq B C) by (forward_using lemma_NCdistinct).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Out B C C) by (conclude lemma_ray4).
assert (nCol B C D) by (conclude lemma_rightangleNC).
assert (nCol C B D) by (forward_using lemma_NCorder).
assert (CongA C B D C B D) by (conclude lemma_equalanglesreflexive).
assert (CongA C B D C B M) by (conclude lemma_equalangleshelper).
assert (nCol C B E) by (forward_using lemma_NCorder).
assert (CongA C B E C B E) by (conclude lemma_equalanglesreflexive).
assert (CongA C B E C B N) by (conclude lemma_equalangleshelper).
assert (CongA C B E C B D) by (conclude lemma_equalanglestransitive).
assert (CongA C B D C B E) by (conclude lemma_equalanglessymmetric).
assert (CongA C B M C B D) by (conclude lemma_equalanglessymmetric).
assert (CongA C B M C B E) by (conclude lemma_equalanglestransitive).
assert (CongA C B M C B N) by (conclude lemma_equalanglestransitive).
assert (CongA M B C N B C) by (conclude lemma_equalanglesflip).
assert (Cong B C B C) by (conclude cn_congruencereflexive).
assert (Cong M C N C) by (conclude (proposition_04 B M C B N C)).
assert (Cong A C A C) by (conclude cn_congruencereflexive).
assert (BetS A N C) by (conclude lemma_betweennesspreserved).
assert (neq A M) by (forward_using lemma_betweennotequal).
assert (Out A M C) by (conclude lemma_ray4).
assert (neq A N) by (forward_using lemma_betweennotequal).
assert (Out A N C) by (conclude lemma_ray4).
assert (Out A C N) by (conclude lemma_ray5).
assert (Out A C M) by (conclude lemma_ray5).
assert (eq M N) by (conclude lemma_layoffunique).
assert (Out B N E) by (conclude lemma_ray5).
assert (Out B M D) by (conclude lemma_ray5).
assert (Out B M E) by (conclude cn_equalitysub).
assert (eq E D) by (conclude lemma_layoffunique).
close.
Qed.

End Euclid.


Set Implicit Arguments.

Require Import
        List
        Ascii
        String
        Syntax.Regex
        Utils.Functions.ListUtils.

Import ListNotations.

Inductive tree : Set :=
| TEps  : tree
| TChr  : ascii -> tree
| TLeft : tree -> tree
| TRight : tree -> tree
| TCat  : tree -> tree -> tree
| TStar : list tree -> tree.

Section TREE_IND.
  Variable P : tree -> Prop.
  Variable Q : list tree -> Prop.

  Hypothesis
    (HTEps: P TEps)
    (HTChr : forall a, P (TChr a))
    (HTLeft : forall t, P t -> P (TLeft t))
    (HTRight : forall t, P t -> P (TRight t))
    (HTCat : forall t, P t -> forall t', P t' -> P (TCat t t'))
    (H : forall (ts : list tree), Q ts -> P (TStar ts))
    (H0 : Q (@nil tree))
    (H1 : forall (t : tree),
        P t ->
        forall (ts : list tree), Q ts -> Q (t :: ts)).

  Fixpoint tree_ind_full (t : tree) : P t :=
    match t as x return P x with
    | TEps       => HTEps
    | TChr a     => HTChr a
    | TLeft t    => HTLeft (tree_ind_full t)
    | TRight t   => HTRight (tree_ind_full t)
    | TCat t t'  => HTCat (tree_ind_full t) (tree_ind_full t')
    | TStar ts   =>
      H ((fix l_ind (ts' : list tree) : Q ts' :=
            match ts' as x return Q x with
            | [] => H0
            | t' :: ts'' => H1 (tree_ind_full t') (l_ind ts'')
            end) ts)
    end.
End TREE_IND.

Inductive is_tree_of : tree -> regex -> Prop :=
| ITEps : is_tree_of TEps #1
| ITChr : forall c, is_tree_of (TChr c) ($ c)
| ITLeft : forall tl l r, is_tree_of tl l -> is_tree_of (TLeft tl) (l :+: r)
| ITRight : forall tr l r, is_tree_of tr r -> is_tree_of (TRight tr) (l :+: r)
| ITCat : forall tl tr l r, is_tree_of tl l ->
                       is_tree_of tr r ->
                       is_tree_of (TCat tl tr) (l @ r)
| ITStarEnd : forall e, is_tree_of (TStar []) (Star e)
| ITStarRec : forall e ts t, is_tree_of t e ->
                        is_tree_of (TStar ts) (Star e) ->
                        is_tree_of (TStar (t :: ts)) (Star e).

Hint Constructors is_tree_of.

Fixpoint flat (t : tree) : string :=
  match t with
  | TEps => ""
  | TChr c => String c ""
  | TLeft t => flat t
  | TRight t => flat t
  | TCat t t' => flat t ++ flat t'
  | TStar ts => fold_right (fun t ac => flat t ++ ac) "" ts
  end.

Lemma str_append_rewind
  : forall s s' a, String a (s ++ s') = (String a s) ++ s'.
Proof.
  induction s ; crush.
Qed.

Lemma flat_correct : forall t e, is_tree_of t e -> (flat t) <<- e.
Proof.
  intros t e H ; induction H ; crush ; eauto.
  destruct (flat t) eqn : Ha ; eauto.
Qed.