(* 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                                                     *)

(** * doTriplet

Pierre Letouzey & Laurent Thery

One step propagation
*)

From Stalmarck Require Export unionState.
From Stalmarck Require Export stateExtra.

(** We define the Stalmarck One Step Saturation as a relation *)
Inductive doTripletP (S : State) : triplet -> State -> Prop :=
  | doTripletAndPpmq :
      forall p q r : rZ,
      eqStateRz S p (rZComp q) ->
      doTripletP S (Triplet rAnd p q r)
        (addEq (q, rZTrue) (addEq (r, rZFalse) S))
  | doTripletAndPpmr :
      forall p q r : rZ,
      eqStateRz S p (rZComp r) ->
      doTripletP S (Triplet rAnd p q r)
        (addEq (q, rZFalse) (addEq (r, rZTrue) S))
  | doTripletAndPqr :
      forall p q r : rZ,
      eqStateRz S q r -> doTripletP S (Triplet rAnd p q r) (addEq (p, r) S)
  | doTripletAndPqmr :
      forall p q r : rZ,
      eqStateRz S q (rZComp r) ->
      doTripletP S (Triplet rAnd p q r) (addEq (p, rZFalse) S)
  | doTripletAndPpT :
      forall p q r : rZ,
      eqStateRz S p rZTrue ->
      doTripletP S (Triplet rAnd p q r)
        (addEq (q, rZTrue) (addEq (r, rZTrue) S))
  | doTripletAndPqT :
      forall p q r : rZ,
      eqStateRz S q rZTrue ->
      doTripletP S (Triplet rAnd p q r) (addEq (p, r) S)
  | doTripletAndPqF :
      forall p q r : rZ,
      eqStateRz S q rZFalse ->
      doTripletP S (Triplet rAnd p q r) (addEq (p, rZFalse) S)
  | doTripletAndPrT :
      forall p q r : rZ,
      eqStateRz S r rZTrue ->
      doTripletP S (Triplet rAnd p q r) (addEq (p, q) S)
  | doTripletAndPrF :
      forall p q r : rZ,
      eqStateRz S r rZFalse ->
      doTripletP S (Triplet rAnd p q r) (addEq (p, rZFalse) S)
  | doTripletEqPpq :
      forall p q r : rZ,
      eqStateRz S p q ->
      doTripletP S (Triplet rEq p q r) (addEq (r, rZTrue) S)
  | doTripletEqPpmq :
      forall p q r : rZ,
      eqStateRz S p (rZComp q) ->
      doTripletP S (Triplet rEq p q r) (addEq (r, rZFalse) S)
  | doTripletEqPpr :
      forall p q r : rZ,
      eqStateRz S p r ->
      doTripletP S (Triplet rEq p q r) (addEq (q, rZTrue) S)
  | doTripletEqPpmr :
      forall p q r : rZ,
      eqStateRz S p (rZComp r) ->
      doTripletP S (Triplet rEq p q r) (addEq (q, rZFalse) S)
  | doTripletEqPqr :
      forall p q r : rZ,
      eqStateRz S q r ->
      doTripletP S (Triplet rEq p q r) (addEq (p, rZTrue) S)
  | doTripletEqPqmr :
      forall p q r : rZ,
      eqStateRz S q (rZComp r) ->
      doTripletP S (Triplet rEq p q r) (addEq (p, rZFalse) S)
  | doTripletEqPpT :
      forall p q r : rZ,
      eqStateRz S p rZTrue ->
      doTripletP S (Triplet rEq p q r) (addEq (q, r) S)
  | doTripletEqPpF :
      forall p q r : rZ,
      eqStateRz S p rZFalse ->
      doTripletP S (Triplet rEq p q r) (addEq (q, rZComp r) S)
  | doTripletEqPqT :
      forall p q r : rZ,
      eqStateRz S q rZTrue ->
      doTripletP S (Triplet rEq p q r) (addEq (p, r) S)
  | doTripletEqPqF :
      forall p q r : rZ,
      eqStateRz S q rZFalse ->
      doTripletP S (Triplet rEq p q r) (addEq (p, rZComp r) S)
  | doTripletEqPrT :
      forall p q r : rZ,
      eqStateRz S r rZTrue ->
      doTripletP S (Triplet rEq p q r) (addEq (p, q) S)
  | doTripletEqPrF :
      forall p q r : rZ,
      eqStateRz S r rZFalse ->
      doTripletP S (Triplet rEq p q r) (addEq (p, rZComp q) S).

#[export] Hint Resolve doTripletAndPpmq doTripletAndPpmr doTripletAndPqr
  doTripletAndPqmr doTripletAndPpT doTripletAndPqT doTripletAndPqF
  doTripletAndPrT doTripletAndPrF doTripletEqPpq doTripletEqPpmq
  doTripletEqPpr doTripletEqPpmr doTripletEqPqr doTripletEqPqmr
  doTripletEqPpT doTripletEqPpF doTripletEqPqT doTripletEqPqF doTripletEqPrT
  doTripletEqPrF : stalmarck.

Theorem doTripletEqAux1 :
 forall (p q : rZ) (S1 S3 : State) (t : triplet),
 doTripletP S1 t (addEq (p, q) S1) ->
 eqState S1 S3 ->
 doTripletP S3 t (addEq (p, q) S3) ->
 exists S4 : State, doTripletP S3 t S4 /\ eqState S4 (addEq (p, q) S1).
Proof.
intros p q S1 S3 t H' H'0 H'1; exists (addEq (p, q) S3); split; auto with stalmarck.
Qed.

Theorem doTripletEqAux2 :
 forall (p q r s : rZ) (S1 S3 : State) (t : triplet),
 doTripletP S1 t (addEq (p, q) (addEq (r, s) S1)) ->
 eqState S1 S3 ->
 doTripletP S3 t (addEq (p, q) (addEq (r, s) S3)) ->
 ex
   (fun S4 : State =>
    doTripletP S3 t S4 /\ eqState S4 (addEq (p, q) (addEq (r, s) S1))).
Proof.
intros p q r s S1 S3 t H' H'0; exists (addEq (p, q) (addEq (r, s) S3)); split;
 auto with stalmarck.
