(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export positive_fraction_encoding.
Require Import ZArithRing.

Definition outside_interval (a b : Z) := (Zsgn a + Zsgn b)%Z.

Definition inside_interval_1 (o1 o2 : Z) :=
  (0 < o1)%Z /\ (0 < o2)%Z \/ (o1 < 0)%Z /\ (o2 < 0)%Z.

Definition inside_interval_2 (o1 o2 : Z) :=
  (0 < o1)%Z /\ (o2 < 0)%Z \/ (o1 < 0)%Z /\ (0 < o2)%Z.

Lemma inside_interval_1_dec_inf :
 forall o1 o2 : Z, {inside_interval_1 o1 o2} + {~ inside_interval_1 o1 o2}.
Proof.
 intros.
 abstract (case (Z_lt_dec 0 o1); intro Ho1;
            [ case (Z_lt_dec 0 o2); intro Ho2;
               [ left; left; split
               | right; intro H;
                  match goal with
                  | id1:(~ ?X1) |- ?X2 =>
                      apply id1; case H; intros (H1, H2);
                       [ idtac
                       | apply False_ind; apply Zlt_irrefl with o1;
                          apply Zlt_trans with 0%Z ]
                  end ]
            | case (Z_lt_dec o1 0); intro Ho1';
               [ case (Z_lt_dec o2 0); intro Ho2;
                  [ left; right; split
                  | right; intro H; case H; intros (H1, H2);
                     [ apply Ho1 | apply Ho2 ] ]
               | right; intro H; apply Ho1; case H; intros (H1, H2);
                  [ idtac | apply False_ind; apply Ho1' ] ] ];
            try assumption).
Defined.

Lemma inside_interval_2_dec_inf :
 forall o1 o2 : Z, {inside_interval_2 o1 o2} + {~ inside_interval_2 o1 o2}.
Proof.
 intros.
 abstract (case (Z_lt_dec 0 o1); intro Ho1;
            [ case (Z_lt_dec o2 0); intro Ho2;
               [ left; left; split
               | right; intro H;
                  match goal with
                  | id1:(~ ?X1) |- ?X2 =>
                      apply id1; case H; intros (H1, H2);
                       [ idtac
                       | apply False_ind; apply Zlt_irrefl with o1;
                          apply Zlt_trans with 0%Z ]
                  end ]
            | case (Z_lt_dec o1 0); intro Ho1';
               [ case (Z_lt_dec 0 o2); intro Ho2;
                  [ left; right; split
                  | right; intro H; case H; intros (H1, H2);
                     [ apply Ho1 | apply Ho2 ] ]
               | right; intro H; apply Ho1; case H; intros (H1, H2);
                  [ idtac | apply False_ind; apply Ho1' ] ] ];
            try assumption).
Defined.

Inductive Qhomographic_sg_denom_nonzero : Z -> Z -> Qpositive -> Prop :=
  | Qhomographic_signok0 :
      forall (c d : Z) (p : Qpositive),
      p = One -> (c + d)%Z <> 0%Z -> Qhomographic_sg_denom_nonzero c d p
  | Qhomographic_signok1 :
      forall (c d : Z) (xs : Qpositive),
      Qhomographic_sg_denom_nonzero c (c + d)%Z xs ->
      Qhomographic_sg_denom_nonzero c d (nR xs)
  | Qhomographic_signok2 :
      forall (c d : Z) (xs : Qpositive),
      Qhomographic_sg_denom_nonzero (c + d)%Z d xs ->
      Qhomographic_sg_denom_nonzero c d (dL xs).

Lemma Qhomographic_signok_1 :
 forall c d : Z, Qhomographic_sg_denom_nonzero c d One -> (c + d)%Z <> 0%Z.
Proof.
 intros.
 inversion H.
 assumption.
Defined.

Lemma Qhomographic_signok_2 :
 forall (c d : Z) (xs : Qpositive),
 Qhomographic_sg_denom_nonzero c d (nR xs) ->
 Qhomographic_sg_denom_nonzero c (c + d) xs.
Proof.
 intros.
 inversion H.
 discriminate H0.
 assumption.
Defined.

Lemma Qhomographic_signok_3 :
 forall (c d : Z) (xs : Qpositive),
 Qhomographic_sg_denom_nonzero c d (dL xs) ->
 Qhomographic_sg_denom_nonzero (c + d) d xs.
Proof.
 intros.
 inversion H.
 discriminate H0.
 assumption.
Defined.

Fixpoint Qhomographic_sign (a b c d : Z) (p : Qpositive) {struct p} :
  forall (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
  Z * (Z * (Z * (Z * Z)) * Qpositive).
set (o1 := outside_interval a b) in *.
set (o2 := outside_interval c d) in *.
destruct p as [q| q| ]; intros H_Qhomographic_sg_denom_nonzero.
 (* p=(nR xs) *)
  case (Z_zerop b).
   (* b=0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    exact ((Zsgn a * Zsgn c)%Z, (a, (b, (c, d)), nR q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Zsgn a, (a, (b, (c, d)), nR q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Zsgn a)%Z, (a, (b, (c, d)), nR q)).
      (* ~`0 < o2` /\ ~ `0 < o2` /\ d<>0  *)
      intro Ho2''.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
   (* b<>0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    case (Z_lt_dec 0 o1).
     (*  `0 < o1` *)
     intro Ho1.
     exact (Zsgn c, (a, (b, (c, d)), nR q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Zsgn c)%Z, (a, (b, (c, d)), nR q)).
      (* ~`0 < o1` /\ ~ `0 < o1` /\ b<>0  *)
      intro Ho1''.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
    (* d<>0 *)
    intro Hd'.
    case (inside_interval_1_dec_inf o1 o2).
     (* (inside_interval_1 o1 o2) *)
     intro H_inside_1.
     exact (1%Z, (a, (b, (c, d)), nR q)).
     (* ~(inside_interval_1 o1 o2) *)
     intro H_inside_1'.
     case (inside_interval_2_dec_inf o1 o2).
      (* (inside_interval_2 o1 o2) *)
      intro H_inside_2.
      exact ((-1)%Z, (a, (b, (c, d)), nR q)).
      (*  ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *)
      intros H_inside_2'.
      exact
       (Qhomographic_sign a (a + b)%Z c (c + d)%Z q
          (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)).
  (* p=(dL xs) *)
  case (Z_zerop b).
   (* b=0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    exact ((Zsgn a * Zsgn c)%Z, (a, (b, (c, d)), dL q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Zsgn a, (a, (b, (c, d)), dL q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Zsgn a)%Z, (a, (b, (c, d)), dL q)).
      (* ~`0 < o2` /\ ~ `0 < o2` /\ d<>0  *)
      intro Ho2''.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).
   (* b<>0 *)
   intro Hb.
   case (Z_zerop d).
    (* d=0 *)
    intro Hd.
    case (Z_lt_dec 0 o1).
     (*  `0 < o1` *)
     intro Ho1.
     exact (Zsgn c, (a, (b, (c, d)), dL q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Zsgn c)%Z, (a, (b, (c, d)), dL q)).
      (* ~`0 < o1` /\ ~ `0 < o1` /\ b<>0  *)
      intro Ho1''.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).
    (* d<>0 *)
    intro Hd'.
    case (inside_interval_1_dec_inf o1 o2).
     (* (inside_interval_1 o1 o2) *)
     intro H_inside_1.
     exact (1%Z, (a, (b, (c, d)), dL q)).
     (* ~(inside_interval_1 o1 o2) *)
     intro H_inside_1'.
     case (inside_interval_2_dec_inf o1 o2).
      (* (inside_interval_2 o1 o2) *)
      intro H_inside_2.
      exact ((-1)%Z, (a, (b, (c, d)), dL q)).
      (*  ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *)
      intros H_inside_2'.
      exact
       (Qhomographic_sign (a + b)%Z b (c + d)%Z d q
          (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)).

 (* p = One *)
  set (soorat := Zsgn (a + b)) in *.
  set (makhraj := Zsgn (c + d)) in *.

  case (Z_eq_dec soorat 0).
   (*  `soorat = 0` *)
   intro eq_numerator0.
   exact (0%Z, (a, (b, (c, d)), One)).
   (*  `soorat <> 0` *)
   intro.
   case (Z_eq_dec soorat makhraj).
    (* soorat = makhraj *)
    intro.
    exact (1%Z, (a, (b, (c, d)), One)).
    (* soorat <> makhraj *)
    intro.
    exact ((-1)%Z, (a, (b, (c, d)), One)).
Defined.

Functional Scheme Qhomographic_sign_ind :=
  Induction for Qhomographic_sign Sort Prop.

Scheme Qhomographic_sg_denom_nonzero_inv_dep :=
  Induction for Qhomographic_sg_denom_nonzero Sort Prop.

Lemma Qhomographic_sign_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H1 H2 : Qhomographic_sg_denom_nonzero c d p),
 Qhomographic_sign a b c d p H1 = Qhomographic_sign a b c d p H2.
Proof.
 intros.
 generalize H2 H1 a b.
 intro.
 abstract let T_local := (intros; simpl in |- *; rewrite H; reflexivity) in
          (elim H0 using Qhomographic_sg_denom_nonzero_inv_dep; intros;
            [ destruct p0 as [q| q| ];
               [ discriminate e
               | discriminate e
               | simpl in |- *; case (Z_eq_dec (Zsgn (a0 + b0)) 0);
                  case (Z_eq_dec (Zsgn (a0 + b0)) (Zsgn (c0 + d0)));
                  intros; reflexivity ]
            | T_local
            | T_local ]).
Defined.

Lemma Qhomographic_sign_equal_strong :
 forall (a1 a2 b1 b2 c1 c2 d1 d2 : Z) (p1 p2 : Qpositive)
   (H_ok_1 : Qhomographic_sg_denom_nonzero c1 d1 p1)
   (H_ok_2 : Qhomographic_sg_denom_nonzero c2 d2 p2),
 a1 = a2 ->
 b1 = b2 ->
 c1 = c2 ->
 d1 = d2 ->
 p1 = p2 ->
 Qhomographic_sign a1 b1 c1 d1 p1 H_ok_1 =
 Qhomographic_sign a2 b2 c2 d2 p2 H_ok_2.
Proof.
 abstract (intros; generalize H_ok_2;
            repeat
             match goal with
             | id1:(?X1 = ?X2) |- ?X3 => rewrite <- id1; clear id1
             end; intro; apply Qhomographic_sign_equal).
Defined.

Lemma sg_One_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = One ->
 Zsgn (a + b) = 0%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (0%Z, (a, (b, (c, d)), One)).
Proof.
 intros.
 destruct p as [q| q| ]; repeat (apply False_ind; discriminate H).
 simpl in |- *.
 case (Z_eq_dec (Zsgn (a + b)) 0).
 intro.
 reflexivity.
 intro.
 Falsum.
Defined.

Lemma sg_One_3 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = One ->
 Zsgn (a + b) <> 0%Z ->
 Zsgn (a + b) = Zsgn (c + d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (1%Z, (a, (b, (c, d)), One)).
Proof.
 intros.
 destruct p as [q| q| ]; repeat (apply False_ind; discriminate H).
 simpl in |- *.
 case (Z_eq_dec (Zsgn (a + b)) 0).
 Falsum.
 intro.
 case (Z_eq_dec (Zsgn (a + b)) (Zsgn (c + d))).
 intro.
 reflexivity.
 intro.
 Falsum.
Defined.

Lemma sg_One_4 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = One ->
 Zsgn (a + b) <> 0%Z ->
 Zsgn (a + b) <> Zsgn (c + d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((-1)%Z, (a, (b, (c, d)), One)).
Proof.
 intros.
 destruct p as [q| q| ]; repeat (apply False_ind; discriminate H).
 simpl in |- *.
 case (Z_eq_dec (Zsgn (a + b)) 0).
 Falsum.
 case (Z_eq_dec (Zsgn (a + b)) (Zsgn (c + d))).
 Falsum.
 reflexivity.
Defined.

Lemma Qhomographic_sign_nR_1 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b = 0%Z ->
 d = 0%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((Zsgn a * Zsgn c)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd; [ reflexivity | Falsum ] | Falsum ].
Defined.

Lemma Qhomographic_sign_nR_2 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b = 0%Z ->
 d <> 0%Z ->
 (0 < outside_interval c d)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (Zsgn a, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ reflexivity | Falsum ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_nR_3 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b = 0%Z ->
 d <> 0%Z ->
 ~ (0 < outside_interval c d)%Z ->
 (outside_interval c d < 0)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((- Zsgn a)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval c d) 0); intro Ho2';
           [ reflexivity | Falsum ] ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_nR_4 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c
                                        (c + d) xs)
   (H_Qhomographic_sg_denom_nonzero_nR : Qhomographic_sg_denom_nonzero c d
                                           (nR xs)),
 b = 0%Z ->
 d <> 0%Z ->
 ~ (0 < outside_interval c d)%Z ->
 ~ (outside_interval c d < 0)%Z ->
 Qhomographic_sign a b c d (nR xs) H_Qhomographic_sg_denom_nonzero_nR =
 Qhomographic_sign a (a + b) c (c + d) xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval c d) 0); intro Ho2';
           [ Falsum | apply Qhomographic_sign_equal ] ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_nR_5 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b <> 0%Z ->
 d = 0%Z ->
 (0 < outside_interval a b)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (Zsgn c, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ reflexivity | Falsum ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_nR_6 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b <> 0%Z ->
 d = 0%Z ->
 ~ (0 < outside_interval a b)%Z ->
 (outside_interval a b < 0)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((- Zsgn c)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval a b) 0); intro Ho2';
           [ reflexivity | Falsum ] ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_nR_7 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c
                                        (c + d) xs)
   (H_Qhomographic_sg_denom_nonzero_nR : Qhomographic_sg_denom_nonzero c d
                                           (nR xs)),
 b <> 0%Z ->
 d = 0%Z ->
 ~ (0 < outside_interval a b)%Z ->
 ~ (outside_interval a b < 0)%Z ->
 Qhomographic_sign a b c d (nR xs) H_Qhomographic_sg_denom_nonzero_nR =
 Qhomographic_sign a (a + b) c (c + d) xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval a b) 0); intro Ho2';
           [ Falsum | apply Qhomographic_sign_equal ] ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_nR_8 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b <> 0%Z ->
 d <> 0%Z ->
 inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (1%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ reflexivity | Falsum ] ] ].
Defined.

Lemma Qhomographic_sign_nR_9 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = nR xs ->
 b <> 0%Z ->
 d <> 0%Z ->
 ~ inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 inside_interval_2 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((-1)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ Falsum
        | case
           (inside_interval_2_dec_inf (outside_interval a b)
              (outside_interval c d)); intro H_inside_2;
           [ reflexivity | Falsum ] ] ] ].
Defined.

Lemma Qhomographic_sign_nR_10 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c
                                        (c + d) xs)
   (H_Qhomographic_sg_denom_nonzero_nR : Qhomographic_sg_denom_nonzero c d
                                           (nR xs)),
 b <> 0%Z ->
 d <> 0%Z ->
 ~ inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 ~ inside_interval_2 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d (nR xs) H_Qhomographic_sg_denom_nonzero_nR =
 Qhomographic_sign a (a + b) c (c + d) xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ Falsum
        | case
           (inside_interval_2_dec_inf (outside_interval a b)
              (outside_interval c d)); intro H_inside_2;
           [ Falsum | apply Qhomographic_sign_equal ] ] ] ].
