(*
Just some extra (optional) thms/stuff, feel free to add more.
*)

(* Thm references etc. are to "Introduction to Bisimulation and Coinduction". *)
Section LTS.

Require Import Coq.Lists.List.
Import ListNotations. (* defines notation [[]] for [nil] *)

(* Stolen from coq-contribs/ccs on Github *)

Variable process action : Set.
Variable transition : process -> action -> process -> Prop.

(*
This is bisimilarity characterized as the largest bisimilation. I.e. thm 1.4.15,
but taken as a definition.

This definition (and its name) is from the above repo.
*)
CoInductive strong_eq : process -> process -> Prop :=
  str_eq : forall p q : process,
    (forall (a : action) (p' : process),
        transition p a p' ->
        exists q' : process, transition q a q' /\ strong_eq p' q') ->
    (forall (a : action) (q' : process),
        transition q a q' ->
        exists p' : process, transition p a p' /\ strong_eq p' q') ->
    strong_eq p q.

(*
Now we want a co-induction principle for this thing! This does not correspond directly to the definition in the book, because we do not want the /\ inside the forall ...
(This is not from the above repo.)
*)
Theorem strong_eq_coind : forall (R : process -> process -> Prop),
    (forall (p q : process),
    (forall (a : action) (p' : process),
        R p q -> transition p a p' ->
        exists q' : process, transition q a q' /\ R p' q')) ->
    (forall (p q : process),
    (forall (a : action) (q' : process),
        R p q -> transition q a q' ->
        exists p' : process, transition p a p' /\ R p' q')) ->
    forall (p q : process), R p q -> strong_eq p q.
Admitted.

Require Import Coq.Relations.Relation_Definitions.

(*
People asked about this during the "lecture", so why not prove it formally?
(Why isn't the first argument implicit for equiv? Strange design!)
Also, warning: The transitivity proof seemed long in the original file (but not necessarily complicated or unreasonably long).

This is thm 1.4.14 in the book.
*)
Theorem strong_eq_equiv' : equiv _ strong_eq.
Admitted.

(* Almost exercise 1.4.16, but alternative definition of bisimilar instead of bisimulation *)
Inductive ttransition : process -> list action -> process -> Prop :=
| ttransition_base : forall (p : process),
    ttransition p [] p
| ttransition_step : forall (p1 p2 p3 : process) (act : action) (acts : list action),
    transition p1 act p2 -> ttransition p2 acts p3 -> ttransition p1 (act::acts) p3.

CoInductive tstrong_eq : process -> process -> Prop :=
  tstr_eq : forall p q : process,
    (forall (acts : list action) (p' : process),
        ttransition p acts p' ->
        exists q' : process, ttransition q acts q' /\ tstrong_eq p' q') ->
    (forall (acts : list action) (q' : process),
        ttransition q acts q' ->
        exists p' : process, ttransition p acts p' /\ tstrong_eq p' q') ->
    tstrong_eq p q.

Theorem strong_eq_eq_tstrong_eq : forall (p q : process), strong_eq p q <-> tstrong_eq p q.
Admitted.

(* 2.1.1 Finite traces and ω-traces on processes *)

(* Finite traces *)
Inductive ft : process -> Prop :=
| ft_stopped p : (forall (a : action), ~(exists (p' : process), transition p a p')) -> ft p
| ft_step p : forall (a : action) (p' : process), transition p a p' -> ft p' -> ft p.

Theorem strong_eq_ft : forall (p q : process),
    ft p -> strong_eq p q -> ft q.
Admitted.

(* ω-traces *)
CoInductive wt (a : action) : process -> Prop :=
| wt_step p : forall (p' : process), transition p a p' -> wt a p' -> wt a p.

(* Co-induction principle for ω-traces *)
Theorem wt_coind : forall (a : action) (R : process -> Prop),
    (forall (p : process), R p -> exists (p' : process), R p' /\ transition p a p') ->
    (forall (p : process), R p -> wt a p).
Admitted.

Theorem strong_eq_wt : forall (a : action) (p q : process),
    wt a p -> strong_eq p q -> wt a q.
Admitted.

End LTS.

(* Shows that P1 and Q1 from fig. 1.2 (in the book), i.e. one of the examples from the "lecture", are bisimilar *)
Inductive ex1_processes :=
  P1 | P2 | Q1 | Q2 | Q3.

Inductive ex1_actions :=
  a | b.

Inductive ex1_trans : ex1_processes -> ex1_actions -> ex1_processes -> Prop :=
(* Left system *)
| P1P2 : ex1_trans P1 a P2
| P2P1 : ex1_trans P2 b P1
(* Right system *)
| Q1Q2 : ex1_trans Q1 a Q2
| Q2Q3 : ex1_trans Q2 b Q3
| Q3Q2 : ex1_trans Q3 a Q2.

Inductive ex1_R : ex1_processes -> ex1_processes -> Prop :=
| P1Q1_R : ex1_R P1 Q1
| P1Q3_R : ex1_R P1 Q3
| P2Q2_R : ex1_R P2 Q2.

Theorem P1_Q1_bisim : strong_eq _ _ ex1_trans P1 Q1.
Proof.
  apply (strong_eq_coind _ _ _ ex1_R); intros.
  * destruct p; inversion H; inversion H0; subst.
   + (* R (P1, Q1) *) exists Q2. split; constructor.
   + (* R (P1, Q3) *) exists Q2. split; constructor.
   + (* R (P2, Q2) *) exists Q3. split; constructor.
  * destruct q; inversion H; inversion H0; subst.
   + (* R (P1, Q1) *) exists P2. split; constructor.
   + (* R (P2, Q2) *) exists P1. split; constructor.
   + (* R (P1, Q3) *) exists P2. split; constructor.
  * constructor. Qed.


Inductive even : nat -> Prop :=
  | Even0 : even 0
  | EvenS : forall n:nat, even n -> even (S (S n)).

Lemma not_1_even: ~ even 1.
Proof.
  unfold not. cut (forall n:nat, n = 1 -> even n -> False). eauto.
  intros n H He. generalize H. clear H. generalize He. elim He.
  intros. discriminate. clear He n. intros. discriminate.
Qed.

Lemma not_1_even': ~ even 1.
Proof.
  unfold not. intros H. inversion H.
Qed.

Lemma plus_2_even_inv: forall n:nat, even (S (S n)) -> even n.
Proof.
  intros n H. inversion H. exact H1.
Qed.

Lemma not_1_even'': ~ even 1.
Proof.
  intro H. generalize (refl_equal 1).
  pattern 1 at -2. elim H; intros; discriminate.
Qed.

Lemma plus_2_even_inv': forall n:nat, even (S (S n)) -> even n.
Proof.
  intro n. cut(forall m:nat, m = S (S n) -> even m -> even n).
  eauto. intros m H He. generalize He H. clear H. generalize n.
  clear n. elim He. intros. discriminate. clear m He.
  intros. injection H1. intros. rewrite <- H2. exact H.
Qed.


Require Export GeoCoq.Tarski_dev.Annexes.circles.
Require Export GeoCoq.Tarski_dev.Annexes.half_angles.
Require Export GeoCoq.Tarski_dev.Ch12_parallel_inter_dec.

Section Inscribed_angle.

Context `{TE:Tarski_euclidean}.

(** The sum of the angles of a triangle is the flat angle. *)

Lemma trisuma__bet : forall A B C D E F, TriSumA A B C D E F -> Bet D E F.
Proof.
  apply alternate_interior__triangle.
  unfold alternate_interior_angles_postulate.
  apply l12_21_a.
Qed.

Lemma bet__trisuma : forall A B C D E F, Bet D E F -> A <> B -> B <> C -> A <> C -> D <> E -> E <> F ->
  TriSumA A B C D E F.
Proof.
  intros A B C D E F HBet; intros.
  destruct (ex_trisuma A B C) as [P [Q [R HTri]]]; auto.
  apply conga_trisuma__trisuma with P Q R; trivial.
  assert (Hd := HTri).
  apply trisuma_distincts in Hd; spliter.
  apply conga_line; auto.
  apply (trisuma__bet A B C); trivial.
Qed.

Lemma right_saccheris : forall A B C D, Saccheri A B C D -> Per A B C.
Proof.
  apply postulates_in_euclidean_context; simpl; repeat (try (left; reflexivity); right).
Qed.

Lemma not_obtuse_saccheris : ~ hypothesis_of_obtuse_saccheri_quadrilaterals.
Proof.
  apply not_oah; right.
  unfold hypothesis_of_right_saccheri_quadrilaterals; apply right_saccheris.
Qed.

Lemma suma123231__sams : forall A B C D E F, SumA A B C B C A D E F -> SAMS D E F C A B.
Proof. exact (t22_20 not_obtuse_saccheris). Qed.

Lemma bet_suma__suma : forall A B C D E F G H I, G <> H -> H <> I ->
  Bet G H I -> SumA A B C B C A D E F -> SumA D E F C A B G H I.
Proof.
  intros A B C D E F G H I HGH HHI HBet HSuma.
  suma.assert_diffs.
  destruct (bet__trisuma A B C G H I) as [D' [E' [F' []]]]; auto.
  apply (conga3_suma__suma D' E' F' C A B G H I); try apply conga_refl; auto.
  apply (suma2__conga A B C B C A); assumption.
Qed.

Lemma high_school_exterior_angle_theorem : forall A B C B', A <> B -> B <> C -> A <> C -> A <> B' ->
  Bet B A B' -> SumA A B C B C A C A B'.
Proof.
  intros A B C B'; intros.
  assert (SumA C A B' C A B B A B').
    apply suma_sym, suma_left_comm, bet__suma; auto.
  destruct (ex_suma A B C B C A) as [D [E [F]]]; auto.
  apply (conga3_suma__suma A B C B C A D E F); try apply conga_refl; auto.
  apply sams2_suma2__conga123 with C A B B A B'.
    apply suma123231__sams; assumption.
    apply bet_suma__sams with B A B'; assumption.
    apply bet_suma__suma; auto.
    assumption.
Qed.

(** If A, B and C are points on a circle where the line AB is a diameter of the circle,
    then the angle ACB is a right angle. *)

Lemma thales_theorem : forall A B C M, ~ Col A B C ->
  Midpoint M A B -> Cong M A M C -> Per A C B.
Proof.
  apply rah__thales_postulate.
  unfold postulate_of_right_saccheri_quadrilaterals; apply right_saccheris.
Qed.

(** In a right triangle, the midpoint of the hypotenuse is the circumcenter. *)

Lemma thales_converse_theorem : forall A B C M, A <> C -> B <> C ->
  Midpoint M A B -> Per A C B -> Cong M A M C.
Proof.
  intros A B C M HAC HBC HM HPer.
  apply thales_postulate__thales_converse_postulate with B; [| |assumption..].
    unfold thales_postulate; apply thales_theorem.
  apply not_col_permutation_5, per_not_col; auto.
Qed.

Lemma bet_cong__ghalfa : forall A B C B', A <> B -> B <> C -> A <> B' ->
  Bet B A B' -> Cong A B A C -> gHalfA A B C C A B'.
Proof.
  intros A B C B' HAB HBC HAB' HBet HCong.
  apply ghalfa_chara; split.
    apply cong__acute; auto.
  assert_diffs.
  apply (conga3_suma__suma A B C B C A C A B'); try apply conga_refl; auto.
    apply high_school_exterior_angle_theorem; auto.
  apply conga_left_comm, l11_44_1_a; Cong.
Qed.

(** If the angle ACB is inscribed in a circle of center O and
    C, O lie on the same side of AB, then this angle is acute. *)

Lemma onc3_os__acute : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OS A B O C ->
  Acute A C B.
Proof.
  intros O P A B C HA HB HC HOS.
  destruct (midpoint_existence A B) as [M HM].
  assert (HNCol : ~ Col A B C) by (eapply one_side_not_col124, HOS).
  assert (HLt : Lt M A M C).
  { assert (HNCol1 : ~ Col A B O) by (eapply one_side_not_col123, HOS).
    assert (M <> O) by (intro; treat_equalities; apply HNCol1; Col).
    assert (O <> C) by (intro; treat_equalities; auto).
    assert_diffs.
    assert (Cong O A O C) by (apply (onc2__cong O P); assumption).
    destruct (angle_partition M O C); auto.
    - assert (HMO := H).
      clear H.
      destruct (l8_18_existence M O C) as [H []].
      { intro.
        destruct (acute_col__out M O C) as [_ [_ [HBet|HBet]]]; auto.
        - apply l9_9_bis in HOS.
          apply HOS.
          repeat split; Col.
          exists M; split; Col.
        - apply (le__nlt O C O M); Le.
          apply (cong2_lt__lt O M O P); Cong.
          apply bet_inc2__incs with A B; Circle; Between.
      }
      assert (Perp O M A B) by (apply mid_onc2__perp with P; auto).
      assert (HOS1 : OS A B C H).
      { apply l12_6, par_not_col_strict with C; Col.
        apply l12_9 with O M; Perp; [|Cop| |Cop].
          apply coplanar_perm_5, col_cop__cop with B; Col; Cop.
          apply coplanar_perm_5, col_cop__cop with A; Col; Cop.
      }
      assert (M <> H) by (intro; subst; apply one_side_not_col124 in HOS1; apply HOS1; Col).
      assert (Per M H C) by (apply perp_per_1, perp_left_comm, perp_col with O; Col).
      apply lt_transitivity with H C; [|assert_diffs; apply l11_46; auto].
      apply cong_lt_per2__lt_1 with O O; Cong.
        apply l8_2, per_col with M; Col; Perp.
        apply perp_per_1, perp_left_comm, perp_col1 with B; Col.
      apply bet__lt1213; auto; apply out2__bet.
        apply (acute_col_perp__out C); [apply acute_sym|..]; Col; Perp.
        apply (l9_19 A B); Col; apply one_side_transitivity with C; assumption.
    - apply lt_transitivity with O C; [|apply l11_46; auto].
      apply (cong2_lt__lt M A O A); Cong.
      apply l11_46; auto.
      left.
      apply mid_onc2__per with P B; auto.
  }
  destruct HLt as [[C' [HBet HCong]] HNCong].
  exists A, C', B; split.
    apply thales_theorem with M; trivial; intro; apply HNCol; ColR.
  assert_diffs.
  assert (C <> C') by (intro; subst; apply HNCong, HCong).
  apply os3__lta.
  - apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; [Col|apply l6_6, bet_out; Between].
      apply out_one_side; [left; intro; apply HNCol; ColR|apply l6_6, bet_out; Between].
  - apply out_one_side_1 with M; Col; apply l6_6, bet_out; auto.
  - apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; [Col|apply l6_6, bet_out; Between].
      apply out_one_side; [left; intro; apply HNCol; ColR|apply l6_6, bet_out; Between].
Qed.

Lemma inscribed_angle_aux : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> TS O C A B ->
  gHalfA A C B A O B.
Proof.
  intros O P A B C HA HB HC HOS HTS.
  destruct (segment_construction C O O P) as [C' []].
  assert_diffs.
  assert (O <> C') by (intro; treat_equalities; auto).
  assert (HCong := (onc2__cong O P)).
  apply suma_preserves_ghalfa with A C C' C' C B A O C' C' O B.
    apply (onc3_os__acute O P); assumption.
    apply ts__suma, invert_two_sides, col_two_sides with O; Side; Col.
    apply ts__suma, invert_two_sides, col_two_sides with C; Col.
    apply ghalfa_out4__ghalfa with A O A C'; try apply out_trivial; auto;
      [apply l6_6, bet_out|apply ghalfa_left_comm, bet_cong__ghalfa]; auto.
    apply ghalfa_out4__ghalfa with O B C' B; try apply out_trivial; auto;
      [apply l6_6, bet_out|apply ghalfa_right_comm, bet_cong__ghalfa]; auto.
Qed.

Lemma inscribed_angle_aux1 : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> OS O C A B ->
  gHalfA A C B A O B.
Proof.
  assert (Haux : forall O P A B C, OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> OS O C A B -> OS O B A C -> gHalfA A C B A O B).
  { intros O P A B C HA HB HC HOS1 HOS2 HOS3.
    destruct (chord_completion O P C O) as [C' [HC' HBet ]]; Circle.
    assert_diffs.
    assert (C' <> O) by (intro; treat_equalities; auto).
    assert (TS O B A C').
    { apply l9_8_2 with C; [|Side].
      apply one_side_not_col124 in HOS3.
      repeat split.
        Col.
        intro; apply HOS3; ColR.
      exists O; split; Col.
    }
    assert (HCong := (onc2__cong O P)).
    apply acute_ghalfa2_sams_suma2__ghalfa123 with B C O A C O B O C' A O C'.
    - repeat split; auto.
        right; intro; assert_cols; assert_ncols; Col.
      exists C'.
      split; CongA.
      repeat split; [Side| |Cop].
      apply l9_9_bis, invert_one_side, one_side_symmetry, os_ts1324__os; [|Side].
      apply col_one_side with C; Col; Side.
    - apply (onc3_os__acute O P); assumption.
    - exists O.
      repeat (split; CongA); [|Cop].
      apply l9_9, invert_two_sides, l9_31; Side.
    - exists C'.
      repeat (split; CongA); [Side|Cop].
    - apply ghalfa_left_comm, bet_cong__ghalfa; auto.
    - apply ghalfa_left_comm, bet_cong__ghalfa; auto.
  }
  intros O P A B C HA HB HC HOS1 HOS2.
  assert_ncols.
  destruct (cop__one_or_two_sides O B A C) as [HTS|]; Col; Cop.
    apply ghalfa_comm, Haux with P; auto; [..|apply one_side_symmetry, os_ts1324__os]; Side.
    apply Haux with P; assumption.
Qed.

(** Euclid Book III Prop 20:
    In a circle the angle at the centre is double of the angle at the circumference,
    when the angles have the same circumference as base. *)

Lemma inscribed_angle : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OS A B O C ->
  gHalfA A C B A O B.
Proof.
  intros O P A B C HA HB HC HOS.
  assert (HCong := (onc2__cong O P)).
  destruct (col_dec A O C).
  { assert_diffs.
    assert (Bet C O A) by (apply col_inc_onc2__bet with O P; Col; Circle).
    assert (O <> C) by (intro; treat_equalities; auto).
    apply ghalfa_right_comm, ghalfa_out4__ghalfa with O B B A; try apply out_trivial; auto.
      apply l6_6, bet_out; auto.
    apply bet_cong__ghalfa; auto.
  }
  destruct (col_dec B O C).
  { assert_diffs.
    assert (Bet C O B) by (apply col_inc_onc2__bet with O P; Col; Circle).
    assert (O <> C) by (intro; treat_equalities; auto).
    apply ghalfa_left_comm, ghalfa_out4__ghalfa with O A A B; try apply out_trivial; auto.
      apply l6_6, bet_out; auto.
    apply bet_cong__ghalfa; auto.
  }
  destruct (cop__one_or_two_sides O C A B); Cop.
    apply inscribed_angle_aux with P; assumption.
    apply inscribed_angle_aux1 with P; assumption.
Qed.

Lemma diam_onc2_ts__suppa : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> Diam C C' O P -> TS A B C C' ->
  SuppA A C B A C' B.
Proof.
  intros O P A B C C' HA HB [HBet [HC HC']] HTS.
  assert_diffs.
  assert (HCong := onc2__cong O P).
  assert (HMid : Midpoint O C C') by (split; Cong).
  assert (C <> C') by (intro; treat_equalities; auto).
  assert (HNColA : ~ Col C C' A) by (apply (onc3__ncol O P); auto).
  assert (HNColB : ~ Col C C' B) by (apply (onc3__ncol O P); auto).
  assert (HSumaA : SumA A C C' C C' A C A C') by (apply cong_mid__suma with O; auto).
  assert (HSumaB : SumA B C C' C C' B C B C') by (apply cong_mid__suma with O; auto).
  assert (Per C A C') by (apply thales_theorem with O; auto).
  assert (Per C B C') by (apply thales_theorem with O; auto).
  assert (HSuma : SumA C A C' C B C' C O C') by (assert_diffs; apply bet_per2__suma; auto).
  apply bet_suma__suppa with C O C'; trivial.
  destruct (ex_suma C A C' C' C B) as [D [E [F HSuma1]]]; auto.
  assert (HTS2 : TS C C' A B) by (apply (chord_intersection O P); assumption).
  assert (HTS3 : TS C' C A B) by (apply invert_two_sides, HTS2).
  assert (Acute C' C A).
  { assert_diffs; apply acute_out2__acute with O A.
      apply l6_6, bet_out; auto.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C' C B).
  { assert_diffs; apply acute_out2__acute with O B.
      apply l6_6, bet_out; auto.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C C' A).
  { assert_diffs; apply acute_out2__acute with O A.
      apply l6_6, bet_out; Between.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C C' B).
  { assert_diffs; apply acute_out2__acute with O B.
      apply l6_6, bet_out; Between.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (HSuma2 : SumA A C B A C' C D E F).
    apply suma_sym, suma_assoc_1 with A C C' C' C B C A C'; SumA.
  assert (HSAMS : SAMS A C B A C' C).
    apply sams_sym, sams_assoc_1 with A C C' C' C B C A C'; SumA.
  apply suma_assoc_1 with A C' C C C' B D E F; [SumA..|].
  apply suma_assoc_2 with C A C' B C C' C B C'; SumA.
Qed.

(** In a circle the angle at the centre is double of the angle at the circumference. *)

Lemma inscribed_angle_1 : forall O P A B C, A <> B -> B <> C -> A <> C ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  SumA A C B A C B A O B.
Proof.
  intros O P A B C HAB HBC HAC HA HB HC HCop.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  destruct (col_dec A B O).
  { assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    assert (Per A C B) by (apply thales_theorem with O; auto; apply cong_transitivity with O P; Cong).
    assert_diffs; apply bet_per2__suma; Between.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  - destruct (chord_completion O P C O) as [C' []]; Circle.
    assert (TS A B C' C) by (apply l9_2, bet_ts__ts with O; Side).
    assert (SuppA A C' B A C B).
      apply (diam_onc2_ts__suppa O P); [..|repeat split|]; Between.
    apply (suma_suppa2__suma A C' B A C' B); trivial.
    apply ghalfa__suma, inscribed_angle with P; trivial.
    exists C; split; trivial.
  - apply ghalfa__suma, inscribed_angle with P; trivial.
Qed.

(** If two angles ACB and ADB are inscribed in the same circle,
    then they are either congruent or supplementary. *)

Lemma cop2_onc4__or_conga_suppa : forall O P A B C C',
  A <> B -> B <> C -> A <> C -> B <> C' -> A <> C' ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  Coplanar A B C O -> Coplanar A B C' O ->
  CongA A C B A C' B \/ SuppA A C B A C' B.
Proof.
  intros O P A B C C'; intros.
  apply suma2__or_conga_suppa with A O B; trivial; apply inscribed_angle_1 with P; assumption.
Qed.

(** If the angle ACB is inscribed in a circle of center O and
    C, O lie on opposite sides of AB, then this angle is obtuse. *)

Lemma onc3_ts__obtuse : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> TS A B O C ->
  Obtuse A C B.
Proof.
  intros O P A B C HA HB HC HTS.
  destruct (chord_completion O P C O) as [C' []]; Circle.
  assert (TS A B C C') by (apply bet_ts__ts with O; Side).
  apply (acute_suppa__obtuse A C' B).
    apply (onc3_os__acute O P); trivial; exists C; split; Side.
  apply (diam_onc2_ts__suppa O P); Side.
  repeat split; Between.
Qed.

(** Euclid Book III Prop 21:
    In a circle the angles in the same segment are equal to one another. *)

Lemma cop_onc4_os__conga : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  OS A B C C' -> Coplanar A B C O ->
  CongA A C B A C' B.
Proof.
  intros O P A B C C' HA HB HC HC' HOS HCop.
  assert_ncols.
  destruct (col_dec A B O).
  { assert_diffs.
    assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    apply l11_16; auto; apply thales_theorem with O; Col; apply cong_transitivity with O P; Cong.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  - assert_diffs; destruct (cop2_onc4__or_conga_suppa O P A B C C') as [|Habs]; auto.
      apply coplanar_trans_1 with C; Col; Cop.
    exfalso.
    apply (nlta A C' B), acute_obtuse__lta.
      apply (obtuse_suppa__acute A C B); [apply (onc3_ts__obtuse O P)|]; trivial.
      apply (onc3_ts__obtuse O P); trivial; apply l9_2, l9_8_2 with C; Side.
  - apply ghalfa2__conga_2 with A O B; apply inscribed_angle with P; trivial.
    apply one_side_transitivity with C; Side.
Qed.

(** Euclid Book III Prop 22:
    The opposite angles of quadrilaterals in circles are equal to two right angles. *)

Lemma cop_onc4_ts__suppa : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  TS A B C C' -> Coplanar A B C O ->
  SuppA A C B A C' B.
Proof.
  intros O P A B C C' HA HB.
  revert C C'.
  assert (Haux : forall C C', OnCircle C O P -> OnCircle C' O P -> TS A B C C' -> OS A B O C ->
    SuppA A C B A C' B).
  { intros C C' HC HC' HTS HOS.
    assert_diffs.
    assert (~ Col C A B) by (destruct HTS; assumption).
    assert (Coplanar A B C' O) by (apply coplanar_trans_1 with C; Cop).
    destruct (cop2_onc4__or_conga_suppa O P A B C C') as [Habs|]; Cop.
    exfalso.
    assert (HLta : LtA A C B A C' B); [|destruct HLta as [_ HN]; apply HN, Habs].
    apply acute_obtuse__lta.
      apply (onc3_os__acute O P); assumption.
    apply (onc3_ts__obtuse O P); trivial.
    apply l9_8_2 with C; Side.
  }
  intros C C' HC HC' HTS HCop.
  assert (~ Col C A B) by (destruct HTS; assumption).
  destruct (col_dec A B O).
  { assert_diffs.
    assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    destruct HTS as [_ []].
    apply per2__suppa; auto; apply thales_theorem with O; Col; apply cong_transitivity with O P; Cong.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  apply suppa_sym, Haux; [..|exists C; split]; Side.
Qed.

(** If the angle ACB is acute and inscribed in a circle of center O,
    then C and O lie on the same side of AB. *)

Lemma acute_cop_onc3__os : forall O P A B C, A <> B ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O -> Acute A C B ->
  OS A B O C.
Proof.
  intros O P A B C HAB HA HB HC HCop HAcute.
  assert_diffs.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  apply coplanar_perm_1 in HCop.
  apply cop__not_two_sides_one_side; Col; intro Habs; apply (nlta A C B).
  - apply acute_per__lta; auto.
    apply thales_theorem with O; trivial.
      apply col_onc2__mid with P; Col.
      apply (onc2__cong O P); assumption.
  - apply acute_obtuse__lta; trivial.
    apply (onc3_ts__obtuse O P); assumption.
Qed.

(** If the angle ACB is obtuse and inscribed in a circle of center O,
    then C and O lie on opposite sides of AB. *)

Lemma cop_obtuse_onc3__ts : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O -> Obtuse A C B ->
  TS A B O C.
Proof.
  intros O P A B C HA HB HC HCop HObtuse.
  assert_diffs.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  apply coplanar_perm_1 in HCop.
  apply cop__not_one_side_two_sides; Col; intro Habs; apply (nlta A C B).
  - apply obtuse_per__lta; auto.
    apply thales_theorem with O; trivial.
      apply col_onc2__mid with P; Col.
      apply (onc2__cong O P); assumption.
  - apply acute_obtuse__lta; trivial.
    apply (onc3_os__acute O P); assumption.
Qed.

(** If the angles ACB and ADB are congruent and inscribed in the same circle,
    then C and D lie on the same side of AB. *)

Lemma conga_cop2_onc4__os : forall O P A B C D, ~ Col A B O ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle D O P ->
  Coplanar A B O C -> Coplanar A B O D -> CongA A C B A D B ->
  OS A B C D.
Proof.
  intros O P A B C D HNCol HA HB HC HD HCopC HCopD HConga.
  assert_diffs.
  destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
  - apply one_side_transitivity with O; [apply one_side_symmetry|];
      apply acute_cop_onc3__os with P; Cop.
    apply (acute_conga__acute A C B); assumption.
  - exfalso.
    apply HNCol, col_permutation_1, midpoint_col.
    destruct (midpoint_existence A B) as [M HM].
    assert (M = O); [|subst; apply HM].
    assert (HCong := onc2__cong O P).
    apply (cong4_cop2__eq A C B); Cong; [..|Cop|Cop].
      apply per_not_col; auto.
      apply cong_commutativity, thales_converse_theorem with B; auto.
  - exists O; split; apply l9_2; apply cop_obtuse_onc3__ts with P; Cop.
    apply (conga_obtuse__obtuse A C B); assumption.
Qed.

(** If the angles ACB and ADB are supplementary and inscribed in the same circle,
    then C and D lie on opposite sides of AB. *)

Lemma cop2_onc4_suppa__ts : forall O P A B C D, ~ Col A B O ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle D O P ->
  Coplanar A B O C -> Coplanar A B O D -> SuppA A C B A D B ->
  TS A B C D.
Proof.
  intros O P A B C D HNCol HA HB HC HD HCopC HCopD HSuppa.
  assert_diffs.
  destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
  - apply l9_8_2 with O.
      apply cop_obtuse_onc3__ts with P; Cop; apply (acute_suppa__obtuse A C B); assumption.
      apply acute_cop_onc3__os with P; Cop.
  - exfalso.
    apply HNCol, col_permutation_1, midpoint_col.
    destruct (midpoint_existence A B) as [M HM].
    assert (M = O); [|subst; apply HM].
    assert (HCong := onc2__cong O P).
    apply (cong4_cop2__eq A C B); Cong; [..|Cop|Cop].
      apply per_not_col; auto.
      apply cong_commutativity, thales_converse_theorem with B; auto.
  - apply l9_2, l9_8_2 with O.
      apply cop_obtuse_onc3__ts with P; Cop.
    apply acute_cop_onc3__os with P; Cop; apply (obtuse_suppa__acute A C B); assumption.
Qed.

(** Non degenerated triangles can be circumscribed. *)

Lemma triangle_circumscription : forall A B C, ~ Col A B C ->
  exists CC : Tpoint, Cong A CC B CC /\ Cong A CC C CC /\ Coplanar A B C CC.
Proof.
  apply postulates_in_euclidean_context; simpl; repeat (try (left; reflexivity); right).
Qed.

(** Euclid Book III Prop 23:
    On the same straight line there cannot be constructed
    two similar and unequal segments of circles on the same side. *)

Lemma conga_cop_onc6_os__eq : forall A B C D O P O' P',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  OnCircle A O' P' -> OnCircle B O' P' -> OnCircle D O' P' -> Coplanar A B D O' ->
  OS A B C D -> CongA A C B A D B ->
  (O = O' /\ Cong O P O' P').
Proof.
  intros A B C D O P O' P' HA HB HC HCop HA' HB' HD' HCop' HOS HConga.
  assert (O = O'); [|split; trivial; subst O'; apply cong_transitivity with O A; Cong].
  assert (HNCol : ~ Col A B C) by (apply one_side_not_col123 with D, HOS).
  assert (HCong := onc2__cong O P).
  destruct (col_dec A B O) as [|HNCol1].
  { assert_diffs.
    apply cong2_cop2_onc3__eq with P' A B D; auto; [|apply coplanar_trans_1 with C; Col; Cop].
    assert (Midpoint O A B) by (apply col_onc2__mid with P; assumption).
    apply thales_converse_theorem with B; auto.
    apply (l11_17 A C B); trivial.
    apply thales_theorem with O; Cong.
  }
  assert (HNCol' : ~ Col A B D) by (apply one_side_not_col124 with C, HOS).
  assert (HCong' := onc2__cong O' P').
  destruct (midpoint_existence A B) as [M HM].
  assert (HOS1 : OS A B O O').
  { assert_diffs; destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
    - apply one_side_transitivity with C;
        [|apply one_side_transitivity with D; trivial; apply one_side_symmetry].
        apply acute_cop_onc3__os with P; auto.
      apply acute_cop_onc3__os with P'; auto.
      apply (acute_conga__acute A C B); assumption.
    - exfalso.
      apply HNCol1.
      assert (O = M); [|subst; Col].
      apply (cong4_cop2__eq A B C); Cong; [|Cop].
      apply cong_commutativity, thales_converse_theorem with B; auto.
    - exists C; split; [|apply l9_2, l9_8_2 with D; [apply l9_2|Side]].
        apply cop_obtuse_onc3__ts with P; auto.
      apply cop_obtuse_onc3__ts with P'; auto.
      apply (conga_obtuse__obtuse A C B); assumption.
  }
  assert (HNCol1' : ~ Col A B O') by (apply one_side_not_col124 with O, HOS1).
  destruct (bet_cop_onc2__ex_onc_os_out O P A B C M) as [C1]; Between; Col; [assert_diffs; auto..|].
  destruct (bet_cop_onc2__ex_onc_os_out O' P' A B D M) as [D1]; Between; Col; [assert_diffs; auto..|].
  spliter.
  assert (HNCol2 : ~ Col A B C1) by (apply one_side_not_col124 with C; assumption).
  assert (HOut : Out M C1 D1).
  { apply (l9_19 A B); [Col| |
      apply one_side_transitivity with C; [|apply one_side_transitivity with D]; Side].
    assert (O <> M) by (intro; subst; apply HNCol1; Col).
    assert (O' <> M) by (intro; subst; apply HNCol1'; Col).
    assert (Col O O' M); [|ColR].
    assert_diffs; apply (cop_per2__col A); auto;
      [|apply mid_onc2__per with P B; auto|apply mid_onc2__per with P' B; auto].
    apply coplanar_trans_1 with B; Col; [|Cop].
    apply coplanar_trans_1 with C; Col; [Cop|].
    apply coplanar_perm_12, coplanar_trans_1 with D; Col; Cop.
  }
  destruct (eq_dec_points C1 D1).
  { subst D1.
    apply (cong4_cop2__eq A B C1); Cong; exists M; left; split; Col.
  }
  assert (HNCol2' : ~ Col A B D1) by (apply one_side_not_col124 with D; assumption).
  assert (CongA A C1 B A C B) by (apply (cop_onc4_os__conga O P); Side; exists M; left; split; Col).
  assert (CongA A D1 B A D B) by (apply (cop_onc4_os__conga O' P'); Side; exists M; left; split; Col).
  assert (Out A B M) by (assert_diffs; apply l6_6, bet_out; Between).
  assert (Out B A M) by (assert_diffs; apply l6_6, bet_out; Between).
  assert (HH := HOut).
  destruct HH as [HMC1 [HMD1 [HBet|HBet]]]; exfalso.
  - apply (lta_not_conga A D B A C B); CongA.
    apply (conga_preserves_lta A D1 B A C1 B); trivial.
    assert (Out D1 M C1) by (apply l6_6, bet_out; Between).
    apply os3__lta; [|apply one_side_symmetry, l9_19 with M; Col|];
      apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2'; ColR.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2'; ColR.
  - apply (lta_not_conga A C B A D B); trivial.
    apply (conga_preserves_lta A C1 B A D1 B); trivial.
    assert (Out C1 M D1) by (apply l6_6, bet_out; Between).
    apply os3__lta; [|apply l9_19 with M; Col|];
      apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2; ColR.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2; ColR.
Qed.

Lemma conga_cop_onc3_os__onc : forall A B C D O P,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  Coplanar A B C O -> OS A B C D -> CongA A C B A D B ->
  OnCircle D O P.
Proof.
  intros A B C D O P HA HB HC HCop HOS HConga.
  destruct (triangle_circumscription A B D) as [O'].
    apply one_side_not_col124 in HOS; Col.
  spliter.
  assert (OnCircle A O' A /\ OnCircle B O' A /\ OnCircle D O' A).
    unfold OnCircle; repeat split; Cong.
  spliter.
  destruct (conga_cop_onc6_os__eq A B C D O P O' A); trivial.
  subst O'; apply cong_transitivity with O A; Cong.
Qed.

(** If the angles ACB and ADB are congruent and C, D lie on the same side of AB,
    then A, B, C and D are concyclic. *)

Lemma conga_os__ex_circle : forall A B C D,
  OS A B C D -> CongA A C B A D B -> exists O P,
  OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ OnCircle D O P /\ Coplanar A B C O.
Proof.
  intros A B C D HOS HConga.
  destruct (triangle_circumscription A B C) as [O]; spliter.
    apply one_side_not_col123 with D, HOS.
  assert (OnCircle A O A /\ OnCircle B O A /\ OnCircle C O A).
    unfold OnCircle; repeat split; Cong.
  spliter.
  exists O, A; repeat split; trivial.
  apply (conga_cop_onc3_os__onc A B C); assumption.
Qed.

(** If the angles ACB and ADB are supplementary and C, D lie on opposite sides of AB,
    then A, B, C and D are concyclic. *)

Lemma suppa_ts__ex_circle : forall A B C D,
  TS A B C D -> SuppA A C B A D B -> exists O P,
  OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ OnCircle D O P /\ Coplanar A B C O.
Proof.
  intros A B.
  assert (Haux : forall C D, TS A B C D -> Obtuse A C B -> SuppA A C B A D B -> exists O P,
    OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ OnCircle D O P /\ Coplanar A B C O).
  { intros C D HTS HObtuse HSuppa.
    assert (HNCol : ~ Col A B C) by (destruct HTS; Col).
    destruct (triangle_circumscription A B C HNCol) as [O]; spliter.
    assert (OnCircle A O A /\ OnCircle B O A /\ OnCircle C O A).
      unfold OnCircle; repeat split; Cong.
    spliter.
    exists O, A; repeat split; trivial.
    destruct (chord_completion O A C O) as [C'[HC' HBet]]; Circle.
    assert (TS A B C C').
      apply bet_ts__ts with O; [apply l9_2, cop_obtuse_onc3__ts with A|]; assumption.
    apply (conga_cop_onc3_os__onc A B C'); trivial.
      apply coplanar_trans_1 with C; Col; Cop.
      exists C; split; Side.
      apply (suppa2__conga456 A C B); [apply (cop_onc4_ts__suppa O A)|]; assumption.
  }
  intros C D HTS HSuppa.
  assert_diffs; destruct (angle_partition A C B) as [|[|]]; auto.
  { destruct (Haux D C) as [O [P]].
      Side.
      apply (acute_suppa__obtuse A C B); trivial.
      apply suppa_sym, HSuppa.
    exists O, P.
    spliter; repeat split; trivial.
    apply coplanar_trans_1 with D; [destruct HTS as [_ []]; Col|Cop..].
  }
  destruct (midpoint_existence A B) as [M].
  exists M, A.
  destruct HTS as [HNCol1 [HNCol2 _]].
  unfold OnCircle; repeat split; [Cong..| | |Cop];
    apply cong_symmetry, thales_converse_theorem with B; auto.
  apply (per_suppa__per A C B); assumption.
Qed.

(** In a convex quadrilateral, if two opposite angles are supplementary
    then the two other angles are also supplementary. *)

Lemma suppa_ts2__suppa : forall A B C D,
  TS A C B D -> TS B D A C -> SuppA A B C A D C -> SuppA B A D B C D.
Proof.
  intros A B C D HTS1 HTS2 HSuppa.
  destruct (suppa_ts__ex_circle A C B D) as [O [P]]; trivial.
  spliter.
  apply (cop_onc4_ts__suppa O P); trivial.
  apply coplanar_perm_2, coplanar_trans_1 with C; [destruct HTS1; Col|Cop..].
Qed.

End Inscribed_angle.

Section Inscribed_angle_2.

Context `{T2D:Tarski_2D}.
Context `{TE:@Tarski_euclidean Tn TnEQD}.

Lemma chord_par_diam : forall O P A B C C' A' U,
 O <> P -> ~Col A B C' -> Diam C C' O P -> Midpoint A' A C' -> OnCircle A O P -> OnCircle B O P ->
 Col A B U -> Perp O U A B -> Par A C' O U -> B = C.
Proof.
intros.
assert_diffs.
assert(Midpoint U A B).
{
  apply(col_onc2_perp__mid O P A B U); Col.
}
assert(O <> A').
intro.
treat_equalities.
induction H7.
apply H7.
exists O.
split; Col.
spliter.
assert(Perp A U  O U).
{
  apply perp_sym in H6.
  apply (perp_col A B O U U); Col.
  intro.
  treat_equalities.
  apply perp_distinct in H6.
  tauto.
}
apply perp_left_comm in H18.
apply perp_not_col in H18.
apply H18; Col.
unfold Diam in H1.
spliter.
assert(HH:=mid_onc2__perp O P A C' A' H15 H13 H3 H17 H2).
assert(Perp O U O A').
{
  apply(par_perp__perp A C' O U O A' H7); Perp.
}

assert(Par O A' A B).
{
  apply (l12_9_2D _ _ _ _ O U); Perp.
}
assert(HM:=midpoint_existence B C').
ex_and HM O'.
assert(HP:= triangle_mid_par A B C' O' A' H0 H20 H2).
apply par_strict_par in HP.
assert(Par O A' A' O').
{
  apply (par_trans _ _ A B); Par.
}
assert(Col O O' A').
{
  induction H21.
  apply False_ind.
  apply H21.
  exists A'.
  split; Col.
  spliter.
  Col.
}

induction(eq_dec_points O O').
treat_equalities.
eapply(symmetric_point_uniqueness C' O); Midpoint.
split; eCong.
Between.

assert(HQ:= mid_onc2__perp O P B C' O' H23  H10 H4 H17 H20).
apply(perp_col O A' A C' O') in HH; Col.
assert(Par A C' B C').
{
  apply(l12_9_2D A C' B C' O O'); Perp.
}
apply False_ind.
induction H24.
apply H24.
exists C'.
split;Col.
spliter.
apply H0.
Col.
Qed.

End Inscribed_angle_2.


(* -*- coding: utf-8 -*- *)
(*************************************************************************

   PROJET RNRT Calife - 2001
   Author: Pierre Crégut - France Télécom R&D
   Licence du projet : LGPL version 2.1

 *************************************************************************)

Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base.
Delimit Scope Int_scope with I.

(** * Abstract Integers. *)

Module Type Int.

  Parameter t : Set.

  Bind Scope Int_scope with t.

  Parameter Inline zero : t.
  Parameter Inline one : t.
  Parameter Inline plus : t -> t -> t.
  Parameter Inline opp : t -> t.
  Parameter Inline minus : t -> t -> t.
  Parameter Inline mult : t -> t -> t.

  Notation "0" := zero : Int_scope.
  Notation "1" := one : Int_scope.
  Infix "+" := plus : Int_scope.
  Infix "-" := minus : Int_scope.
  Infix "*" := mult : Int_scope.
  Notation "- x" := (opp x) : Int_scope.

  Open Scope Int_scope.

  (** First, Int is a ring: *)
  Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t).

  (** Int should also be ordered: *)

  Parameter Inline le : t -> t -> Prop.
  Parameter Inline lt : t -> t -> Prop.
  Parameter Inline ge : t -> t -> Prop.
  Parameter Inline gt : t -> t -> Prop.
  Notation "x <= y" := (le x y): Int_scope.
  Notation "x < y" := (lt x y) : Int_scope.
  Notation "x >= y" := (ge x y) : Int_scope.
  Notation "x > y" := (gt x y): Int_scope.
  Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
  Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i).
  Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i).

  (** Basic properties of this order *)
  Axiom lt_trans : forall i j k, i<j -> j<k -> i<k.
  Axiom lt_not_eq : forall i j, i<j -> i<>j.

  (** Compatibilities *)
  Axiom lt_0_1 : 0<1.
  Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l.
  Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
  Axiom mult_lt_compat_l :
   forall i j k, 0 < k -> i < j -> k*i<k*j.

  (** We should have a way to decide the equality and the order*)
  Parameter compare : t -> t -> comparison.
  Infix "?=" := compare (at level 70, no associativity) : Int_scope.
  Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j.
  Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j.
  Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j.

  (** Up to here, these requirements could be fulfilled
     by any totally ordered ring. Let's now be int-specific: *)
  Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1).

  (** Btw, lt_0_1 could be deduced from this last axiom *)

  (** Now we also require a division function.
      It is deliberately underspecified, since that's enough
      for the proofs below. But the most appropriate variant
      (and the one needed to stay in sync with the omega engine)
      is "Floor" (the historical version of Coq's [Z.div]). *)

  Parameter diveucl : t -> t -> t * t.
  Notation "i / j" := (fst (diveucl i j)).
  Notation "i 'mod' j" := (snd (diveucl i j)).
  Axiom diveucl_spec :
    forall i j, j<>0 -> i = j * (i/j) + (i mod j).

End Int.

(** Of course, Z is a model for our abstract int *)

Module Z_as_Int <: Int.

  Open Scope Z_scope.

  Definition t := Z.
  Definition zero := 0.
  Definition one := 1.
  Definition plus := Z.add.
  Definition opp := Z.opp.
  Definition minus := Z.sub.
  Definition mult := Z.mul.

  Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t).
  Proof.
  constructor.
  exact Z.add_0_l.
  exact Z.add_comm.
  exact Z.add_assoc.
  exact Z.mul_1_l.
  exact Z.mul_comm.
  exact Z.mul_assoc.
  exact Z.mul_add_distr_r.
  unfold minus, Z.sub; auto.
  exact Z.add_opp_diag_r.
  Qed.

  Definition le := Z.le.
  Definition lt := Z.lt.
  Definition ge := Z.ge.
  Definition gt := Z.gt.
  Definition le_lt_iff := Z.le_ngt.
  Definition ge_le_iff := Z.ge_le_iff.
  Definition gt_lt_iff := Z.gt_lt_iff.

  Definition lt_trans := Z.lt_trans.
  Definition lt_not_eq := Z.lt_neq.

  Definition lt_0_1 := Z.lt_0_1.
  Definition plus_le_compat := Z.add_le_mono.
  Definition mult_lt_compat_l := Zmult_lt_compat_l.
  Lemma opp_le_compat i j : i<=j -> (-j)<=(-i).
  Proof. apply -> Z.opp_le_mono. Qed.

  Definition compare := Z.compare.
  Definition compare_Eq := Z.compare_eq_iff.
  Lemma compare_Lt i j : compare i j = Lt <-> i<j.
  Proof. reflexivity. Qed.
  Lemma compare_Gt i j : compare i j = Gt <-> i>j.
  Proof. reflexivity. Qed.

  Definition le_lt_int := Z.lt_le_pred.

  Definition diveucl := Z.div_eucl.
  Definition diveucl_spec := Z.div_mod.

End Z_as_Int.

(** * Properties of abstract integers *)

Module IntProperties (I:Int).
 Import I.
 Local Notation int := I.t.

 (** Primo, some consequences of being a ring theory... *)

 Definition two := 1+1.
 Notation "2" := two : Int_scope.

 (** Aliases for properties packed in the ring record. *)

 Definition plus_assoc := ring.(Radd_assoc).
 Definition plus_comm := ring.(Radd_comm).
 Definition plus_0_l := ring.(Radd_0_l).
 Definition mult_assoc := ring.(Rmul_assoc).
 Definition mult_comm := ring.(Rmul_comm).
 Definition mult_1_l := ring.(Rmul_1_l).
 Definition mult_plus_distr_r := ring.(Rdistr_l).
 Definition opp_def := ring.(Ropp_def).
 Definition minus_def := ring.(Rsub_def).

 Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l
  mult_plus_distr_r opp_def minus_def.

 (** More facts about [plus] *)

 Lemma plus_0_r : forall x, x+0 = x.
 Proof. intros; rewrite plus_comm; apply plus_0_l. Qed.

 Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z).
 Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed.

 Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z.
 Proof.
  intros.
  rewrite <- (plus_0_r y), <- (plus_0_r z), <-(opp_def x).
  now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute.
 Qed.

 (** More facts about [mult] *)

 Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z.
 Proof.
  intros.
  rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z).
  apply mult_plus_distr_r.
 Qed.

 Lemma mult_0_l x : 0*x = 0.
 Proof.
  assert (H := mult_plus_distr_r 0 1 x).
  rewrite plus_0_l, mult_1_l, plus_comm in H.
  apply plus_reg_l with x.
  now rewrite <- H, plus_0_r.
 Qed.

 Lemma mult_0_r x : x*0 = 0.
 Proof.
   rewrite mult_comm. apply mult_0_l.
 Qed.

 Lemma mult_1_r x : x*1 = x.
 Proof.
   rewrite mult_comm. apply mult_1_l.
 Qed.

 (** More facts about [opp] *)

 Definition plus_opp_r := opp_def.

 Lemma plus_opp_l : forall x, -x + x = 0.
 Proof. intros; now rewrite plus_comm, opp_def. Qed.

 Lemma mult_opp_comm : forall x y, - x * y = x * - y.
 Proof.
  intros.
  apply plus_reg_l with (x*y).
  rewrite <- mult_plus_distr_l, <- mult_plus_distr_r.
  now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l.
 Qed.

 Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1).
 Proof.
  intros; now rewrite mult_comm, mult_opp_comm, mult_1_l.
 Qed.

 Lemma opp_involutive : forall x, -(-x) = x.
 Proof.
  intros.
  apply plus_reg_l with (-x).
  now rewrite opp_def, plus_comm, opp_def.
 Qed.

 Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y.
 Proof.
  intros.
  apply plus_reg_l with (x+y).
  rewrite opp_def.
  rewrite plus_permute.
  do 2 rewrite plus_assoc.
  now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def.
 Qed.

 Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y.
 Proof.
  intros.
  rewrite <- mult_opp_comm.
  apply plus_reg_l with (x*y).
  now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l.
 Qed.

 Lemma egal_left n m : 0 = n+-m <-> n = m.
 Proof.
  split; intros.
  - apply plus_reg_l with (-m).
    rewrite plus_comm, <- H. symmetry. apply plus_opp_l.
  - symmetry. subst; apply opp_def.
 Qed.

 (** Specialized distributivities *)

 Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int.
 Hint Rewrite <- plus_assoc : int.

 Hint Rewrite plus_0_l plus_0_r mult_0_l mult_0_r mult_1_l mult_1_r : int.

 Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 :
  v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2) =
  (v * c1 + l1) * k1 + (v * c2 + l2) * k2.
 Proof.
  autorewrite with int; f_equal; now rewrite plus_permute.
 Qed.

 Lemma OMEGA11 v1 c1 l1 l2 k1 :
  v1 * (c1 * k1) + (l1 * k1 + l2) = (v1 * c1 + l1) * k1 + l2.
 Proof.
  now autorewrite with int.
 Qed.

 Lemma OMEGA12 v2 c2 l1 l2 k2 :
   v2 * (c2 * k2) + (l1 + l2 * k2) = l1 + (v2 * c2 + l2) * k2.
 Proof.
  autorewrite with int; now rewrite plus_permute.
 Qed.

 Lemma sum1 a b c d : 0 = a -> 0 = b -> 0 = a * c + b * d.
 Proof.
 intros; subst. now autorewrite with int.
 Qed.

 (** Secondo, some results about order (and equality) *)

 Lemma lt_irrefl : forall n, ~ n<n.
 Proof.
 intros n H.
 elim (lt_not_eq _ _ H); auto.
 Qed.

 Lemma lt_antisym : forall n m, n<m -> m<n -> False.
 Proof.
 intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto.
 Qed.

 Lemma lt_le_weak : forall n m, n<m -> n<=m.
 Proof.
  intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto.
 Qed.

 Lemma le_refl : forall n, n<=n.
 Proof.
 intros; rewrite le_lt_iff; apply lt_irrefl; auto.
 Qed.

 Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m.
 Proof.
 intros n m; do 2 rewrite le_lt_iff; intros.
 rewrite <- compare_Lt in H0.
 rewrite <- gt_lt_iff, <- compare_Gt in H.
 rewrite <- compare_Eq.
 destruct compare; intuition.
 Qed.

 Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }.
 Proof.
  intros.
  generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
  destruct compare; [ left; right | left; left | right ]; intuition.
  rewrite gt_lt_iff in H1; intuition.
 Qed.

 Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }.
 Proof.
  intros.
  generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
  destruct compare; [ right | left | right ]; intuition discriminate.
 Qed.

 Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n).
 Proof.
  intros.
  rewrite le_lt_iff.
  destruct (lt_dec n m); intuition.
 Qed.

 Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }.
 Proof.
  intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition.
 Qed.

 Lemma le_lt_dec : forall n m, { n<=m } + { m<n }.
 Proof.
  intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff.
 Qed.

 Definition beq i j := match compare i j with Eq => true | _ => false end.

 Infix "=?" := beq : Int_scope.

 Lemma beq_iff i j : (i =? j) = true <-> i=j.
 Proof.
 unfold beq. rewrite <- (compare_Eq i j). now destruct compare.
 Qed.

 Lemma beq_reflect i j : reflect (i=j) (i =? j).
 Proof.
 apply iff_reflect. symmetry. apply beq_iff.
 Qed.

 Lemma eq_dec : forall n m:int, { n=m } + { n<>m }.
 Proof.
  intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition.
 Qed.

 Definition blt i j := match compare i j with Lt => true | _ => false end.

 Infix "<?" := blt : Int_scope.

 Lemma blt_iff i j : (i <? j) = true <-> i<j.
 Proof.
 unfold blt. rewrite <- (compare_Lt i j). now destruct compare.
 Qed.

 Lemma blt_reflect i j : reflect (i<j) (i <? j).
 Proof.
 apply iff_reflect. symmetry. apply blt_iff.
 Qed.

 Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }.
 Proof.
  intros n m Hnm.
  destruct (eq_dec n m) as [H'|H'].
  - right; intuition.
  - left; rewrite lt_le_iff.
    contradict H'.
    now apply le_antisym.
 Qed.

 Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m.
 Proof.
  intros n m H. now destruct (le_is_lt_or_eq _ _ H).
 Qed.

 Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p.
 Proof.
  intros n m p; rewrite 3 le_lt_iff; intros A B C.
  destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto.
  generalize (lt_trans _ _ _ H C); intuition.
 Qed.

 Lemma not_eq (a b:int) : ~ a <> b <-> a = b.
 Proof.
  destruct (eq_dec a b); intuition.
 Qed.

 (** Order and operations *)

 Lemma le_0_neg n : n <= 0 <-> 0 <= -n.
 Proof.
 rewrite <- (mult_0_l (-(1))) at 2.
 rewrite <- opp_eq_mult_neg_1.
 split; intros.
 - now apply opp_le_compat.
 - rewrite <-(opp_involutive 0), <-(opp_involutive n).
   now apply opp_le_compat.
 Qed.

 Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m.
 Proof.
 intros.
 replace n with ((n+p)+-p).
 replace m with ((m+p)+-p).
 apply plus_le_compat; auto.
 apply le_refl.
 now rewrite <- plus_assoc, opp_def, plus_0_r.
 now rewrite <- plus_assoc, opp_def, plus_0_r.
 Qed.

 Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q.
 Proof.
 intros.
 apply le_neq_lt.
 apply plus_le_compat; auto.
 apply lt_le_weak; auto.
 rewrite lt_le_iff in H0.
 contradict H0.
 apply plus_le_reg_r with m.
 rewrite (plus_comm q m), <-H0, (plus_comm p m).
 apply plus_le_compat; auto.
 apply le_refl; auto.
 Qed.

 Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q.
 Proof.
 intros.
 apply plus_le_lt_compat; auto.
 apply lt_le_weak; auto.
 Qed.

 Lemma opp_lt_compat : forall n m, n<m -> -m < -n.
 Proof.
 intros n m; do 2 rewrite lt_le_iff; intros H; contradict H.
 rewrite <-(opp_involutive m), <-(opp_involutive n).
 apply opp_le_compat; auto.
 Qed.

 Lemma lt_0_neg n : n < 0 <-> 0 < -n.
 Proof.
 rewrite <- (mult_0_l (-(1))) at 2.
 rewrite <- opp_eq_mult_neg_1.
 split; intros.
 - now apply opp_lt_compat.
 - rewrite <-(opp_involutive 0), <-(opp_involutive n).
   now apply opp_lt_compat.
 Qed.

 Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m.
 Proof.
 intros.
 rewrite <- (mult_0_l n), mult_comm.
 apply mult_lt_compat_l; auto.
 Qed.

 Lemma mult_integral_r n m : 0 < n -> n * m = 0 -> m = 0.
 Proof.
 intros Hn H.
 destruct (lt_eq_lt_dec 0 m) as [[Hm| <- ]|Hm]; auto; exfalso.
 - generalize (mult_lt_0_compat _ _ Hn Hm).
   rewrite H.
   exact (lt_irrefl 0).
 - rewrite lt_0_neg in Hm.
   generalize (mult_lt_0_compat _ _ Hn Hm).
   rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l.
   exact (lt_irrefl 0).
 Qed.

 Lemma mult_integral n m : n * m = 0 -> n = 0 \/ m = 0.
 Proof.
 intros H.
 destruct (lt_eq_lt_dec 0 n) as [[Hn|Hn]|Hn].
 - right; apply (mult_integral_r n m); trivial.
 - now left.
 - right; apply (mult_integral_r (-n) m).
   + now apply lt_0_neg.
   + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H.
     now rewrite opp_eq_mult_neg_1, mult_0_l.
 Qed.

 Lemma mult_le_compat_l i j k :
   0<=k -> i<=j -> k*i <= k*j.
 Proof.
 intros Hk Hij.
 apply le_is_lt_or_eq in Hk. apply le_is_lt_or_eq in Hij.
 destruct Hk as [Hk | <-], Hij as [Hij | <-];
  rewrite ? mult_0_l; try apply le_refl.
 now apply lt_le_weak, mult_lt_compat_l.
 Qed.

 Lemma mult_le_compat i j k l :
   i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l.
 Proof.
 intros Hij Hkl Hi Hk.
 apply le_trans with (i*l).
 - now apply mult_le_compat_l.
 - rewrite (mult_comm i), (mult_comm j).
   apply mult_le_compat_l; trivial.
   now apply le_trans with k.
 Qed.

 Lemma sum5 a b c d : 0 <> c -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
 Proof.
 intros Hc Ha <-. autorewrite with int. contradict Hc.
 symmetry in Hc. destruct (mult_integral _ _ Hc); congruence.
 Qed.

 Lemma le_left n m : n <= m <-> 0 <= m + - n.
 Proof.
  split; intros.
  - rewrite <- (opp_def m).
    apply plus_le_compat.
    apply le_refl.
    apply opp_le_compat; auto.
  - apply plus_le_reg_r with (-n).
    now rewrite plus_opp_r.
 Qed.

 Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0.
 Proof.
 intros.
 assert (y=-x).
  subst x; symmetry; apply opp_involutive.
 clear H1; subst y.
 destruct (eq_dec 0 x) as [H'|H']; auto.
 assert (H'':=le_neq_lt _ _ H H').
 generalize (plus_le_lt_compat _ _ _ _ H0 H'').
 rewrite plus_opp_l, plus_0_l.
 intros.
 elim (lt_not_eq _ _ H1); auto.
 Qed.

 Lemma sum2 a b c d :
   0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
 Proof.
 intros Hd <- Hb. autorewrite with int.
 rewrite <- (mult_0_l 0).
 apply mult_le_compat; auto; apply le_refl.
 Qed.

 Lemma sum3 a b c d :
  0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
 Proof.
 intros.
 rewrite <- (plus_0_l 0).
 apply plus_le_compat; auto.
 rewrite <- (mult_0_l 0).
 apply mult_le_compat; auto; apply le_refl.
 rewrite <- (mult_0_l 0).
 apply mult_le_compat; auto; apply le_refl.
 Qed.

 (** Lemmas specific to integers (they use [le_lt_int]) *)

 Lemma lt_left n m : n < m <-> 0 <= m + -n + -(1).
 Proof.
 rewrite <- plus_assoc, (plus_comm (-n)), plus_assoc.
 rewrite <- le_left.
 apply le_lt_int.
 Qed.

 Lemma OMEGA4 x y z : 0 < x -> x < y -> z * y + x <> 0.
 Proof.
 intros H H0 H'.
 assert (0 < y) by now apply lt_trans with x.
 destruct (lt_eq_lt_dec z 0) as [[G|G]|G].

 - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0).
   rewrite H'.
   rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r.
   apply le_lt_iff.
   rewrite mult_comm. rewrite <- (mult_0_r y).
   apply mult_le_compat_l; auto using lt_le_weak.
   apply le_0_neg. rewrite opp_plus_distr.
   apply le_lt_int. now apply lt_0_neg.

 - apply (lt_not_eq 0 (z*y+x)); auto.
   subst. now autorewrite with int.

 - apply (lt_not_eq 0 (z*y+x)); auto.
   rewrite <- (plus_0_l 0).
   auto using plus_lt_compat, mult_lt_0_compat.
 Qed.

 Lemma OMEGA19 x : x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1).
 Proof.
 intros.
 do 2 rewrite <- le_lt_int.
 rewrite <- opp_eq_mult_neg_1.
 destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H'].
 auto.
 congruence.
 right.
 rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0).
 apply opp_lt_compat; auto.
 Qed.

 Lemma mult_le_approx n m p :
  0 < n -> p < n -> 0 <= m * n + p -> 0 <= m.
 Proof.
 do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H.
 apply lt_0_neg, le_lt_int, le_left in Hm.
 rewrite lt_0_neg.
 rewrite opp_plus_distr, mult_comm, opp_mult_distr_r.
 rewrite le_lt_int. apply lt_left.
 rewrite le_lt_int.
 apply le_trans with (n+-(1)); [ now apply le_lt_int | ].
 apply plus_le_compat; [ | apply le_refl ].
 rewrite <- (mult_1_r n) at 1.
 apply mult_le_compat_l; auto using lt_le_weak.
 Qed.

 (** Some decidabilities *)

 Lemma dec_eq : forall i j:int, decidable (i=j).
 Proof.
  red; intros; destruct (eq_dec i j); auto.
 Qed.

 Lemma dec_ne : forall i j:int, decidable (i<>j).
 Proof.
  red; intros; destruct (eq_dec i j); auto.
 Qed.

 Lemma dec_le : forall i j:int, decidable (i<=j).
 Proof.
  red; intros; destruct (le_dec i j); auto.
 Qed.

 Lemma dec_lt : forall i j:int, decidable (i<j).
 Proof.
  red; intros; destruct (lt_dec i j); auto.
 Qed.

 Lemma dec_ge : forall i j:int, decidable (i>=j).
 Proof.
  red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto.
 Qed.

 Lemma dec_gt : forall i j:int, decidable (i>j).
 Proof.
  red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto.
 Qed.

End IntProperties.

(** * The Coq side of the romega tactic *)

Module IntOmega (I:Int).
Import I.
Module IP:=IntProperties(I).
Import IP.
Local Notation int := I.t.

(* ** Definition of reified integer expressions

   Terms are either:
   - integers [Tint]
   - variables [Tvar]
   - operation over integers (addition, product, opposite, subtraction)

   Opposite and subtraction are translated in additions and products.
   Note that we'll only deal with products for which at least one side
   is [Tint]. *)

Inductive term : Set :=
  | Tint : int -> term
  | Tplus : term -> term -> term
  | Tmult : term -> term -> term
  | Tminus : term -> term -> term
  | Topp : term -> term
  | Tvar : N -> term.

Bind Scope romega_scope with term.
Delimit Scope romega_scope with term.
Arguments Tint _%I.
Arguments Tplus (_ _)%term.
Arguments Tmult (_ _)%term.
Arguments Tminus (_ _)%term.
Arguments Topp _%term.

Infix "+" := Tplus : romega_scope.
Infix "*" := Tmult : romega_scope.
Infix "-" := Tminus : romega_scope.
Notation "- x" := (Topp x) : romega_scope.
Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope.

(* ** Definition of reified goals

   Very restricted definition of handled predicates that should be extended
   to cover a wider set of operations.
   Taking care of negations and disequations require solving more than a
   goal in parallel. This is a major improvement over previous versions. *)

Inductive proposition : Set :=
  (** First, basic equations, disequations, inequations *)
  | EqTerm : term -> term -> proposition
  | NeqTerm : term -> term -> proposition
  | LeqTerm : term -> term -> proposition
  | GeqTerm : term -> term -> proposition
  | GtTerm : term -> term -> proposition
  | LtTerm : term -> term -> proposition
  (** Then, the supported logical connectors *)
  | TrueTerm : proposition
  | FalseTerm : proposition
  | Tnot : proposition -> proposition
  | Tor : proposition -> proposition -> proposition
  | Tand : proposition -> proposition -> proposition
  | Timp : proposition -> proposition -> proposition
  (** Everything else is left as a propositional atom (and ignored). *)
  | Tprop : nat -> proposition.

(** Definition of goals as a list of hypothesis *)
Notation hyps := (list proposition).

(** Definition of lists of subgoals (set of open goals) *)
Notation lhyps := (list hyps).

(** A single goal packed in a subgoal list *)
Notation singleton := (fun a : hyps => a :: nil).

(** An absurd goal *)
Definition absurd := FalseTerm :: nil.

(** ** Decidable equality on terms *)

Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
  match t1, t2 with
  | Tint i1, Tint i2 => i1 =? i2
  | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22
  | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22
  | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22
  | (- t1), (- t2) => eq_term t1 t2
  | [v1], [v2] => N.eqb v1 v2
  | _, _ => false
  end%term.

Infix "=?" := eq_term : romega_scope.

Theorem eq_term_iff (t t' : term) :
 (t =? t')%term = true <-> t = t'.
Proof.
 revert t'. induction t; destruct t'; simpl in *;
 rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2;
  intuition congruence.
Qed.

Theorem eq_term_reflect (t t' : term) : reflect (t=t') (t =? t')%term.
Proof.
 apply iff_reflect. symmetry. apply eq_term_iff.
Qed.

(** ** Interpretations of terms (as integers). *)

Fixpoint Nnth {A} (n:N)(l:list A)(default:A) :=
 match n, l with
   | _, nil => default
   | 0%N, x::_ => x
   | _, _::l => Nnth (N.pred n) l default
 end.

Fixpoint interp_term (env : list int) (t : term) : int :=
  match t with
  | Tint x => x
  | (t1 + t2)%term => interp_term env t1 + interp_term env t2
  | (t1 * t2)%term => interp_term env t1 * interp_term env t2
  | (t1 - t2)%term => interp_term env t1 - interp_term env t2
  | (- t)%term => - interp_term env t
  | [n]%term => Nnth n env 0
  end.

(** ** Interpretation of predicats (as Coq propositions) *)

Fixpoint interp_prop (envp : list Prop) (env : list int)
 (p : proposition) : Prop :=
  match p with
  | EqTerm t1 t2 => interp_term env t1 = interp_term env t2
  | NeqTerm t1 t2 => (interp_term env t1) <> (interp_term env t2)
  | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2
  | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2
  | GtTerm t1 t2 => interp_term env t1 > interp_term env t2
  | LtTerm t1 t2 => interp_term env t1 < interp_term env t2
  | TrueTerm => True
  | FalseTerm => False
  | Tnot p' => ~ interp_prop envp env p'
  | Tor p1 p2 => interp_prop envp env p1 \/ interp_prop envp env p2
  | Tand p1 p2 => interp_prop envp env p1 /\ interp_prop envp env p2
  | Timp p1 p2 => interp_prop envp env p1 -> interp_prop envp env p2
  | Tprop n => nth n envp True
  end.

(** ** Intepretation of hypothesis lists (as Coq conjunctions) *)

Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps)
  : Prop :=
  match l with
  | nil => True
  | p' :: l' => interp_prop envp env p' /\ interp_hyps envp env l'
  end.

(** ** Interpretation of conclusion + hypotheses

   Here we use Coq implications : it's less easy to manipulate,
   but handy to relate to the Coq original goal (cf. the use of
   [generalize], and lighter (no repetition of types in intermediate
   conjunctions). *)

Fixpoint interp_goal_concl (c : proposition) (envp : list Prop)
 (env : list int) (l : hyps) : Prop :=
  match l with
  | nil => interp_prop envp env c
  | p' :: l' =>
      interp_prop envp env p' -> interp_goal_concl c envp env l'
  end.

Notation interp_goal := (interp_goal_concl FalseTerm).

(** Equivalence between these two interpretations. *)

Theorem goal_to_hyps :
 forall (envp : list Prop) (env : list int) (l : hyps),
 (interp_hyps envp env l -> False) -> interp_goal envp env l.
Proof.
 induction l; simpl; auto.
Qed.

Theorem hyps_to_goal :
 forall (envp : list Prop) (env : list int) (l : hyps),
 interp_goal envp env l -> interp_hyps envp env l -> False.
Proof.
 induction l; simpl; auto.
 intros H (H1,H2). auto.
Qed.

(** ** Interpretations of list of goals

    Here again, two flavours... *)

Fixpoint interp_list_hyps (envp : list Prop) (env : list int)
 (l : lhyps) : Prop :=
  match l with
  | nil => False
  | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l'
  end.

Fixpoint interp_list_goal (envp : list Prop) (env : list int)
 (l : lhyps) : Prop :=
  match l with
  | nil => True
  | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l'
  end.

(** Equivalence between the two flavours. *)

Theorem list_goal_to_hyps :
 forall (envp : list Prop) (env : list int) (l : lhyps),
 (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
Proof.
 induction l; simpl; intuition. now apply goal_to_hyps.
Qed.

Theorem list_hyps_to_goal :
 forall (envp : list Prop) (env : list int) (l : lhyps),
 interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
Proof.
 induction l; simpl; intuition. eapply hyps_to_goal; eauto.
Qed.

(** ** Stabiliy and validity of operations *)

(** An operation on terms is stable if the interpretation is unchanged. *)

Definition term_stable (f : term -> term) :=
  forall (e : list int) (t : term), interp_term e t = interp_term e (f t).

(** An operation on one hypothesis is valid if this hypothesis implies
    the result of this operation. *)

Definition valid1 (f : proposition -> proposition) :=
  forall (ep : list Prop) (e : list int) (p1 : proposition),
  interp_prop ep e p1 -> interp_prop ep e (f p1).

Definition valid2 (f : proposition -> proposition -> proposition) :=
  forall (ep : list Prop) (e : list int) (p1 p2 : proposition),
  interp_prop ep e p1 ->
  interp_prop ep e p2 -> interp_prop ep e (f p1 p2).

(** Same for lists of hypotheses, and for list of goals *)

Definition valid_hyps (f : hyps -> hyps) :=
  forall (ep : list Prop) (e : list int) (lp : hyps),
  interp_hyps ep e lp -> interp_hyps ep e (f lp).

Definition valid_list_hyps (f : hyps -> lhyps) :=
  forall (ep : list Prop) (e : list int) (lp : hyps),
  interp_hyps ep e lp -> interp_list_hyps ep e (f lp).

Definition valid_list_goal (f : hyps -> lhyps) :=
  forall (ep : list Prop) (e : list int) (lp : hyps),
  interp_list_goal ep e (f lp) -> interp_goal ep e lp.

(** Some results about these validities. *)

Theorem valid_goal :
  forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps),
  valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
Proof.
 intros; simpl; apply goal_to_hyps; intro H1;
 apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
Qed.

Theorem goal_valid :
 forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
Proof.
 unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps;
 intro H2; apply list_hyps_to_goal with (1 := H1);
 apply (H ep e lp); assumption.
Qed.

Theorem append_valid :
 forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
 interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
 interp_list_hyps ep e (l1 ++ l2).
Proof.
 induction l1; simpl in *.
 - now intros l2 [H| H].
 - intros l2 [[H| H]| H].
   + auto.
   + right; apply IHl1; now left.
   + right; apply IHl1; now right.
Qed.

(** ** Valid operations on hypotheses *)

(** Extract an hypothesis from the list *)

Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.

Theorem nth_valid :
 forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
 interp_hyps ep e l -> interp_prop ep e (nth_hyps i l).
Proof.
 unfold nth_hyps. induction i; destruct l; simpl in *; try easy.
 intros (H1,H2). now apply IHi.
Qed.

(** Apply a valid operation on two hypotheses from the list, and
    store the result in the list. *)

Definition apply_oper_2 (i j : nat)
  (f : proposition -> proposition -> proposition) (l : hyps) :=
  f (nth_hyps i l) (nth_hyps j l) :: l.

Theorem apply_oper_2_valid :
 forall (i j : nat) (f : proposition -> proposition -> proposition),
 valid2 f -> valid_hyps (apply_oper_2 i j f).
Proof.
 intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl;
 intros lp Hlp; split.
 - apply Hf; apply nth_valid; assumption.
 - assumption.
Qed.

(** In-place modification of an hypothesis by application of
    a valid operation. *)

Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
 (l : hyps) {struct i} : hyps :=
  match l with
  | nil => nil
  | p :: l' =>
      match i with
      | O => f p :: l'
      | S j => p :: apply_oper_1 j f l'
      end
  end.

Theorem apply_oper_1_valid :
 forall (i : nat) (f : proposition -> proposition),
 valid1 f -> valid_hyps (apply_oper_1 i f).
Proof.
 unfold valid_hyps.
 induction i; intros f Hf ep e [ | p lp]; simpl; intuition.
Qed.

(** ** A tactic for proving stability *)

Ltac loop t :=
  match t with
  (* Global *)
  | (?X1 = ?X2) => loop X1 || loop X2
  | (_ -> ?X1) => loop X1
  (* Interpretations *)
  | (interp_hyps _ _ ?X1) => loop X1
  | (interp_list_hyps _ _ ?X1) => loop X1
  | (interp_prop _ _ ?X1) => loop X1
  | (interp_term _ ?X1) => loop X1
  (* Propositions *)
  | (EqTerm ?X1 ?X2) => loop X1 || loop X2
  | (LeqTerm ?X1 ?X2) => loop X1 || loop X2
  (* Terms *)
  | (?X1 + ?X2)%term => loop X1 || loop X2
  | (?X1 - ?X2)%term => loop X1 || loop X2
  | (?X1 * ?X2)%term => loop X1 || loop X2
  | (- ?X1)%term => loop X1
  | (Tint ?X1) => loop X1
  (* Eliminations *)
  | (if ?X1 =? ?X2 then _ else _) =>
      let H := fresh "H" in
      case (beq_reflect X1 X2); intro H;
      try (rewrite H in *; clear H); simpl; auto; Simplify
  | (if ?X1 <? ?X2 then _ else _) =>
      case (blt_reflect X1 X2); intro; simpl; auto; Simplify
  | (if (?X1 =? ?X2)%term then _ else _) =>
      let H := fresh "H" in
      case (eq_term_reflect X1 X2); intro H;
      try (rewrite H in *; clear H); simpl; auto; Simplify
  | (if _ && _ then _ else _) => rewrite andb_if; Simplify
  | (if negb _ then _ else _) => rewrite negb_if; Simplify
  | match N.compare ?X1 ?X2 with _ => _ end =>
    destruct (N.compare_spec X1 X2); Simplify
  | match ?X1 with _ => _ end => destruct X1; auto; Simplify
  | _ => fail
  end

with Simplify := match goal with
  |  |- ?X1 => try loop X1
  | _ => idtac
  end.

(** ** Operations on equation bodies *)

(** The operations below handle in priority _normalized_ terms, i.e.
    terms of the form:
      [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))]
    with [v1>v2>...] and all [ki<>0].
    See [normalize] below for a way to put terms in this form.

    These operations also produce a correct (but suboptimal)
    result in case of non-normalized input terms, but this situation
    should normally not happen when running [romega].

     /!\ Do not modify this section (especially [fusion] and [normalize])
    without tweaking the corresponding functions in [refl_omega.ml].
*)

(** Multiplication and sum by two constants. Invariant: [k1<>0]. *)

Fixpoint scalar_mult_add (t : term) (k1 k2 : int) : term :=
  match t with
  | v1 * Tint x1 + l1 =>
    v1 * Tint (x1 * k1) + scalar_mult_add l1 k1 k2
  | Tint x => Tint (k1 * x + k2)
  | _ => t * Tint k1 + Tint k2 (* shouldn't happen *)
  end%term.

Theorem scalar_mult_add_stable e t k1 k2 :
 interp_term e (scalar_mult_add t k1 k2) =
 interp_term e (t * Tint k1 + Tint k2).
Proof.
 induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm.
 rewrite IHt2. simpl. apply OMEGA11.
Qed.

(** Multiplication by a (non-nul) constant. *)

Definition scalar_mult (t : term) (k : int) := scalar_mult_add t k 0.

Theorem scalar_mult_stable e t k :
 interp_term e (scalar_mult t k) =
 interp_term e (t * Tint k).
Proof.
 unfold scalar_mult. rewrite scalar_mult_add_stable. simpl.
 apply plus_0_r.
Qed.

(** Adding a constant

    Instead of using [scalar_norm_add t 1 k], the following
    definition spares some computations.
 *)

Fixpoint scalar_add (t : term) (k : int) : term :=
  match t with
  | m + l => m + scalar_add l k
  | Tint x => Tint (x + k)
  | _ => t + Tint k
  end%term.

Theorem scalar_add_stable e t k :
 interp_term e (scalar_add t k) = interp_term e (t + Tint k).
Proof.
 induction t; simpl; Simplify; simpl; auto.
 rewrite IHt2. simpl. apply plus_assoc.
Qed.

(** Division by a constant

    All the non-constant coefficients should be exactly dividable *)

Fixpoint scalar_div (t : term) (k : int) : option (term * int) :=
  match t with
  | v * Tint x + l =>
    let (q,r) := diveucl x k in
    if (r =? 0)%I then
      match scalar_div l k with
      | None => None
      | Some (u,c) => Some (v * Tint q + u, c)
      end
    else None
  | Tint x =>
    let (q,r) := diveucl x k in
    Some (Tint q, r)
  | _ => None
  end%term.

Lemma scalar_div_stable e t k u c : k<>0 ->
  scalar_div t k = Some (u,c) ->
  interp_term e (u * Tint k + Tint c) = interp_term e t.
Proof.
 revert u c.
 induction t; simpl; Simplify; try easy.
 - intros u c Hk. assert (H := diveucl_spec t0 k Hk).
   simpl in H.
   destruct diveucl as (q,r). simpl in H. rewrite H.
   injection 1 as <- <-. simpl. f_equal. apply mult_comm.
 - intros u c Hk.
   destruct t1; simpl; Simplify; try easy.
   destruct t1_2; simpl; Simplify; try easy.
   assert (H := diveucl_spec t0 k Hk).
   simpl in H.
   destruct diveucl as (q,r). simpl in H. rewrite H.
   case beq_reflect; [intros -> | easy].
   destruct (scalar_div t2 k) as [(u',c')|] eqn:E; [|easy].
   injection 1 as <- ->. simpl.
   rewrite <- (IHt2 u' c Hk); simpl; auto.
   rewrite plus_0_r , (mult_comm k q). symmetry. apply OMEGA11.
Qed.

(** Fusion of two equations.

    From two normalized equations, this fusion will produce
    a normalized output corresponding to the coefficiented sum.
    Invariant: [k1<>0] and [k2<>0].
*)

Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term :=
  match t1 with
  | [v1] * Tint x1 + l1 =>
    (fix fusion_t1 t2 : term :=
       match t2 with
         | [v2] * Tint x2 + l2 =>
           match N.compare v1 v2 with
             | Eq =>
               let k := (k1 * x1 + k2 * x2)%I in
               if (k =? 0)%I then fusion l1 l2 k1 k2
               else [v1] * Tint k + fusion l1 l2 k1 k2
             | Lt => [v2] * Tint (k2 * x2) + fusion_t1 l2
             | Gt => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2
           end
         | Tint x2 => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2
         | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *)
       end) t2
  | Tint x1 => scalar_mult_add t2 k2 (k1 * x1)
  | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *)
  end%term.

Theorem fusion_stable e t1 t2 k1 k2 :
 interp_term e (fusion t1 t2 k1 k2) =
 interp_term e (t1 * Tint k1 + t2 * Tint k2).
Proof.
 revert t2; induction t1; simpl; Simplify; simpl; auto.
 - intros; rewrite scalar_mult_add_stable. simpl.
   rewrite plus_comm. f_equal. apply mult_comm.
 - intros. Simplify. induction t2; simpl; Simplify; simpl; auto.
   + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11.
   + rewrite IHt1_2. simpl. subst n0.
     rewrite (mult_comm k1), (mult_comm k2) in H0.
     rewrite <- OMEGA10, H0. now autorewrite with int.
   + rewrite IHt1_2. simpl. subst n0.
     rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10.
   + rewrite IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12.
   + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11.
Qed.

(** Term normalization.

   Precondition: all [Tmult] should be on at least one [Tint].
   Postcondition: a normalized equivalent term (see below).
*)

Fixpoint normalize t :=
  match t with
  | Tint n => Tint n
  | [n]%term => ([n] * Tint 1 + Tint 0)%term
  | (t + t')%term => fusion (normalize t) (normalize t') 1 1
  | (- t)%term => scalar_mult (normalize t) (-(1))
  | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1))
  | (Tint k * t)%term | (t * Tint k)%term =>
    if k =? 0 then Tint 0 else scalar_mult (normalize t) k
  | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *)
  end.

Theorem normalize_stable : term_stable normalize.
Proof.
 intros e t.
 induction t; simpl; Simplify; simpl;
 rewrite ?scalar_mult_stable; simpl in *; rewrite <- ?IHt1;
 rewrite ?fusion_stable; simpl; autorewrite with int; auto.
 - now f_equal.
 - rewrite mult_comm. now f_equal.
 - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal.
 - rewrite <- opp_eq_mult_neg_1. now f_equal.
Qed.

(** ** Normalization of a proposition.

    The only basic facts left after normalization are
    [0 = ...] or [0 <> ...] or [0 <= ...].
    When a fact is in negative position, we factorize a [Tnot]
    out of it, and normalize the reversed fact inside.

    /!\ Here again, do not change this code without corresponding
    modifications in [refl_omega.ml].
*)

Fixpoint normalize_prop (negated:bool)(p:proposition) :=
  match p with
  | EqTerm t1 t2 =>
    if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2)))
    else EqTerm (Tint 0) (normalize (t1-t2))
  | NeqTerm t1 t2 =>
    if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2)))
    else NeqTerm (Tint 0) (normalize (t1-t2))
  | LeqTerm t1 t2 =>
    if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))))
    else LeqTerm (Tint 0) (normalize (t2-t1))
  | GeqTerm t1 t2 =>
    if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))))
    else LeqTerm (Tint 0) (normalize (t1-t2))
  | LtTerm t1 t2 =>
    if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2)))
    else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))
  | GtTerm t1 t2 =>
    if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1)))
    else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))
  | Tnot p => Tnot (normalize_prop (negb negated) p)
  | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p')
  | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p')
  | Timp p p' => Timp (normalize_prop (negb negated) p)
                      (normalize_prop negated p')
  | Tprop _ | TrueTerm | FalseTerm => p
  end.

Definition normalize_hyps := List.map (normalize_prop false).

Local Ltac simp := cbn -[normalize].

Theorem normalize_prop_valid b e ep p :
  interp_prop e ep (normalize_prop b p) <-> interp_prop e ep p.
Proof.
 revert b.
 induction p; intros; simp; try tauto.
 - destruct b; simp;
   rewrite <- ?normalize_stable; simpl; rewrite ?minus_def.
   + rewrite not_eq. apply egal_left.
   + apply egal_left.
 - destruct b; simp;
   rewrite <- ?normalize_stable; simpl; rewrite ?minus_def;
   apply not_iff_compat, egal_left.
 - destruct b; simp;
   rewrite <- ? normalize_stable; simpl; rewrite ?minus_def.
   + symmetry. rewrite le_lt_iff. apply not_iff_compat, lt_left.
   + now rewrite <- le_left.
 - destruct b; simp;
   rewrite <- ? normalize_stable; simpl; rewrite ?minus_def.
   + symmetry. rewrite ge_le_iff, le_lt_iff.
     apply not_iff_compat, lt_left.
   + rewrite ge_le_iff. now rewrite <- le_left.
 - destruct b; simp;
   rewrite <- ? normalize_stable; simpl; rewrite ?minus_def.
   + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat.
     now rewrite <- le_left.
   + symmetry. rewrite gt_lt_iff. apply lt_left.
 - destruct b; simp;
   rewrite <- ? normalize_stable; simpl; rewrite ?minus_def.
   + rewrite lt_le_iff. apply not_iff_compat.
     now rewrite <- le_left.
   + symmetry. apply lt_left.
 - now rewrite IHp.
 - now rewrite IHp1, IHp2.
 - now rewrite IHp1, IHp2.
 - now rewrite IHp1, IHp2.
Qed.

Theorem normalize_hyps_valid : valid_hyps normalize_hyps.
Proof.
 intros e ep l. induction l; simpl; intuition.
 now rewrite normalize_prop_valid.
Qed.

Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) :
 interp_goal ep env (normalize_hyps l) -> interp_goal ep env l.
Proof.
 intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
Qed.

(** ** A simple decidability checker

   For us, everything is considered decidable except
   propositional atoms [Tprop _]. *)

Fixpoint decidability (p : proposition) : bool :=
  match p with
  | Tnot t => decidability t
  | Tand t1 t2 => decidability t1 && decidability t2
  | Timp t1 t2 => decidability t1 && decidability t2
  | Tor t1 t2 => decidability t1 && decidability t2
  | Tprop _ => false
  | _ => true
  end.

Theorem decidable_correct :
 forall (ep : list Prop) (e : list int) (p : proposition),
 decidability p = true -> decidable (interp_prop ep e p).
Proof.
 induction p; simpl; intros Hp; try destruct (andb_prop _ _ Hp).
 - apply dec_eq.
 - apply dec_ne.
 - apply dec_le.
 - apply dec_ge.
 - apply dec_gt.
 - apply dec_lt.
 - left; auto.
 - right; unfold not; auto.
 - apply dec_not; auto.
 - apply dec_or; auto.
 - apply dec_and; auto.
 - apply dec_imp; auto.
 - discriminate.
Qed.

(** ** Omega steps

   The following inductive type describes steps as they can be
   found in the trace coming from the decision procedure Omega.
   We consider here only normalized equations [0=...], disequations
   [0<>...] or inequations [0<=...].

   First, the final steps leading to a contradiction:
   - [O_BAD_CONSTANT i] : hypothesis i has a constant body
     and this constant is not compatible with the kind of i.
   - [O_NOT_EXACT_DIVIDE i k] :
     equation i can be factorized as some [k*t+c] with [0<c<k].

   Now, the intermediate steps leading to a new hypothesis:
   - [O_DIVIDE i k cont] :
     the body of hypothesis i could be factorized as [k*t+c]
     with either [k<>0] and [c=0] for a (dis)equation, or
     [0<k] and [c<k] for an inequation. We change in-place the
     body of i for [t].
   - [O_SUM k1 i1 k2 i2 cont] : creates a new hypothesis whose
     kind depends on the kind of hypotheses [i1] and [i2], and
     whose body is [k1*body(i1) + k2*body(i2)]. Depending of the
     situation, [k1] or [k2] might have to be positive or non-nul.
   - [O_MERGE_EQ i j cont] :
     inequations i and j have opposite bodies, we add an equation
     with one these bodies.
   - [O_SPLIT_INEQ i cont1 cont2] :
     disequation i is split into a disjonction of inequations.
*)

Definition idx := nat. (** Index of an hypothesis in the list *)

Inductive t_omega : Set :=
  | O_BAD_CONSTANT : idx -> t_omega
  | O_NOT_EXACT_DIVIDE : idx -> int -> t_omega

  | O_DIVIDE : idx -> int -> t_omega -> t_omega
  | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega
  | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega
  | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega.

(** ** Actual resolution steps of an omega normalized goal *)

(** First, the final steps, leading to a contradiction *)

(** [O_BAD_CONSTANT] *)

Definition bad_constant (i : nat) (h : hyps) :=
  match nth_hyps i h with
  | EqTerm (Tint Nul) (Tint n) => if n =? Nul then h else absurd
  | NeqTerm (Tint Nul) (Tint n) => if n =? Nul then absurd else h
  | LeqTerm (Tint Nul) (Tint n) => if n <? Nul then absurd else h
  | _ => h
  end.

Theorem bad_constant_valid i : valid_hyps (bad_constant i).
Proof.
 unfold valid_hyps, bad_constant; intros ep e lp H.
 generalize (nth_valid ep e i lp H); Simplify.
 rewrite le_lt_iff. intuition.
Qed.

(** [O_NOT_EXACT_DIVIDE] *)

Definition not_exact_divide (i : nat) (k : int) (l : hyps) :=
  match nth_hyps i l with
  | EqTerm (Tint Nul) b =>
    match scalar_div b k with
    | Some (body,c) =>
      if (Nul =? 0) && (0 <? c) && (c <? k) then absurd
      else l
    | None => l
    end
  | _ => l
  end.

Theorem not_exact_divide_valid i k :
 valid_hyps (not_exact_divide i k).
Proof.
 unfold valid_hyps, not_exact_divide; intros.
 generalize (nth_valid ep e i lp).
 destruct (nth_hyps i lp); simpl; auto.
 destruct t0; auto.
 destruct (scalar_div t1 k) as [(body,c)|] eqn:E; auto.
 Simplify.
 assert (k <> 0).
 { intro. apply (lt_not_eq 0 k); eauto using lt_trans. }
 apply (scalar_div_stable e) in E; auto. simpl in E.
 intros H'; rewrite <- H' in E; auto.
 exfalso. revert E. now apply OMEGA4.
Qed.

(** Now, the steps generating a new equation. *)

(** [O_DIVIDE] *)

Definition divide (k : int) (prop : proposition) :=
  match prop with
  | EqTerm (Tint o) b =>
    match scalar_div b k with
    | Some (body,c) =>
      if (o =? 0) && (c =? 0) && negb (k =? 0)
      then EqTerm (Tint 0) body
      else TrueTerm
    | None => TrueTerm
    end
  | NeqTerm (Tint o) b =>
    match scalar_div b k with
    | Some (body,c) =>
      if (o =? 0) && (c =? 0) && negb (k =? 0)
      then NeqTerm (Tint 0) body
      else TrueTerm
    | None => TrueTerm
    end
  | LeqTerm (Tint o) b =>
    match scalar_div b k with
    | Some (body,c) =>
      if (o =? 0) && (0 <? k) && (c <? k)
      then LeqTerm (Tint 0) body
      else prop
    | None => prop
    end
  | _ => TrueTerm
  end.

Theorem divide_valid k : valid1 (divide k).
Proof.
 unfold valid1, divide; intros ep e p;
 destruct p; simpl; auto;
 destruct t0; simpl; auto;
 destruct scalar_div as [(body,c)|] eqn:E; simpl; Simplify; auto.
 - apply (scalar_div_stable e) in E; auto. simpl in E.
   intros H'; rewrite <- H' in E. rewrite plus_0_r in E.
   apply mult_integral in E. intuition.
 - apply (scalar_div_stable e) in E; auto. simpl in E.
   intros H' H''. now rewrite <- H'', mult_0_l, plus_0_l in E.
 - assert (k <> 0).
   { intro. apply (lt_not_eq 0 k); eauto using lt_trans. }
   apply (scalar_div_stable e) in E; auto. simpl in E. rewrite <- E.
   intro H'. now apply mult_le_approx with (3 := H').
Qed.

(** [O_SUM]. Invariant: [k1] and [k2] non-nul. *)

Definition sum (k1 k2 : int) (prop1 prop2 : proposition) :=
  match prop1 with
  | EqTerm (Tint o) b1 =>
      match prop2 with
      | EqTerm (Tint o') b2 =>
          if (o =? 0) && (o' =? 0)
          then EqTerm (Tint 0) (fusion b1 b2 k1 k2)
          else TrueTerm
      | LeqTerm (Tint o') b2 =>
          if (o =? 0) && (o' =? 0) && (0 <? k2)
          then LeqTerm (Tint 0) (fusion b1 b2 k1 k2)
          else TrueTerm
      | NeqTerm (Tint o') b2 =>
          if (o =? 0) && (o' =? 0) && negb (k2 =? 0)
          then NeqTerm (Tint 0) (fusion b1 b2 k1 k2)
          else TrueTerm
      | _ => TrueTerm
      end
  | LeqTerm (Tint o) b1 =>
      if (o =? 0) && (0 <? k1)
      then match prop2 with
          | EqTerm (Tint o') b2 =>
              if o' =? 0 then
              LeqTerm (Tint 0) (fusion b1 b2 k1 k2)
              else TrueTerm
          | LeqTerm (Tint o') b2 =>
              if (o' =? 0) && (0 <? k2)
              then LeqTerm (Tint 0) (fusion b1 b2 k1 k2)
              else TrueTerm
          | _ => TrueTerm
          end
      else TrueTerm
  | NeqTerm (Tint o) b1 =>
      match prop2 with
      | EqTerm (Tint o') b2 =>
          if (o =? 0) && (o' =? 0) && negb (k1 =? 0)
          then NeqTerm (Tint 0) (fusion b1 b2 k1 k2)
          else TrueTerm
      | _ => TrueTerm
      end
  | _ => TrueTerm
  end.

Theorem sum_valid :
 forall (k1 k2 : int), valid2 (sum k1 k2).
Proof.
 unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum;
 Simplify; simpl; rewrite ?fusion_stable;
 simpl; intros; auto.
 - apply sum1; auto.
 - rewrite plus_comm. apply sum5; auto.
 - apply sum2; auto using lt_le_weak.
 - apply sum5; auto.
 - rewrite plus_comm. apply sum2; auto using lt_le_weak.
 - apply sum3; auto using lt_le_weak.
Qed.

(** [MERGE_EQ] *)

Definition merge_eq (prop1 prop2 : proposition) :=
  match prop1 with
  | LeqTerm (Tint o) b1 =>
      match prop2 with
      | LeqTerm (Tint o') b2 =>
          if (o =? 0) && (o' =? 0) &&
             (b1 =? scalar_mult b2 (-(1)))%term
          then EqTerm (Tint 0) b1
          else TrueTerm
      | _ => TrueTerm
      end
  | _ => TrueTerm
  end.

Theorem merge_eq_valid : valid2 merge_eq.
Proof.
 unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto.
 rewrite scalar_mult_stable. simpl.
 intros; symmetry ; apply OMEGA8 with (2 := H0).
 - assumption.
 - elim opp_eq_mult_neg_1; trivial.
Qed.

(** [O_SPLIT_INEQ] (only step to produce two subgoals). *)

Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) :=
  match nth_hyps i l with
  | NeqTerm (Tint o) b1 =>
      if o =? 0 then
       f1 (LeqTerm (Tint 0) (scalar_add b1 (-(1))) :: l) ++
       f2 (LeqTerm (Tint 0) (scalar_mult_add b1 (-(1)) (-(1))) :: l)
      else l :: nil
  | _ => l :: nil
  end.

Theorem split_ineq_valid :
 forall (i : nat) (f1 f2 : hyps -> lhyps),
 valid_list_hyps f1 ->
 valid_list_hyps f2 -> valid_list_hyps (split_ineq i f1 f2).
Proof.
 unfold valid_list_hyps, split_ineq; intros i f1 f2 H1 H2 ep e lp H;
 generalize (nth_valid _ _ i _ H); case (nth_hyps i lp);
 simpl; auto; intros t1 t2; case t1; simpl;
 auto; intros z; simpl; auto; intro H3.
 Simplify.
 apply append_valid; elim (OMEGA19 (interp_term e t2)).
 - intro H4; left; apply H1; simpl; rewrite scalar_add_stable;
    simpl; auto.
 - intro H4; right; apply H2; simpl; rewrite scalar_mult_add_stable;
    simpl; auto.
 - generalize H3; unfold not; intros E1 E2; apply E1;
    symmetry ; trivial.
Qed.

(** ** Replaying the resolution trace *)

Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps :=
  match t with
  | O_BAD_CONSTANT i => singleton (bad_constant i l)
  | O_NOT_EXACT_DIVIDE i k => singleton (not_exact_divide i k l)
  | O_DIVIDE i k cont =>
      execute_omega cont (apply_oper_1 i (divide k) l)
  | O_SUM k1 i1 k2 i2 cont =>
      execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l)
  | O_MERGE_EQ i1 i2 cont =>
      execute_omega cont (apply_oper_2 i1 i2 merge_eq l)
  | O_SPLIT_INEQ i cont1 cont2 =>
      split_ineq i (execute_omega cont1) (execute_omega cont2) l
  end.

Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr).
Proof.
 simple induction tr; unfold valid_list_hyps, valid_hyps; simpl.
 - intros; left; now apply bad_constant_valid.
 - intros; left; now apply not_exact_divide_valid.
 - intros m k t' Ht' ep e lp H; apply Ht';
    apply
     (apply_oper_1_valid m (divide k)
        (divide_valid k) ep e lp H).
 - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht';
    apply
     (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e
        lp H).
 - intros i1 i2 t' Ht' ep e lp H; apply Ht';
    apply
     (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e
        lp H).
 - intros i k1 H1 k2 H2 ep e lp H;
    apply
     (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e
        lp H).
Qed.

(** ** Rules for decomposing the hypothesis

   This type allows navigation in the logical constructors that
   form the predicats of the hypothesis in order to decompose them.
   This allows in particular to extract one hypothesis from a conjunction.
   NB: negations are now silently traversed. *)

Inductive direction : Set :=
  | D_left : direction
  | D_right : direction.

(** This type allows extracting useful components from hypothesis, either
   hypothesis generated by splitting a disjonction, or equations.
   The last constructor indicates how to solve the obtained system
   via the use of the trace type of Omega [t_omega] *)

Inductive e_step : Set :=
  | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step
  | E_EXTRACT : nat -> list direction -> e_step -> e_step
  | E_SOLVE : t_omega -> e_step.

(** Selection of a basic fact inside an hypothesis. *)

Fixpoint extract_hyp_pos (s : list direction) (p : proposition) :
 proposition :=
  match p, s with
  | Tand x y, D_left :: l => extract_hyp_pos l x
  | Tand x y, D_right :: l => extract_hyp_pos l y
  | Tnot x, _ => extract_hyp_neg s x
  | _, _ => p
  end

 with extract_hyp_neg (s : list direction) (p : proposition) :
 proposition :=
  match p, s with
  | Tor x y, D_left :: l => extract_hyp_neg l x
  | Tor x y, D_right :: l => extract_hyp_neg l y
  | Timp x y, D_left :: l =>
    if decidability x then extract_hyp_pos l x else Tnot p
  | Timp x y, D_right :: l => extract_hyp_neg l y
  | Tnot x, _ => if decidability x then extract_hyp_pos s x else Tnot p
  | _, _ => Tnot p
  end.

Theorem extract_valid :
 forall s : list direction, valid1 (extract_hyp_pos s).
Proof.
 assert (forall p s ep e,
         (interp_prop ep e p ->
          interp_prop ep e (extract_hyp_pos s p)) /\
         (interp_prop ep e (Tnot p) ->
          interp_prop ep e (extract_hyp_neg s p))).
 { induction p; destruct s; simpl; auto; split; try destruct d; try easy;
   intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto;
   destruct decidability eqn:D; auto;
   apply (decidable_correct ep e) in D; unfold decidable in D;
   (apply IHp || apply IHp1); tauto. }
 red. intros. now apply H.
Qed.

(** Attempt to shorten error messages if romega goes rogue...
    NB: [interp_list_goal _ _ BUG = False /\ True]. *)
Definition BUG : lhyps := nil :: nil.

(** Split and extract in hypotheses *)

Fixpoint decompose_solve (s : e_step) (h : hyps) : lhyps :=
  match s with
  | E_SPLIT i dl s1 s2 =>
      match extract_hyp_pos dl (nth_hyps i h) with
      | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h)
      | Tnot (Tand x y) =>
          if decidability x
          then
           decompose_solve s1 (Tnot x :: h) ++
           decompose_solve s2 (Tnot y :: h)
          else BUG
      | Timp x y =>
          if decidability x then
            decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h)
          else BUG
      | _ => BUG
      end
  | E_EXTRACT i dl s1 =>
      decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h)
  | E_SOLVE t => execute_omega t h
  end.

Theorem decompose_solve_valid (s : e_step) :
 valid_list_goal (decompose_solve s).
Proof.
 apply goal_valid. red. induction s; simpl; intros ep e lp H.
 - assert (H' : interp_prop ep e (extract_hyp_pos l (nth_hyps n lp))).
   { now apply extract_valid, nth_valid. }
   destruct extract_hyp_pos; simpl in *; auto.
   + destruct p; simpl; auto.
     destruct decidability eqn:D; [ | simpl; auto].
     apply (decidable_correct ep e) in D.
     apply append_valid. simpl in *. destruct D.
     * right. apply IHs2. simpl; auto.
     * left. apply IHs1. simpl; auto.
   + apply append_valid. destruct H'.
     * left. apply IHs1. simpl; auto.
     * right. apply IHs2. simpl; auto.
   + destruct decidability eqn:D; [ | simpl; auto].
     apply (decidable_correct ep e) in D.
     apply append_valid. destruct D.
     * right. apply IHs2. simpl; auto.
     * left. apply IHs1. simpl; auto.
 - apply IHs; simpl; split; auto.
   now apply extract_valid, nth_valid.
 - now apply omega_valid.
Qed.

(** Reduction of subgoal list by discarding the contradictory subgoals. *)

Definition valid_lhyps (f : lhyps -> lhyps) :=
  forall (ep : list Prop) (e : list int) (lp : lhyps),
  interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp).

Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
  match lp with
  | nil => nil
  | (FalseTerm :: nil) :: lp' => reduce_lhyps lp'
  | x :: lp' => BUG
  end.

Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
Proof.
 unfold valid_lhyps; intros ep e lp; elim lp.
 - simpl; auto.
 - intros a l HR; elim a.
    + simpl; tauto.
    + intros a1 l1; case l1; case a1; simpl; tauto.
Qed.

Theorem do_reduce_lhyps :
 forall (envp : list Prop) (env : list int) (l : lhyps),
 interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
Proof.
 intros envp env l H; apply list_goal_to_hyps; intro H1;
 apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid;
 assumption.
Qed.

(** Pushing the conclusion into the hypotheses. *)

Definition concl_to_hyp (p : proposition) :=
  if decidability p then Tnot p else TrueTerm.

Definition do_concl_to_hyp :
  forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps),
  interp_goal envp env (concl_to_hyp c :: l) ->
  interp_goal_concl c envp env l.
Proof.
 induction l; simpl.
 - unfold concl_to_hyp; simpl.
   destruct decidability eqn:D; [ | simpl; tauto ].
   apply (decidable_correct envp env) in D. unfold decidable in D.
   simpl. tauto.
 - simpl in *; tauto.
Qed.

(** The omega tactic : all steps together *)

Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) :=
  reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))).

Theorem do_omega :
 forall (t : e_step) (envp : list Prop)
   (env : list int) (c : proposition) (l : hyps),
 interp_list_goal envp env (omega_tactic t c l) ->
 interp_goal_concl c envp env l.
Proof.
 unfold omega_tactic; intros t ep e c l H.
 apply do_concl_to_hyp.
 apply normalize_hyps_goal.
 apply (decompose_solve_valid t).
 now apply do_reduce_lhyps.
Qed.

End IntOmega.

(** For now, the above modular construction is instanciated on Z,
    in order to retrieve the initial ROmega. *)

Module ZOmega := IntOmega(Z_as_Int).


Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Lemma In_app_iff: forall A l l' (a: A),
  In a (l ++ l') <-> In a l \/ In a l'.
Proof.
  intros A.
  induction l as [| a t IH].
  - intros l' a. split.
    + intros H. right. apply H.
    + intros [H1 | H2].
      * destruct H1.
      * apply H2.
  - intros l' x. split.
    + intros [H1 | H2].
      * left. left. apply H1.
      * apply IH in H2.
        destruct H2 as [H3 | H4].
        -- left. right. apply H3.
        -- right. apply H4.
    + intros [[H1 | H2] | H3].
      * left. apply H1.
      * right. apply IH. left. apply H2.
      * right. apply IH. right. apply H3.
Qed.

Fixpoint All {T: Type} (P: T -> Prop) (l: list T): Prop :=
  match l with
  | [] => True
  | a :: t => P a /\ All P t
  end.

Lemma All_In:
  forall T (P: T -> Prop) (l: list T),
  (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T.
  induction l as [| a t IH].
  - split.
    + intros H. apply I.
    + intros H0 x H.
      destruct H.
  - split.
    + intros H. split.
      * apply H. left. reflexivity.
      * apply IH. intros x H2.
        apply H. right. apply H2.
    + intros [H1 H2] x H3.
      destruct H3 as [H4 | H5].
      * rewrite <- H4. apply H1.
      * apply IH. apply H2. apply H5.
Qed.


(* Set Implicit Arguments. *)

Inductive term : Set :=
  | tm_true : term
  | tm_false : term
  | tm_if : term -> term -> term -> term.

Reserved Notation "t --> t'" (at level 50).

Inductive s_step : term -> term -> Prop :=
  | E_IfTrue : forall t2 t3, tm_if tm_true t2 t3 --> t2
  | E_IfFalse : forall t2 t3, tm_if tm_false t2 t3 --> t3
  | E_If : forall t1 t1' t2 t3, t1 --> t1' -> tm_if t1 t2 t3 --> tm_if t1' t2 t3
  where "t --> t'" := (s_step t t').

Definition s : term := tm_if tm_true tm_false tm_false.
Definition t : term := tm_if s tm_true tm_true.
Definition u : term := tm_if tm_false tm_true tm_true.

Example p36_ex_step :
  tm_if t tm_false tm_false --> tm_if u tm_false tm_false.
Proof.
  apply E_If.
  apply E_If.
  apply E_IfTrue.
Qed.

Theorem theo3_5_4 :
  forall t t' t'' : term, t --> t' /\ t --> t'' -> t' = t''.
Proof.
  intros t t' t'' H1.
  destruct H1 as [e1 e2].

  generalize dependent t''.
  induction e1.

  (* E_IfTrue *)
  intros. inversion e2. reflexivity. inversion H3.
  (* E_IfFalse *)
  intros. inversion e2. reflexivity. inversion H3.
  (* E_If *)
  intros. inversion e2.
    rewrite <- H0 in e1. inversion e1.
    rewrite <- H0 in e1. inversion e1.
    rewrite (IHe1 t1'0 H3). reflexivity.
Qed.


Require Import lam_cl_es_no
               abstract_machine_facts.

Module Sim := DetAbstractMachine_Sim Lam_ClES_NO_EAM_minus.

Import Lam_ClES_NO_EAM_minus.
Import Lam_ClES_NO_RefLang Lam_ClES_NO_Cal.RedLang.

Example t1 := Lam0 (App0 (Lam0 (Lam0 (Var0 1))) (Var0 0)).

Eval compute in
    Sim.n_steps
    ( c_init t1 )
    14.

Eval compute in
    Sim.n_steps
    ( c_init (Lam0 (App0  t1  (Var0 0) )) )
    20.

Fixpoint nat_term0 n :=
    match n with
    | 0   => Lam0 (Lam0 (Var0 0))
    | S n => Lam0 (Lam0 (App0 (Var0 1) (App0 (App0 (nat_term0 n) (Var0 1)) (Var0 0))))
    end.

Definition add_term0 :=
    Lam0 (Lam0 (Lam0 (Lam0
        (App0 (App0 (Var0 3)
            (Var0 1))
            (App0 (App0 (Var0 2) (Var0 1)) (Var0 0)))))).

Definition mul_term0 :=
    Lam0 (Lam0 (Lam0 (Lam0
        (App0 (App0

        (App0 (App0 (Var0 2)
            (Lam0 (App0 (App0 add_term0 (Var0 4)) (Var0 0)) ))
            (nat_term0 0))

        (Var0 1)) (Var0 0))))).

Eval compute in
    Sim.n_steps
    ( c_init (App0 (App0 mul_term0 (nat_term0 3)) (nat_term0 4)) )
    672.