Qed.

(** proagation is compatible with equality *)
Theorem doTripletEqCompEx :
 forall (S1 S2 S3 : State) (t : triplet),
 doTripletP S1 t S2 ->
 eqState S1 S3 -> exists S4 : State, doTripletP S3 t S4 /\ eqState S4 S2.
Proof.
intros S1 S2 S3 t H' H'1; inversion H';
 apply doTripletEqAux2 || apply doTripletEqAux1; auto with stalmarck;
 generalize (eqStateEq _ _ _ _ H'1 H); auto with stalmarck.
Qed.

Theorem doTripletUnionEx1 :
 forall (p q : rZ) (S1 : State) (t : triplet),
 doTripletP S1 t (addEq (p, q) S1) ->
 exists S3 : State, addEq (p, q) S1 = unionState S3 S1.
Proof.
intros p q S1 t H'; exists ((p, q) :: nil); auto with stalmarck.
Qed.

Theorem doTripletUnionEx2 :
 forall (p q r s : rZ) (S1 : State) (t : triplet),
 doTripletP S1 t (addEq (p, q) (addEq (r, s) S1)) ->
 exists S3 : State, addEq (p, q) (addEq (r, s) S1) = unionState S3 S1.
Proof.
intros p q r s S1 t H'; exists ((p, q) :: (r, s) :: nil); auto with stalmarck.
Qed.

(** Doing  propagation we just add equations *)
Theorem doTripletUnionEx :
 forall (S1 S2 : State) (t : triplet),
 doTripletP S1 t S2 -> exists S3 : State, S2 = unionState S3 S1.
intros S1 S2 t H'; inversion H';
 apply doTripletUnionEx2 with (t := t) ||
   apply doTripletUnionEx1 with (t := t); auto with stalmarck; rewrite H1;
 auto with stalmarck.
Qed.

(** The result is always bigger *)
Theorem doTripletIncl :
 forall (S1 S2 : State) (t : triplet), doTripletP S1 t S2 -> inclState S1 S2.
Proof.
intros S1 S2 t H'.
case (doTripletUnionEx S1 S2 t); auto with stalmarck.
intros x H'0; rewrite H'0; auto with stalmarck.
Qed.

Theorem doTripletUnionAux1 :
 forall (p q : rZ) (S1 S3 : State) (t : triplet),
 doTripletP (unionState S3 S1) t (addEq (p, q) (unionState S3 S1)) ->
 exists S4 : State,
   doTripletP (unionState S3 S1) t S4 /\
   eqState S4 (unionState S3 (addEq (p, q) S1)).
Proof.
intros p q S1 S3 t H'; exists (addEq (p, q) (unionState S3 S1)); split; auto with stalmarck.
apply eqStateTrans with (unionState (unionState ((p, q) :: nil) S3) S1); auto with stalmarck.
apply eqStateTrans with (unionState (unionState S3 ((p, q) :: nil)) S1); auto with stalmarck.
apply eqStateSym; auto with stalmarck.
replace (addEq (p, q) S1) with (unionState ((p, q) :: nil) S1); auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
Qed.

Theorem doTripletUnionAux2 :
 forall (p q r s : rZ) (S1 S3 : State) (t : triplet),
 doTripletP (unionState S3 S1) t
   (addEq (p, q) (addEq (r, s) (unionState S3 S1))) ->
 exists S4 : State,
   doTripletP (unionState S3 S1) t S4 /\
   eqState S4 (unionState S3 (addEq (p, q) (addEq (r, s) S1))).
Proof.
intros p q r s S1 S3 t H';
 exists (addEq (p, q) (addEq (r, s) (unionState S3 S1)));
 split; auto with stalmarck.
apply
 eqStateTrans with (unionState (unionState ((p, q) :: (r, s) :: nil) S3) S1);
 auto with stalmarck.
apply
 eqStateTrans with (unionState (unionState S3 ((p, q) :: (r, s) :: nil)) S1);
 auto with stalmarck.
apply
 eqStateTrans with (unionState S3 (unionState ((p, q) :: (r, s) :: nil) S1));
 auto with stalmarck.
apply eqStateSym; auto with stalmarck.
apply unionStateAssoc.
Qed.

(** Propagation is a congruence *)
Theorem doTripletCongruentEx :
 forall (S1 S2 S3 : State) (t : triplet),
 doTripletP S1 t S2 ->
 exists S4 : State,
   doTripletP (unionState S3 S1) t S4 /\ eqState S4 (unionState S3 S2).
Proof.
intros S1 S2 S3 t H'; inversion H';
 apply doTripletUnionAux2 || apply doTripletUnionAux1;
 auto with stalmarck; generalize (eqStateIncl _ _ _ _ (unionStateInclR S3 S1) H);
 auto with stalmarck.
Qed.

(** It is monotone *)
Theorem doTripletMonotoneEx :
 forall (S1 S2 S3 : State) (t : triplet),
 doTripletP S1 t S3 ->
 inclState S1 S2 -> exists S4 : State, doTripletP S2 t S4 /\ inclState S3 S4.
Proof.
intros S1 S2 S3 t H' H'0.
elim (doTripletCongruentEx S1 S3 S2 t);
 [ intros S4 E; Elimc E; intros H'6 H'7 | idtac ];
 auto with stalmarck.
elim (doTripletEqCompEx (unionState S2 S1) S4 S2 t);
 [ intros S5 E; Elimc E; intros H'9 H'10 | idtac | idtac ];
 auto with stalmarck.
exists S5; split; auto with stalmarck.
apply inclStateTrans with (S2 := unionState S2 S3); auto with stalmarck.
apply inclStateEqStateComp with (S1 := S4) (S3 := S4); auto with stalmarck.
red in |- *; auto with stalmarck.
Qed.

(** It is confluent *)
Theorem doTripletConflEx :
 forall (t1 t2 : triplet) (S1 S2 S3 : State),
 doTripletP S1 t1 S2 ->
 doTripletP S1 t2 S3 ->
 exists S4 : State,
   (exists S5 : State,
      doTripletP S2 t2 S4 /\ doTripletP S3 t1 S5 /\ eqState S4 S5).
Proof.
intros t1 t2 S1 S2 S3 H' H'0.
elim (doTripletUnionEx S1 S2 t1); [ intros S4 E; rewrite E | idtac ]; auto with stalmarck.
elim (doTripletUnionEx S1 S3 t2); [ intros S5 E0; rewrite E0 | idtac ]; auto with stalmarck.
elim (doTripletCongruentEx S1 S2 S5 t1);
 [ intros S6 E1; Elimc E1; intros H'6 H'7 | idtac ];
 auto with stalmarck.
elim (doTripletCongruentEx S1 S3 S4 t2);
 [ intros S7 E1; Elimc E1; intros H'8 H'9 | idtac ];
 auto with stalmarck.
exists S7; exists S6; split; [ idtac | split ]; auto with stalmarck.
apply eqStateTrans with (S2 := unionState S4 S3); auto with stalmarck.
rewrite E0.
apply eqStateTrans with (S2 := unionState S5 S2); auto with stalmarck.
rewrite E.
apply eqStateTrans with (S2 := unionState (unionState S4 S5) S1); auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
apply eqStateTrans with (S2 := unionState (unionState S5 S4) S1); auto with stalmarck.
apply eqStateSym; auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
Qed.

Lemma realizeStateEvalAux1 :
 forall (f : rNat -> bool) (p q r s t u : rZ) (S : State)
   (EqS : eqStateRz S p q),
 (rZEval f p = rZEval f q ->
  rZEval f r = rZEval f s /\ rZEval f t = rZEval f u) ->
 realizeState f S -> realizeState f (addEq (r, s) (addEq (t, u) S)).
Proof.
intros f p q r s t u S H' H'0 H'1.
Elimc H'0; [ intros H'3 H'4 | idtac ].
apply realizeStateAddEq; auto with stalmarck.
apply realizeStateInv with (S := S); auto with stalmarck.
Qed.

Lemma realizeStateEvalAux2 :
 forall (f : rNat -> bool) (p q r s : rZ) (S : State) (EqS : eqStateRz S p q),
 (rZEval f p = rZEval f q -> rZEval f r = rZEval f s) ->
 realizeState f S -> realizeState f (addEq (r, s) S).
Proof.
intros f p q r s S H' H'0 H'1.
lapply H'0; [ intros H'2 | idtac ].
apply realizeStateAddEq; auto with stalmarck.
apply realizeStateInv with (S := S); auto with stalmarck.
Qed.