Defined.

(* the next 10 proofs are just clone of the above 10 proofs *)

Lemma Qhomographic_sign_dL_1 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b = 0%Z ->
 d = 0%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((Zsgn a * Zsgn c)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd; [ reflexivity | Falsum ] | Falsum ].
Defined.

Lemma Qhomographic_sign_dL_2 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b = 0%Z ->
 d <> 0%Z ->
 (0 < outside_interval c d)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (Zsgn a, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ reflexivity | Falsum ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_dL_3 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b = 0%Z ->
 d <> 0%Z ->
 ~ (0 < outside_interval c d)%Z ->
 (outside_interval c d < 0)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((- Zsgn a)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval c d) 0); intro Ho2';
           [ reflexivity | Falsum ] ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_dL_4 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero
                                        (c + d) d xs)
   (H_Qhomographic_sg_denom_nonzero_dL : Qhomographic_sg_denom_nonzero c d
                                           (dL xs)),
 b = 0%Z ->
 d <> 0%Z ->
 ~ (0 < outside_interval c d)%Z ->
 ~ (outside_interval c d < 0)%Z ->
 Qhomographic_sign a b c d (dL xs) H_Qhomographic_sg_denom_nonzero_dL =
 Qhomographic_sign (a + b) b (c + d) d xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ case (Z_zerop d); intro Hd;
     [ Falsum
     | case (Z_lt_dec 0 (outside_interval c d)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval c d) 0); intro Ho2';
           [ Falsum | apply Qhomographic_sign_equal ] ] ]
  | Falsum ].
