(**************************************************************************
* TLC: A library for Coq                                                  *
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Inhabited *)

Global Instance prod_inhab : forall `{Inhab A, Inhab B}, Inhab (A * B).
Proof using. intros. apply (prove_Inhab (arbitrary, arbitrary)). Qed.

(* ********************************************************************** *)
(** * Comparable *)

Definition prod_compare {A B : Type} `{Comparable A} `{Comparable B} (x y : A * B) :=
  let (x1, x2) := x in let (y1, y2) := y in
  decide (x1 = y1 /\ x2 = y2).

Global Instance prod_comparable : forall A B : Type,
  Comparable A -> Comparable B -> Comparable (A * B).
Proof using.
  introv CA CB. applys comparable_beq (@prod_compare A B _ _). intros x y.
  destruct x; destruct y; simpl; rew_refl; iff H; inverts~ H;
   tryfalse; auto; try congruence.
Qed.

(* ********************************************************************** *)
(** * Structure *)

(** Decomposition as projection *)

Lemma tuple2_from_proj : forall A1 A2 (x:A1*A2),
  (fst x, snd x) = x.
Proof using. intros. destruct~ x. Qed.

(** Structural equality *)

Section Properties.
Variables (A1 A2 A3 A4 : Type).
Lemma eq_prod2 : forall (x1 y1:A1) (x2 y2:A2),
  x1 = y1 -> x2 = y2 -> (x1, x2) = (y1, y2).
Proof using. intros. subst~. Qed.

Lemma eq_prod3 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> (x1, x2, x3) = (y1, y2, y3).
Proof using. intros. subst~. Qed.

Lemma eq_prod4 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> (x1, x2, x3, x4) = (y1, y2, y3, y4).
Proof using. intros. subst~. Qed.

End Properties.

Hint Immediate eq_prod2 eq_prod3 eq_prod4.

(* ********************************************************************** *)
(** * Operations *)

(** [fst] and [snd] are defined in the standard library *)

Implicit Arguments fst [[A] [B]].
Implicit Arguments snd [[A] [B]].

(* ---------------------------------------------------------------------- *)
(** ** Notation for projections *)

(** N-ary projections are defined as notations and not as
    definitions, which has appeared to be more flexible with
    respect to type inference.
    TODO: investigate the possibility of using definitions. *)

Notation "'proj11' P" := P (at level 69, only parsing).

Notation "'proj21' P" := (proj1 P) (at level 69, only parsing).
Notation "'proj22' P" := (proj2 P) (at level 69, only parsing).

Notation "'proj31' P" := (proj1 P) (at level 69).
Notation "'proj32' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj33' P" := (proj2 (proj2 P)) (at level 69).

Notation "'proj41' P" := (proj1 P) (at level 69).
Notation "'proj42' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj43' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj44' P" := (proj2 (proj2 (proj2 P))) (at level 69).

Notation "'proj51' P" := (proj1 P) (at level 69).
Notation "'proj52' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj53' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj54' P" := (proj1 (proj2 (proj2 (proj2 P)))) (at level 69).
Notation "'proj55' P" := (proj2 (proj2 (proj2 (proj2 P)))) (at level 69).

(*-----------------------------------------------------*)
(** ** Currying *)

Section Currying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition curry1 f : A1 -> B :=
  f.
Definition curry2 f : A1 -> A2 -> B :=
  fun x1 x2 => f (x1,x2).
Definition curry3 f : A1 -> A2 -> A3 -> B :=
  fun x1 x2 x3 => f (x1,x2,x3).
Definition curry4 f : A1 -> A2 -> A3 -> A4 -> B :=
  fun x1 x2 x3 x4 => f (x1,x2,x3,x4).
Definition curry5 f : A1 -> A2 -> A3 -> A4 -> A5 -> B :=
  fun x1 x2 x3 x4 x5 => f (x1,x2,x3,x4,x5).
End Currying.

(*-----------------------------------------------------*)
(** ** Uncurrying *)

Section Uncurrying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition uncurry1 f : A1 -> B :=
  f.
Definition uncurry2 f : A1*A2 -> B :=
  fun p => match p with (x1,x2) =>
  f x1 x2 end.
Definition uncurry3 f : A1*A2*A3 -> B :=
  fun p => match p with (x1,x2,x3) =>
  f x1 x2 x3 end.
Definition uncurry4 f : A1*A2*A3*A4 -> B :=
  fun p => match p with (x1,x2,x3,x4) =>
  f x1 x2 x3 x4 end.
Definition uncurry5 f : A1*A2*A3*A4*A5 -> B :=
  fun p => match p with (x1,x2,x3,x4,x5) =>
  f x1 x2 x3 x4 x5 end.
End Uncurrying.

(* ---------------------------------------------------------------------- *)
(** ** Uncurrying for relations *)

(** [uncurrypN] turns a function of type [A1 -> A1 -> .. -> AN -> AN -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Uncurryp.
Variables (A1 A2 A3 A4 B : Type).
Definition uncurryp1 f : A1 -> A1 -> B :=
  f.
Definition uncurryp2 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 x2 y2 end.
Definition uncurryp3 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 x2 x3 y1 y2 y3 end.
Definition uncurryp4 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 x2 x3 x4 y1 y2 y3 y4 end.
End Uncurryp.

(** Unfolding *)

Tactic Notation "unfold_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4.

Tactic Notation "unfolds_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4 in *.

(* ---------------------------------------------------------------------- *)
(** ** Inverse projections for relations *)

(* TODO: rename to [unprojpNK] and define also [unprojNK] *)

(** [unprojNK] turns a function of type [AK -> AK -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Unproj.
Variables (A1 A2 A3 A4 B : Type).
Definition unproj21 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 end.
Definition unproj22 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x2 y2 end.
Definition unproj31 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 y1 end.
Definition unproj32 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x2 y2 end.
Definition unproj33 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x3 y3 end.
Definition unproj41 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 y1 end.
Definition unproj42 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x2 y2 end.
Definition unproj43 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x3 y3 end.
Definition unproj44 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x4 y4 end.
End Unproj.

Implicit Arguments unproj21 [ A1 B ].
Implicit Arguments unproj22 [ A2 B ].
Implicit Arguments unproj31 [ A1 B ].
Implicit Arguments unproj32 [ A2 B ].
Implicit Arguments unproj33 [ A3 B ].
Implicit Arguments unproj41 [ A1 B ].
Implicit Arguments unproj42 [ A2 B ].
Implicit Arguments unproj43 [ A3 B ].
Implicit Arguments unproj44 [ A4 B ].

(** Unfolding *)

Tactic Notation "unfold_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44.

Tactic Notation "unfolds_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44 in *.


(* begin hide *)

Require Import
  Coq.Structures.OrderedTypeEx
  Coq.FSets.FSetAVL
  Coq.Arith.Compare_dec.

Require Import Aniceto.Set.
Require Import Aniceto.Map.

Require Import
  Brenner.Semantics TaskMap PhaserMap Vars Syntax.

Require Import Aniceto.Graphs.Graph.
Require Aniceto.Graphs.Bipartite.Bipartite.
Require Aniceto.Graphs.Bipartite.Cycle.

Set Implicit Arguments.

Module C := Graphs.Bipartite.Cycle.
(* end hide *)

(** * Resource dependency state *)

(** We define an event as a pair of phaser ids and a natural (the phase). *)

Module EVT := PairOrderedType PHID Nat_as_OT.

(* begin hide *)
Module Set_EVT := FSetAVL.Make EVT.
Module Set_EVT_Extra := SetUtil Set_EVT.
Module Map_EVT := FMapAVL.Make EVT.
Module Map_EVT_Extra := MapUtil Map_EVT.
Definition set_event := Set_EVT.t.
(* end hide *)
Definition event := EVT.t.

(** Function [get_phaser] obtains the phaser id in the event. *)

Definition get_phaser (e:event) : phid := fst e.

(** Function [get_phase] obtains the phase number of the event. *)

Definition get_phase (e:event) : nat := snd e.

(** Phases from the same phaser are in a precedes relation. *)

Definition prec (e1:event) (e2:event) :=
  get_phaser e1 = get_phaser e2 /\ get_phase e1 < get_phase e2.

(* begin hide *)

Section StateProps.

Variable s:state.

(* end hide *)

(**

Let [s] be a [state].
We say that a task [t] is waiting for an event [e]
when task [t] is executing an instruction [Await] and
the target phaser is defined in the phaser map. *)

Definition WaitOn (t:tid) (e:event) :=
  exists prg,
  Map_TID.MapsTo t (pcons (await (get_phaser e) (get_phase e)) prg) (get_tasks s) /\
  Map_PHID.In (get_phaser e) (get_phasers s).

(** A task [t] is registered in an event [e] if [t] is registered
    in phaser [get_phaser e] and in phase [get_phase r]; task [t] must
    defined in the taskmap. *)

Definition Registered (t:tid) (e:event) :=
  exists ph,
  Map_PHID.MapsTo (get_phaser e) ph (get_phasers s) /\
  Map_TID.MapsTo t (get_phase e) ph /\ Map_TID.In t (get_tasks s).

Lemma registered_def:
  forall ph e t,
  Map_PHID.MapsTo (get_phaser e) ph (get_phasers s) ->
  Map_TID.MapsTo t (get_phase e) ph ->
  Map_TID.In t (get_tasks s) ->
  Registered t e.
Proof.
  intros.
  unfold Registered.
  exists ph.
  intuition.
Qed.

Lemma registered_in_tasks:
  forall t e,
  Registered t e ->
  Map_TID.In t (get_tasks s).
Proof.
  unfold Registered.
  intros.
  destruct H as (?,(?,(?,?))).
  assumption.
Qed.

(** an event [e] impedes a task [t] this task is registered in a
   event [e'] that precedes [e]; the impeding event must be the target of
   a blocked task. *)

Definition ImpededBy(e:event) (t:tid) :=
  (exists t', WaitOn t' e) /\
  (exists e', Registered t e' /\ prec e' e).

Lemma impeded_by_def:
  forall e t t' e',
  WaitOn t' e ->
  Registered t e' ->
  prec e' e ->
  ImpededBy e t.
Proof.
  unfold ImpededBy.
  intros.
  split.
  - exists t'.
    assumption.
  - exists e'.
    intuition.
Qed.

Lemma impeded_by_in_tasks:
  forall t e,
  ImpededBy e t ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  destruct H as (_,(?,(H,_))).
  eauto using registered_in_tasks.
Qed.

End StateProps.

(** We now characterize a deadlocked state.
    Let [AllTasksWaitFor] be a state such that all tasks in the state
    are waiting for an event. *)

Definition AllTasksWaitOn s :=
  forall t, (Map_TID.In t (get_tasks s) -> exists e, WaitOn s t e).

(** Let [AllBlockedRegistered] be a state such that any task waiting for
    an event, that event is also impeding another task in the state. *)

Definition AllImpededBy s :=
  forall t e, WaitOn s t e -> exists t', ImpededBy s e t'.

(** A totally deadlocked state is such that all tasks are waiting for
    events that are impeding a tasks in the task map. *)

Definition TotallyDeadlocked (s:state) :=
  AllTasksWaitOn s /\ AllImpededBy s /\
  exists t, Map_TID.In t (get_tasks s). (* nonempty *)

(* TODO: Now would be a nice time to show that a totally deadlocked state
   does not reduce. For this we need to have a decidable reduction. *)

(** A [Deadlocked] state is such that we can take a partition of the task
    map [tm] and [tm'] such that the state [(get_phasers s, tm)] is
    totally deadlock. *)

Definition Deadlocked (s:state) :=
  exists tm tm',
  Map_TID_Props.Partition (get_tasks s) tm tm' /\
  TotallyDeadlocked ((get_phasers s), tm).

(** A GRG is a bipartite graph that is defined
   from relations [WaitOn] and [ImpededBy]. *)

Notation TEdge s := (Bipartite.AA (WaitOn s) (ImpededBy s)).
Notation REdge s := (Bipartite.BB (WaitOn s) (ImpededBy s)).
Notation TWalk s := (Walk (TEdge s)).
Notation RWalk s := (Walk (REdge s)).
Notation TCycle s := (Cycle (TEdge s)).
Notation RCycle s := (Cycle (REdge s)).
Notation t_edge := (tid * tid) % type.
Notation t_walk := (list t_edge).

(** In WFG an arc from task [t1] to [t2] is read as [t1] waits for [t2].
    In Brenner this means that there exists an event [e] where task
    [t1] is blocked and task [t2] has not arrived at event [e].*)

Lemma tedge_spec:
  forall s (t1 t2:tid),
  TEdge s (t1, t2) <->
  exists e,
  WaitOn s t1 e /\ ImpededBy s e t2.
Proof.
  split.
  + intros.
    simpl in H.
    inversion H.
    subst.
    exists b.
    intuition.
  + intros.
    destruct H as (e, (H1, H2)).
    simpl.
    eauto using Bipartite.aa.
Qed.

(** In an SG an arc from [e1] to [e2] can be read
    as event [e1] happens before event [e2].
    In Brenner, this means that there is a task [t]
    blocked in [e2] and impedes [e1]. Recall the definition
    of [ImpededBy] that states that [t] is registered in
    an event [e'] that precedes [e]; and that event
    [e] is obtained because there exists some task blocked
    in [e] (again by definition). *)

Lemma redge_spec:
  forall s (e1 e2:event),
  REdge s (e1, e2) <->
  exists t,
  ImpededBy s e1 t /\ WaitOn s t e2.
Proof.
  split.
  - intros.
    inversion H.
    subst.
    exists a.
    simpl in *.
    intuition.
  - intros [t (Hi, Hw)].
    simpl.
    eauto using Bipartite.bb.
Qed.

Section Graphs.

Variable s:state.

(** Since the graph is bipartite, then if we have a cycle in the WFG, then
    there exists a cycle in the SG. *)

Theorem wfg_to_sg:
  forall s c,
  TCycle s c ->
  exists c', RCycle s c'.
Proof.
  intros.
  eauto using Cycle.cycle_a_to_b.
Qed.

(** Vice-versa also holds. *)

Theorem sg_to_wfg:
  forall c,
  RCycle s c ->
  exists c', TCycle s c'.
Proof.
  intros.
  eauto using Cycle.cycle_b_to_a.
Qed.

End Graphs.

Section Basic.
  Variable s:state.

(** In our language tasks can only await a single phaser, so
    it is easy to see that the [WaitOn] predicate is actually a function
    from task ids to events. *)

Lemma wait_on_fun:
  forall t e e',
  WaitOn s t e ->
  WaitOn s t e' ->
  e = e'.
Proof.
  intros.
  unfold WaitOn in *.
  destruct H as (p1, (H1, H2)).
  destruct H0 as (p2, (H3, H4)).
  (* MapsTo is functional, so p1 = p2 *)
  assert (Heq:= @Map_TID_Facts.MapsTo_fun _ _ _ _ _
          H1 H3).
  inversion Heq.
  destruct e as (p,n).
  destruct e' as (p', n').
  simpl in *.
  auto.
Qed.

(** We show that any task id in the [WaitOn] is in the task map of [s]. *)

Lemma wait_on_in_tasks:
  forall t e,
  WaitOn s t e ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  unfold WaitOn in H.
  destruct H as (p, (H1, H2)).
  apply Map_TID_Extra.mapsto_to_in in H1.
  assumption.
Qed.

Lemma impeded_by_in_phasermap:
  forall e t,
  ImpededBy s e t ->
  Map_PHID.In (elt:=Phaser.phaser) (get_phaser e) (get_phasers s).
Proof.
  intros.
  destruct H as ((t',H),_).
  unfold WaitOn in H.
  destruct H as (_, (_, H)).
  assumption.
Qed.

End Basic.


Load "Example11".

(********************if b then x1 else y1 = if b then x2 else y2 -> if b then t[x1] else t'[y1] = if b then t[x2] else t'[y2]************************)

Theorem Ex12bol_bol: forall (n1 n2 n3 n4 n5 n6 : nat)(b b1 b2:Bool),   (if_then_else_B b (Bvar n1) (Bvar n2)) ## (if_then_else_B b (Bvar n3) (Bvar n4)) ->  (if_then_else_B b [n5:= (Bvar n1)]b1 [n6:= (Bvar n2)]b2)  ##  (if_then_else_B b [n5:= (Bvar n3)]b1  [n6:= (Bvar n4)] b2).
Proof.
intros.
assert (H1:   (if_then_else_B b [n5:= if_then_else_B b (Bvar n1) (Bvar n2)] b1 [n6 := if_then_else_B b (Bvar n1) (Bvar n2)] b2) ## (if_then_else_B b [n5:= (Bvar n1)]b1 [n6:= (Bvar n2)]b2)).
apply Ex9bol_bol1 with  (b1:=b1)(b2:=b2).
rewrite <- H1.
rewrite H.
apply Ex9bol_bol1 with (b1:= b1)(b2:=b2).
Qed.

Theorem Ex12bol_msg: forall (n1 n2 n3 n4 n5 n6 : nat)(b :Bool) (m1 m2 : message),   (if_then_else_B b (Bvar n1) (Bvar n2)) ## (if_then_else_B b (Bvar n3) (Bvar n4)) ->  (if_then_else_M b ((n5:= (Bvar n1))m1) ((n6:= (Bvar n2)) m2))  #  (if_then_else_M b ((n5:= (Bvar n3))m1)  ((n6:= (Bvar n4)) m2)).
Proof.
intros.
pose proof Ex9bol_msg1.
assert (H1:   (if_then_else_M b ((n5:= if_then_else_B b (Bvar n1) (Bvar n2)) m1) ((n6 := if_then_else_B b (Bvar n1) (Bvar n2)) m2)) # (if_then_else_M b ((n5:= (Bvar n1))m1) ((n6:= (Bvar n2))m2))).
apply Ex9bol_msg1 with  (m1:=m1)(m2:=m2).
rewrite <- H1.
rewrite H.
apply Ex9bol_msg1.
Qed.

Theorem Ex12msg_msg: forall (n1 n2 n3 n4 n5 n6 : nat)(b:Bool)(m1 m2: message),  (if_then_else_M b (Mvar n1) (Mvar n2)) # (if_then_else_M b (Mvar n3) (Mvar n4)) ->  ( if_then_else_M b (submsg_msg n5 (Mvar n1) m1)  (submsg_msg n6 (Mvar n2) m2))  # (if_then_else_M b (submsg_msg n5 (Mvar n3) m1)  (submsg_msg n6 (Mvar n4) m2)).
Proof.
intros.
assert (H1:  (if_then_else_M b (submsg_msg n5  (if_then_else_M b (Mvar n1) (Mvar n2)) m1) (submsg_msg n6 (if_then_else_M b (Mvar n1) (Mvar n2)) m2)) # ( if_then_else_M b (submsg_msg n5  (Mvar n1)  m1) (submsg_msg n6 (Mvar n2) m2))).
apply Ex9msg_msg1 .
rewrite <-H1.
rewrite H.
apply Ex9msg_msg1.
Qed.

Theorem Ex12msg_bol: forall (n1 n2 n3 n4 n5 n6 : nat)(b:Bool)(b1 b2: Bool),  (if_then_else_M b (Mvar n1) (Mvar n2)) # (if_then_else_M b (Mvar n3) (Mvar n4)) ->  ( if_then_else_B b  ([[ n5 := (Mvar n1)]] b1)  ( [[ n6 := (Mvar n2)]] b2)) ## (if_then_else_B b ([[ n5 := (Mvar n3)]] b1)  ([[ n6 := (Mvar n4)]] b2)).
Proof.
intros.
assert (H1:  (if_then_else_B b ( [[ n5 := (if_then_else_M b (Mvar n1) (Mvar n2) )]] b1) ([[ n6 := (if_then_else_M b (Mvar n1) (Mvar n2))]] b2)) ## ( if_then_else_B b ( [[ n5 :=  (Mvar n1)]]  b1) ( [[ n6 :=  (Mvar n2)]] b2))).
apply Ex9msg_bol1 .
rewrite <-H1.
rewrite H.
apply Ex9msg_bol1.
Qed.


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

From Coq Require Import FunInd.
From QArithSternBrocot Require Import Field_Theory_Q.
From QArithSternBrocot Require Export Qhomographic_Qpositive_to_Q_properties.

Definition spec_fraction_encoding (a b : Z) : Q := Qmult a (Qinv b).

Definition spec_positive_fraction_encoding (a b : Z)
  (Ha : (0 < a)%Z) (Hb : (0 < b)%Z) :=
  Qpositive_mult (Z_to_Qpositive a Ha) (Qpositive_inv (Z_to_Qpositive b Hb)).

Definition spec_positive_fraction_encoding1 (a b : Z) :=
  Q_tail (Qmult a (Qinv b)).

Definition spec_positive_fraction_encoding2 (a b : Z) :=
  Qpositive_mult (Q_tail a) (Qpositive_inv (Q_tail b)).

Lemma spec_coding :
 forall m n : nat,
 Qpositive_c (S m) (S n) (S m + S n) =
 spec_positive_fraction_encoding1 (m + 1) (n + 1).
Proof.
 unfold spec_positive_fraction_encoding1 in |- *.
 unfold Qmult in |- *.
 intros m n.
 transitivity
  (Qpositive_mult (Qpositive_c (S m) 1 (S (S m)))
     (Qpositive_inv (Qpositive_c (S n) 1 (S (S n))))).
 (* 1.1 *)
 unfold Qpositive_mult in |- *.
 rewrite Qpositive_i_c; [ idtac | apply Nat.lt_0_succ | apply le_n ].

 set (P := Qpositive_i (Qpositive_c (S n) 1 (S (S n)))) in *.
 set (p := fst P) in *.
 set (q := snd P) in *.
 transitivity (Qpositive_c (S m * 1) (1 * S n) (S m * 1 + 1 * S n)).
  (* 1.1.1 *)
  repeat rewrite Nat.mul_1_l; repeat rewrite Nat.mul_1_r; reflexivity.
  (* 1.1.2 *)
  assert (P = (S n, 1)).
  unfold P in |- *.
  apply Qpositive_i_c; try apply Nat.lt_0_succ.
  apply le_n.
  replace (Qpositive_i (Qpositive_inv (Qpositive_c (S n) 1 (S (S n))))) with
   (q, p).
  replace q with 1.
  replace p with (S n).
  reflexivity.
  change (S n = fst P) in |- *.
  rewrite H.
  reflexivity.
  change (1 = snd P) in |- *.
  rewrite H.
  reflexivity.
  symmetry  in |- *.
  apply inv_correct.
  transitivity P.
  reflexivity.
  unfold p, q in |- *.
  apply pair_1.
 (* 1.2 *)
 replace (m + 1)%Z with (Z.succ m); [ idtac | reflexivity ].
 rewrite <- Znat.inj_S.
 replace (n + 1)%Z with (Z.succ n); [ idtac | reflexivity ].
 rewrite <- Znat.inj_S.
 simpl in |- *.
 repeat rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
 reflexivity.
Defined.

Lemma spec_positive_fraction_encoding1_positive_fraction_encoding :
 forall (m n : Z) (Hm : (0 < m)%Z) (Hn : (0 < n)%Z),
 spec_positive_fraction_encoding m n Hm Hn =
 spec_positive_fraction_encoding1 m n.
Proof.
 intros;
  unfold spec_positive_fraction_encoding, spec_positive_fraction_encoding1
   in |- *; elim (inject_nat_S_inf m Hm); elim (inject_nat_S_inf n Hn);
  intros nn Hnn mm Hmm; generalize Hn Hm; rewrite Hnn;
  rewrite Hmm; intros; unfold Qmult in |- *; simpl in |- *;
  repeat rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
  reflexivity.
Defined.

Lemma spec_positive_fraction_encoding1_positive_fraction_encoding2 :
 forall (m n : Z) (Hm : (0 < m)%Z) (Hn : (0 < n)%Z),
 spec_positive_fraction_encoding m n Hm Hn =
 spec_positive_fraction_encoding2 m n.
Proof.
 intros m n Hm Hn;
  unfold spec_positive_fraction_encoding2, spec_positive_fraction_encoding
   in |- *; apply f_equal2 with Qpositive Qpositive;
  try apply f_equal with Qpositive; destruct m as [| pm| pm];
  try discriminate Hm; destruct n as [| pn| pn]; try discriminate Hn;
  reflexivity.
Defined.

Lemma coding :
 forall (m n : Z) (Hm : (0 < m)%Z) (Hn : (0 < n)%Z),
 positive_fraction_encoding m n Hm Hn =
 spec_positive_fraction_encoding m n Hm Hn.
Proof.
 intros m n Hm Hn.
 transitivity
  (Qpositive_c (S (pred_nat m Hm)) (S (pred_nat n Hn))
     (S (pred_nat m Hm) + S (pred_nat n Hn))).
 (* T1 *)
 unfold positive_fraction_encoding in |- *.
 generalize (Zminus2_wf m n Hm Hn); intro f.
 generalize Hm Hn; clear Hm Hn.
 pattern m, n, f in |- *.
 elim f using fractionalAcc_ind_dep; clear m n f; intros.
 (* 1 *)
 rewrite (encoding_algorithm_0 m n Hm Hn (fractionalacc0 m n e) e).
 generalize Hm Hn.
 rewrite e.
 intros.
 symmetry  in |- *.
 apply Qpositive_c_equal_One.
 apply f_equal with nat.
 apply pred_nat_equal.
 (* 2 *)
 generalize (Zlt_minus n m l0).
 intro Hmn.
 rewrite
  (encoding_algorithm_1 m n Hm Hn (fractionalacc1 m n l l0 f) l0 l Hmn f)
  .
 rewrite plus_Sn_m.
 rewrite Qpositive_c_dL.
 apply f_equal with Qpositive.
 rewrite minus_pred_nat with n m Hn Hm Hmn.
 rewrite
  Qpositive_c_equal with (p' := S (pred_nat m Hm) + S (pred_nat (n - m) Hmn));
  try auto with arith.
 rewrite (encoding_algorithm_equal m (n - m) l Hm Hmn Hmn f f).
 apply H.
 repeat rewrite absolu_pred_nat.
 replace (pred_nat m Hm) with (Z.abs_nat (m - 1)).
 repeat rewrite <- absolu_plus; try abstract lia.
 rewrite pred_nat_absolu; reflexivity.
 repeat rewrite absolu_pred_nat.
 apply lt_absolu; try abstract lia.
 (* 3 *)
 generalize (Zlt_minus m n l0).
 intro Hmn.
 rewrite
  (encoding_algorithm_2 m n Hm Hn (fractionalacc2 m n l l0 f) l0 Hmn l f)
  .
 rewrite plus_Sn_m.
 rewrite Qpositive_c_nR.
 apply f_equal with Qpositive.
 rewrite minus_pred_nat with m n Hm Hn Hmn.
 rewrite
  Qpositive_c_equal with (p' := S (pred_nat (m - n) Hmn) + S (pred_nat n Hn));
  try auto with arith.
 rewrite (encoding_algorithm_equal (m - n) n Hmn Hmn l Hn f f).
 apply H.
 repeat rewrite absolu_pred_nat.
 replace (pred_nat m Hm) with (Z.abs_nat (m - 1)).
 repeat rewrite <- absolu_plus; try abstract lia.
 rewrite pred_nat_absolu; reflexivity.
 repeat rewrite absolu_pred_nat.
 apply lt_absolu; try abstract lia.
 (* T2 *)
 rewrite spec_positive_fraction_encoding1_positive_fraction_encoding.
 transitivity
  (spec_positive_fraction_encoding1 (S (pred_nat m Hm)) (S (pred_nat n Hn))).
 (* T2.1 *)
 repeat rewrite Znat.inj_S.
 unfold Z.succ in |- *.
 apply spec_coding.
 (* T2.2 *)
 repeat rewrite <- pred_nat_unfolded.
 reflexivity.
Defined.

Functional Scheme Qmult_ind := Induction for Qmult Sort Prop.

Lemma coding_Q :
 forall (m n : Z) (Hdenom : n <> 0%Z),
 fraction_encoding m n Hdenom = spec_fraction_encoding m n.
Proof.
 intros m n Hdenom; unfold spec_fraction_encoding in |- *.
(*  unfold fraction_encoding in |- *. *)
 functional induction (fraction_encoding m n Hdenom).
 (* 1 *)
 (* Here I should explicitly write the coercions, and still even after that the generated predicate is independent of m and n *)
 (* Functional Induction Qmult (Z_to_Q m) (Qinv (Z_to_Q n)). *)
 (* So I should add the following equalities *)
 set (x := Qinv n) in *.
 set (y := Z_to_Q m) in *.
 assert (x = Qinv n); trivial.
 assert (y = m); trivial.
 generalize H H0.
 clear  H H0 e .
 functional induction (Qmult y x); intros.
 (* Qneg 0: 1 *)
 apply False_ind.
 apply (Zorder.Zlt_not_eq _ _ a0).
 rewrite <- Zsgn_15.
 apply Zsgn_6.
 rewrite Z_eq_mult; try reflexivity.
 apply eq_Z_to_Q.
 symmetry  in |- *; assumption.
 (* Qneg 0 : 2 *)
 apply False_ind.
 apply Hdenom.
 apply eq_Z_to_Q.
 apply Qinv_0.
 symmetry  in |- *; assumption.
 (* Qneg Qpos : 1 *)
 apply False_ind.
 apply (Zlt_asym _ _ a0).
 rewrite <- Zsgn_15.
 apply Zsgn_26.
 assert (Hm : (0 < m)%Z);
  [ idtac | assert (Hn' : (0 < n)%Z); [ idtac | abstract auto with zarith ] ].
 apply Qpos_POS_1 with x'.
 symmetry  in |- *; assumption.
 apply pos_Z_to_Q.
 apply Qinv_1.
 rewrite <- H.
 abstract auto with *.
 (* Qneg Qneg : 1 *)
 apply f_equal with Qpositive.
 rewrite coding.
 unfold spec_positive_fraction_encoding in |- *.
 apply f_equal2 with Qpositive Qpositive.
 assert (Hm : (0 < m)%Z);
  [ apply Qpos_POS_1 with x'; symmetry  in |- *; assumption | idtac ].
 rewrite <- (Z_to_Qpositive_equal m (Z.abs m) Hm).
 apply Qpos_injective.
 rewrite <- Z_to_Qpositive_to_Q.
 symmetry  in |- *; assumption.
 symmetry  in |- *; apply Z.abs_eq; apply Zlt_le_weak; assumption.
 apply Qneg_injective.
 rewrite H.
 change (Qinv (Qneg (Z_to_Qpositive (Z.abs n) (Zabs_11 n Hdenom))) = Qinv n)
  in |- *.
 apply f_equal with Q.
 assert (Hn' : (n < 0)%Z);
  [ apply neg_Z_to_Q; apply Qinv_2; rewrite <- H; apply Qlt_neg_zero
  | idtac ].
 destruct n as [| pn| pn]; try discriminate Hn'.
 unfold Z_to_Q in |- *.
 apply f_equal with Qpositive.
 reflexivity.
 (* Qneg 0 : 3 *)
 apply False_ind.
 apply Hdenom.
 apply eq_Z_to_Q.
 apply Qinv_0.
 symmetry  in |- *; assumption.
 (* Qneg Qneg : 2 *)
 apply f_equal with Qpositive.
 rewrite coding.
 unfold spec_positive_fraction_encoding in |- *.
 apply f_equal2 with Qpositive Qpositive.
 apply Qneg_injective.
 assert (Hm : (m < 0)%Z);
  [ apply neg_Z_to_Q; rewrite <- H0; apply Qlt_neg_zero | idtac ].
 destruct m as [| pm| pm]; try discriminate Hm.
 rewrite H0.
 unfold Z_to_Q in |- *.
 apply f_equal with Qpositive.
 reflexivity.

 apply Qpos_injective.
 rewrite H.
 change (Qinv (Qpos (Z_to_Qpositive (Z.abs n) (Zabs_11 n Hdenom))) = Qinv n)
  in |- *.
 apply f_equal with Q.
 rewrite <- Z_to_Qpositive_to_Q.
 rewrite Z.abs_eq; try reflexivity.
 apply Zlt_le_weak.
 apply pos_Z_to_Q.
 apply Qinv_1.
 rewrite <- H.
 apply Qlt_zero_pos.
 (* Qneg Qpos : 2 *)
 apply False_ind.
 apply (Zlt_asym _ _ a0).
 rewrite <- Zsgn_15.
 apply Zsgn_26.
 assert (Hm : (m < 0)%Z);
  [ idtac | assert (Hn' : (n < 0)%Z); [ idtac | abstract auto with zarith ] ].
 apply Qneg_NEG_1 with x'.
 symmetry  in |- *; assumption.
 apply neg_Z_to_Q.
 apply Qinv_2.
 rewrite <- H.
 apply Qlt_neg_zero.

 (* 2 *)
 set (x := Qinv n) in *.
 set (y := Z_to_Q m) in *.
 assert (x = Qinv n); trivial.
 assert (y = m); trivial.
 generalize H H0.
 clear e H H0.
 functional induction (Qmult y x); intros.
 (* Qpos 0: 1 *)
 apply False_ind.
 generalize (Z.gt_lt _ _ b); clear b; intro z.
 apply (Zorder.Zlt_not_eq _ _ z).
 symmetry  in |- *.
 rewrite <- Zsgn_15.
 apply Zsgn_6.
 rewrite Z_eq_mult; try reflexivity.
 apply eq_Z_to_Q.
 symmetry  in |- *; assumption.
 (* Qpos 0 : 2 *) (* C *)
 apply False_ind.
 apply Hdenom.
 apply eq_Z_to_Q.
 apply Qinv_0.
 symmetry  in |- *; assumption.
 (* Qpos Qpos : 1 *)
 apply f_equal with Qpositive.
 rewrite coding.
 unfold spec_positive_fraction_encoding in |- *.
 apply f_equal2 with Qpositive Qpositive.
 assert (Hm : (0 < m)%Z);
  [ apply Qpos_POS_1 with x'; symmetry  in |- *; assumption | idtac ].
 rewrite <- (Z_to_Qpositive_equal m (Z.abs m) Hm).
 apply Qpos_injective.
 rewrite <- Z_to_Qpositive_to_Q.
 symmetry  in |- *; assumption.
 symmetry  in |- *; apply Z.abs_eq; apply Zlt_le_weak; assumption.
 apply Qpos_injective.
 rewrite H.
 change (Qinv (Qpos (Z_to_Qpositive (Z.abs n) (Zabs_11 n Hdenom))) = Qinv n)
  in |- *.
 apply f_equal with Q.
 rewrite <- Z_to_Qpositive_to_Q.
 rewrite Z.abs_eq; try reflexivity.
 apply Zlt_le_weak.
 apply pos_Z_to_Q.
 apply Qinv_1.
 rewrite <- H.
 apply Qlt_zero_pos.
 (* Qpos Qneg : 1 *)
 apply False_ind.
 generalize (Z.gt_lt _ _ b); clear b; intro z.
 apply (Zlt_asym _ _ z).
 rewrite <- Zsgn_15.
 apply Zsgn_27.
 assert (Hm : (0 < m)%Z);
  [ idtac
  | assert (Hn' : (n < 0)%Z); [ idtac | try abstract auto with zarith ] ].
 apply Qpos_POS_1 with x'.
 symmetry  in |- *; assumption.
 apply neg_Z_to_Q.
 apply Qinv_2.
 rewrite <- H.
 abstract auto with *.
 (* Qpos 0 : 3 *)  (* C *)
 apply False_ind.
 apply Hdenom.
 apply eq_Z_to_Q.
 apply Qinv_0.
 symmetry  in |- *; assumption.
 (* Qpos Qneg : 2 *)
 apply False_ind.
 generalize (Z.gt_lt _ _ b); clear b; intro z.
 apply (Zlt_asym _ _ z).
 rewrite <- Zsgn_15.
 apply Zsgn_27.
 assert (Hm : (m < 0)%Z);
  [ idtac | assert (Hn' : (0 < n)%Z); [ idtac | abstract auto with zarith ] ].
 apply Qneg_NEG_1 with x'.
 symmetry  in |- *; assumption.
 apply pos_Z_to_Q.
 apply Qinv_1.
 rewrite <- H.
 apply Qlt_zero_pos.
 (* Qpos Qpos : 2 *)
 apply f_equal with Qpositive.
 rewrite coding.
 unfold spec_positive_fraction_encoding in |- *.
 apply f_equal2 with Qpositive Qpositive.
 apply Qneg_injective.
 assert (Hm : (m < 0)%Z);
  [ apply neg_Z_to_Q; rewrite <- H0; apply Qlt_neg_zero | idtac ].
 destruct m as [| pm| pm]; try discriminate Hm.
 rewrite H0.
 unfold Z_to_Q in |- *.
 apply f_equal with Qpositive.
 reflexivity.

 apply Qneg_injective.
 rewrite H.
 change (Qinv (Qneg (Z_to_Qpositive (Z.abs n) (Zabs_11 n Hdenom))) = Qinv n)
  in |- *.
 apply f_equal with Q.
 assert (Hn' : (n < 0)%Z);
  [ apply neg_Z_to_Q; apply Qinv_2; rewrite <- H; apply Qlt_neg_zero
  | idtac ].
 destruct n as [| pn| pn]; try discriminate Hn'.
 unfold Z_to_Q in |- *.
 apply f_equal with Qpositive.
 reflexivity.
 (* 3 *)
 replace m with 0%Z.
 reflexivity.
 symmetry  in |- *; apply Zmult_integral_l with n;
  [ idtac | apply Zsgn_2; rewrite Zsgn_15 ]; assumption.
Defined.

Definition spec_h (a b c d : Z) (q : Q) : Q :=
  Qmult (Qplus (Qmult a q) b) (Qinv (Qplus (Qmult c q) d)).

Definition spec_Qhomographic_Qpositive_to_Q (a b c d : Z)
  (p : Qpositive) : Q :=
  Qmult (Qplus (Qmult a (Qpos p)) b) (Qinv (Qplus (Qmult c (Qpos p)) d)).

Definition spec_ni (a b c d : Z) (p : Qpositive) : Qpositive :=
  Q_tail
    (Qmult (Qplus (Qmult a (Qpos p)) b) (Qinv (Qplus (Qmult c (Qpos p)) d))).

(* Here we should expect that a*p+b > 0 and c*p+d > 0, this follow from homographicAcc *)
Definition spec_ni2 (a b c d : Z) (p : Qpositive) : Qpositive :=
  Qpositive_mult (Q_tail (Qplus (Qmult a (Qpos p)) b))
    (Qpositive_inv (Q_tail (Qplus (Qmult c (Qpos p)) d))).

Lemma spec_Qhomographic_Qpositive_to_Q_nR :
 forall (a b c d : Z) (q : Qpositive),
 spec_Qhomographic_Qpositive_to_Q a b c d (nR q) =
 spec_Qhomographic_Qpositive_to_Q a (a + b) c (c + d) q.
Proof.
 intros.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 do 2 rewrite Qmult_Z_nR.
 repeat rewrite <- Qplus_assoc.
 repeat rewrite <- Z_to_Qplus.
 reflexivity.
Defined.

Lemma spec_Qhomographic_Qpositive_to_Q_dL :
 forall (a b c d : Z) (q : Qpositive),
 spec_Qhomographic_Qpositive_to_Q a b c d (dL q) =
 spec_Qhomographic_Qpositive_to_Q (a + b) b (c + d) d q.
Proof.
 intros.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 do 2 rewrite Qmult_Z_plus_Z_dL.
 set (p := Qpos q) in *.
 set (A := Z_to_Q (a + b)) in *.
 set (C := Z_to_Q (c + d)) in *.
 rewrite <- Qdiv_num_denom.
 reflexivity.
 (* Here Abstract Discriminate doesn't work , even if we unfold p *)
 discriminate.
Defined.

Lemma spec_Qhomographic_Qpositive_to_Q_nR_unfolded :
 forall (a b c d : Z) (q : Qpositive),
 Qmult (Qplus (Qmult a (Qpos (nR q))) b)
   (Qinv (Qplus (Qmult c (Qpos (nR q))) d)) =
 Qmult (Qplus (Qmult a (Qpos q)) (a + b)%Z)
   (Qinv (Qplus (Qmult c (Qpos q)) (c + d)%Z)).
Proof spec_Qhomographic_Qpositive_to_Q_nR.

Lemma spec_Qhomographic_Qpositive_to_Q_dL_unfolded :
 forall (a b c d : Z) (q : Qpositive),
 Qmult (Qplus (Qmult a (Qpos (dL q))) b)
   (Qinv (Qplus (Qmult c (Qpos (dL q))) d)) =
 Qmult (Qplus (Qmult (a + b)%Z (Qpos q)) b)
   (Qinv (Qplus (Qmult (c + d)%Z (Qpos q)) d)).
Proof spec_Qhomographic_Qpositive_to_Q_dL.

Lemma spec_ni2_nR :
 forall (a b c d : Z) (q : Qpositive),
 spec_ni2 a b c d (nR q) = spec_ni2 a (a + b) c (c + d) q.
Proof.
 intros.
 unfold spec_ni2 in |- *.
 do 2 rewrite Qmult_Z_nR.
 repeat rewrite <- Qplus_assoc.
 repeat rewrite <- Z_to_Qplus.
 reflexivity.
Defined.

Lemma spec_ni2_dL :
 forall (a b c d : Z) (q : Qpositive),
 Qplus (Qmult (a + b)%Z (Qpos q)) b <> Zero ->
 Qplus (Qmult (c + d)%Z (Qpos q)) d <> Zero ->
 spec_ni2 a b c d (dL q) = spec_ni2 (a + b) b (c + d) d q.
Proof.
 intros a b c d p Hnum Hdenom.
 unfold spec_ni2 in |- *.
 do 2 rewrite Qmult_Z_plus_Z_dL.
 repeat rewrite <- Q_tail_Qinv.
 repeat rewrite <- Q_tail_Qmult; try assumption.
 apply f_equal with Q.
 rewrite <- Qdiv_num_denom; [ reflexivity | discriminate ].
 apply Qinv_resp_nonzero; assumption.
 apply Qmult_resp_nonzero; [ assumption | discriminate ].
 apply Qinv_resp_nonzero; apply Qmult_resp_nonzero;
  [ assumption | discriminate ].
Defined.

Lemma spec_ni2_nR_emission :
 forall (a b c d : Z) (q : Qpositive),
 Qlt Zero (Qplus (Qmult a (Qpos q)) b) ->
 Qlt Zero (Qplus (Qmult c (Qpos q)) d) ->
 Qlt Zero (Qplus (Qmult (a - c)%Z (Qpos q)) (b - d)%Z) ->
 nR (spec_ni2 (a - c) (b - d) c d q) = spec_ni2 a b c d q.
Proof.
 intros a b c d q Hab Hcd Habcd;
  generalize (Qlt_not_eq _ _ Hab) (Qlt_not_eq _ _ Hcd) (Qlt_not_eq _ _ Habcd);
  intros Hab' Hcd' Habcd'.
 rewrite what_nR_does.
 unfold spec_ni2 in |- *.
 rewrite <- Q_tail_Qinv.
 repeat rewrite <- Q_tail_Qmult;
  match goal with
  |  |- (Qinv _ <> _) => apply Qinv_resp_nonzero
  |  |- _ => idtac
  end; try assumption.
 replace One with (Q_tail Qone); trivial.
 rewrite <- Q_tail_Qplus_pos.
 apply f_equal with Q.
 repeat rewrite Z_to_Qminus.
 abstract (field; assumption).
 apply Qlt_mult_pos_pos; try apply Qinv_pos; assumption.
 apply Qlt_zero_one.
Defined.

Lemma spec_ni2_dL_emission :
 forall (a b c d : Z) (q : Qpositive),
 Qlt Zero (Qplus (Qmult a (Qpos q)) b) ->
 Qlt Zero (Qplus (Qmult c (Qpos q)) d) ->
 Qlt Zero (Qplus (Qmult (c - a)%Z (Qpos q)) (d - b)%Z) ->
 dL (spec_ni2 a b (c - a) (d - b) q) = spec_ni2 a b c d q.
Proof.
 intros a b c d q Hab Hcd Habcd;
  generalize (Qlt_not_eq _ _ Hab) (Qlt_not_eq _ _ Hcd) (Qlt_not_eq _ _ Habcd);
  intros Hab' Hcd' Habcd'.
 rewrite what_dL_does.
 unfold spec_ni2 in |- *.
 repeat rewrite <- Q_tail_Qinv.
 repeat rewrite <- Q_tail_Qmult;
  match goal with
  |  |- (Qinv _ <> _) => apply Qinv_resp_nonzero
  |  |- _ => idtac
  end; try assumption.
 replace One with (Q_tail Qone); trivial.
 rewrite <- Q_tail_Qplus_pos.
 rewrite <- Q_tail_Qinv.
 repeat rewrite <- Q_tail_Qmult;
  repeat
   match goal with
   |  |- (Qinv _ <> _) => apply Qinv_resp_nonzero
   |  |- (Qmult _ _ <> _) => apply Qmult_resp_nonzero
   end; try assumption.
 apply f_equal with Q.
 repeat rewrite Z_to_Qminus.
Opaque Qmult Qplus Qinv Qone.
 field.
 repeat
  match goal with
  |  |- (Qinv _ <> _) => apply Qinv_resp_nonzero
  |  |- (Qmult _ _ <> _) => apply Qmult_resp_nonzero
  |  |- (Qplus _ _ <> _) => do 2 rewrite Z_to_Qminus in Habcd'; assumption
  end; try assumption.
 split.
  apply Qlt_not_eq; trivial.
  do 2 rewrite Z_to_Qminus in Habcd'; assumption.
apply Qlt_not_eq; apply Qlt_plus_pos_pos.
apply Qlt_mult_pos_pos; try assumption.
apply Qinv_pos; assumption.
apply Qlt_zero_one.
apply Qlt_mult_pos_pos; try apply Qinv_pos; assumption.
apply Qlt_zero_one.
Defined.

Lemma homographic_sign :
 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 =
 Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d p).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 unfold h_sign in |- *.
 functional induction
  (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero).
 (* (nR1) : b=0 & d=0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 simpl in |- *.
 transitivity
  (Qsgn (Qmult (Qmult a (Qpos (nR q))) (Qinv (Qmult c (Qpos (nR q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 repeat rewrite Qsgn_29.
 abstract ring.
 apply f_equal with Q.
 field.
 split.
  discriminate.
  intro;
  generalize
   (Qhomographic_sg_denom_nonzero_nonzero_3 c 0 (nR q)
      H_Qhomographic_sg_denom_nonzero); intros [H_| H_];
  apply H_; clear H_; [ apply eq_Z_to_Q; assumption | reflexivity].
 (* (nR2) : b=0 & d<>0 & 0<o2  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
  clear e2 e0 e1; simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qmult a (Qpos (nR q))) (Qinv (Qplus (Qmult c (Qpos (nR q))) d)))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 simpl in |- *.
 generalize (Zsgn_21 _ _ a1) (Zsgn_23 _ _ a1) (Zsgn_19 _ _ a1);
  intros Hc_nonneg Hd_nonneg Hcd_pos.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with 1%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_7.
 generalize (Zlt_cotrans_pos _ _ Hcd_pos); intros [Hc| Hd];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q; [ field | reflexivity ].

 (* (nR3) : b=0 & d<>0 & ~0<o2 & o2<0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2;
  simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qmult a (Qpos (nR q))) (Qinv (Qplus (Qmult c (Qpos (nR q))) d)))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 simpl in |- *.
 generalize (Zsgn_22 _ _ a1) (Zsgn_24 _ _ a1) (Zsgn_20 _ _ a1);
  intros Hc_nonpos Hd_nonpos Hcd_neg.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with (-1)%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_8.
 generalize (Zlt_cotrans_neg _ _ Hcd_neg); intros [Hc| Hd];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q; [ field | reflexivity ].
 (* (nR4) : b=0 & d<>0 & ~0<o2 & ~o2<0  *)
 clear e3 e0 e1 e2;
  rewrite spec_Qhomographic_Qpositive_to_Q_nR; rewrite IHp0;
  reflexivity.
 (* (nR5) : b<>0 & d=0 & 0<o1  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e2 e0 e1.
 simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qplus (Qmult a (Qpos (nR q))) b) (Qinv (Qmult c (Qpos (nR q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 generalize (Zsgn_21 _ _ a1) (Zsgn_23 _ _ a1) (Zsgn_19 _ _ a1);
  intros Ha_nonneg Hb_nonneg Hab_pos.
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with 1%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_7.
 generalize (Zlt_cotrans_pos _ _ Hab_pos); intros [Ha_| Hb_];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q;
  [ reflexivity | apply f_equal with Q; abstract ring ].

 (* (nR6) : b<>0 & d=0 & ~0<o1 & o1<0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2;
  simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qplus (Qmult a (Qpos (nR q))) b) (Qinv (Qmult c (Qpos (nR q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 generalize (Zsgn_22 _ _ a1) (Zsgn_24 _ _ a1) (Zsgn_20 _ _ a1);
  intros Ha_nonpos Hb_nonpos Hab_neg.
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with (-1)%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_8.
 generalize (Zlt_cotrans_neg _ _ Hab_neg); intros [Ha_| Hb_];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q;
  [ reflexivity | apply f_equal with Q; abstract ring ].
 (* (nR7) : b<>0 & d=0 & ~0<o1 & ~o1<0  *)
 clear e3 e0 e1 e2 ;
  rewrite spec_Qhomographic_Qpositive_to_Q_nR; rewrite IHp0;
  reflexivity.
 (* (nR8) : b<>0 & d<>0 & (i1 o1 o2) *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e2 e0 e1  .
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 case (inside_interval_1_inf _ _ a0); clear a0;
  intros (Hab, Hcd);
  repeat
   match goal with
   | id1:(0 < outside_interval _ _)%Z |- _ =>
       generalize (Zsgn_21 _ _ id1) (Zsgn_23 _ _ id1) (Zsgn_19 _ _ id1);
        clear id1
   | id1:(outside_interval _ _ < 0)%Z |- _ =>
       generalize (Zsgn_22 _ _ id1) (Zsgn_24 _ _ id1) (Zsgn_20 _ _ id1);
        clear id1
   end; intros Ha_ Hb_ Hab_ Hc_ Hd_ Hcd_.
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with 1%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with 1%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with (-1)%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with (-1)%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 (* (nR9) : b<>0 & d<>0 & ~(i1 o1 o2) & (i2 o1 o2)*)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2 b2.
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 case (inside_interval_2_inf _ _ a0); clear a0;
  intros (Hab, Hcd);
  repeat
   match goal with
   | id1:(0 < outside_interval _ _)%Z |- _ =>
       generalize (Zsgn_21 _ _ id1) (Zsgn_23 _ _ id1) (Zsgn_19 _ _ id1);
        clear id1
   | id1:(outside_interval _ _ < 0)%Z |- _ =>
       generalize (Zsgn_22 _ _ id1) (Zsgn_24 _ _ id1) (Zsgn_20 _ _ id1);
        clear id1
   end.
 intros Hc_ Hd_ Hcd_ Ha_ Hb_ Hab_.
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with 1%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with (-1)%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 intros Ha_ Hb_ Hab_ Hc_ Hd_ Hcd_.
 replace (Qsgn (Qplus (Qmult a (Qpos (nR q))) b)) with (-1)%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (nR q))) d)) with 1%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 (* (nR10) : b<>0 & d<>0 & ~(i1 o1 o2) & ~(i2 o1 o2)*)
 clear e3 e0 e1 e2;
  rewrite spec_Qhomographic_Qpositive_to_Q_nR; rewrite IHp0;
  reflexivity.
 (* Now we just copy-paste the above 10 cases and change nR to dL, the only different cases are recursive calls in which we use
    spec_Qhomographic_Qpositive_to_Q_dL instead of spec_Qhomographic_Qpositive_to_Q_nR  (cases nR4,nR7,nR10 above) *)
 (* (dL1) : b=0 & d=0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *; clear e1 e0.
 simpl in |- *.
 transitivity
  (Qsgn (Qmult (Qmult a (Qpos (dL q))) (Qinv (Qmult c (Qpos (dL q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 repeat rewrite Qsgn_29.
 abstract ring.
 apply f_equal with Q.
 field.
 split.
  discriminate.
  intro;
  generalize
   (Qhomographic_sg_denom_nonzero_nonzero_3 c 0 (dL q)
      H_Qhomographic_sg_denom_nonzero); intros [H_| H_];
  apply H_; clear H_; [ apply eq_Z_to_Q; assumption | reflexivity].
 (* (dL2) : b=0 & d<>0 & 0<o2  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
  clear e2 e0 e1; simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qmult a (Qpos (dL q))) (Qinv (Qplus (Qmult c (Qpos (dL q))) d)))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 simpl in |- *.
 generalize (Zsgn_21 _ _ a1) (Zsgn_23 _ _ a1) (Zsgn_19 _ _ a1);
  intros Hc_nonneg Hd_nonneg Hcd_pos.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with 1%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_7.
 generalize (Zlt_cotrans_pos _ _ Hcd_pos); intros [Hc| Hd];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q; [ field | reflexivity ].

 (* (dL3) : b=0 & d<>0 & ~0<o2 & o2<0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2;
  simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qmult a (Qpos (dL q))) (Qinv (Qplus (Qmult c (Qpos (dL q))) d)))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 simpl in |- *.
 generalize (Zsgn_22 _ _ a1) (Zsgn_24 _ _ a1) (Zsgn_20 _ _ a1);
  intros Hc_nonpos Hd_nonpos Hcd_neg.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with (-1)%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_8.
 generalize (Zlt_cotrans_neg _ _ Hcd_neg); intros [Hc| Hd];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q; [ field | reflexivity ].
 (* (dL4) : b=0 & d<>0 & ~0<o2 & ~o2<0  *)
 clear e3 e0 e1 e2;
  rewrite spec_Qhomographic_Qpositive_to_Q_dL; rewrite IHp0;
  reflexivity.
 (* (dL5) : b<>0 & d=0 & 0<o1  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e2 e0 e1 .
 simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qplus (Qmult a (Qpos (dL q))) b) (Qinv (Qmult c (Qpos (dL q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 generalize (Zsgn_21 _ _ a1) (Zsgn_23 _ _ a1) (Zsgn_19 _ _ a1);
  intros Ha_nonneg Hb_nonneg Hab_pos.
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with 1%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_7.
 generalize (Zlt_cotrans_pos _ _ Hab_pos); intros [Ha_| Hb_];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q;
  [ reflexivity | apply f_equal with Q; abstract ring ].

 (* (dL6) : b<>0 & d=0 & ~0<o1 & o1<0  *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2;
  simpl in |- *.
 transitivity
  (Qsgn
     (Qmult (Qplus (Qmult a (Qpos (dL q))) b) (Qinv (Qmult c (Qpos (dL q)))))).
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 rewrite Qsgn_15.
 simpl in |- *.
 generalize (Zsgn_22 _ _ a1) (Zsgn_24 _ _ a1) (Zsgn_20 _ _ a1);
  intros Ha_nonpos Hb_nonpos Hab_neg.
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with (-1)%Z.
 rewrite Qsgn_29.
 abstract auto with zarith.
 symmetry  in |- *.
 apply Qsgn_8.
 generalize (Zlt_cotrans_neg _ _ Hab_neg); intros [Ha_| Hb_];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].

 apply f_equal with Q.
 apply f_equal2 with Q Q;
  [ reflexivity | apply f_equal with Q; abstract ring ].
 (* (dL7) : b<>0 & d=0 & ~0<o1 & ~o1<0  *)
 clear e3 e0 e1 e2 ;
  rewrite spec_Qhomographic_Qpositive_to_Q_dL; rewrite IHp0;
  reflexivity.
 (* (dL8) : b<>0 & d<>0 & (i1 o1 o2) *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e2 e0 e1  .
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 case (inside_interval_1_inf _ _ a0); clear a0;
  intros (Hab, Hcd);
  repeat
   match goal with
   | id1:(0 < outside_interval _ _)%Z |- _ =>
       generalize (Zsgn_21 _ _ id1) (Zsgn_23 _ _ id1) (Zsgn_19 _ _ id1);
        clear id1
   | id1:(outside_interval _ _ < 0)%Z |- _ =>
       generalize (Zsgn_22 _ _ id1) (Zsgn_24 _ _ id1) (Zsgn_20 _ _ id1);
        clear id1
   end; intros Ha_ Hb_ Hab_ Hc_ Hd_ Hcd_.
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with 1%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with 1%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with (-1)%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with (-1)%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 (* (dL9) : b<>0 & d<>0 & ~(i1 o1 o2) & (i2 o1 o2)*)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  clear e3 e0 e1 e2 b2.
 repeat rewrite Qsgn_15.
 rewrite Qsgn_28.
 case (inside_interval_2_inf _ _ a0); clear a0;
  intros (Hab, Hcd);
  repeat
   match goal with
   | id1:(0 < outside_interval _ _)%Z |- _ =>
       generalize (Zsgn_21 _ _ id1) (Zsgn_23 _ _ id1) (Zsgn_19 _ _ id1);
        clear id1
   | id1:(outside_interval _ _ < 0)%Z |- _ =>
       generalize (Zsgn_22 _ _ id1) (Zsgn_24 _ _ id1) (Zsgn_20 _ _ id1);
        clear id1
   end.
 intros Hc_ Hd_ Hcd_ Ha_ Hb_ Hab_.
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with 1%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with (-1)%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 intros Ha_ Hb_ Hab_ Hc_ Hd_ Hcd_.
 replace (Qsgn (Qplus (Qmult a (Qpos (dL q))) b)) with (-1)%Z.
 replace (Qsgn (Qplus (Qmult c (Qpos (dL q))) d)) with 1%Z.
 abstract auto with zarith.
 symmetry  in |- *; apply Qsgn_7; generalize (Zlt_cotrans_pos _ _ Hcd_);
  intros [Hc_1| Hd_1];
  [ apply Qlt_le_reg_pos;
     [ apply Qsgn_9; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonneg; assumption ]
  | apply Qle_lt_reg_pos;
     [ apply Qle_mult_nonneg_nonneg;
        [ apply Z_to_Q_nonneg; assumption | auto with * ]
     | apply Z_to_Q_pos; assumption ] ].
 symmetry  in |- *; apply Qsgn_8; generalize (Zlt_cotrans_neg _ _ Hab_);
  intros [Ha_1| Hb_1];
  [ apply Qlt_le_reg_neg;
     [ apply Qsgn_10; rewrite Qsgn_15; simpl in |- *; rewrite Qsgn_29;
        rewrite Zmult_1_r; abstract auto with zarith
     | apply Z_to_Q_nonpos; assumption ]
  | apply Qle_lt_reg_neg;
     [ apply Qle_mult_nonpos_pos;
        [ apply Z_to_Q_nonpos; assumption | auto with * ]
     | apply Z_to_Q_neg; assumption ] ].
 (* (dL10) : b<>0 & d<>0 & ~(i1 o1 o2) & ~(i2 o1 o2)*)
 clear e3 e0 e1 e2;
  rewrite spec_Qhomographic_Qpositive_to_Q_dL; rewrite IHp0;
  reflexivity.
(**********************************************************)
 (* (One1) : (Z.sgn (a+b)) = 0 *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *; clear e0.
 rewrite Qsgn_15.
 replace (Qsgn (Qplus (Qmult a (Qpos One)) b)) with 0%Z.
 abstract auto with zarith.
 rewrite Qmult_sym.
 rewrite Qmult_one_left.
 rewrite <- Z_to_Qplus.
 symmetry  in |- *.
 rewrite Qsgn_29.
 assumption.
 (* (One2) : (Z.sgn (a+b))<>0 & (Z.sgn (a+b))=(Z.sgn (c+d)) *)
 Transparent Qone.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *; clear e1 e0 ;
  rewrite Qsgn_15; repeat rewrite Qmult_one_right;
  rewrite Qsgn_28; repeat rewrite <- Z_to_Qplus; repeat rewrite Qsgn_29;
     rewrite <- a0; rewrite <- Zsgn_15; symmetry  in |- *;
  apply Zsgn_7'; abstract auto with zarith.
 (* (One2) : (Z.sgn (a+b))<>0 & (Z.sgn (a+b))<>(Z.sgn (c+d)) *)
 unfold spec_Qhomographic_Qpositive_to_Q in |- *; clear e1 e0;
     abstract (rewrite Qsgn_15; repeat rewrite Qmult_one_right; rewrite Qsgn_28;
       repeat rewrite <- Z_to_Qplus; repeat rewrite Qsgn_29;
         generalize
           (Zsgn_3 _
             (Qhomographic_signok_1 _ _ _x));
           intro Hcd_; generalize (Zsgn_1' (a + b)) (Zsgn_1' (c + d));
             intros [[Hab| Hab]| Hab] [[Hcd| Hcd]| Hcd];
               try solve [ Falsum ]; rewrite Hab in b1;
		 rewrite Hcd in b1; try solve [ Falsum ];
		   rewrite Hab; rewrite Hcd; constructor).
Defined.

Lemma homographicAcc_positive :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 Qlt Zero (Qplus (Qmult (Z_to_Q a) (Qpos p)) (Z_to_Q b)) /\
 Qlt Zero (Qplus (Qmult (Z_to_Q c) (Qpos p)) (Z_to_Q d)).
Proof.
 intros.
 induction H;
  try
   match goal with
   | id1:(_ /\ _) |- _ => elim id1; clear id1; intros IH_xind1 IH_ind2
   end.
 (* 1 *)
 split; rewrite H; rewrite Qmult_one_right; rewrite <- Z_to_Qplus;
  apply Z_to_Q_pos; assumption.
 (* 2 *)
 split; try assumption; replace a with (a - c + c)%Z;
  try abstract auto with zarith; replace b with (b - d + d)%Z;
  try abstract auto with zarith; repeat rewrite Z_to_Qplus;
  replace (Qplus (Qmult (Qplus (a - c)%Z c) (Qpos p)) (Qplus (b - d)%Z d))
   with
   (Qplus (Qplus (Qmult (a - c)%Z (Qpos p)) (b - d)%Z)
      (Qplus (Qmult c (Qpos p)) d)); try abstract ring;
  apply Qlt_plus_pos_pos; assumption.
 (* 3 *)
 split; try assumption; replace c with (c - a + a)%Z;
  try abstract auto with zarith; replace d with (d - b + b)%Z;
  try abstract auto with zarith; repeat rewrite Z_to_Qplus;
  replace (Qplus (Qmult (Qplus (c - a)%Z a) (Qpos p)) (Qplus (d - b)%Z b))
   with
   (Qplus (Qplus (Qmult (c - a)%Z (Qpos p)) (d - b)%Z)
      (Qplus (Qmult a (Qpos p)) b)); try abstract ring;
  apply Qlt_plus_pos_pos; assumption.
 (* 4 *)
 split; rewrite Qmult_Z_nR; rewrite <- Qplus_assoc; rewrite <- Z_to_Qplus;
  assumption.
 (* 5 *)
 split; rewrite Qmult_Z_plus_Z_dL; apply Qlt_mult_pos_pos; try assumption;
  apply Qinv_pos; abstract auto with *.
Defined.

Lemma homographicAcc_positive_numerator :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 Qlt Zero (Qplus (Qmult (Z_to_Q a) (Qpos p)) (Z_to_Q b)).
Proof.
 intros; elim (homographicAcc_positive _ _ _ _ _ H); trivial.
Defined.

Lemma homographicAcc_positive_denominator :
 forall (a b c d : Z) (p : Qpositive),
 homographicAcc a b c d p ->
 Qlt Zero (Qplus (Qmult (Z_to_Q c) (Qpos p)) (Z_to_Q d)).
Proof.
 intros; elim (homographicAcc_positive _ _ _ _ _ H); trivial.
Defined.

Lemma output_bit :
 forall (a b c d : Z) (p : Qpositive) (hyp_Acc : homographicAcc a b c d p),
 Qhomographic_Qpositive_to_Qpositive a b c d p hyp_Acc = spec_ni2 a b c d p.
Proof.
 intros a b c d p hyp_Acc.
 generalize (homographicAcc_positive_numerator _ _ _ _ _ hyp_Acc).
 generalize (homographicAcc_positive_denominator _ _ _ _ _ hyp_Acc).
 pattern a, b, c, d, p, hyp_Acc in |- *.
 elim hyp_Acc using homographicAcc_ind_dep; clear a b c d p hyp_Acc; intros;
  simpl in |- *.
 (* (One1) p= One *)
 unfold spec_ni2 in |- *; case (Qpositive_dec_One p); intros Hp;
  [ idtac | Falsum ]; rewrite coding;
  unfold spec_positive_fraction_encoding in |- *; replace (Qpos p) with Qone;
  [ idtac | rewrite e; trivial ]; repeat rewrite Qmult_one_right;
  repeat rewrite <- Z_to_Qplus; repeat rewrite Z_to_Qpositive_Q_tail_pos;
  reflexivity.
 (* (2) ~p=One & (top_more a b c d) *)
 case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ];
  case (top_more_informative a b c d); intros Habcd;
  [ idtac | Falsum ];
  generalize (homographicAcc_positive_numerator _ _ _ _ _ h);
  intros H_acpbd; rewrite H; trivial; apply spec_ni2_nR_emission;
  assumption.
 (* (3) ~p=One & ~(top_more a b c d)&(top_more c d a b) *)
 case (Qpositive_dec_One p); intros Hp; [ Falsum | idtac ];
  case (top_more_informative a b c d); intros Habcd;
  [ Falsum | idtac ]; case (top_more_informative c d a b);
  intros Hcdab; [ idtac | Falsum ];
  generalize (homographicAcc_positive_denominator _ _ _ _ _ h);
  intros H_acpbd; rewrite H; trivial; apply spec_ni2_dL_emission;
  assumption.
 (* (nR4) p=(nR xs) & ~(top_more a b c d)&~(top_more c d a b) *)
 case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ];
  case (top_more_informative c d a b); intros Hcdab;
  [ Falsum | idtac ];
  generalize (homographicAcc_positive_numerator _ _ _ _ _ h);
  generalize (homographicAcc_positive_denominator _ _ _ _ _ h);
  intros H_acpbd H_acpbd'; rewrite H; trivial; rewrite spec_ni2_nR;
  reflexivity.
 (* (dL5) p=(dL xs) & ~(top_more a b c d)&~(top_more c d a b) *)
 case (top_more_informative a b c d); intros Habcd; [ Falsum | idtac ];
  case (top_more_informative c d a b); intros Hcdab;
  [ Falsum | idtac ];
  generalize (homographicAcc_positive_numerator _ _ _ _ _ h);
  generalize (homographicAcc_positive_denominator _ _ _ _ _ h);
  intros H_acpbd H_acpbd'; rewrite H; trivial.
 rewrite spec_ni2_dL; reflexivity || apply Qlt_not_eq; assumption.
Defined.

Lemma spec_Qhomographic_Qpositive_to_Q_spec_ni2_pos :
 forall (a b c d : Z) (q : Qpositive),
 Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d q) = 1%Z ->
 spec_Qhomographic_Qpositive_to_Q a b c d q = Qpos (spec_ni2 a b c d q).
Proof.
 intros a b c d p H.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 unfold spec_ni2 in |- *.
 rewrite <- Q_tail_Qinv.
 rewrite <- Q_tail_Qmult.
 rewrite <- Q_tail_Q_pos.
 reflexivity.
 apply Qsgn_9.
 assumption.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 discriminate H.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 rewrite Qmult_sym in H.
 discriminate H.
Defined.

(* This lemma is useless, to be removed later *)
Lemma spec_Qhomographic_Qpositive_to_Q_spec_ni2_neg :
 forall (a b c d : Z) (q : Qpositive),
 Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d q) = (-1)%Z ->
 spec_Qhomographic_Qpositive_to_Q a b c d q = Qneg (spec_ni2 a b c d q).
Proof.
 intros a b c d p H.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 unfold spec_ni2 in |- *.
 rewrite <- Q_tail_Qinv.
 rewrite <- Q_tail_Qmult.
 rewrite <- Q_tail_Q_neg.
 reflexivity.
 apply Qsgn_10.
 assumption.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 discriminate H.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 rewrite Qmult_sym in H.
 discriminate H.
Defined.

(** We use this when (Z.sgn a+b)<0 *)
Lemma spec_Qhomographic_Qpositive_to_Q_spec_ni2_neg_1 :
 forall (a b c d : Z) (q : Qpositive),
 Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d q) = (-1)%Z ->
 spec_Qhomographic_Qpositive_to_Q a b c d q =
 Qneg (spec_ni2 (- a) (- b) c d q).
Proof.
 intros a b c d p H.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 unfold spec_ni2 in |- *.
 rewrite <- Q_tail_Qinv.
 rewrite <- Q_tail_Qmult.
 rewrite Qopp_Qpos.
 rewrite <- Q_tail_Q_pos.
 rewrite Qopp_linear.
 abstract ring.

 apply Qsgn_9.
 rewrite Qopp_linear.
 rewrite Qmult_Qopp_left.
 rewrite Qsgn_25.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H.
 constructor.

 rewrite Qopp_linear.
 apply Qopp_resp_nonzero.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 discriminate H.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 rewrite Qmult_sym in H.
 discriminate H.
Defined.

(** We use this when 0<=(Z.sgn a+b) *)
Lemma spec_Qhomographic_Qpositive_to_Q_spec_ni2_neg_2 :
 forall (a b c d : Z) (q : Qpositive),
 Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d q) = (-1)%Z ->
 spec_Qhomographic_Qpositive_to_Q a b c d q =
 Qneg (spec_ni2 a b (- c) (- d) q).
Proof.
 intros a b c d p H.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 unfold spec_ni2 in |- *.
 rewrite <- Q_tail_Qinv.
 rewrite <- Q_tail_Qmult.
 rewrite Qopp_Qpos.
 rewrite <- Q_tail_Q_pos.
 rewrite Qopp_linear.
 rewrite Qinv_Qopp.
 abstract ring.

 apply Qsgn_9.
 rewrite Qopp_linear.
 rewrite Qinv_Qopp.
 rewrite Qmult_sym.
 rewrite Qmult_Qopp_left.
 rewrite Qsgn_25.
 rewrite Qmult_sym.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H.
 constructor.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 discriminate H.

 rewrite Qopp_linear.
 rewrite Qinv_Qopp.
 apply Qopp_resp_nonzero.

 intro H_absurd.
 unfold spec_Qhomographic_Qpositive_to_Q in H.
 rewrite H_absurd in H.
 rewrite Qmult_sym in H.
 discriminate H.
Defined.

(** Here we don't require that a*q+b<>0, maybe we should! but the lemma is true anyway! *)
Lemma spec_Qhomographic_Qpositive_to_Q_Zopp :
 forall (a b c d : Z) (q : Qpositive),
 spec_Qhomographic_Qpositive_to_Q (- a) (- b) (- c) (- d) q =
 spec_Qhomographic_Qpositive_to_Q a b c d q.
Proof.
 intros a b c d q.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 repeat rewrite Zopp_eq_mult_neg_1.

 repeat rewrite Z_to_Qmult.
 repeat rewrite <- Qmult_assoc.
 rewrite (Qmult_sym (-1)%Z).
 repeat rewrite Qmult_assoc.
 repeat rewrite <- Q_distr_left.
 rewrite <- Qdiv_num_denom with (p := (-1)%Z).
 reflexivity.
 abstract discriminate.
Defined.

(** Here we don't require that a*q+b<>0, maybe we should! but the lemma is true anyway! *)
Lemma spec_Qhomographic_Qpositive_to_Q_Zopp_2 :
 forall (a b c d : Z) (q : Qpositive),
 spec_Qhomographic_Qpositive_to_Q (- a) (- b) c d q =
 Qopp (spec_Qhomographic_Qpositive_to_Q a b c d q).
Proof.
 intros a b c d q.
 unfold spec_Qhomographic_Qpositive_to_Q in |- *.
 rewrite Qopp_linear.
 apply Qmult_Qopp_left.
Defined.

Lemma spec_Qhomographic_Qpositive_to_Q_Zopp_3 :
 forall (a b c d : Z) (q : Qpositive),
 spec_Qhomographic_Qpositive_to_Q a b (- c) (- d) q =
 Qopp (spec_Qhomographic_Qpositive_to_Q a b c d q).
Proof.
 intros a b c d q; unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  rewrite Qopp_linear; rewrite Qinv_Qopp; rewrite Qmult_sym;
  rewrite Qmult_Qopp_left; rewrite Qmult_sym; reflexivity.
Defined.

Lemma sg_pres_fraction :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 Qmult
   (Qplus
      (Qmult (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
         (Qpos (new_p a b c d p H_Qhomographic_sg_denom_nonzero)))
      (new_b a b c d p H_Qhomographic_sg_denom_nonzero))
   (Qinv
      (Qplus
         (Qmult (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
            (Qpos (new_p a b c d p H_Qhomographic_sg_denom_nonzero)))
         (new_d a b c d p H_Qhomographic_sg_denom_nonzero))) =
 Qmult (Qplus (Qmult a (Qpos p)) b) (Qinv (Qplus (Qmult c (Qpos p)) d)).
Proof.
intros a b c d p H_Qhomographic_sg_denom_nonzero.
unfold new_a, new_b, new_c, new_d, new_p in |- *.
functional induction (Qhomographic_sign a b c d p
                             H_Qhomographic_sg_denom_nonzero);
try reflexivity;rewrite IHp0; clear IHp0;symmetry  in |- *;
try first [
    apply spec_Qhomographic_Qpositive_to_Q_nR_unfolded |
       apply spec_Qhomographic_Qpositive_to_Q_dL_unfolded
].
Qed.

Lemma a_field_equality_1 :
 forall x y z t w : Q,
 Qmult x t = Qmult y z ->
 t <> Zero ->
 Qplus (Qmult z w) t <> Zero ->
 Qmult (Qplus (Qmult x w) y) (Qinv (Qplus (Qmult z w) t)) = Qmult y (Qinv t).
Proof.
 intros a b c d p H_xt_eq_yz Ht H_denom;
 rewrite Qdiv_num_denom with (p := d); [ idtac | assumption ];
 replace (Qmult (Qplus (Qmult a p) b) d) with
   (Qplus (Qmult (Qmult a d) p) (Qmult b d));
 [ idtac | ring ]; rewrite H_xt_eq_yz;
 field; auto.
Defined.

Lemma Qhomographic_sg_denom_nonzero_correct_1 :
 forall (c d : Z) (p : Qpositive),
 Qhomographic_sg_denom_nonzero c d p -> Qplus (Qmult c (Qpos p)) d <> Zero.
Proof.
 intros c d p H_Qhomographic_sg_denom_nonzero.
 induction H_Qhomographic_sg_denom_nonzero.
  (* 1 *)
  replace Zero with (Z_to_Q 0); trivial.
  rewrite H.
  rewrite Qmult_one_right.
  rewrite <- Z_to_Qplus.
  apply Z_to_Q_not_eq.
  assumption.
  (* 2 *)
  rewrite Qpos_nR.
  replace (Qplus (Qmult c (Qplus (Qpos xs) Qone)) d) with
   (Qplus (Qmult c (Qpos xs)) (Qplus c d)).
  rewrite <- Z_to_Qplus.
  assumption.
  abstract ring.
  (* 3 *)
  rewrite Qpos_dL.
  replace (Qplus (Qmult c (Qmult (Qpos xs) (Qinv (Qplus (Qpos xs) Qone)))) d)
   with
   (Qmult (Qplus (Qmult (Qplus c d) (Qpos xs)) d)
      (Qinv (Qplus (Qpos xs) Qone))).
  apply Qmult_resp_nonzero.
  rewrite <- Z_to_Qplus.
  assumption.
  abstract discriminate.
  abstract (field; discriminate).
Defined.

Lemma Qhomographic_sg_denom_nonzero_correct_2 :
 forall (c d : Z) (p : Qpositive),
 Qplus (Qmult c (Qpos p)) d <> Zero -> Qhomographic_sg_denom_nonzero c d p.
Proof.
 intros c d p.
 generalize c d.
 clear c d.
 induction p.
 (* nR *)
 intros.
 apply Qhomographic_signok1.
 apply IHp.
 replace (Qplus (Qmult c (Qpos p)) (c + d)%Z) with
  (Qplus (Qmult c (Qplus (Qpos p) Qone)) d).
 rewrite Qpos_nR in H; assumption.
 rewrite Z_to_Qplus.
 abstract ring.
 (* dL *)
 intros.
 apply Qhomographic_signok2.
 apply IHp.
 intro.
 apply H.
 rewrite Qpos_dL.
 replace (Qplus (Qmult c (Qmult (Qpos p) (Qinv (Qplus (Qpos p) Qone)))) d)
  with
  (Qmult (Qplus (Qmult (Qplus c d) (Qpos p)) d) (Qinv (Qplus (Qpos p) Qone))).
 rewrite <- Z_to_Qplus.
 rewrite H0.
 rewrite Qmult_zero; reflexivity.

 abstract (field; discriminate).
 (* One *)
 intros.
 apply Qhomographic_signok0; trivial.
 intro.
 apply H.
 rewrite Qmult_one_right.
 rewrite <- Z_to_Qplus.
 replace Zero with (Z_to_Q 0); trivial.
 apply f_equal with Z; assumption.
Defined.

Lemma homography_positive_input :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 Qmult (Qplus (Qmult a (Qpos p)) b) (Qinv (Qplus (Qmult c (Qpos p)) d)).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction
   (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero).

 (* 1 *)
 clear e e0 e1.
 rename x into Hc0;
 rename a0 into ad_eq_bc;
   rewrite coding_Q.
 assert (b0_eq_zero : b = 0%Z).
 rewrite Zmult_0_r in ad_eq_bc.
        apply Zmult_integral_l with c;assumption || symmetry  in |- *;
        assumption.

	rewrite b0_eq_zero.
	simpl in *.
        unfold spec_fraction_encoding in |- *;
        repeat rewrite Qplus_zero_right;
        abstract (
                   (* Field.
                           Anomaly: Search error. Please report.
                         *)
                   rewrite <- Qdiv_num_denom; [ reflexivity | discriminate ]) .
 clear e e0 e1.
 rename x into Hc0;
 rename a0 into ad_eq_bc;
   rewrite coding_Q.
 assert (b0_eq_zero : b = 0%Z).
 rewrite Zmult_0_r in ad_eq_bc.
        apply Zmult_integral_l with c;assumption || symmetry  in |- *;
        assumption.

	rewrite b0_eq_zero.
	simpl in *.
        unfold spec_fraction_encoding in |- *;
        repeat rewrite Qplus_zero_right;
        abstract (
                   (* Field.
                           Anomaly: Search error. Please report.
                         *)
                   rewrite <- Qdiv_num_denom; [ reflexivity | discriminate ]) .
 (* 2 *)
  rewrite coding_Q;
  unfold spec_fraction_encoding in |- *; symmetry  in |- *;
  apply a_field_equality_1;
  [ repeat rewrite <- Z_to_Qmult; apply f_equal with Z
  | replace Zero with (Z_to_Q 0); trivial; apply Z_to_Q_not_eq
  | apply Qhomographic_sg_denom_nonzero_correct_1 ];
  assumption.
 (* 3 *)
 clear e0 e;
   symmetry  in |- *;
  replace
   (Qmult (Qplus (Qmult a (Qpos p)) b) (Qinv (Qplus (Qmult c (Qpos p)) d)))
   with (spec_Qhomographic_Qpositive_to_Q a b c d p);
  trivial; apply Qsgn_2;
  rewrite <- (homographic_sign a b c d p H_Qhomographic_sg_denom_nonzero);
  assumption.
 (* 4 *)
 rewrite output_bit;
  rewrite <- spec_Qhomographic_Qpositive_to_Q_spec_ni2_pos;
  unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  rewrite sg_pres_fraction;
  [ reflexivity
  | change (Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d p) = 1%Z) in |- *;
     rewrite <- (homographic_sign a b c d p H_Qhomographic_sg_denom_nonzero);
     assumption ].
 (* 5 *)
 rewrite output_bit;
  rewrite <- spec_Qhomographic_Qpositive_to_Q_spec_ni2_pos;
  rewrite spec_Qhomographic_Qpositive_to_Q_Zopp;
  unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  rewrite sg_pres_fraction;
  [ reflexivity
  | change (Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d p) = 1%Z) in |- *;
     rewrite <- (homographic_sign a b c d p H_Qhomographic_sg_denom_nonzero);
     assumption ].
 (* 6 *)
 rewrite output_bit;
  rewrite <- spec_Qhomographic_Qpositive_to_Q_spec_ni2_neg_1;
  unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  rewrite sg_pres_fraction;
  [ reflexivity
  | change (Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d p) = (-1)%Z)
     in |- *;
     rewrite <- (homographic_sign a b c d p H_Qhomographic_sg_denom_nonzero);
     assumption ].
 (* 7 *)
 rewrite output_bit;
  rewrite <- spec_Qhomographic_Qpositive_to_Q_spec_ni2_neg_2;
  unfold spec_Qhomographic_Qpositive_to_Q in |- *;
  rewrite sg_pres_fraction;
  [ reflexivity
  | change (Qsgn (spec_Qhomographic_Qpositive_to_Q a b c d p) = (-1)%Z)
     in |- *;
     rewrite <- (homographic_sign a b c d p H_Qhomographic_sg_denom_nonzero);
     assumption ].
Defined.

Lemma homography :
 forall (a b c d : Z) (s : Q)
   (H_Qhomographic_denom_nonzero : Qhomographic_denom_nonzero c d s),
 Qhomographic a b c d s H_Qhomographic_denom_nonzero = spec_h a b c d s.
Proof.
 intros a b c d [| s| s] H_Qhomographic_denom_nonzero.
 (* (1) s=Zero *)
 unfold Qhomographic in |- *.
 unfold spec_h in |- *.
 rewrite Qmult_sym with a Zero.
 rewrite Qmult_sym with c Zero.
 repeat rewrite Qmult_zero.
 repeat rewrite Qplus_zero_left.
 rewrite coding_Q.
 reflexivity.
 (* (2) s=(Qpos s) *)
 unfold Qhomographic in |- *.
 unfold spec_h in |- *.
 apply homography_positive_input.
 (* (3) s=(Qneg s) *)
 unfold Qhomographic in |- *.
 unfold spec_h in |- *.
 rewrite homography_positive_input.
 apply f_equal2 with Q Q; [ idtac | apply f_equal with Q ];
  apply f_equal2 with Q Q; trivial; repeat rewrite Z_to_Qopp;
  repeat rewrite <- Qmult_neg; abstract ring.
Defined.

Lemma Qhomographic_denom_nonzero_correct_1 :
 forall (c d : Z) (q : Q),
 Qplus (Qmult c q) d <> Zero -> Qhomographic_denom_nonzero c d q.
Proof.
 abstract (intros c d [| p| p] H_denom;
            [  (* Zero *)
               apply Qhomographicok0; trivial; intros H;
               apply H_denom; rewrite H; replace (Z_to_Q 0) with Zero;
               trivial; abstract ring
            |  (* Qpos *)
               apply Qhomographicok1 with p; trivial;
               apply Qhomographic_sg_denom_nonzero_correct_2;
               assumption
            |  (* Qneg *)
               apply Qhomographicok2 with p; trivial;
               apply Qhomographic_sg_denom_nonzero_correct_2;
               intro H; apply H_denom;
               replace (Qmult c (Qneg p)) with (Qmult (- c)%Z (Qpos p));
               trivial; rewrite Z_to_Qopp; rewrite Qopp_Qpos; abstract
               ring ]).
Defined.

Lemma Qhomographic_denom_nonzero_correct_2 :
 forall (c d : Z) (q : Q),
 Qhomographic_denom_nonzero c d q -> Qplus (Qmult c q) d <> Zero.
Proof.
 abstract (intros c d q H_Qhomographic_denom_nonzero;
            induction H_Qhomographic_denom_nonzero;
            [  (* Zero *)
               rewrite H; replace (Qmult c Zero) with Zero;
               [ idtac | abstract ring ]; rewrite Qplus_zero_left;
               replace Zero with (Z_to_Q 0); trivial;
               apply Z_to_Q_not_eq; assumption
            |  (* Qpos *)
               rewrite H; apply Qhomographic_sg_denom_nonzero_correct_1;
               assumption
            |  (* Qneg *)
               rewrite H;
               replace (Qmult c (Qneg p)) with (Qmult (- c)%Z (Qpos p));
               [ apply Qhomographic_sg_denom_nonzero_correct_1; assumption
               | rewrite Z_to_Qopp; rewrite Qopp_Qpos; abstract ring ] ]).
Defined.

Theorem homography_algorithm_is_correct :
 forall (a b c d : Z) (q : Q) (H_denom : Qplus (Qmult c q) d <> Zero),
 Qhomographic a b c d q (Qhomographic_denom_nonzero_correct_1 c d q H_denom) =
 Qmult (Qplus (Qmult a q) b) (Qinv (Qplus (Qmult c q) d)).
Proof.
 intros a b c d q H_denom;
  apply
   (homography a b c d q (Qhomographic_denom_nonzero_correct_1 c d q H_denom)).
Defined.


Require Import Coqlib.
Require Import String.
Require Import PCM.
Require Import Any.

Set Implicit Arguments.
Set Typeclasses Depth 5.

Create HintDb iprop.
Ltac uipropall :=
  repeat (autounfold with iprop; autorewrite with iprop;
       all_once_fast ltac:(fun H => autounfold with iprop in H; autorewrite with iprop in H); ss).

Section IPROP.
  Context {Σ: GRA.t}.

  Local Notation iPred := (Σ -> Prop).

  Record iProp' :=
    iProp_intro {
        iProp_pred :> iPred;
        iProp_mono: forall r0 r1 (WF: URA.wf r1) (LE: URA.extends r0 r1),
          iProp_pred r0 -> iProp_pred r1;
      }.

  Program Definition Sepconj (P Q: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => exists a b, r = URA.add a b /\ P a /\ Q b) _).
  Next Obligation.
    red in LE. des; subst.
    exists H, (H0 ⋅ ctx). rewrite URA.add_assoc. splits; auto.
    eapply iProp_mono; eauto.
    { eapply URA.wf_mon. instantiate(1:=H). r_wf WF. }
    { exists ctx. auto. }
  Qed.

  Program Definition Pure (P: Prop): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun _ => P) _).

  Program Definition Ex {X: Type} (P: X -> iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => exists x, P x r) _).
  Next Obligation.
    esplits. eapply iProp_mono; eauto.
  Qed.

  Program Definition Univ {X: Type} (P: X -> iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => forall x, P x r) _).
  Next Obligation.
    eapply iProp_mono; eauto.
  Qed.

  Program Definition Own (r0: Σ): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r1 => URA.extends r0 r1) _).
  Next Obligation.
    etrans; eauto.
  Qed.

  Program Definition And (P Q: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => P r /\ Q r) _).
  Next Obligation.
    splits; auto; eapply iProp_mono; eauto.
  Qed.

  Program Definition Or (P Q: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => P r \/ Q r) _).
  Next Obligation.
    des.
    { left. eapply iProp_mono; eauto. }
    { right. eapply iProp_mono; eauto. }
  Qed.

  Program Definition Impl (P Q: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r0 => forall r1 (WF: URA.wf r1) (LE: URA.extends r0 r1),
                        URA.wf r1 -> P r1 -> Q r1) _).
  Next Obligation.
    eapply H; eauto. etrans; eauto.
  Qed.

  Program Definition Wand (P Q: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => forall rp, URA.wf (r ⋅ rp) -> P rp -> Q (r ⋅ rp)) _).
  Next Obligation.
    eapply iProp_mono; [..|eapply H]; eauto.
    { eapply URA.extends_add; auto. }
    { eapply URA.wf_extends; eauto. eapply URA.extends_add; auto. }
  Qed.

  Program Definition Emp: iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun _ => True) _).

  Program Definition Persistently (P: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r0 => P (URA.core r0)) _).
  Next Obligation.
    eapply iProp_mono; eauto.
    { eapply URA.wf_core; eauto. }
    { eapply URA.extends_core; eauto. }
  Qed.

  Program Definition Plainly (P: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r => P ε) _).

  Program Definition Later (P: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro P _).
  Next Obligation.
    eapply iProp_mono; eauto.
  Qed.

  Program Definition Upd (P: iProp'): iProp' :=
    Seal.sealing
      "iProp"
      (iProp_intro (fun r0 => forall ctx, URA.wf (r0 ⋅ ctx) -> exists r1, URA.wf (r1 ⋅ ctx) /\ P r1) _).
  Next Obligation.
    red in LE. des. subst. hexploit (H (ctx0 ⋅ ctx)).
    { rewrite URA.add_assoc. auto. }
    i. des. esplits; [..|eauto]. eapply URA.wf_mon.
    instantiate (1:=ctx0). r_wf H1.
  Qed.

  Definition Entails (P Q : iProp') : Prop :=
    Seal.sealing
      "iProp"
      (forall r (WF: URA.wf r), P r -> Q r).

  Hint Rewrite (Seal.sealing_eq "iProp"): iprop.
  #[local] Hint Unfold Sepconj Pure Ex Univ Own And Or Impl Wand Emp Persistently Later Upd Entails: iprop.

  (* BI axioms *)
  Global Program Instance PreOrder_Entails: PreOrder Entails.
  Next Obligation.
  Proof.
    ii. uipropall.
  Qed.
  Next Obligation.
  Proof.
    ii. uipropall. ii. exploit (H r); et.
  Qed.

  Lemma Pure_intro: forall (φ : Prop) (P : iProp'), φ -> Entails P (Pure φ).
  Proof.
    ii. uipropall.
  Qed.

  Lemma Pure_elim: forall (φ : Prop) (P : iProp'), (φ -> Entails (Pure True) P) -> Entails (Pure φ) P.
  Proof.
    ii. uipropall. ii. eapply H in H0; et.
  Qed.

  Lemma And_elim_l: forall P Q : iProp', Entails (And P Q) P.
  Proof.
    ii. uipropall. ii. eapply H.
  Qed.

  Lemma And_elim_r: forall P Q : iProp', Entails (And P Q) Q.
  Proof.
    ii. uipropall. ii. eapply H.
  Qed.

  Lemma And_intro: forall P Q R : iProp', Entails P Q -> Entails P R -> Entails P (And Q R).
  Proof.
    ii. uipropall. ii. split; [eapply H|eapply H0]; et.
  Qed.

  Lemma Or_intro_l: forall P Q : iProp', Entails P (Or P Q).
  Proof.
    ii. uipropall. ii. left. ss.
  Qed.

  Lemma Or_intro_r: forall P Q : iProp', Entails Q (Or P Q).
  Proof.
    ii. uipropall. ii. right. ss.
  Qed.

  Lemma Or_elim: forall P Q R : iProp', Entails P R -> Entails Q R -> Entails (Or P Q) R.
  Proof.
    ii. uipropall. ii. inv H1.
    { eapply H; ss. }
    { eapply H0; ss. }
  Qed.

  Lemma Impl_intro_r: forall P Q R : iProp', Entails (And P Q) R -> Entails P (Impl Q R).
  Proof.
    ii. uipropall. ii. eapply H; et. splits; auto. eapply iProp_mono; eauto.
  Qed.

  Lemma Impl_elim_l: forall P Q R : iProp', Entails P (Impl Q R) -> Entails (And P Q) R.
  Proof.
    ii. uipropall. ii. inv H0. eapply H; et. refl.
  Qed.

  Lemma Univ_intro: forall (A : Type) (P : iProp') (Ψ : A -> iProp'), (forall a : A, Entails P (Ψ a)) -> Entails P (Univ (fun a : A => Ψ a)).
  Proof.
    ii. uipropall. ii. specialize (H x). uipropall. eapply H; et.
  Qed.

  Lemma Univ_elim: forall (A : Type) (Ψ : A -> iProp') (a : A), Entails (Univ (fun a0 : A => Ψ a0)) (Ψ a).
  Proof.
    ii. uipropall.
  Qed.

  Lemma Ex_intro: forall (A : Type) (Ψ : A -> iProp') (a : A), Entails (Ψ a) (Ex (fun a0 : A => Ψ a0)).
  Proof.
    ii. uipropall. ii. eexists. eauto.
  Qed.

  Lemma Ex_elim: forall (A : Type) (Φ : A -> iProp') (Q : iProp'), (forall a : A, Entails (Φ a) Q) -> Entails (Ex (fun a : A => Φ a)) Q.
  Proof.
    ii. uipropall. ii. des. specialize (H x). uipropall. et.
  Qed.

  Lemma Sepconj_mono: forall P P' Q Q' : iProp', Entails P Q -> Entails P' Q' -> Entails (Sepconj P P') (Sepconj Q Q').
  Proof.
    ii. uipropall. ii. unfold Sepconj in *. des; subst. esplits; et.
    { eapply H; et. eapply URA.wf_mon; et. }
    { eapply H0; et. eapply URA.wf_mon; et. rewrite URA.add_comm. et. }
  Qed.

  Lemma Emp_Sepconj_l: forall P : iProp', Entails P (Sepconj Emp P).
  Proof.
    ii. uipropall. ii. exists ε, r. splits; ss. rewrite URA.unit_idl. et.
  Qed.

  Lemma Emp_Sepconj_r: forall P : iProp', Entails (Sepconj Emp P) P.
  Proof.
    ii. uipropall. ii. inv H. des; subst. eapply iProp_mono; eauto.
    exists x. r_solve.
  Qed.

  Lemma Sepconj_comm: forall P Q : iProp', Entails (Sepconj P Q) (Sepconj Q P).
  Proof.
    ii. uipropall. ii. unfold Sepconj in *. des. subst. exists b, a. splits; et. apply URA.add_comm.
  Qed.

  Lemma Sepconj_assoc: forall P Q R : iProp', Entails (Sepconj (Sepconj P Q) R) (Sepconj P (Sepconj Q R)).
  Proof.
    ii. uipropall. ii. unfold Sepconj in *. des; subst. esplits; [|apply H2| |apply H3|apply H1]; ss.
    rewrite URA.add_assoc. ss.
  Qed.

  Lemma Wand_intro_r: forall P Q R : iProp', Entails (Sepconj P Q) R -> Entails P (Wand Q R).
  Proof.
    ii. uipropall. ii. eapply H; et.
  Qed.

  Lemma Wand_elim_l: forall P Q R : iProp', Entails P (Wand Q R) -> Entails (Sepconj P Q) R.
  Proof.
    ii. uipropall. ii. unfold Sepconj in *. des; subst. eapply H; et. eapply URA.wf_mon; et.
  Qed.

  Lemma Persistently_mono: forall P Q : iProp', Entails P Q -> Entails (Persistently P) (Persistently Q).
  Proof.
    ii. uipropall. ii. eapply H; eauto. eapply URA.wf_core; eauto.
  Qed.

  Lemma Persistently_idem: forall P : iProp', Entails (Persistently P) (Persistently (Persistently P)).
  Proof.
    ii. uipropall. ii. rewrite URA.core_idem. auto.
  Qed.

  Lemma Persistently_emp: Entails Emp (Persistently Emp).
  Proof.
    uipropall.
  Qed.

  Lemma Persistently_univ: forall (A : Type) (Ψ : A -> iProp'), Entails (Univ (fun a => Persistently (Ψ a))) (Persistently (Univ (fun a => Ψ a))).
  Proof.
    ii. uipropall. ii. specialize (H x). uipropall.
  Qed.

  Lemma Persistently_ex: forall (A : Type) (Ψ : A -> iProp'), Entails (Persistently (Ex (fun a => Ψ a))) (Ex (fun a => Persistently (Ψ a))).
  Proof.
    ii. uipropall. ii. des. exists x. uipropall.
  Qed.

  Lemma Persistently_sep: forall P Q : iProp', Entails (Sepconj (Persistently P) Q) (Persistently P).
  Proof.
    ii. uipropall. ii. des. subst.
    eapply iProp_mono; [..|eauto].
    { eapply URA.wf_core; eauto. }
    { eapply URA.extends_core; eauto. exists b. auto. }
  Qed.

  Lemma Persistently_and: forall P Q : iProp', Entails (And (Persistently P) Q) (Sepconj P Q).
  Proof.
    ii. uipropall. ii. des. esplits; eauto. rewrite URA.core_id. auto.
  Qed.

  Lemma Persistently_and2: forall P Q : iProp', Entails (And (Persistently P) (Persistently Q)) (Persistently (And P Q)).
  Proof.
    ii. uipropall.
  Qed.

  Lemma Upd_intro: forall P : iProp', Entails P (Upd P).
  Proof.
    ii. uipropall. ii. exists r. splits; auto.
  Qed.

  Lemma Upd_mono: forall P Q : iProp', Entails P Q -> Entails (Upd P) (Upd Q).
  Proof.
    ii. uipropall. ii. exploit H0; et. i. des.
    exploit (H r1); et. eapply URA.wf_mon; et.
  Qed.

  Lemma Upd_trans: forall P : iProp', Entails (Upd (Upd P)) (Upd P).
  Proof.
    ii. uipropall. ii. exploit H; et. i. des. exploit x1; eauto.
  Qed.

  Lemma Upd_frame_r: forall P R : iProp', Entails (Sepconj (Upd P) R) (Upd (Sepconj P R)).
  Proof.
    ii. uipropall. ii. unfold Sepconj in *. des. subst. exploit (H1 (b ⋅ ctx)); et.
    { rewrite URA.add_assoc. et. }
    i. des. esplits; [..|eapply x1|eapply H2]; ss.
    rewrite <- URA.add_assoc. et.
  Qed.
End IPROP.
Hint Rewrite (Seal.sealing_eq "iProp"): iprop.
#[export] Hint Unfold Sepconj Pure Ex Univ Own And Or Impl Wand Emp Persistently Later Upd Entails: iprop.


(**
Let `X` be an algebra and let `Y` be an displayed algebra over `X`.
Denote the total algebra of `Y` by `E`.
Note that we always have the projectio `p : E --> X`.
In this file, we map sections of `p` to displayed algebra maps from `X` to `Y`
 *)
Require Import prelude.all.

Require Import syntax.hit_signature.
Require Import algebras.set_algebra.
Require Import displayed_algebras.displayed_algebra.
Require Import displayed_algebras.total_algebra.

(** We first show operations of displayed algebras commute with transports *)
Definition transportb_disp_alg_operator
           {P : poly_code}
           {A : hSet}
           (Y : A → hSet)
           (c : ⦃ P ⦄ A → A)
           (cY : ∏ (x : ⦃ P ⦄ A), poly_dact P Y x → Y (c x))
           {a₁ a₂ : ⦃ P ⦄ A}
           (p : a₁ = a₂)
           (y : poly_dact P Y a₁)
  : cY a₁ y
    =
    transportb Y (maponpaths c p) (cY a₂ (transportf (poly_dact P Y) p y)).
Proof.
  induction p.
  reflexivity.
Qed.

(** Next we compute `poly_pr2` composed with the action of the functor *)
Definition poly_pr2_fmap
           (P : poly_code)
           {X : hSet}
           (Y : X → hSet)
           (f : X → total2_hSet Y)
           (x : ⦃ P ⦄ X)
           (p : (λ z, pr1(f z)) = idfun X)
  : poly_pr2 P Y (#⦃ P ⦄ f x)
    =
    transportf (poly_dact P Y)
               (eqtohomot (!(functor_id (⦃ P ⦄) X)) x
                          @ eqtohomot (maponpaths (#⦃ P ⦄) (!p)) x
                          @ eqtohomot (functor_comp (⦃ P ⦄) _ _) x)
               (poly_dmap P Y (λ z, transportf Y (eqtohomot p z) (pr2 (f z))) x).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂] ; simpl.
  - rewrite transportf_const.
    reflexivity.
  - rewrite transport_f_f.
    rewrite transportf_set.
    + reflexivity.
    + apply X.
  - induction x as [x | x].
    + refine (IHP₁ x @ _).
      refine (!(transportf_inl (poly_dact P₁ Y) (poly_dact P₂ Y) _ _) @ _).
      apply (transportf_paths (sum_hset_fam (poly_dact P₁ Y) (poly_dact P₂ Y))).
      apply setcoprod.
    + refine (IHP₂ x @ _).
      refine (!(transportf_inr (poly_dact P₁ Y) (poly_dact P₂ Y) _ _) @ _).
      apply (transportf_paths (sum_hset_fam (poly_dact P₁ Y) (poly_dact P₂ Y))).
      apply setcoprod.
  - induction x as [x₁ x₂].
    apply dirprod_paths.
    + refine (IHP₁ x₁ @ _).
      refine (_ @ !(transportf_pr1 _ (#⦃ P₁ ⦄ _ _ ,, #⦃ P₂ ⦄ _ _) _ _)).
      apply (transportf_paths (poly_dact P₁ Y)).
      apply setproperty.
    + refine (IHP₂ x₂ @ _).
      refine (_ @ !(transportf_pr2 _ (#⦃ P₁ ⦄ _ _ ,, #⦃ P₂ ⦄ _ _) _ _)).
      apply (transportf_paths (poly_dact P₂ Y)).
      apply setproperty.
Qed.

(** Lemma *)
Definition functor_fid
           {P : poly_code}
           {X : hSet}
           {x : ⦃ P ⦄ X}
           {f : X → X}
           (p : f = idfun X)
  : x = #⦃ P ⦄ f x.
Proof.
  rewrite p.
  rewrite (functor_id (⦃ P ⦄)).
  reflexivity.
Qed.

(** Now we show that a section of the projection gives rise to a dependent map to `Y` *)
Definition section_to_disp_alg_map
           {Σ : hit_signature}
           {X : set_algebra Σ}
           (Y : disp_algebra X)
           (f : X --> total_algebra Y)
           (p : f · projection Y = identity X)
  : disp_algebra_map Y.
Proof.
  use tpair.
  - exact (λ x, transportf
                  (pr1 Y)
                  (eqtohomot (maponpaths pr1 (maponpaths pr1 p)) x)
                  (pr2 (pr11 f x))).
  - intros x.
    refine (_ @ _).
    {
      apply maponpaths.
      exact (fiber_paths_b (eqtohomot (pr21 f) x)).
    }
    unfold transportb.
    rewrite transport_f_f.
    simpl ; cbn.
    refine (_ @ _).
    {
      apply maponpaths.
      refine (transportb_disp_alg_operator (pr1 Y) _ (pr12 Y) _ _).
      refine (eqtohomot (!(functor_comp (⦃ point_arg Σ⦄) _ _)) x @ _).
      refine (_ @ _).
      {
        apply maponpaths_2.
        apply (maponpaths pr1 (maponpaths pr1 p)).
      }
      apply (eqtohomot (functor_id (⦃ point_arg Σ ⦄) _) x).
    }
    simpl.
    unfold transportb.
    rewrite transport_f_f.
    simple refine (_ @ !(transportb_disp_alg_operator
                           _ _ _
                           (functor_fid (maponpaths pr1 (maponpaths pr1 p)))
                           _)).
    unfold transportb.
    use transportf_paths_2.
    refine (!_).
    refine (_ @ _).
    {
      apply maponpaths.
      refine (transportb_disp_alg_operator (pr1 Y) _ (pr12 Y) _ _).
      refine (_ @ _).
      {
        apply maponpaths_2.
        apply (maponpaths pr1 (maponpaths pr1 p)).
      }
      apply (eqtohomot (functor_id (⦃ point_arg Σ ⦄) _) x).
    }
    unfold transportb.
    rewrite !transport_f_f.
    refine (!_).
    refine (_ @ _).
    {
      do 2 apply maponpaths.
      refine (poly_pr2_fmap _ _ _ _ _).
      exact (maponpaths pr1 (maponpaths pr1 p)).
    }
    simpl.
    rewrite transport_f_f.
    refine (!_).
    rewrite transportf_set.
    + apply maponpaths.
      apply (transportf_paths_3 (poly_dact (point_arg Σ) Y)).
      reflexivity.
    + apply setproperty.
Qed.


Require Export SystemFR.EquivalentStar.

Lemma equivalent_ite_true:
  forall b e1 e2,
    is_erased_term b ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    wf b 0 ->
    wf e1 0 ->
    wf e2 0 ->
    pfv b term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    b ~>* ttrue ->
    [ ite b e1 e2 ≡ e1 ].
Proof.
  intros; eapply equivalent_star; repeat step || list_utils;
    eauto using star_trans with cbvlemmas smallstep.
Qed.

Lemma equivalent_ite_false:
  forall b e1 e2,
    is_erased_term b ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    wf b 0 ->
    wf e1 0 ->
    wf e2 0 ->
    pfv b term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    b ~>* tfalse ->
    [ ite b e1 e2 ≡ e2 ].
Proof.
  intros; eapply equivalent_star; repeat step || list_utils;
    eauto using star_trans with cbvlemmas smallstep.
Qed.

Lemma equivalent_ite:
  forall t1 t2 t3 t,
    is_erased_term t1 ->
    is_erased_term t2 ->
    is_erased_term t3 ->
    wf t1 0 ->
    wf t2 0 ->
    wf t3 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    pfv t3 term_var = nil ->
    (t1 ~>* ttrue \/ t1 ~>* tfalse) ->
    (t1 ~>* ttrue -> [ t2 ≡ t ]) ->
    (t1 ~>* tfalse -> [ t3 ≡ t ]) ->
    [ ite t1 t2 t3 ≡ t ].
Proof.
  steps; eauto using equivalent_ite_true, equivalent_ite_false, equivalent_sym, equivalent_trans.
Qed.

Lemma equivalent_ite_true2:
  forall b e1 e2 e,
    is_erased_term b ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    wf b 0 ->
    wf e1 0 ->
    wf e2 0 ->
    pfv b term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    b ~>* ttrue ->
    [ e1 ≡ e ] ->
    [ ite b e1 e2 ≡ e ].
Proof.
  eauto using equivalent_ite_true, equivalent_sym, equivalent_trans.
Qed.

Lemma equivalent_ite_false2:
  forall b e1 e2 e,
    is_erased_term b ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    wf b 0 ->
    wf e1 0 ->
    wf e2 0 ->
    pfv b term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    b ~>* tfalse ->
    [ ite b e1 e2 ≡ e ] ->
    [ e2 ≡ e ].
Proof.
  eauto using equivalent_ite_false, equivalent_sym, equivalent_trans.
Qed.

Lemma equivalent_ite_true3:
  forall b e1 e2 e,
    b ~>* ttrue ->
    [ ite b e1 e2 ≡ e ] ->
    [ e1 ≡ e ].
Proof.
  intros.
  eapply equivalent_trans; try eassumption.
  apply equivalent_sym.
  apply equivalent_ite_true; unfold equivalent_terms in *; repeat step || list_utils.
Qed.

Lemma equivalent_ite_false3:
  forall b e1 e2 e,
    b ~>* tfalse ->
    [ ite b e1 e2 ≡ e ] ->
    [ e2 ≡ e ].
Proof.
  intros.
  eapply equivalent_trans; try eassumption.
  apply equivalent_sym.
  apply equivalent_ite_false; unfold equivalent_terms in *; repeat step || list_utils.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28synthconj5_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv0) lv2) ->  (@eq natural (Succ (plus (mult lv0 lv1) (plus lv0 lv1))) (plus lv2 (plus Zero (Succ lv1)))).
Admitted.
QuickChick conj28synthconj5_hyp.