(** If the triplet is valid, we keep realizability while doing propagation *)
Theorem realizeStateEval :
 forall (f : rNat -> bool) (S1 S2 : State) (t : triplet),
 realizeState f S1 ->
 doTripletP S1 t S2 -> tEval f t = true -> f zero = true -> realizeState f S2.
Proof.
intros f S1 S2 t H' H'0; elim H'0; simpl in |- *; auto with stalmarck;
 intros p q r H'1 H'2 H'3;
 apply realizeStateEvalAux1 with (1 := H'1) ||
   apply realizeStateEvalAux2 with (1 := H'1); auto with stalmarck;
 try rewrite rZEvalCompInv; try rewrite rZEvalCompInv;
 generalize H'2; try repeat rewrite H'3; case (rZEval f p);
 simpl in |- *; case (rZEval f q); simpl in |- *; case (rZEval f r);
 simpl in |- *; auto with stalmarck; try repeat rewrite H'3; auto with stalmarck.
Qed.

Lemma evalRealizeStateAux1 :
 forall (A : Prop) (f : rNat -> bool) (p q r s t u : rZ)
   (S : State) (EqS : eqStateRz S p q),
 (rZEval f p = rZEval f q /\
  rZEval f r = rZEval f s /\ rZEval f t = rZEval f u -> A) ->
 realizeState f (addEq (r, s) (addEq (t, u) S)) -> A.
Proof.
intros A f p q r s t u S H' H'0 H'1.
lapply H'0; [ intros H'2 | split; [ idtac | split ] ]; auto with stalmarck.
apply realizeStateInv with (S := S); auto with stalmarck.
apply realizeStateIncl with (1 := H'1); auto with stalmarck.
apply realizeStateInv with (1 := H'1); auto with stalmarck.
apply realizeStateInv with (1 := H'1); auto with stalmarck.
Qed.

Lemma evalRealizeStateAux2 :
 forall (A : Prop) (f : rNat -> bool) (p q r s : rZ)
   (S : State) (EqS : eqStateRz S p q),
 (rZEval f p = rZEval f q /\ rZEval f r = rZEval f s -> A) ->
 realizeState f (addEq (r, s) S) -> A.
Proof.
intros A f p q r s S H' H'0 H'1.
lapply H'0; [ intros H'2 | split ]; auto with stalmarck.
apply realizeStateInv with (S := S); auto with stalmarck.
apply realizeStateIncl with (1 := H'1); auto with stalmarck.
apply realizeStateInv with (1 := H'1); auto with stalmarck.
Qed.

(** Conversely if the result of a propagation is realizable this means that
   the triplet is valid *)
Theorem evalRealizeState :
 forall (f : rNat -> bool) (S1 S2 : State) (t : triplet),
 doTripletP S1 t S2 -> realizeState f S2 -> f zero = true -> tEval f t = true.
Proof.
intros f S1 S2 t H'; elim H'; intros p q r H'1 H2 H'3;
 apply evalRealizeStateAux1 with (1 := H'1) (3 := H2) ||
   apply evalRealizeStateAux2 with (1 := H'1) (3 := H2);
 try rewrite rZEvalCompInv; try rewrite rZEvalCompInv;
 simpl in |- *; case (rZEval f p); simpl in |- *; case (rZEval f q);
 simpl in |- *; case (rZEval f r); simpl in |- *; auto with stalmarck;
 try repeat rewrite H'3; auto with stalmarck; intuition.
Qed.

(** Prove that the semantic of doTriplet is correct *)
Theorem realizeStateEvalEquiv :
 forall (f : rNat -> bool) (S1 S2 : State) (t : triplet),
 doTripletP S1 t S2 ->
 realizeState f S1 ->
 f zero = true -> (realizeState f S2 <-> tEval f t = true).
Proof.
intros f S1 S2 H' H'0; red in |- *.
split; intros H'1.
apply evalRealizeState with (1 := H'0); auto with stalmarck.
apply realizeStateEval with (2 := H'0); auto with stalmarck.
Qed.

Theorem doTripletBisIncl :
 forall (t : triplet) (S1 S2 : State),
 doTripletP S1 t S2 ->
 forall S3 : State, doTripletP S1 t S3 -> inclState S3 S2.
Proof.
intros t S1 S2 H12 S3 H13.
apply realizeStateInclInv; intros f Pfzero Pf2; unfold realizeState in |- *;
 intros i j Pij; apply realizeStateInv with (S := S3);
 auto with stalmarck.
cut (realizeState f S1); [ intros Pf1 | idtac ].
apply realizeStateEval with (S1 := S1) (t := t); auto with stalmarck.
apply evalRealizeState with (S1 := S1) (S2 := S2); auto with stalmarck.
apply realizeStateIncl with (S1 := S2); auto with stalmarck.
apply doTripletIncl with (t := t); auto with stalmarck.
Qed.

(** It does not matter which rule you apply *)
Theorem doTripletEq :
 forall (S1 S2 S3 : State) (t : triplet),
 doTripletP S1 t S2 -> doTripletP S1 t S3 -> eqState S2 S3.
Proof.
intros S1 S2 S3 t H' H'0.
red in |- *; split; apply doTripletBisIncl with (S1 := S1) (t := t); auto with stalmarck.
Qed.

(** Monotony of the saturation *)
Theorem doTripletEqMonotone :
 forall (S1 S2 S3 S4 : State) (t : triplet),
 doTripletP S1 t S3 ->
 doTripletP S2 t S4 -> inclState S1 S2 -> inclState S3 S4.
Proof.
intros S1 S2 S3 S4 t H' H'0 H'1.
elim (doTripletMonotoneEx S1 S2 S3 t);
 [ intros S5 E; Elimc E; intros H'8 H'9 | idtac | idtac ];
 auto with stalmarck.
apply inclStateEqStateComp with (S1 := S3) (S3 := S5); auto with stalmarck.
apply doTripletEq with (S1 := S2) (t := t); auto with stalmarck.
Qed.

(** It is compatible *)
Theorem doTripletEqComp :
 forall (t : triplet) (S1 S2 S3 S4 : State),
 doTripletP S1 t S3 -> doTripletP S2 t S4 -> eqState S1 S2 -> eqState S3 S4.
Proof.
intros t S1 S2 S3 S4 H' H'0 H'1.
elim (doTripletEqCompEx S1 S3 S2 t);
 [ intros S5 E; Elimc E; intros H'8 H'9 | idtac | idtac ];
 auto with stalmarck.
apply eqStateTrans with (S2 := S5); auto with stalmarck.
apply doTripletEq with (S1 := S2) (t := t); auto with stalmarck.
Qed.

(** It is confluent *)
Theorem doTripletConfl :
 forall (t1 t2 : triplet) (S1 S2 S3 S4 S5 : State),
 doTripletP S1 t1 S2 ->
 doTripletP S2 t2 S4 ->
 doTripletP S1 t2 S3 -> doTripletP S3 t1 S5 -> eqState S4 S5.
Proof.
intros t1 t2 S1 S2 S3 S4 S5 H' H'0 H'1 H'2.
elim (doTripletConflEx t1 t2 S1 S2 S3);
 [ intros S6 E; Elimc E; intros S7 E0; Elimc E0; intros H'10 H'11; Elimc H'11;
    intros H'12 H'13
 | idtac
 | idtac ]; auto with stalmarck.
apply eqStateTrans with (S2 := S6).
apply doTripletEqComp with (t := t2) (S1 := S2) (S2 := S2); auto with stalmarck.
apply eqStateTrans with (S2 := S7); auto with stalmarck.
apply doTripletEqComp with (t := t1) (S1 := S3) (S2 := S3); auto with stalmarck.
Qed.

Theorem doTripletInvolExAux1 :
 forall (tr : triplet) (p q : rZ) (S1 S3 : State),
 inclState (addEq (p, q) S1) S3 ->
 inclState S1 S3 ->
 doTripletP S3 tr (addEq (p, q) S3) ->
 ex (fun S4 : State => doTripletP S3 tr S4 /\ eqState S3 S4).
Proof.
intros tr p q S1 S3 H' H'0 H'1; exists (addEq (p, q) S3); split; auto with stalmarck.
generalize (eqStateIncl (addEq (p, q) S1)); intros Eq1; red in |- *; auto 8 with stalmarck.
Qed.

Theorem doTripletInvolExAux2 :
 forall (tr : triplet) (p q r s : rZ) (S1 S3 : State),
 inclState (addEq (p, q) (addEq (r, s) S1)) S3 ->
 inclState S1 S3 ->
 doTripletP S3 tr (addEq (p, q) (addEq (r, s) S3)) ->
 ex (fun S4 : State => doTripletP S3 tr S4 /\ eqState S3 S4).
Proof.
intros tr p q r s S1 S3 H' H'0 H'1; exists (addEq (p, q) (addEq (r, s) S3));
 split; auto with stalmarck.
generalize (eqStateIncl (addEq (p, q) (addEq (r, s) S1))); intros Eq1;
 red in |- *; auto 8 with stalmarck.
Qed.

(** A triplet is useful only once *)
Theorem doTripletInvolEx :
 forall (t : triplet) (S1 S2 S3 : State),
 doTripletP S1 t S2 ->
 inclState S2 S3 -> exists S4 : State, doTripletP S3 t S4 /\ eqState S3 S4.
Proof.
intros t S1 S2 S3 H' H'0; (generalize (eqStateIncl S1); intros Eq0);
 cut (inclState S1 S3);
 [ idtac
 | apply inclStateTrans with (S2 := S2); auto with stalmarck;
    apply doTripletIncl with (t := t); auto with stalmarck ]; generalize H'0;
 clear H'0; elim H'; intros p q r H'0 H'1 H'2;
 apply doTripletInvolExAux2 with (1 := H'1) ||
   apply doTripletInvolExAux1 with (1 := H'1); auto with stalmarck.
Qed.

Theorem doTripletInvol :
 forall (t : triplet) (S1 S2 S3 S4 : State),
 doTripletP S1 t S2 -> inclState S2 S3 -> doTripletP S3 t S4 -> eqState S3 S4.
Proof.
intros t S1 S2 S3 S4 H' H'0 H'1.
elim (doTripletInvolEx t S1 S2 S3);
 [ intros S5 E; Elimc E; intros H'8 H'9 | idtac | idtac ];
 auto with stalmarck.
apply eqStateTrans with (S2 := S5); auto with stalmarck.
apply doTripletEqComp with (t := t) (S1 := S3) (S2 := S3); auto with stalmarck.
Qed.


Require Import List.
Require Import Compare_dec.

Require Import SimpSyntax.
Require Import Contexts.

Require Import Le Lt.

(* Interpretation relations *)

Inductive SimpParamItrp D (G:D->Type) F : list nat->forall T:forall d,G d->Type,(forall d g,F d->T d g)->Type :=
	spItrpNil : SimpParamItrp D G F nil (fun d _=>F d) (fun _ _ f=>f) |
	spItrpCons a la P (a':AtCtx G a P) B la' :
		SimpParamItrp D G F la (fun d g=>forall p,B d (existT _ g p)) la'->
		SimpParamItrp D G F (a :: la) (fun d g=>B d (existT _ g (ctxProj a' d g))) (fun d g f=>la' d g f (ctxProj a' d g)).

Inductive SimpFamItrp D (G:D->Type) : simpFam->(forall d,G d->Type)->Type :=
	sfItrpNil : SimpFamItrp D G nil (fun _ _=>Type) |
	sfItrpCons f la T F (f':AtTCtx D f F) la' T' :
		SimpParamItrp D G F la (fun _ _=>Type) la'->
		SimpFamItrp D (fun d=>sigT (fun g=>la' d g (tctxProj f' d))) T T'->
		SimpFamItrp D G ((f,la) :: T) (fun d g=>forall p,T' d (existT _ g p)).

Inductive SimpCtxItrp D : list (nat * list nat)->(D->Type)->Type :=
	scItrpNil : SimpCtxItrp D nil (fun _=>unit) |
	scItrpCons f la G G' F (f':AtTCtx D f F) la' :
		SimpCtxItrp D G G'->
		SimpParamItrp D G' F la (fun _ _=>Type) la'->
		SimpCtxItrp D ((f,la) :: G) (fun d=>sigT (fun g=>la' d g (tctxProj f' d))).

Inductive SimpTCtxItrp : list simpFam->Type->Type :=
	stcItrpNil : SimpTCtxItrp nil unit |
	stcItrpCons F D D' F' :
		SimpTCtxItrp D D'->
		SimpFamItrp D' (fun _=>unit) F (fun d _=>F' d)->
		SimpTCtxItrp (F :: D) (sigT F').

Lemma spItrpNilInv D G F T la' (P:forall T:forall d,G d->Type,(forall d g,F d->T d g)->Type) :
SimpParamItrp D G F nil T la'->P (fun d _=>F d) (fun _ _ f=>f)->P T la'.
	intro.
	inversion_clear X.
	intro.
	exact X.
Qed.

Lemma spItrpConsInv D G F a la T la' (C:forall T:forall d,G d->Type,(forall d g,F d->T d g)->Type) :
SimpParamItrp D G F (a :: la) T la'->
	(forall P (a':AtCtx G a P) B la',SimpParamItrp D G F la (fun d g=>forall p,B d (existT _ g p)) la'->
	C (fun d g=>B d (existT _ g (ctxProj a' d g))) (fun d g f=>la' d g f (ctxProj a' d g)))->
C T la'.
	intro.
	inversion_clear X.
	intro.
	apply X with (1 := X0).
Qed.

Lemma sfItrpNilInv D G T : SimpFamItrp D G nil T->(T = fun _ _=>Type).
	assert (forall T_,(nil = T_)->SimpFamItrp D G T_ T->(T = fun _ _=>Type));[| apply H;reflexivity].
	intros.
	destruct X.

	reflexivity.

	destruct nil_cons with (1 := H).
Qed.

Lemma sfItrpConsInv D G f la T T' P : SimpFamItrp D G ((f,la) :: T) T'->
	(forall F (f':AtTCtx D f F) la' T',
		SimpParamItrp D G F la (fun _ _=>Type) la'->
		SimpFamItrp D (fun d=>sigT (fun g=>la' d g (tctxProj f' d))) T T'->
	P (fun d g=>forall p,T' d (existT _ g p)))->
P T'.
	intro.
	inversion_clear X.
	intro.
	apply X with (1 := X0) (2 := X1).
Qed.

Lemma scItrpConsInv D f la G G' P : SimpCtxItrp D ((f,la) :: G) G'->
	(forall G' F (f':AtTCtx D f F) la',SimpCtxItrp D G G'->SimpParamItrp D G' F la (fun _ _=>Type) la'->
	P (fun d=>sigT (fun g=>la' d g (tctxProj f' d))))->
P G'.
	intros.
	inversion_clear X.
	apply X0 with (1 := X1) (2 := X2).
Qed.

Lemma stcItrpConsInv F D D' P : SimpTCtxItrp (F :: D) D'->
	(forall D' F',SimpTCtxItrp D D'->SimpFamItrp D' (fun _=>unit) F (fun d _=>F' d)->
	P (sigT F'))->
P D'.
	intros.
	inversion_clear X.
	apply X0 with (1 := X1) (2 := X2).
Qed.

(*
Lemma spItrpBumpGS D G F n la P : forall T la',SimpParamItrp D G F (laBumpG n O la) T la'->
SimpParamItrp D (fun d=>sigT (P d)) F (laBumpG (S n) O la) (fun d g=>T d (projT1 g)) (fun d g=>la' d (projT1 g)).
	induction la;simpl.

	intros.
	apply spItrpNilInv with (1 := X).
	apply spItrpNil.

	intros ? ?.
	assert (forall k,k = match nat_compare a O with
		Lt => a |
		_ => k
	end) as nolt.
		intro.
		destruct (nat_compare_spec a O);try reflexivity.
		destruct lt_n_O with (1 := H).
	rewrite <- nolt.
	rewrite <- nolt.
	clear nolt.
	intro.
	apply spItrpConsInv with (1 := X).
	clear T la' X.
	intros.
	pose proof (IHla _ _ X).
	apply spItrpCons with (a' := popCtx _ a')
		(B := fun d (g':sigT (fun g=>P0 d (projT1 g)))=>match g' with existT g p=>B d (existT _ (projT1 g) p) end)
		(1 := X0).
Qed.
*)

Definition bumpCtx D GL P l G (xg:ExtCtx D GL l G) := extCtxComp xg (fun d=>sigT (P d)) (fun d=>@projT1 _ _).
Implicit Arguments bumpCtx [D GL l G].

Definition bumpG D GL P l G (xg:ExtCtx D GL l G) := xc_G' (bumpCtx P xg).
Implicit Arguments bumpG [D GL l G].

Definition bumpF D GL P l G (xg:ExtCtx D GL l G) T (F:forall d (g:G d),T d g) d (g:bumpG P xg d) := F d (xc_f' (bumpCtx P xg) d g).
Implicit Arguments bumpF [D GL l G T].

Lemma spItrpBumpGS D G F n l la GL P (xg:ExtCtx D GL l G) : forall T la',SimpParamItrp D G F (laBumpG n l la) T la'->
SimpParamItrp D (bumpG P xg) F (laBumpG (S n) l la) (bumpF P xg T) (bumpF P xg la').
(* Do I need such a general induction pred? *)
	unfold bumpF.
	unfold bumpG.
	set (xc := bumpCtx P xg).
	set (G' := xc_G' xc).
	set (f' := xc_f' xc).
	change (forall d,G' d->G d) in (type of f').
	induction la;simpl.

	intros.
	apply spItrpNilInv with (1 := X).
	apply spItrpNil.

	intros ? ?.
destruct (lt_dec a l) as [Ho | Ho].
Focus 2.
	assert (forall k,k = match nat_compare a l with
		Lt => a |
		_ => k
	end) as nolt.
		intro.
		destruct (nat_compare_spec a l);try reflexivity.
		destruct (Ho H).
	rewrite <- nolt.
	rewrite <- nolt.
	clear nolt.
	intro.
	apply spItrpConsInv with (1 := X).
	clear T la' X.
	intros.
assert (AtCtx G' (S n + a) (fun d g=>P0 d (f' d g))) as a''.
Focus 2.
pose proof (spItrpCons _ _ _ _ _ _ a''
	(fun d (g:sigT (fun g=>P0 d (f' d g)))=>B d (existT _ (f' d (projT1 g)) (projT2 g))) _ (IHla _ _ X)).
simpl in X0.
rewrite in X0.
exact X0.
Qed.

Lemma spItrpBumpGS_O D G F n la T la' P : SimpParamItrp D G F (laBumpG n O la) T la'->
SimpParamItrp D (fun d=>sigT (P d)) F (laBumpG (S n) O la) (fun d g=>T d (projT1 g)) (fun d g=>la' d (projT1 g)).
	apply spItrpBumpGS with (P := P) (xg := extCtxO D G).
Qed.

Lemma sfItrpBumpGS D n F GL P : forall G l F' (xg:ExtCtx D GL l G),SimpFamItrp D G (fBumpG n l F) F'->
SimpFamItrp D (bumpG P xg) (fBumpG (S n) l F) (bumpF P xg F').
	unfold bumpF.
	unfold bumpG.
	induction F as [| p];[| destruct p as (f,la)];simpl;intros until 1.

	rewrite sfItrpNilInv with (1 := X).
	clear n F' X.
	apply sfItrpNil.

	apply sfItrpConsInv with (1 := X).
	clear F' X.
	intros B ? ?.
	pose (A d g := la' d g (tctxProj f' d)).
	change (forall F',SimpParamItrp D G B (laBumpG n l la) (fun _ _=>Type) la'->
		SimpFamItrp D (fun d=>sigT (A d)) (fBumpG n (S l) F) F'->
		SimpFamItrp D (xc_G' (bumpCtx P xg)) ((f,laBumpG (S n) l la) :: fBumpG (S n) (S l) F)
			(fun d g=>forall p,F' d (existT _ (xc_f' (bumpCtx P xg) d g) p))).
	simpl.
	intros ? Xp Xf.
	pose (F_ d g := forall p,F' d (existT _ g p)).
	change (SimpFamItrp D (xc_G' (bumpCtx P xg))
		((f,laBumpG (S n) l la) :: fBumpG (S n) (S l) F)
		(fun d g=>F_ d (xc_f' (bumpCtx P xg) d g))).
	pose proof (IHF _ _ _ (extCtxS xg _) Xf) as Xfb.
	clear Xf.
	pose (GLb d := sigT (P d)).
	pose (u d := @projT1 _ (P d)).
	change (bumpCtx P (extCtxS xg A)) with (extCtxComp (extCtxS xg A) GLb u) in Xfb.
	rewrite extCtxCompSEq in Xfb.
	unfold extCtxSComp' in Xfb.
	pose proof (extCtxSCompRewr (bumpCtx P xg) _
		(fun G' f'=>SimpFamItrp D G' (fBumpG (S n) (S l) F) (fun d g=>F' d (f' d g))) Xfb) as Xfb'.
	simpl in Xfb'.
	clear GLb u Xfb.
	pose (Gb := xc_G' (bumpCtx P xg)).
	pose (u := xc_f' (bumpCtx P xg)).
	change (forall d,Gb d->G d) in (type of u).
	pose (la'b d g := la' d (u d g)).
	pose (F'b d (g:sigT (fun g=>la'b d g (tctxProj f' d))) := F' d (existT (A d) (u d (projT1 g)) (projT2 g))).
	change (SimpFamItrp D (fun d=>sigT (fun g=>la'b d g (tctxProj f' d))) (fBumpG (S n) (S l) F) F'b) in Xfb'.
	apply sfItrpCons with (2 := Xfb').
	clear F'b Xfb'.
	subst la'b.
	apply spItrpBumpGS with (1 := Xp) (xg := xg).
Qed.

Lemma sfItrpBumpGS_O D G n F F' P : SimpFamItrp D G (fBumpG n O F) F'->
SimpFamItrp D (fun d=>sigT (P d)) (fBumpG (S n) O F) (fun d g=>F' d (projT1 g)).
	apply sfItrpBumpGS with (P := P) (xg := extCtxO D G).
Qed.

Lemma spItrpBumpD D G F la T la' B : SimpParamItrp D G F la T la'->
SimpParamItrp (sigT B) (fun d=>G (projT1 d)) (fun d=>F (projT1 d)) la (fun d=>T (projT1 d)) (fun d=>la' (projT1 d)).
	intro.
	induction X.

	apply spItrpNil.

	pose proof (spItrpCons _ _ _ _ _ _ (ctxBumpD _ a') (fun d=>B0 (projT1 d)) _ IHX).
	simpl in X0.
	rewrite ctxProj_BumpD in X0.
	exact X0.
Qed.

Lemma sfItrpBumpDS D n F T : forall G F',SimpFamItrp D G (fBumpD n F) F'->
SimpFamItrp (sigT T) (fun d=>G (projT1 d)) (fBumpD (S n) F) (fun d=>F' (projT1 d)).
	induction F;simpl;intros.

	rewrite sfItrpNilInv with (1 := X).
	apply sfItrpNil.

	destruct a as (f,la).
	apply sfItrpConsInv with (1 := X).
	clear F' X.
	intros B ? ? F'.
	intros.
	pose proof (IHF _ _ X0).
	apply sfItrpCons with (f' := popTCtx T f') (la' := fun d=>la' (projT1 d)) (2 := X1).
	apply spItrpBumpD with (1 := X).
Qed.

Lemma scItrpAt a D C : forall G G',(a < length G)->SimpCtxItrp D G G'->
	(forall f la F (f':AtTCtx D f F) la',((f,la) = pBumpG (S a) O (nth a G (O,nil)))->
		SimpParamItrp D G' F la (fun _ _=>Type) la'->
		AtCtx G' a (fun d g=>la' d g (tctxProj f' d))->
	C)->
C.
	induction a;intros ? ?;
	(destruct G;intro H;[destruct lt_n_O with (1 := H) |]);
	simpl in H;destruct p as (f,la);intro X;
	apply scItrpConsInv with (1 := X);clear G' X;simpl;intros.

	rewrite <- laBumpG_O with (l := O) (la := la) in X0.
	pose proof (spItrpBumpGS_O _ _ _ _ _ _ _ (fun d g=>la' d g (tctxProj f' d)) X0).
	apply X1 with (1 := eq_refl _) (2 := X2) (3 := topCtx _).

	apply IHa with (2 := X).
		apply lt_S_n with (1 := H).
	intros.
	destruct (nth a G (O,nil)) as (f_,la_).
	simpl in X1,H0.
	assert (f0 = f_).
		change (fst (f0,la0) = fst (f_,laBumpG (S a) O la_)).
		rewrite <- H0.
		reflexivity.
	assert (la0 = laBumpG (S a) O la_).
		change (snd (f0,la0) = snd (f_,laBumpG (S a) O la_)).
		rewrite <- H0.
		reflexivity.
	clear H0.
	subst f0 la0.
	pose proof (spItrpBumpGS_O _ _ _ _ _ _ _ (fun d g=>la' d g (tctxProj f' d)) X2).
	apply X1 with (1 := eq_refl _) (2 := X4) (3 := popCtx _ X3).
Qed.

Lemma stcItrpAt f C : forall D D',(f < length D)->SimpTCtxItrp D D'->
	(forall F,AtTCtx D' f F->
		SimpFamItrp D' (fun _=>unit) (fBumpD (S f) (nth f D nil)) (fun d _=>F d)->
	C)->
C.
	induction f;intros ? ?;
	(destruct D as [| F];intro H;[destruct lt_n_O with (1 := H) |]);intro X;
	apply stcItrpConsInv with (1 := X);clear D' X;simpl;intros.

	apply X1 with (1 := topTCtx _).
	apply sfItrpBumpDS with (G := fun _=>unit) (F' := fun d _=>F' d).
	rewrite fBumpD_O.
	exact X0.

	apply IHf with (2 := X).
		apply lt_S_n with (1 := H).
	intros.
	apply X1 with (1 := popTCtx _ X2).
	apply sfItrpBumpDS with (1 := X3).
Qed.

Lemma sfItrpBuildG D G G' T T' : SimpFamItrp D (fun _=>unit) T (fun d _=>T' d)->
	SimpCtxItrp D G G'->(fBumpG 1 O T = T)->
SimpFamItrp D G' T (fun d _=>T' d).
	simpl.
	intros.
	induction X0.

	exact X.

	rewrite <- H.
	rewrite <- fBumpG_O with (l := O) (F := T) in IHX0.
	apply sfItrpBumpGS_O with (1 := IHX0).
Qed.

Lemma sfItrpConsAtInv D G f la T F (f':AtTCtx D f F) la' T' P : SimpFamItrp D G ((f,la) :: T) T'->
	SimpParamItrp D G F la (fun _ _=>Type) la'->
	(forall T',SimpFamItrp D (fun d=>sigT (fun g=>la' d g (tctxProj f' d))) T T'->
	P (fun d g=>forall p,T' d (existT _ g p)))->
P T'.
Admitted.

Lemma spItrpTotal G F la T D G' F' C : SimpParamOK G F la T->
	SimpCtxItrp D G G'->
	SimpFamItrp D (fun _=>unit) F (fun d _=>F' d)->
	(forall T' la',
		SimpParamItrp D G' F' la T' la'->
		SimpFamItrp D G' T T'->
	C)->
C.
	simpl.
intros ? ? ?.
induction H;intro.

eapply X1.
	apply spItrpNil.

	apply sfItrpBuildG with (1 := X0) (2 := X) (3 := e).

apply scItrpAt with (1 := l) (2 := X).
intros ? ? ? f' la0' ? ? a'.
pose (P d g := la0' d g (tctxProj f' d)).
change (AtCtx G' a P) in a'.
apply IHSimpParamOK.
rewrite <- H0.
intros.
revert la' X3.
apply sfItrpConsAtInv with (f' := f') (1 := X4) (2 := X2).
clear T' X4.
intros.
change (forall d,sigT (P d)->Type) in T'.
change (SimpFamItrp D (fun d=>sigT (P d)) B T') in X3.
change (forall d g,F' d->forall p,T' d (existT _ g p)) in la'.
change (SimpParamItrp D G' F' la (fun d g=>forall p,T' d (existT _ g p)) la') in X4.
eapply X1.

apply spItrpCons with (a' := a') (1 := X4).

(* Need substitution lemma *)
Admitted.

Lemma sfItrpTotal D G T D' C : SimpFamOK D G T->SimpTCtxItrp D D'->forall G',SimpCtxItrp D' G G'->
	(forall T',SimpFamItrp D' G' T T'->C)->
C.
	intros ? ?.
	induction H;intros.

	eapply X1.
	apply sfItrpNil.

	apply stcItrpAt with (1 := l) (2 := X);intros ? f' ?.
	apply spItrpTotal with (1 := s) (2 := X0) (3 := X2);intros.
	revert la' X3.
	rewrite sfItrpNilInv with (1 := X4).
	clear T' X4.
	intros.
	eapply IHSimpFamOK.
		apply scItrpCons with (f' := f') (1 := X0) (2 := X3).
	simpl.
	intros.
	eapply X1.
	apply sfItrpCons with (1 := X3) (2 := X4).
Qed.

(* Cannot use ad-hoc predicates. No way to compute B. *)
Inductive SimpParamDom D (G:D->Type) F : list nat->Type :=
	spItrpNil : SimpParamDom D G F nil |
	spItrpCons a la P (a':AtCtx G a P) B la' :
		SimpParamDom D G F la->
		SimpParamDom D G F (a :: la).

Inductive SimpFamDom D (G:D->Type) : simpFam->Type :=
	sfDomNil : SimpFamDom D G nil |
	sfDomCons f la T F (f':AtTCtx D f F) la' :
		SimpParamItrp D G F la (fun _ _=>Type) la'->
		SimpFamDom D (fun d=>sigT (fun g=>la' d g (tctxProj f' d))) T->
		SimpFamDom D G ((f,la) :: T).

Lemma spDomItrp D G F la T la' : SimpParamItrp D G F la T la'->SimpParamDom D G F la.
Qed.
Implicit Arguments spDomItrp [D G F la T la'].

Lemma sfDomItrp D G F F' : SimpFamItrp D G F F'->SimpFamDom D G F.
intro.
induction X.

apply sfDomNil.

apply sfDomCons with (1 := s) (2 := IHX).
Qed.
Implicit Arguments sfDomItrp [D G F F'].

Definition itrpSimpParam D G F la (X:SimpParamDom D G F la) : sigT (fun T=>forall d g,F d->T d g).
Defined.

Lemma spItrpUniq D G F la T la' (X:SimpParamItrp D G F la T la') : existT _ T la' = itrpSimpParam D G F la (spDomItrp X).
Qed.

Definition itrpSimpFam D G F (X:SimpFamDom D G F) : forall d,G d->Type.
induction F as [| p];[| destruct p as (f,la)].

exact (fun _ _=>Type).

intros d g.
Defined.


(* 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) := (Z.sgn a + Z.sgn 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 Z.lt_irrefl with o1;
                          apply Z.lt_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 Z.lt_irrefl with o1;
                          apply Z.lt_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 ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), nR q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Z.sgn a, (a, (b, (c, d)), nR q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Z.sgn 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 (Z.sgn c, (a, (b, (c, d)), nR q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Z.sgn 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 ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), dL q)).
    (* d<>0 *)
    intro Hd'.
    case (Z_lt_dec 0 o2).
     (*  `0 < o2` *)
     intro Ho2.
     exact (Z.sgn a, (a, (b, (c, d)), dL q)).
     (* ~( 0<o2 ) *)
     intro Ho2'.
     case (Z_lt_dec o2 0).
      (* o2 < 0  *)
      intro Ho2.
      exact ((- Z.sgn 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 (Z.sgn c, (a, (b, (c, d)), dL q)).
     (* ~( 0<o1 ) *)
     intro Ho1'.
     case (Z_lt_dec o1 0).
      (* o1 < 0  *)
      intro Ho1.
      exact ((- Z.sgn 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 := Z.sgn (a + b)) in *.
  set (makhraj := Z.sgn (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 (Z.sgn (a0 + b0)) 0);
                  case (Z.eq_dec (Z.sgn (a0 + b0)) (Z.sgn (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 ->
 Z.sgn (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 (Z.sgn (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 ->
 Z.sgn (a + b) <> 0%Z ->
 Z.sgn (a + b) = Z.sgn (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 (Z.sgn (a + b)) 0).
 Falsum.
 intro.
 case (Z.eq_dec (Z.sgn (a + b)) (Z.sgn (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 ->
 Z.sgn (a + b) <> 0%Z ->
 Z.sgn (a + b) <> Z.sgn (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 (Z.sgn (a + b)) 0).
 Falsum.
 case (Z.eq_dec (Z.sgn (a + b)) (Z.sgn (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 =
 ((Z.sgn a * Z.sgn 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 =
 (Z.sgn 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 =
 ((- Z.sgn 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 =
 (Z.sgn 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 =
 ((- Z.sgn 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 =
 ((Z.sgn a * Z.sgn 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 =
 (Z.sgn 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 =
 ((- Z.sgn 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 =
 (Z.sgn 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 =
 ((- Z.sgn 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 sg_sign 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 (Z.sgn (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 (Z.sgn (a + b)) (Z.sgn (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.