Defined.

Lemma Qhomographic_sign_dL_5 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b <> 0%Z ->
 d = 0%Z ->
 (0 < outside_interval a b)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (Zsgn c, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ reflexivity | Falsum ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_dL_6 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b <> 0%Z ->
 d = 0%Z ->
 ~ (0 < outside_interval a b)%Z ->
 (outside_interval a b < 0)%Z ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((- Zsgn c)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval a b) 0); intro Ho2';
           [ reflexivity | Falsum ] ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_dL_7 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero
                                        (c + d) d xs)
   (H_Qhomographic_sg_denom_nonzero_dL : Qhomographic_sg_denom_nonzero c d
                                           (dL xs)),
 b <> 0%Z ->
 d = 0%Z ->
 ~ (0 < outside_interval a b)%Z ->
 ~ (outside_interval a b < 0)%Z ->
 Qhomographic_sign a b c d (dL xs) H_Qhomographic_sg_denom_nonzero_dL =
 Qhomographic_sign (a + b) b (c + d) d xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ case (Z_lt_dec 0 (outside_interval a b)); intro Ho2;
        [ Falsum
        | case (Z_lt_dec (outside_interval a b) 0); intro Ho2';
           [ Falsum | apply Qhomographic_sign_equal ] ]
     | Falsum ] ].
Defined.

Lemma Qhomographic_sign_dL_8 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b <> 0%Z ->
 d <> 0%Z ->
 inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 (1%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ reflexivity | Falsum ] ] ].
Defined.

Lemma Qhomographic_sign_dL_9 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 p = dL xs ->
 b <> 0%Z ->
 d <> 0%Z ->
 ~ inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 inside_interval_2 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero =
 ((-1)%Z, (a, (b, (c, d)), p)).
Proof.
 intros; generalize H_Qhomographic_sg_denom_nonzero;
  clear H_Qhomographic_sg_denom_nonzero; rewrite H;
  intros H_Qhomographic_sg_denom_nonzero; simpl in |- *;
  case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ Falsum
        | case
           (inside_interval_2_dec_inf (outside_interval a b)
              (outside_interval c d)); intro H_inside_2;
           [ reflexivity | Falsum ] ] ] ].
Defined.

Lemma Qhomographic_sign_dL_10 :
 forall (a b c d : Z) (p xs : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero
                                        (c + d) d xs)
   (H_Qhomographic_sg_denom_nonzero_dL : Qhomographic_sg_denom_nonzero c d
                                           (dL xs)),
 b <> 0%Z ->
 d <> 0%Z ->
 ~ inside_interval_1 (outside_interval a b) (outside_interval c d) ->
 ~ inside_interval_2 (outside_interval a b) (outside_interval c d) ->
 Qhomographic_sign a b c d (dL xs) H_Qhomographic_sg_denom_nonzero_dL =
 Qhomographic_sign (a + b) b (c + d) d xs H_Qhomographic_sg_denom_nonzero.
Proof.
 intros; simpl in |- *; case (Z_zerop b); intro Hb;
  [ Falsum
  | case (Z_zerop d); intro Hd;
     [ Falsum
     | case
        (inside_interval_1_dec_inf (outside_interval a b)
           (outside_interval c d)); intro H_inside_1;
        [ Falsum
        | case
           (inside_interval_2_dec_inf (outside_interval a b)
              (outside_interval c d)); intro H_inside_2;
           [ Falsum | apply Qhomographic_sign_equal ] ] ] ].
Defined.

Lemma sg_sign :
 forall (a b c d : Z) (qp : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d qp),
 let (l1, L2) :=
     Qhomographic_sign a b c d qp H_Qhomographic_sg_denom_nonzero in
 {l1 = 0%Z} + {l1 = 1%Z} + {l1 = (-1)%Z}.
Proof.
 fix 5.
 intros.
 (* (nR p) *)

 let T_local :=
  (case (Z_zerop b); intro Hb;
    [ case (Z_zerop d); intro Hd;
       [ match goal with
         | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
             rewrite
              (Qhomographic_sign_nR_1 a b c d (nR q) q
                 H_Qhomographic_sg_denom_nonzero (refl_equal (nR q)) Hb Hd)

         | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
             rewrite
              (Qhomographic_sign_dL_1 a b c d (dL q) q
                 H_Qhomographic_sg_denom_nonzero (refl_equal (dL q)) Hb Hd)

         end; generalize a c;
          intros [|pa|pa] [| pc| pc];
          simpl in |- *; first
          [ right; reflexivity
          | left; left; reflexivity
          | left; right; reflexivity ]
       | case (Z_lt_dec 0 (outside_interval c d)); intros Ho2;
          [ match goal with
            | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_nR_2 a b c d (nR q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (nR q)) Hb Hd Ho2)
            | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_dL_2 a b c d (dL q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (dL q)) Hb Hd Ho2)
            end; generalize a; intros [| pa| pa]; simpl in |- *; first
             [ right; reflexivity
             | left; left; reflexivity
             | left; right; reflexivity ]
          | case (Z_lt_dec (outside_interval c d) 0); intros Ho2';
             [ match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_3 a b c d
                       (nR q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (nR q)) Hb Hd Ho2 Ho2')

               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_3 a b c d
                       (dL q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (dL q)) Hb Hd Ho2 Ho2')

               end; generalize a; intros [| pa| pa];
                simpl in |- *; first
                [ right; reflexivity
                | left; left; reflexivity
                | left; right; reflexivity ]
             | match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_4 a b c d
                       (nR q) q
                       (Qhomographic_signok_2 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd Ho2 Ho2')

               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_4 a b c d
                       (dL q) q
                       (Qhomographic_signok_3 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd Ho2 Ho2')

               end; apply sg_sign ] ] ]
    | case (Z_zerop d); intro Hd;
       [ case (Z_lt_dec 0 (outside_interval a b)); intros Ho1;
          [ match goal with
            | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_nR_5 a b c d (nR q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (nR q)) Hb Hd Ho1)
            | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_dL_5 a b c d (dL q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (dL q)) Hb Hd Ho1)
            end; generalize c; intros [| pc| pc]; simpl in |- *; first
             [ right; reflexivity
             | left; left; reflexivity
             | left; right; reflexivity ]
          | case (Z_lt_dec (outside_interval a b) 0); intros Ho1';
             [ match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_6 a b c d
                       (nR q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (nR q)) Hb Hd Ho1 Ho1')

               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_6 a b c d
                       (dL q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (dL q)) Hb Hd Ho1 Ho1')

               end; generalize c; intros [| pc| pc];
                simpl in |- *; first
                [ right; reflexivity
                | left; left; reflexivity
                | left; right; reflexivity ]
             | match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_7 a b c d
                       (nR q) q
                       (Qhomographic_signok_2 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd Ho1 Ho1')

               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_7 a b c d
                       (dL q) q
                       (Qhomographic_signok_3 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd Ho1 Ho1')

               end; apply sg_sign ] ]
       | case
          (inside_interval_1_dec_inf (outside_interval a b)
             (outside_interval c d)); intros H_inside_1;
          [ match goal with
            | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_nR_8 a b c d (nR q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (nR q)) Hb Hd H_inside_1)

            | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                rewrite
                 (Qhomographic_sign_dL_8 a b c d (dL q) q
                    H_Qhomographic_sg_denom_nonzero
                    (refl_equal (dL q)) Hb Hd H_inside_1)

            end; first
             [ right; reflexivity
             | left; left; reflexivity
             | left; right; reflexivity ]
          | case
             (inside_interval_2_dec_inf (outside_interval a b)
                (outside_interval c d)); intros H_inside_2;
             [ match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_9 a b c d
                       (nR q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (nR q)) Hb Hd H_inside_1 H_inside_2)

               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_9 a b c d
                       (dL q) q H_Qhomographic_sg_denom_nonzero
                       (refl_equal (dL q)) Hb Hd H_inside_1 H_inside_2)

               end; first
                [ right; reflexivity
                | left; left; reflexivity
                | left; right; reflexivity ]
             | match goal with
               | id1:(?X1 ?X2 ?X3 (nR ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_nR_10 a b c d
                       (nR q) q
                       (Qhomographic_signok_2 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd H_inside_1
                       H_inside_2)
               | id1:(?X1 ?X2 ?X3 (dL ?X4)) |- ?X5 =>
                   rewrite
                    (Qhomographic_sign_dL_10 a b c d
                       (dL q) q
                       (Qhomographic_signok_3 c d q
                          H_Qhomographic_sg_denom_nonzero)
                       H_Qhomographic_sg_denom_nonzero Hb Hd H_inside_1
                       H_inside_2)
               end; apply sg_sign ] ] ] ]) in
 (destruct qp as [q| q| ];
   [ T_local
   | T_local
   | case (Z_eq_dec (Zsgn (a + b)) 0); intro H_ab;
      [ rewrite
         (sg_One_2 a b c d One H_Qhomographic_sg_denom_nonzero
            (refl_equal One) H_ab)
      | case (Z_eq_dec (Zsgn (a + b)) (Zsgn (c + d))); intro H_ab_cd;
         [ rewrite
            (sg_One_3 a b c d One H_Qhomographic_sg_denom_nonzero
               (refl_equal One) H_ab H_ab_cd)
         | rewrite
            (sg_One_4 a b c d One H_Qhomographic_sg_denom_nonzero
               (refl_equal One) H_ab H_ab_cd) ] ]; first
      [ right; reflexivity
      | left; left; reflexivity
      | left; right; reflexivity ] ]).
Defined.

Definition h_sign (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  let (l1, L2) :=
      Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero in
  l1.

Lemma sg_sign_dec :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 {h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 0%Z} +
 {h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z} +
 {h_sign a b c d p H_Qhomographic_sg_denom_nonzero = (-1)%Z}.
Proof.
 intros.
 unfold h_sign in |- *.
 generalize (sg_sign a b c d p H_Qhomographic_sg_denom_nonzero).
 case (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero).
 intros l1 L2.
 trivial.
Defined.


Set Implicit Arguments.
Require Import OrderedType.
Require Import Classes.RelationClasses.

Section Node.
  Variables Name Tag : Type.
  Inductive Node : Type :=
  | file : Name -> Tag -> Node
  | dir : Name -> list Node -> Node.
End Node.

Module Node_as_OT (N T:OrderedType) <: OrderedType.
  Module MN := OrderedTypeFacts N.
  Module MT := OrderedTypeFacts T.

  Definition t := Node N.t T.t.

  Definition eq (x1 x2 : t) : Prop :=
    match x1, x2 with
    | @dir _ _ n1 _, @dir _ _ n2 _ => N.eq n1 n2
    | @file _ _ n1 s1, @file _ _ n2 s2 => N.eq n1 n2 /\ T.eq s1 s2
    | _, _ => False
    end.

  Definition lt (x1 x2 : t) : Prop :=
    match x1, x2 with
    | @dir _ _ n1 _, @dir _ _ n2 _ => N.lt n1 n2
    | @dir _ _ n1 _, @file _ _ n2 _ => N.lt n1 n2
    | @file _ _ n1 _, @dir _ _ n2 _ => N.lt n1 n2 \/ N.eq n1 n2
    | @file _ _ n1 s1, @file _ _ n2 s2 => (N.lt n1 n2) \/ (N.eq n1 n2 /\ T.lt s1 s2)
    end.

  Lemma eq_refl : Reflexive eq.
  Proof.
    hnf. destruct x; simpl.
    - split; [apply N.eq_refl | apply T.eq_refl].
    - apply N.eq_refl.
  Qed.

  Lemma eq_sym : Symmetric eq.
  Proof.
    hnf. intros. destruct x, y; simpl in *; try contradiction.
    - destruct H. apply N.eq_sym in H. apply T.eq_sym in H0.
      split; assumption.
    - apply N.eq_sym in H. assumption.
  Qed.

  Lemma eq_trans : Transitive eq.
  Proof.
    hnf. intros. destruct x, y, z; simpl in *; try contradiction.
    - destruct H, H0. split; [apply (N.eq_trans H H0) | apply (T.eq_trans H1 H2)].
    - apply (N.eq_trans H H0).
  Qed.

  Ltac simpl_lt_cases :=
    intros; simpl in *;
    repeat match goal with
           | H : _ \/ _ |- _ => destruct H
           | H : _ /\ _ |- _ => destruct H
           end;
    match goal with
    | H : N.lt ?n ?n0, H0: N.lt ?n0 ?n1 |- _ =>
      assert (N.lt n n1); [apply (N.lt_trans H H0) | clear H H0]
    | H : N.eq ?n ?n0, H0: N.lt ?n0 ?n1 |- _ =>
      assert (N.lt n n1); [apply (MN.eq_lt H H0) | clear H H0]
    | H : N.lt ?n ?n0, H0: N.eq ?n0 ?n1 |- _ =>
      assert (N.lt n n1); [apply (MN.lt_eq H H0) | clear H H0]
    | H : N.eq ?n ?n0, H0 : N.eq ?n0 ?n1 |- _ =>
      assert (N.eq n n1); [apply (N.eq_trans H H0) | clear H H0]
    | _ => idtac
    end.

  Lemma lt_trans : forall (x y z : t), lt x y -> lt y z -> lt x z.
  Proof.
    intros. destruct x, y, z; simpl_lt_cases.
    all: try assumption || (left; assumption) ||
             (right; split; [reflexivity | assumption]).
    - assert (T.lt t1 t5); [revert H2 H1; apply T.lt_trans|].
      right. split; assumption.
    - right. assumption.
  Qed.

  Lemma lt_not_eq : forall (x y : t), lt x y -> ~ eq x y.
  Proof.
    intros. unfold not; intro. destruct x, y; simpl in *; try contradiction.
    - destruct H, H0.
      + contradiction (N.lt_not_eq H).
      + destruct H. contradiction (T.lt_not_eq H2).
    - contradiction (N.lt_not_eq H).
  Qed.

  Definition compare : forall (x y : t), Compare lt eq x y.
  Proof.
    intros; destruct x, y;
      [case_eq (N.compare t0 t2) | case_eq (N.compare t0 t2) |
       case_eq (N.compare t0 t1) | case_eq (N.compare t0 t1)]; intros.
    all: match goal with
         | H : N.compare _ _ = LT _ |- _ =>
           apply LT; simpl; try assumption || (left; assumption)
         | H : N.compare _ _ = GT _ |- _ =>
           apply GT; simpl; try assumption || (left; assumption)
         | _ => idtac
         end.
    - destruct (T.compare t1 t3).
      + apply LT. simpl. right. split; assumption.
      + apply EQ. simpl. split; assumption.
      + apply GT. simpl. right. split; [apply (N.eq_sym e) | assumption].
    - apply LT. simpl. right. assumption.
    - apply GT. simpl. right. apply (N.eq_sym e).
    - apply EQ. simpl. assumption.
  Qed.

  Definition eq_dec : forall (x y : t), {eq x y} + {~ eq x y}.
  Proof.
    intros. destruct x, y; simpl; try auto.
    - case_eq (N.eq_dec t0 t2); case_eq (T.eq_dec t1 t3); intros;
        try (left; split; assumption) ||
            (right; unfold not; intro; destruct H1; contradiction).
    - apply N.eq_dec.
  Qed.
End Node_as_OT.


(** Congruence closure *)
Require Import Arith.Peano_dec.
Require Import List.
Require Import Cybele.Cybele.
Require Import Cybele.Map.
Require Import Cybele.DataStructures.
Require Import Definitions.

Set Implicit Arguments.
Set Transparent Obligation.
Import Monad ListNotations.

(** The congruence-closure algorithm *)
Module CongruenceClosure (P: Parameters).
  Definition T: Type := EqProof.t P.Values.

  Definition Sig: Sig.t := Sig.Make nil
    (Index.FMap.t T :: (bool: Type) :: nil).

  Definition Hash := Ref.t Sig (Index.FMap.t T).
  Definition M := M Sig.

  Definition read (hash: Hash) (key: Index.t): M T :=
    let! map := !hash in
    match Index.FMap.find key map with
    | None => error "Hash read: not found"
    | Some v => ret v
    end.

  Definition write (hash: Hash) (key: Index.t) (value: T): M unit :=
    let! map := !hash in
    match Index.FMap.find key map with
    | None => error "Hash write: not found"
    | Some _ => hash :=! Index.FMap.add key value map
    end.

  Definition do (map: Index.FMap.t (M unit)): M (Index.FMap.t unit) :=
    Index.FMap.fold (fun k x map' =>
      let! x := x in
      let! map' := map' in
      ret (Index.FMap.add k x map'))
      map (ret (Index.FMap.empty _)).

  Definition iter (hash: Hash) (f: Index.t -> T -> M unit): M unit :=
    let! map := !hash in
    do! do (Index.FMap.mapi f map) in
    ret tt.

  Definition Find (hash: Hash) (index: Index.t)
    : M {index': Index.t | Values.AreEqual P.Values index index'}.
    refine (
      dependent_fix (fun i => {j: Index.t | Values.AreEqual P.Values i j})
        (fun f i =>
          let! eq_proof := read hash i in
          let (i', j, Hij) := eq_proof in
          match Index.Ordered.eq_dec i i' with
            | left Pii' => _
            | right Pii' => error "Find: i <> i' unexpected"
          end)
        index).
    refine (
      match Index.Ordered.eq_dec i j with
        | left _ => ret (exist _ j _)
        | right _ =>
          let! r := f j in
          let (k, Hjk) := r in
          do! write hash i (EqProof.Make (i := i) (j := k) _) in
          ret (exist _ k _)
      end);
      congruence.
  Defined.

  (** Do the union and return [true] if the values were in different sets *)
  Definition Merge (hash: Hash) (Hij: T): M bool.
    refine (
      let (i, j, Hij) := Hij in
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.Ordered.eq_dec i' j' with
      | left _ => ret false
      | right _ =>
        do! write hash i' (EqProof.Make (i := i') (j := j') _) in
        ret true
      end).
    congruence.
  Defined.

  (** The equality proof of two values if they are equivalent *)
  Definition AreEquiv (hash: Hash) (i j: Index.t)
    : M (option (Values.AreEqual P.Values i j)).
    refine (
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.Ordered.eq_dec i' j' with
      | left Hi'j' => ret (Some _)
      | right _ => ret None
      end).
    congruence.
  Defined.

  Fixpoint areCongruentAux (xs ys: list Index.t)
    (f: forall (x y: Index.t), M (option (Values.AreEqual P.Values x y)))
    {struct xs}
    : M (option (Values.AreEqualList' P.Values xs ys)).
    destruct xs as [| x xs]; destruct ys as [| y ys];
      [exact (ret (Some I)) | exact (ret None) |
      exact (ret None) | ]; simpl.
    refine (
      let! Pxy := f x y in
      let! Pxsys := areCongruentAux xs ys f in
      match (Pxy, Pxsys) with
      | (Some _, Some _) => ret (Some _)
      | _ => ret None
      end); tauto.
  Defined.

  (** The equality proof of two values if they are congruent *)
  Definition AreCongruent (hash: Hash)
    : forall (ij: Index.t * Index.t),
      M (option (Values.AreEqual P.Values (fst ij) (snd ij))).
    refine (dependent_fix
      (fun xy => option (Values.AreEqual P.Values (fst xy) (snd xy)))
      _); intros f xy.
    destruct xy as [x y].
    refine (
      let! OHxy := AreEquiv hash x y in
      match OHxy with
      | Some _ => ret OHxy
      | None => _
      end); clear OHxy.
    destruct x as [i xs]; destruct y as [j ys]; simpl.
    refine (
      match eq_nat_dec i j with
      | left Hij =>
        let! OHxsys := areCongruentAux xs ys (fun x y => f (x, y)) in
        match OHxsys with
        | None => ret None
        | Some Hxsys => ret (Some _)
        end
      | _ => ret None
      end).
    rewrite Hij.
    apply Values.CongruenceRule.
    now apply Values.AreEqualList'ImpliesAreEqualList.
  Defined.

  (** Merge two equal values and merge the new congruent terms *)
  Definition RecurseMerge (hash: Hash) (get_preds: Index.t -> M Index.FSet.t)
    (Pij: T): M bool :=
    fix_ (fun recurse_merge Pij =>
      let! b := Merge hash Pij in
      if b then
        let (i, j, _) := Pij in
        let! ps := get_preds i in
        let! qs := get_preds j in
        do!
          Index.FSet.fold (fun p next =>
            do! next in
            Index.FSet.fold (fun q next =>
              do! next in
              let! P := AreCongruent hash (p, q) in
              match P with
              | Some P =>
                do! recurse_merge (EqProof.Make P) in
                ret tt
              | None => ret tt
              end)
              qs (ret tt))
            ps (ret tt) in
        ret true
      else
        ret false)
      Pij.

  (** Generate the congruent relation given a list of equalities and
      other involved terms *)
  Definition CongruenceClosure (eq_proofs: list T) (other_indexes: list Index.t)
    : M Hash :=
    let preds :=
      Index.Preds (other_indexes ++ flat_map (fun (P: T) =>
        let (i, j, _) := P in
        i :: j :: nil) eq_proofs) in
    let get_preds (i: Index.t): M Index.FSet.t :=
      match Index.FMap.find i preds with
      | Some s => ret s
      | None => error "Invalid index in preds"
      end in
    let! hash := tmp_ref Sig 0 (Index.FMap.mapi (fun i _ =>
      EqProof.Make (i := i) (j := i) eq_refl) preds) in
    do! List.do (List.map (RecurseMerge hash get_preds) eq_proofs) in
    ret hash.

  (** Compute the equality proof of two terms with congruence-closure *)
  Definition ProveEqual (eq_proofs: list T) (i j: Index.t)
    : M (Values.AreEqual P.Values i j).
    refine (
      let! hash := CongruenceClosure eq_proofs (i :: j :: nil) in
      let! Pii' := Find hash i in
      let! Pjj' := Find hash j in
      let (i', Hii') := Pii' in
      let (j', Hjj') := Pjj' in
      match Index.Ordered.eq_dec i' j' with
      | left Hi'j' => ret _
      | right _ => error "Equality proof not found"
      end).
    rewrite Hi'j' in Hii'.
    apply (eq_trans Hii').
    now apply eq_sym.
  Defined.
End CongruenceClosure.