Require Import List.
Require Import ListSet.
Import ListNotations.
Require Import Nat.
Require Import Bool.
From Legion Require Import Map.

Parameter region : Type.
Parameter location : Type.
Definition physical_region : Type := set location.
Parameter Id_T : Type.

Definition Task_ID := nat.

(* Declarations for ListSet and Map *)

Axiom Id_T_dec :
  forall x y : Id_T, {x = y} + {x <> y}.

Axiom loc_dec :
  forall x y : location, {x = y} + {x <> y}.

Axiom option_loc_dec:
 forall x y : option location, {x = y} + {x <> y}.

Axiom region_eq_neq :
  forall x y : region, {x = y} + {x <> y}.

Definition set_inter_reg := set_inter region_eq_neq.

Axiom physical_region_eq_neq :
  forall r1 r2 : physical_region, {r1 = r2} + {r1 <> r2}.

(* Core Legion Types (page 4) *)
Inductive coherence_mode : Type :=
  | Atomic (r : region) | Simult (r : region)
.

Definition Qs : Type := set coherence_mode.

Inductive priv_T : Type :=
  | Reads (r : region)
  | Writes (r : region)
  | Reduces (id : Id_T) (r : region)
.

Definition Phis := set priv_T.

Inductive constraint : Type :=
| Subregion (r1:region) (r2 : region)
| Disjoint (r1 : region) (r2 : region)
.

Axiom constraint_dec :
  forall x y : constraint, {x = y} + {x <> y}.

Definition Omegas : Type := set constraint.

Inductive T : Type :=
  | TBool | TInt
  | TTuple (tup : list T)
  | TPointer (t : T) (rs : list region)
  | TColoring (r : region)
  | (* ∃rs.t *) TRegionRelation (rs : list region) (t:T) (Ω : Omegas)
    (* TODO change to universal quantification over regions *)
  | (* ∀ *) TTask (rs : list region) (ts : list T) (Φ : list Phis) (Q : list Qs) (tr : T)
.

Inductive expr : Type :=
  | EBool (b : bool)
  | EInt (i : nat)
  | Tuple (es : list expr)
  | ExprIndex (e : expr) (n : nat)
  | Id (id : Id_T)
  | NewPointer (t : T) (r : region)
  | NullPointer (t : T) (r : region)
  | IsNull (e : expr)
  | Upregion (e : expr) (rs : list region)
  | Downregion (e : expr) (rs : list region)
  | Read (e1 : expr)
  | Write (e1 : expr) (e2 : expr)
  | Reduce (id : Id_T) (e1 : expr) (e2 : expr)
  | NewColor (r : region)
  | Color (e1 : expr) (e2 : expr) (e3 : expr)
  | Add (e1 : expr) (e2 : expr)
  | Compare (e1 : expr) (e2 : expr)
  | LetIn (id : Id_T) (t : T) (e1 : expr) (e2 : expr)
  | If (e1 : expr) (e2 : expr) (e3 : expr)
  | Call (id : Id_T) (rs : list region) (es : list expr)
  | Partition (rp : region) (e1 : expr) (rs : list region) (e2 : expr)
  | Pack (e1 : expr) (t : T) (rs : list region)
  | Unpack (e1 : expr) (id : Id_T) (t : T) (rs : list region) (e2 : expr)
.

Inductive value : Type :=
  | VBool (b : bool)
  | VInt (i : nat)
  (* Value tuples in the paper have two entries; changed for consistency with expressions. *)
  | VTuple (vs : list value)
  | VNull
  | VLocation (l : location)
  | VColoring (l : list (location * nat))
  | VRegionRelationInstance (rs : list physical_region) (v : value)
.

Axiom value_dec :
  forall x y : value, {x = y} + {x <> y}.

(* Heap, takes heap location to type *)
Definition Hs := partial_map location T.

(* Store takes global variables to values *)
Definition Ss := partial_map location value.

Inductive CoherenceMode :=
  | SSimult | SAtomic | SExcl
.

(* entry in an execution history *)
Inductive entry : Type :=
  | SRead (l : location) (c : CoherenceMode) (v : value) (a : Task_ID)
  | SWrite (l : location) (c : CoherenceMode) (v : value) (a : Task_ID)
  | SReduce (id : Id_T) (l : location) (c : CoherenceMode) (v : value) (a : Task_ID)
.

Definition get_loc (eps : entry) :=
  match eps with
  | SRead l _ _ _ | SWrite l _ _ _ | SReduce _ l _ _ _ => l
  end.

Definition get_mode (eps : entry) :=
  match eps with
  | SRead _ m _ _ | SWrite _ m _ _ | SReduce _ _ m _ _ => m
  end.

Definition get_val (eps : entry) :=
  match eps with
  | SRead _ _ v _ | SWrite _ _ v _ | SReduce _ _ _ v _ => v
  end.

Definition get_tag (eps : entry) :=
  match eps with
  | SRead _ _ _ t | SWrite _ _ _ t | SReduce _ _ _ _ t => t
  end.

(* E is stored backwards in some rules. TODO: Change throughout to store forwards *)
Definition Es := list entry.

(* a type map *)
Definition Gammas : Type := partial_map Id_T T.

(* map *)
Definition Ms : Type := partial_map region physical_region.

(* map *)
Definition Ls : Type := partial_map Id_T value.

Definition ClobberSet : Type := set location.

(* Helper Functions (Figure 5, page 9)
 ******************
*)

(* Figure 5, page 9 *)
Fixpoint apply_rev (S : Ss) (E : Es) : Ss :=
match E with
  | nil => S
  | SRead l c v t :: E' => apply_rev S E'
  | SWrite l c v t :: E' => add_mapping loc_dec (apply_rev S E') l v
  | SReduce id l _ v _ :: E' =>
      let S' := apply_rev S E' in
      (match S' l with
      | Some sl => add_mapping loc_dec S' l (Call id [] [sl; v])
      | None => S' (* error *)
      end)
  end.
Definition apply (S : Ss) (E : Es) : Ss :=
  apply_rev S (rev E).

(* Valid Interleaving Test, fig 7, page 14 *)

Inductive any_interleave : Es -> list Es -> Prop :=
  | any_interleave_empty l :
      (forall (empty : Es), empty = []) ->
      any_interleave [] l
  | any_interleave_nonempty ep E' Elist Elist':
      is_append_one Elist ep Elist' ->
      any_interleave (ep::E') Elist'
with
  is_append_one : list Es -> entry -> list Es -> Prop :=
  | is_append_one_hd ep Elist Elist' :
    tl Elist = Elist' ->
    is_append_one Elist ep ((ep :: hd [] Elist) :: tl Elist)
  | is_append_one_tl ep Elist Elist' E1:
    is_append_one Elist ep Elist' ->
    is_append_one (E1::Elist) ep (E1::Elist')
.

Inductive coherent : Ss -> set location -> set location -> Es -> Prop :=
  | coherent_empty S L1 L2 :
      coherent S L1 L2 []
  | coherent_read S L1 L2 E ep l c v t :
      (~ (In l L2) \/ S l = Some v) ->
      coherent S L1 L2 E ->
      ep = SRead l c v t ->
      coherent S L1 L2 (ep::E)
  | coherent_write S L1 L2 E ep l c v t :
      coherent (apply S [ep]) L1 (l :: L2) E ->
      ep = SWrite l c v t ->
      In l L1 ->
      coherent S L1 L2 (ep::E)
  | coherent_other S L1 L2 E ep l c v t :
      coherent (apply S [ep]) L1 L2 E ->
      (ep = SWrite l c v t /\ ~ (In l L1)) \/ (exists id, ep = SReduce id l c v t) ->
      coherent S L1 L2 (ep::E)
.

(* Takes a single ex. trace, not a list of execution traces *)
Definition seq_equiv (S:Ss) (L1 : set location) (L2 : set location) (E' : Es) (Eseq : Es)
  : Prop :=
  coherent S L1 L2 Eseq /\
  (forall (l : location), In l L1 -> (apply S E') l = (apply S Eseq) l).

Fixpoint Lexcl_helper (E:Es) (C:ClobberSet) : set location :=
  match E with
  | [] => []
  | h :: E' => let L' := Lexcl_helper E' C in (
    match get_mode h with
    | SExcl => get_loc h :: L'
    | _ => L' end)
  end.

Axiom location_eq_neq:
  forall x y : location, {x = y} + {x <> y}.

Definition Lexcl (E:Es) (C:ClobberSet) : set location :=
  set_diff location_eq_neq (Lexcl_helper E C) C.

Fixpoint Latomic_helper (E:Es) (C:ClobberSet) : set location :=
  match E with
  | [] => []
  | h :: E' => let L' := Latomic_helper E' C in (
    match get_mode h with
    | SAtomic => get_loc h :: L'
    | _ => L' end)
  end.

Definition Latomic (E:Es) (C:ClobberSet) : set location :=
  set_diff location_eq_neq
    (Latomic_helper E C)
    (set_union location_eq_neq C (Lexcl E C)).

(* filters by tag *)
Fixpoint darrow (t : Task_ID) (E : Es) : Es :=
  match E with
  | [] => []
  | h :: E' => if Nat.eqb t (get_tag h) then h::darrow t E'
                  else darrow t E'
  end.

Definition valid_interleave (S : Ss) (C : ClobberSet)
  (E' : Es) (Elist : list Es) : Prop :=
  any_interleave E' Elist /\
  coherent S (Lexcl E' C) (Lexcl E' C) E' /\
  seq_equiv S (Lexcl E' C) (Lexcl E' C) E' (fold_right (@app entry) nil Elist) /\
  forall t, seq_equiv S (Latomic E' C) (empty_set location) (darrow t E')
    (darrow t (fold_right (@app entry) nil Elist))
.

(* ======== *)

(* need to reference M *)
Fixpoint coherence_marking_helper
  (M : Ms) (l : location) (Q : Qs) (has_atomic : bool) : CoherenceMode :=
  match Q with
  | [] => if has_atomic then SAtomic else SExcl
  | Simult r :: Q' =>
    (match M r with
    | Some rho => if set_mem loc_dec l rho then SSimult
                  else coherence_marking_helper M l Q' has_atomic
    | None => coherence_marking_helper M l Q' has_atomic
    end
    )
  | Atomic r :: Q' =>
    (match M r with
    | Some rho => coherence_marking_helper M l Q' (orb has_atomic (set_mem loc_dec l rho))
    | None => coherence_marking_helper M l Q' has_atomic
    end
    )
  end.

Definition coherence_marking (M : Ms) (l : location) (Q : Qs) : CoherenceMode :=
  coherence_marking_helper M l Q false.

(* mark coherence (page 9) *)
Fixpoint mark_coherence (M : Ms) (E : Es) (Q : Qs) (taskid : nat) : Es :=
  let cm l := coherence_marking M l Q in
  match E with
  | [] => []
  | SRead l c v t :: E' => SRead l (cm l) v t :: mark_coherence M E' Q taskid
  | SWrite l c v t :: E' => SWrite l (cm l) v t :: mark_coherence M E' Q taskid
  | SReduce id l c v t :: E' => SReduce id l (cm l) v t :: mark_coherence M E' Q taskid
  end.

(* needed for [nth] *)
Definition default_E : Es := [].
Definition default_expr := EBool false.
Definition default_val := VBool false.
Parameter default_loc : location.
Parameter default_S : Ss.

(* Type rules
   *************************
 *)

(* Privilege and Constraint Closure (Fig. 3, page 7) *)

(* Note: Although privilege and constraint sets are implemented as sets,
    we implement privilege and constraint closure as relations,
    because constructing an explicit set is intractable.
*)

Inductive constraint_closure : Omegas -> constraint -> Prop :=
  | Cc_in Ω c : In c Ω -> constraint_closure Ω c
  | Cc_sub_refl_l Ω ri rj:
      constraint_closure Ω (Subregion ri rj) ->
      constraint_closure Ω (Subregion ri ri)
  | Cc_sub_refl_r Ω ri rj:
      constraint_closure Ω (Subregion ri rj) ->
      constraint_closure Ω (Subregion rj rj)
  | Cc_sub_trans Ω ri rj rk :
      constraint_closure Ω (Subregion ri rj) ->
      constraint_closure Ω (Subregion rj rk) ->
      constraint_closure Ω (Subregion ri rk)
  | Cc_sub_disj Ω ri rj rk :
      constraint_closure Ω (Subregion ri rj) ->
      constraint_closure Ω (Disjoint rj rk) ->
      constraint_closure Ω (Disjoint ri rk)
  | Cc_disj_symm Ω ri rj :
      constraint_closure Ω (Disjoint ri rj) ->
      constraint_closure Ω (Disjoint rj ri)
.

Inductive privilege_closure : Omegas -> Phis -> priv_T -> Prop :=
  | Pc_in Ω Φ P : In P Φ -> privilege_closure Ω Φ P
  | Pc_sub_reads Ω Φ ri rj :
      constraint_closure Ω (Subregion ri rj) ->
      privilege_closure Ω Φ (Reads rj) ->
      privilege_closure Ω Φ (Reads ri)
  | Pc_sub_writes Ω Φ ri rj :
      constraint_closure Ω (Subregion ri rj) ->
      privilege_closure Ω Φ (Writes rj) ->
      privilege_closure Ω Φ (Writes ri)
  | Pc_sub_reduces Ω Φ id ri rj :
      constraint_closure Ω (Subregion ri rj) ->
      privilege_closure Ω Φ (Reduces id rj) ->
      privilege_closure Ω Φ (Reduces id ri)
  | Pc_rw_reduces Ω Φ r id :
      privilege_closure Ω Φ (Reads r) ->
      privilege_closure Ω Φ (Writes r) ->
      privilege_closure Ω Φ (Reduces id r)
.

(* Substitutes regions in types parametrized over regions *)
Definition subst_regions (t : T) (rs' : list region) :=
  match t with
  | TBool | TInt | TTuple _ | TColoring _ => t
  | TPointer t rs => TPointer t rs'
  | TRegionRelation rs t Ω => TRegionRelation rs' t Ω
  | TTask rs ts Φ Q tr => TTask rs' ts Φ Q tr
  end.

(* ⊢ *)
Inductive typed : Gammas -> Phis -> Omegas -> expr -> T -> Prop :=
  (* Figure 4, page 8 *)
  | T_Read Γ Φ Ω e1 t rs :
      typed Γ Φ Ω e1 (TPointer t rs) ->
      (forall (r:region), In r rs -> privilege_closure Ω Φ (Reads r)) ->
      typed Γ Φ Ω (Read e1) t
  | T_Write Γ Φ Ω e1 e2 t rs :
      typed Γ Φ Ω e1 (TPointer t rs) ->
      typed Γ Φ Ω e2 t ->
      (forall (r : region), In r rs -> privilege_closure Ω Φ (Writes r)) ->
      typed Γ Φ Ω (Write e1 e2) (TPointer t rs)
  | T_Reduce Γ Φ Ω id e1 e2 t1 t2 rs :
      Γ id = Some (TTask rs [t1; t2] [] [] t1) ->
      typed Γ Φ Ω e1 (TPointer t1 rs) ->
      typed Γ Φ Ω e2 t2 ->
      (forall (r : region), In r rs -> privilege_closure Ω Φ (Reduces id r)) ->
      typed Γ Φ Ω (Reduce id e1 e2) (TPointer t1 rs)
  | T_New Γ Φ Ω t r :
      typed Γ Φ Ω (NewPointer t r) (TPointer t [r])
  | T_UpRgn Γ Φ Ω e t rs rs' :
      typed Γ Φ Ω e (TPointer t rs') ->
      (forall ri : region, forall rj' : region,
        In ri rs -> In rj' rs' -> constraint_closure Ω (Subregion ri rj')) ->
      typed Γ Φ Ω (Upregion e rs) (TPointer t rs)
  | T_DnRgn Γ Φ Ω e t rs rs' :
      typed Γ Φ Ω e (TPointer t rs') ->
      typed Γ Φ Ω (Downregion e rs) (TPointer t rs)
  | T_NewColor Γ Φ Ω r :
      typed Γ Φ Ω (NewColor r) (TColoring r)
  | T_Color Γ Φ Ω e1 e2 e3 t r :
      typed Γ Φ Ω e1 (TColoring r) ->
      typed Γ Φ Ω e2 (TPointer t [r]) ->
      typed Γ Φ Ω e3 TInt ->
      typed Γ Φ Ω (Color e1 e2 e3) (TColoring r)
  | T_Partition Γ Φ Ω Ω' e1 e2 rp rs t :
      typed Γ Φ Ω e1 (TColoring rp) ->
      Ω' = (let cd := constraint_dec in set_union cd
            (set_union cd Ω (set_map cd (fun r => Subregion r rp) rs))
            (set_diff cd
              (set_map cd (fun rr => Disjoint (fst rr) (snd rr)) (set_prod rs rs))
              (set_map cd (fun rr => Disjoint rr rr) rs))) ->
      typed Γ Φ Ω' e2 t ->
      (* (forall r, (exists id, Γ id = r) -> ~ (In rs r)) -> *)
      (* set_inter rs regions_of(Γ,t) *)
      typed Γ Φ Ω' (Partition rp e1 rs e2) t
  | T_Pack Γ Φ Ω Ω1 e1 rs rs' t1 t2 :
      t1 = (TRegionRelation rs' t2 Ω1) ->
      (* Ω1[rs' / rs] ⊆ Ω* -> *)
      typed Γ Φ Ω e1 (subst_regions t2 rs') ->
      typed Γ Φ Ω (Pack e1 t1 rs) (subst_regions t2 rs')
  | T_Unpack Γ Γ' Φ Ω Ω' Ω1 e1 e2 id rs rs' t1 t2 t3 :
      t1 = (TRegionRelation rs' t2 Ω1) ->
      typed Γ Φ Ω e1 t1 ->
      Γ' = add_mapping Id_T_dec Γ id (subst_regions t2 rs) ->
      Ω' = Ω (* ∪ (add_mappings Ω1 rs) *) ->
      typed Γ' Φ Ω' e2 t3 ->
      (* what is regions_of(Γ, T1, T3)? *)
      typed Γ Φ Ω (Unpack e1 id t1 rs e2) t3
  | T_Call Γ Φ Φ' Ω es id rs rs' Q' tr ts :
      Γ id = Some (TTask rs' ts Φ' Q' tr) ->
      all_typed_subst Γ Φ Ω es ts rs ->
      (* Φ′[r1/r′1,...,rk/r′k]⊆Φ∗ *)
      typed Γ Φ Ω (Call id rs es) (subst_regions tr rs)
with
  all_typed_subst : Gammas -> Phis -> Omegas -> list expr -> list T -> list region -> Prop :=
  | all_typed_subst_empty Γ Φ Ω rs :
      all_typed_subst Γ Φ Ω [] [] rs
  | all_typed_subst_nonempty Γ Φ Ω e1 es t1 ts rs :
      all_typed_subst Γ Φ Ω es ts rs ->
      typed Γ Φ Ω e1 (subst_regions t1 rs)->
      all_typed_subst Γ Φ Ω (e1::es) (t1::ts) rs
.

(* Evaluation rules *)

Definition oset_mem {X Y : Type} dec (m : partial_map X (set Y)) (x : X) (a:Y) :=
  match m x with
  | Some s => set_mem dec a s
  | None => false
  end.

(* ↦ *)
Inductive eval : Ms -> Ls -> Hs -> Ss -> ClobberSet -> expr -> value -> Es -> Prop :=
  (* Trivial evaluation rules from page 23 *)
  | E_Bool (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (b:bool) :
      eval M L H S C (EBool b) (VBool b) []
  | E_Int (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (i:nat) :
      eval M L H S C (EInt i) (VInt i) []
  | E_Tuple (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (es : list expr) (vs : list value) (E : Es) (n:nat)
      (z1 : eval M L H S C (Tuple es) (VTuple vs) E) :
      eval M L H S C (ExprIndex (Tuple es) n) (nth n vs default_val) E

  | E_MakeTuple (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (es : list expr) (vs : list value) (Elist : list Es) (E' : Es)
      (zvalid : valid_interleave S C E' Elist)
      (zeval : eval_chain M L H S C es vs Elist) :
    eval M L H S C (Tuple es) (VTuple vs) (last Elist default_E)

  | E_Var (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (id : Id_T) (v : value)
      (z1 : L id = Some v) :
    eval M L H S C (Id id) v []

  | E_Let (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e1 : expr) (v1 : value) (E1 : Es)
      (id : Id_T) (t : T)
      (L' : Ls) (S' : Ss) (e2 : expr) (v2 : value) (E2 : Es) (E' : Es)
      (zvalid : valid_interleave S C E' [E1; E2])
      (* L' = L[v1 / id] *):
    eval M L H S C (LetIn id t e1 e2) v2 E'

  | E_Add (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e1 : expr) (E1 : Es)
      (S' : Ss) (e2 : expr) (E2 : Es) (E' : Es)
      (v' : value) (i1 : nat) (i2 : nat) (i' : nat)
      (zeval1 : eval M L H S C e1 (VInt i1) E1)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S' C e2 (VInt i2) E2)
      (z' : v' = VInt i')
      (zplus : i' = i1 + i2)
      (zvalid : valid_interleave S C E' [E1; E2]) :
    eval M L H S C (Add e1 e2) v' E'

  | E_Compare (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e1 : expr) (v1 : value) (E1 : Es)
      (S' : Ss) (e2 : expr) (v2 : value) (E2 : Es) (E' : Es)
      (v' : value) (i1 : nat) (i2 : nat) (b : bool)
      (zeval1 : eval M L H S C e1 (VInt i1) E1)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S' C e2 (VInt i2) E2)
      (z' : v' = VBool b)
      (zltb : b = ltb i1 i2)
      (zvalid : valid_interleave S C E' [E1; E2]) :
    eval M L H S C (Compare e1 e2) v' E'

  | E_IsNull_F (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e : expr) (l : location) (E : Es)
      (zeval : eval M L H S C e (VLocation l) E) :
    eval M L H S C (IsNull e) (VBool false) E

  | E_IsNull_T (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e : expr) (l : location) (E : Es)
      (zeval : eval M L H S C e (VNull) E) :
    eval M L H S C (IsNull e) (VBool true) E

  | E_IfElse_F (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e1 : expr) (E1 : Es)
      (S' : Ss) (e2 : expr) (e3 : expr) (v3 : value) (E3 : Es)
      (zeval1 : eval M L H S C e1 (VBool false) E1)
      (zapply : S' = apply S E1)
      (zeval3 : eval M L H S' C e3 (v3) E3) :
    eval M L H S C (If e1 e2 e3) v3 (E1 ++ E3)

  | E_IfElse_T (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e1 : expr) (E1 : Es)
      (S' : Ss) (e2 : expr) (e3 : expr) (v2 : value) (E2 : Es)
      (zeval1 : eval M L H S C e1 (VBool true) E1)
      (zapply : S' = apply S E1)
      (zeval3 : eval M L H S' C e2 (v2) E2) :
    eval M L H S C (If e1 e2 e3) v2 (E1 ++ E2)

  (* Main rules, from page 8 *)
  | E_Read (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e : expr) (l : location) (E : Es)
      (S' : Ss) (v : value) (v' : value)
      (zeval : eval M L H S C e (VLocation l) E)
      (zapply : S' = apply S E)
      (zv : Some v = if set_mem loc_dec l C then S' l else Some v' (* : H(l) *) ):
    eval M L H S C (Read e) v (E ++ [SRead l SExcl v 0])

  | E_Write (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (e1 : expr) (l : location) (E1 : Es) (S' : Ss)
      (e2 : expr) (v : value) (E2 : Es) (E' : Es)
      (zeval1 : eval M L H S C e1 (VLocation l) E1)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S C e2 v E2)
      (zvalid : valid_interleave S C E' [E1; E2]) :
    eval M L H S C (Write e1 e2) (VLocation l) (E' ++ [SWrite l SExcl v 0])

  | E_Reduce (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (e1 : expr) (l : location) (E1 : Es) (S' : Ss)
      (e2 : expr) (v : value) (E2 : Es) (E' : Es)
      (id : Id_T)
      (zeval1 : eval M L H S C e1 (VLocation l) E1)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S C e2 v E2)
      (zvalid : valid_interleave S C E' [E1; E2]) :
    eval M L H S C (Reduce id e1 e2) (VLocation l) (E' ++ [SReduce id l SExcl v 0])

  | E_New (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (l : location) (r : region)
      (t : T)
      (zincl : match (M r) with | Some rho => In l rho | None => False end)
      (* znotls : l not in domain S *)
      (zheap : H l = Some TBool (* should be H l = M[[t]] somehow? *) ):
    eval M L H S C (NewPointer t r) (VLocation l) []

  | E_UpRgn (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e : expr) (v : value) (E : Es)
      (rs : list region)
      (zeval : eval M L H S C e v E) :
    eval M L H S C (Upregion e rs) v E

  | E_DnRgn (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (e : expr) (v : value) (E : Es)
      (l : location)
      (rs : list region)
      (zeval : eval M L H S C e v E)
      (zv : v = if (existsb (fun ri => oset_mem loc_dec M ri l) rs)
        then (VLocation l) else VNull) :
    eval M L H S C (Downregion e rs) v E

  | E_NewColor (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (r : region) (K : list (location * nat))
      (zm : forallb (fun lk => oset_mem loc_dec M r (fst lk)) K = true )
      (zdistinct: forall i j,
        (i >= 1 /\ i <= length K /\ j >= 1 /\ j <= length K /\ i <> j) ->
        fst (nth i K (default_loc, 0)) <> fst (nth j K (default_loc, 0))) :
    eval M L H S C (NewColor r) (VColoring K) []

  | E_Color (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (e1 : expr) (K : list (location * nat)) (E1 : Es) (S' : Ss)
      (e2 : expr) (l : location) (E2 : Es)
      (e3 : expr) (v : value) (E3 : Es) (E' : Es) (S'' : Ss)
      (K' : list (location * nat))
      (* (zK' : K' = (l, v) :: li, vi for li, vi in K if l <> li) *)
      (zeval1 : eval M L H S C e1 (VColoring K) E1)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S C e2 (VLocation l) E2)
      (zapply' : S'' = apply S E2)
      (zeval3 : eval M L H S C e3 v E3)
      (zvalid : valid_interleave S C E' [E1; E2; E3]) :
    eval M L H S C (Color e1 e2 e3) (VColoring K') E'

  | E_Partition  (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (rp : region)
      (e1 : expr) (K : list (location * nat)) (E1 : Es) (S' : Ss)
      (rs : list region) (rhos : list physical_region) (e2 : expr)
      (v : value) (E2 : Es) (E' : Es)
      (zeval1 : eval M L H S C e1 (VColoring K) E1)
      (zrhos: forall i : nat, i >= 1 /\ i <= length rhos ->
        forall l : location, set_In l (nth i rhos []) <-> set_In (l, i) K)
      (zapply : S' = apply S E1)
      (zeval2 : eval M L H S C e2 v E2)
      (zvalid : valid_interleave S C E' [E1; E2])
    : eval M L H S C (Partition rp e1 rs e2) v E'

  | E_Pack (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (e1 : expr) (v : value) (E : Es) (rhos : list physical_region) (rs : list region)
      (t1 : T) (v' : value)
      (zeval1 : eval M L H S C e1 v E)
      (zrhos : map Some rhos = map M rs)
      (zv' : v' = VRegionRelationInstance rhos v)
    : eval M L H S C (Pack e1 t1 rs) v' E

  | E_Unpack  (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet)
      (e1 : expr) (rhos : list physical_region) (v1 : value) (E1 : Es)
      (M' : Ms) (rs : list region)
      (L' : Ls) (id : Id_T) (S' : Ss)
      (e2 : expr) (t : T)
      (v2 : value) (E2 : Es) (E' : Es)
      (zeval1 : eval M L H S C e1 (VRegionRelationInstance rhos v1) E1)
      (zM' : M' = add_mappings region_eq_neq M rs rhos)
      (zL' : L' = add_mapping Id_T_dec L id v1)
      (zapply : S' = apply S E1)
      (zvalid : valid_interleave S C E' [E1; E2])
    : eval M L H S C (Unpack e1 id t rs e2) v2 E'

  | E_Call (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) (rs : list region)
      (aas : list Id_T) (rs' : list region)
      ( es : list expr) (vs : list value) (Elist : list Es) (Slist : list Ss)
      (M' : Ms) (L' : Ls) (S' : Ss) (C' : ClobberSet) (E' : Es) (Q' : Qs) (id : Id_T)
      (enp1 : expr) (vnp1 : value) (E'' : Es) (Enp1 : Es) (Enp1' : Es) (taskid : Task_ID)
      (zeval_chain : eval_chain_call M L H Slist C es vs Elist)
      (zS : S = hd default_S Slist)
      (zvalid : valid_interleave S C E' Elist)
      (zfunction : True) (* TODO fix *)
      (zM' : M' = add_mappings region_eq_neq (@empty region physical_region) rs'
                    (map (fun r => match M r with | Some rho => rho | None => [] end) rs))
      (zL' : L' = add_mappings Id_T_dec (@empty Id_T value) aas vs )
      (zapply : S' = apply S E')
      (zC' : True)   (* TODO: fix *)
      (zeval_np1 : eval M' L' H S' C' enp1 vnp1 Enp1)
      (zEnp1' : Enp1 = mark_coherence M' Enp1 Q' taskid) (* taskid fresh *)
      (zvalid' : valid_interleave S C E'' [E'; Enp1'])
    : eval M L H S C (Call id rs es) vnp1 E''
with
  (* needed for E_MakeTuple *)
  eval_chain : Ms -> Ls -> Hs -> Ss -> ClobberSet ->
    list expr -> list value -> list Es -> Prop :=
  | eval_chain_empty (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) :
    eval_chain M L H S C [] [] []
  | eval_chain_nonempty (M:Ms) (L:Ls) (H:Hs) (S0:Ss) (C:ClobberSet)
      (e1 : expr) (v1 : value) (E1 : Es)
      (es : list expr) (vs : list value) (Elist : list Es)
    (z1 : let S1 := apply S0 E1 in eval M L H S1 C e1 v1 E1 /\
      eval_chain M L H S1 C es vs Elist) :
      eval_chain M L H (apply S0 E1) C (e1::es) (v1::vs) (E1::Elist)
with
  eval_chain_call : Ms -> Ls -> Hs -> list Ss -> ClobberSet ->
    list expr -> list value -> list Es -> Prop :=
  | eval_chain_call_empty (M:Ms) (L:Ls) (H:Hs) (S:Ss) (C:ClobberSet) :
    eval_chain_call M L H [] C [] [] []
  | eval_chain_call_nonempty (M:Ms) (L:Ls) (H:Hs) (S1:Ss) (C:ClobberSet)
      (e1 : expr) (v1 : value) (E1 : Es)
      (Slist : list Ss) (es : list expr) (vs : list value) (Elist : list Es)
    (z1 : eval M L H S1 C e1 v1 E1 /\ eval_chain_call M L H Slist C es vs Elist) :
      eval_chain_call M L H (S1::Slist) C (e1::es) (v1::vs) (E1::Elist)
.

Check eval.

(* alternate Fixpoint version of eval_chain
    match es, vs, Elist with
    | [] , [] , [] => True
    | e1::es', v1 :: vs', E1 :: Elist' =>
      let S1 := apply S0 E1 in
      eval M L H S0 C e1 v1 E1 /\ eval_chain M L H S1 C es' vs' Elist'
    | _, _ => False
    end
*)

(* used in theorem 1, 3 *)
(* E :M Φ *)
Definition privileges_cover_ops (E:Es) (M:Ms) (Φ:Phis) : Prop :=
  forall ep, In ep E -> match ep with
  | SRead l _ _ _ =>
      exists r mr, M r = Some mr /\ In l mr /\ In (Reads r) Φ
  | SWrite l _ _ _ =>
      exists r mr, M r = Some mr /\ In l mr /\ In (Writes r) Φ
  | SReduce id l _ _ _ =>
      exists r mr, M r = Some mr /\ In l mr /\ In (Reduces id r) Φ
  end.


Require Export assetmapping_spl_def.
Require Export featuremodel_spl_def.
Require Export cktrans_spl_def.
Require Export spl_int.
Require Export assetmapping_spl_int.
Require Export assetmapping_spl_inst.

Require Export featuremodel_spl_int.
Require Export featuremodel_spl_inst.
Require Export featuremodel_spl_proofs.

Require Export cktrans_spl_int.
Require Export cktrans_spl_proofs.
Require Export cktrans_spl_inst.

Require Export maps_proofs.
Require Export maps_int.
Require Export maps_def.
Require Export maps_inst.

Require Export spl_def.
Require Export spl_proofs.

Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.
Import Maps.
Import CKTransSPL.
Import FeatureModelSPL.
Import AssetMappingSPL.
Import SPL.

Program Instance Ins_SPL {FMs: FeatureModel FM Conf}
         {AssetM : AssetMapping Asset AssetName AM}
         {ckTrans: CKTrans FM Asset AM CK Conf}
         {spl: SPL Asset Conf FM AM CK ArbitrarySPL} :
           SPL Asset Conf FM AM CK PL :=
{
  getFM:= getFM_func;
  getAM:= getAM_func;
  getCK:= getCK_func;
  getCk:= getCk_func;
  genPL:= genPL_func;
  genPLCK := genPLCK_func;
  gerPL:= gerPL_func;
  wfPL := wfPL_func;
  plRefinement:= plRefinement_func;
  products:= products_func;
  plRefinementAlt:= plRefinementAlt_func;
  subsetProducts:= subsetProducts_func;
  plWeakRefinement:= plWeakRefinement_func;
  strongerPLRefinement:= strongerPLrefinement_func;

}.
 Next Obligation. {(*fmEquivalenceCompositionality*)
  intros.
    split.
    + unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl.  unfold getFM_func in H0. destruct pl in H0.
         simpl in H0. destruct pls0 in H0. simpl in H0. destruct p. simpl in H0.
         rewrite f in H0. rewrite fm. apply H0.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
    + unfold wfPL_func. intros.
      unfold equivalentFMs in H. intuition.
} Qed. Next Obligation. {(*weakFMcompositionality*)
  intros.
    unfold plRefinement_func.
    intros. exists c1.  split.
      +  unfold getFM_func. simpl.  unfold getFM_func in H1. destruct pl in H1.
        simpl in H1. destruct pls0 in H1. simpl in H1. destruct p. simpl in H1.  rewrite f in H1.
        rewrite fm. apply H1.
      + unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.

} Qed. Next Obligation. {(*ckEquivalenceCompositionality*)
  intros.
    split.
    + unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl.  unfold getFM_func in H0. destruct pl in H0.
        simpl in H0. destruct pls0 in H0. simpl in H0. destruct p. simpl in H0.
        destruct fm, f. apply H0.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
     + unfold wfPL_func. intros.
      unfold equivalentFMs in H.
      intuition.

} Qed. Next Obligation. {(*weakerCKcompositionality*)
 intros.
    split.
    + unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl.  unfold getFM_func in H0. destruct pl in H0.
        simpl in H0. destruct pls0 in H0. simpl in H0. destruct p. simpl in H0.  rewrite f in H0.
        rewrite fm. apply H0.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
    + unfold wfPL_func. intros.
      unfold equivalentFMs in H.
      intuition.
} Qed. Next Obligation. {(*amRefinementCompositionality*)
   intros.
    split.
    + unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl.  unfold getFM_func in H0. destruct pl in H0.
        simpl in H0. destruct pls0 in H0. simpl in H0. destruct p. simpl in H0.  rewrite f in H0.
        rewrite fm. apply H0.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
    + unfold wfPL_func. intros.
      unfold equivalentFMs in H.
      intuition.

} Qed. Next Obligation. {(*fullCompositionality*)
   intros.
    split.
    +  unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl. unfold getFM_func in H2.
        simpl in H2. destruct pl in H2. simpl in H2.
        destruct pls0 in H2. simpl in H2. destruct p. simpl in H2.
        destruct fm. rewrite f in H2. apply H2.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
    + unfold wfPL_func. intros.
      unfold equivalentFMs in H.
      intuition.

} Qed. Next Obligation.
{(*weakFullCompositionality*)

 intros.
    unfold plRefinement_func.
    intros. exists c1.  split.
      +  unfold getFM_func. simpl.  unfold getFM_func in H2. destruct pl in H2.
        simpl in H2. destruct pls0 in H2. simpl in H2. destruct p.
        simpl in H2.  rewrite f in H2.
        rewrite fm. apply H2.
      + unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.

} Qed. Next Obligation.
{(*fullCompositionality2*)
 intros.
    split.
    +  unfold plRefinement_func. intros. exists c1. split.
      -  unfold getFM_func. simpl. unfold getFM_func in H2.
        simpl in H2. destruct pl in H2. simpl in H2. destruct pls0 in H2. simpl in H2. destruct p.
        simpl in H2.  destruct fm. rewrite f in H2. apply H2.
      - unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.
    + unfold wfPL_func. intros.
      unfold equivalentFMs in H.
      intuition.

} Qed. Next Obligation. { (*weakFullCompositionality2*)
 intros.
    unfold plRefinement_func.
    intros. exists c1.  split.
      +  unfold getFM_func. simpl.  unfold getFM_func in H2. destruct pl in H2.
        simpl in H2. destruct pls0 in H2. simpl in H2. destruct p.
        simpl in H2.  rewrite f in H2.
        rewrite fm. apply H2.
      + unfold getCK_func. unfold getAM_func. simpl.
        apply assetRefinementReflexivity_axiom.

}  Qed. Next Obligation.
{(*plRefAlt*)
  split.
        + intros.  apply equalsRefinementAlt. reflexivity.
        + intros. destruct H. unfold plRefinementAlt in H. unfold plRefinementAlt_func.
          intros p3 H1.
           specialize (H p3). apply H in H1. destruct H1. unfold plRefinementAlt_func in H0.
           specialize (H0 x). destruct H1. apply H0 in H1.
           destruct H1. destruct H1.  exists x0.  split.
            - apply H1.
            - generalize H2, H3. apply assetRefinementTranstivity_axiom.

} Qed. Next Obligation.
{(*strongerPLref*)
  intros.
    split.
    + apply equalsStrongerPL. reflexivity.
    + unfold strongerPLrefinement_func. intros. destruct H. specialize (H c). specialize (H1 c).
      destruct c. apply H in H0. destruct H0.
      split.
      - apply H1 in H0. destruct H0. apply H0.
      -  apply H1 in H0. destruct H0.  generalize H3. generalize H2. apply assetRefinementTranstivity_axiom.

} Qed. Next Obligation.
{(*plRef*)
  intros.
      split.
      + apply equalsPL. reflexivity.
      + unfold plRefinement_func. intros. destruct H. specialize (H c1).
        specialize (H1 c1). destruct c1. apply H in H0. destruct H0.
        destruct H0. destruct x. apply H1 in H0. destruct H0. destruct H0.
        exists x. split.
        - apply H0.
        - generalize H3. generalize H2. apply assetRefinementTranstivity_axiom.

} Qed.


Set Implicit Arguments.

Require Import Platform.Cito.CModule.
Require Import Platform.Cito.GoodModuleDec.
Require Import Platform.Cito.GoodModule.
Require Import Platform.Cito.GoodFunction.

Definition cfun_to_gfun (name : string) (f : CFun) : GoodFunction.
  refine (Build_GoodFunction (Build_Func name f) _).
  destruct f; simpl in *.
  Require Import Platform.Cito.GoodModuleDecFacts.
  eapply is_good_func_sound; eauto.
Defined.

Require Import Platform.Cito.StringMap.
Require Import Platform.Cito.StringMapFacts.

Definition cfuns_to_gfuns (fs : StringMap.t CFun) : list GoodFunction := List.map (uncurry cfun_to_gfun) (StringMap.elements fs).

Require Import Platform.Cito.NameDecoration.

Lemma cfuns_to_gfuns_nodup fs : NoDup (List.map (fun (f : GoodFunction) => SyntaxFunc.Name f) (cfuns_to_gfuns fs)).
Proof.
  unfold cfuns_to_gfuns.
  rewrite map_map.
  simpl.
  eapply NoDup_elements; eauto.
Qed.

Definition cmodule_to_gmodule name (H : is_good_module_name name = true) (m : CModule) : GoodModule.GoodModule.
  refine (@Build_GoodModule name _ (cfuns_to_gfuns (Funs m)) _).
  eapply is_good_module_name_sound; eauto.
  eapply cfuns_to_gfuns_nodup.
Defined.

Lemma NoDup_ArgVars (f : CFun) : NoDup (ArgVars f).
Proof.
  destruct f; simpl.
  Require Import Platform.Cito.GoodModuleDecFacts.
  eapply is_good_func_sound in good_func.
  destruct good_func.
  eauto.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import quiztree.
Require Import part.
Require Import znat.
Require Import discharge.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Ruling out a part using a combination of discharging and reducibility.    *)
(* In principle, this brings together almost all the elements of the proof   *)
(* development, so for modularity we only import a predicate on parts from   *)
(* the reducibility half, with the assumption that it is always false when   *)
(* the part fits the map. We'll tie up everithing in present.v (anyway,      *)
(* we can't really use the reducibility check in recursive functions, that   *)
(* causes the recursion check to diverge).                                   *)

(* The hubcap concrete syntax is used directly in the source file, so the    *)
(* sector indices start at 1 in the concrete syntax, and are shifted by the  *)
(* parsing and pretty-printing. An additional shift by 2 is done during the  *)
(* verification, to line up with the rules.                                  *)

(* We also define a simpler source cap check, which is used in present12.v   *)
(* to exclude hub sizes greater than 11 (using lemma dscore_cap1).           *)

(* The sequence structure of hubcaps is compressed, not for speed, but to    *)
(* save space in the large proofs generated by the presentation scripts.     *)

Inductive hubcap : Set :=
  | Hubcap0
  | Hubcap1 (j : nat) (b : znat) (hc : hubcap)
  | Hubcap2 (j1 j2 : nat) (b : znat) (hc : hubcap).

Module HubcapSyntax.

Notation "'[]'" := Hubcap0 (at level 8).
Notation "'T' [ j1 ] '<=' b h" := (Hubcap1 (pred j1) (Zpos b) h)
  (at level 8, j1, b at level 0, h at level 9,
   format "'T' [ j1 ] '<=' b  h").
Notation "'T' [ j1 ] '<=' ( - b ) h" := (Hubcap1 (pred j1) (- (Zpos b)) h)
  (at level 8, j1, b at level 0, h at level 9,
   format "'T' [ j1 ] '<=' ( - b )  h").
Notation "'T' [ j1 , j2 ] '<=' b h" := (Hubcap2 (pred j1) (pred j2) (Zpos b) h)
  (at level 8, j1, j2, b at level 0, h at level 9,
   format "'T' [ j1 , j2 ] '<=' b  h").
Notation "'T' [ j1 , j2 ] '<=' ( - b ) h" :=
     (Hubcap2 (pred j1) (pred j2) (- (Zpos b)) h)
  (at level 8, j1, j2, b at level 0, h at level 9,
   format "'T' [ j1 , j2 ] '<=' ( - b )  h").

End HubcapSyntax.

Section Hubcap.

Variables (nhub : nat) (redp : part -> bool) (rf : drule_fork nhub).
Let rs0 := source_drules rf.
Let rt0 := target_drules rf.

Variable g : hypermap.
Hypothesis Hg : plain_cubic_pentagonal g.
Let HgF : pentagonal g := Hg.
Hypothesis Hredp : forall (x : g) p, redp p -> negb (exact_fitp x p).

(* Source bound checking.                                                   *)

Fixpoint check_dbound1_rec (p : part) (rs : drules) (ns m : nat) {struct m}
                       : bool :=
  if m is S m' then
    if rs is Adds r rs' then
      if size rs' < ns then true else
      let p' := meet_part p r in
      (let: SortDrules dns rs'' := sort_drules p' rs' in
       if ns - dns is S ns' then check_dbound1_rec p' rs'' ns' m' else redp p')
      && check_dbound1_rec p rs' ns m'
    else true
  else false.

Definition check_dbound1 p ns :=
  let: DruleFork rs _ _ := rf in check_dbound1_rec p rs ns (size rs + 1).

Lemma check_dbound1P : forall (x : g) p ns,
 arity x = nhub -> exact_fitp x p -> check_dbound1 p ns -> dbound1 rs0 x <= ns.
Proof.
move=> x p ns Hxn; rewrite /check_dbound1 /rs0 /source_drules.
case: rf => rs _ _; move: (size rs + 1) => m.
elim: m ns rs p => // [m Hrec] ns [|r rs] //= p Hxp.
case Hns: (size rs < ns).
  clear; apply: leq_trans Hns.
  by rewrite -add1n; apply leq_add2; [ case (fitp x r) | apply: count_size ].
set p' := meet_part p r; case/andP{Hn}.
case Hxr: (fitp x r); last by clear; apply: Hrec => //=; rewrite Hxr.
have Exp': exact_fitp x p' by apply: exact_fitp_meet.
case/andP: (Exp') => _ Hxp'.
case: (sort_drulesP Hxp' rs) => [dns rs'].
case Dns': (ns - dns) => [|ns']; first by move=> *; case/idPn: Exp'; auto.
have Hns': dns < ns by rewrite ltn_lt0sub Dns'.
move=> Hrsp' _; rewrite -(leq_add_sub (ltnW Hns')) Dns' /=.
rewrite add1n addnS ltnS leq_add2l; eauto.
Qed.

Fixpoint check_unfit (p : part) (ru : drules) {struct ru} : bool :=
  if ru is Adds r ru' then
    if cmp_part p r is Psubset then true else check_unfit p ru'
  else false.

Lemma check_unfitP : forall (x : g) p, fitp x p -> forall ru,
  dbound1 ru x = 0 -> check_unfit p ru = false.
Proof.
move=> x p Hxp; elim=> [|r ru Hrec] //=.
case Hxr: (fitp x r) => // Hru; rewrite {Hrec Hru}(Hrec Hru).
by rewrite (fitp_cmp Hxp) in Hxr; case: (cmp_part p r) Hxr.
Qed.

(* Single target bound checking.                                               *)

Fixpoint check_dbound2_rec (p : part) (rt rs ru : drules) (nt m : nat) {struct m}
                         : bool :=
  if m is S m' then
    if rt is Adds r rt' then
      if size rt' < nt then true else
      let p' := meet_part p r in
      (if check_unfit p' ru then true else
       let: SortDrules dnt rt'' := sort_drules p' rt' in
       let: SortDrules dns rs' := sort_drules p' rs in
       if dns + nt - dnt is S nt' then
          check_dbound2_rec p' rt'' rs' ru nt' m'
       else redp p')
      && check_dbound2_rec p rt' rs (Adds r ru) nt m'
    else true
  else false.

Definition check_dbound2 p b :=
  let: DruleFork rs rt _ := rf in
  let: SortDrules dnt rt' := sort_drules p rt in
  let: SortDrules dns rs' := sort_drules p rs in
  if (dns - dnt + b)%Z is Zpos nt then
    check_dbound2_rec p rt' rs' seq0 nt (size rt' + 2)
  else false.

Lemma check_dbound2P : forall (x : g) p b, arity x = nhub ->
  exact_fitp x p -> check_dbound2 p b -> (dbound2 rt0 rs0 x <= b)%Z.
Proof.
move=> x p b Hxn Exp; rewrite /check_dbound2 /dbound2; case/andP: (Exp) => _ Hxp.
rewrite /rs0 /rt0 /source_drules /target_drules; case: rf => rs rt _.
set ru : drules := seq0; have Hru: dbound1 ru x = 0 by done.
case: {rt}(sort_drulesP Hxp rt)=> dnt rt; set m := size rt + 2.
case: {rs Hxp}(sort_drulesP Hxp rs) => dns rs Hp.
rewrite !zpos_addn -addzA addzCA /leqz -addzA -oppz_sub leqzI oppz_sub.
rewrite addzC -!addzA addzCA (addzA dns).
case: {dns dnt b}(dns - dnt + b)%Z Hp => // nt; rewrite -zpos_addn leqz_nat.
elim: {rt}m nt (rt) rs ru Hru p Exp => // [m Hrec] nt.
case=> //= [r rt] rs ru Hru p Exp; case Hnt: (size rt < nt).
  clear; apply: (leq_trans _ (leq_addl _ _)); apply: leq_trans Hnt.
  by rewrite -add1n; apply leq_add2; [ case (fitp x r) | apply: count_size ].
set p' := meet_part p r; case/andP{Hnt}.
case Hxr: (fitp x r); last by clear; apply: Hrec => //=; rewrite Hxr.
have Exp': exact_fitp x p' by apply: exact_fitp_meet.
case/andP: (Exp') => [_ Hxp'] Hp'rt _; move: Hp'rt.
rewrite (check_unfitP Hxp' Hru).
case: {rt}(sort_drulesP Hxp' rt) => [dnt rt].
case: {Hxp' rs}(sort_drulesP Hxp' rs) => [dns rs].
case Dnt': (subn (addn dns nt) dnt) => [|nt'].
  by move=> *; case/idPn: Exp'; auto.
have Hnt': dnt < dns + nt by rewrite ltn_lt0sub Dnt'.
move=> Hrp'; rewrite -!addnA (addnCA dns) -(leq_add_sub (ltnW Hnt')) Dnt' /=.
rewrite !(addnC dnt) !addnA leq_add2r addnS add1n ltnS; eauto.
Qed.

(* Dual target bound check.                                                      *)

Fixpoint check_2dbound2_rec
          (p1 p2 : part) (rt1 rs1 ru1 rt2 rs2 ru2 : drules) (i nt m : nat)
           {struct m} : bool :=
  if m is S m' then
    if rt1 is Adds r rt1' then
      if size rt1' + size rt2 < nt then true else
      let p1' := meet_part p1 r in
      let p2' := rot_part i p1' in
      (if check_unfit p1' ru1 || check_unfit p2' ru2 then true else
       let: SortDrules dnt1 rt1'' := sort_drules p1' rt1' in
       let: SortDrules dns1 rs1' := sort_drules p1' rs1 in
       let: SortDrules dnt2 rt2' := sort_drules p2' rt2 in
       let: SortDrules dns2 rs2' := sort_drules p2' rs2 in
       if dns1 + (dns2 + nt) - (dnt1 + dnt2) is S nt' then
         check_2dbound2_rec p1' p2' rt1'' rs1' ru1 rt2' rs2' ru2 i nt' m'
       else redp p1')
      && check_2dbound2_rec p1 p2 rt1' rs1 (Adds r ru1) rt2 rs2 ru2 i nt m'
    else
     if rt2 is Seq0 then true else
     check_2dbound2_rec p2 p1 rt2 rs2 ru2 rt1 rs1 ru1 (nhub - i) nt m'
  else false.

Definition check_2dbound2 p1 i b :=
  let p2 := rot_part i p1 in
  let: DruleFork rs rt _ := rf in
  let: SortDrules dnt1 rt1 := sort_drules p1 rt in
  let: SortDrules dns1 rs1 := sort_drules p1 rs in
  let: SortDrules dnt2 rt2 := sort_drules p2 rt in
  let: SortDrules dns2 rs2 := sort_drules p2 rs in
  if ((dns1 + dns2)%dnat - (dnt1 + dnt2)%dnat + b)%Z is Zpos nt then
    let m := size rt1 + (size rt2 + 3) in
    check_2dbound2_rec p1 p2 rt1 rs1 seq0 rt2 rs2 seq0 i nt m
  else false.

Lemma check_2dbound2P : forall (x : g) p i b,
    arity x = nhub -> exact_fitp x p -> i <= nhub -> check_2dbound2 p i b ->
  (dbound2 rt0 rs0 x + dbound2 rt0 rs0 (iter i face x) <= b)%Z.
Proof.
move=> x1 p1 i b Hx1n Ex1p Hi; rewrite /check_2dbound2 /dbound2.
rewrite /rs0 /rt0 /source_drules /target_drules; case: rf => rs rt _.
set ru : drules := seq0; have Hru: forall x : g, dbound1 ru x = 0 by done.
set p2 := rot_part i p1; set x2 := iter i face x1.
move: ru {2 4}ru {Hru}(Hru x1) (Hru x2) => ru1 ru2 Hru1 Hru2.
case/andP: (Ex1p); rewrite Hx1n; move/eqP=> Ep1 Hx1p.
have Ex2p: exact_fitp x2 p2 by rewrite /x2 /p2 -fitp_rot -?Ep1.
case: (sort_drulesP Hx1p rt) => [dnt1 rt1].
case: {Hx1p Ep1}(sort_drulesP Hx1p rs) => [dns1 rs1].
case/andP: (Ex2p) => [_ Hx2p].
case: {rt}(sort_drulesP Hx2p rt) => [dnt2 rt2]; move: (size rt1 + _) => m.
case: {rs Hx2p}(sort_drulesP Hx2p rs) => [dns2 rs2]; rewrite !zpos_addn => Hp.
rewrite -addzA (addzCA (- _)) -oppz_add (addzC dnt1) -addzA 2!(addzA dnt1).
rewrite -(addzA (dnt1 + _)) (addzCA (dnt1 + _)) addzA -oppz_sub.
rewrite (addzC dns1) -(addzA _ dns1) (addzA dns1) (addzC (dns1 + _)).
rewrite /leqz -addzA -oppz_add leqzI addzA -2!addzA (addzA (dns1 + _)).
case: {dns1 dns2 dnt1 dnt2 b}(dns1 + dns2 - (dnt1 + dnt2) + b)%Z Hp => // nt.
rewrite -!zpos_addn -addnA leqz_nat; move: rt2 rs2 ru2 p2 Hru2 Ex2p; rewrite {}/x2.
elim: m rt1 => // m Hrec [|r rt1] /= in nt x1 i Hx1n Hi rs1 ru1 p1 Hru1 Ex1p |- *.
  set x2 := iter i face x1; set i' := nhub - i.
  case=> // r rt; move: {r rt}(Adds r rt) => rt2 rs2 ru2 p2 Hru2 Ex2p.
  rewrite addnC addnCA -[0]/(dbound1 seq0 x1); move: rs1 ru1 p1 Hru1 Ex1p.
  have <-: iter i' face x2 = x1.
    rewrite /x2 -iter_addn addnC /i' leq_add_sub // -Hx1n; exact: iter_face_arity.
  apply: Hrec; auto; [by rewrite /x2 arity_iter_face | exact: leq_subr].
set x2 := iter i face x1 => rt2 rs2 ru2 p2 Hru2 Ex2p.
case Hnt: (size rt1 + size rt2 < nt).
  rewrite addnA => _; apply: leq_trans (leq_addl _ _); apply: leq_trans Hnt.
  rewrite -add1n -addnA; apply leq_add2; first by case (fitp x1 r).
  by apply leq_add2; apply: count_size.
set p1' := meet_part p1 r; case/andP{Hnt}.
case Hxr: (fitp x1 r);
  last by clear; rewrite /= add0n /x2; apply Hrec; rewrite //= Hxr.
have Ex1p': exact_fitp x1 p1' by apply: exact_fitp_meet.
case/andP: (Ex1p'); rewrite Hx1n; move/eqP=> Ep1' Hx1p'.
set p2' := rot_part i p1'.
have Ex2p': exact_fitp x2 p2' by rewrite /x2 /p2' -fitp_rot -?Ep1'.
case/andP: (Ex2p') => [_ Hx2p'] Hp'nt _; move: Hp'nt.
rewrite (check_unfitP Hx1p' Hru1) (check_unfitP Hx2p' Hru2) /=.
case: {rt1}(sort_drulesP Hx1p' rt1) => [dnt1 rt1].
case: {rs1 Hx1p'}(sort_drulesP Hx1p' rs1) => [dns1 rs1].
case: {rt2}(sort_drulesP Hx2p' rt2) => [dnt2 rt2].
case: {rs2 Hx2p'}(sort_drulesP Hx2p' rs2) => [dns2 rs2].
case Dnt': (dns1 + (dns2 + nt) - (dnt1 + dnt2)) => [|nt'].
  by move=> *; case/idPn: Ex1p'; auto.
have Hnt': dnt1 + dnt2 < dns1 + (dns2 + nt) by rewrite ltn_lt0sub Dnt'.
move=> Hrp'; rewrite -!addnA !(addnCA dns1) !(addnCA dns2).
rewrite -(leq_add_sub (ltnW Hnt')) {}Dnt' add1n !addnS ltnS.
rewrite -!addnA -!(addnCA dnt1) -!(addnCA dnt2) !leq_add2l /x2; eauto.
Qed.

(* Cover checking; we compute the multiset of indices in a first pass, then *)
(* check coverage.                                                          *)

Fixpoint tally_hubcap (hc : hubcap) : natseq :=
  match hc with
  | Hubcap1 i _ hc' => incr_sub (tally_hubcap hc') i
  | Hubcap2 i j _ hc' => incr_sub (incr_sub (tally_hubcap hc') i) j
  | _ => seq0
  end.

Fixpoint hubcap_cover_rec (v : natseq) (b : znat) (hc : hubcap) {struct hc}
                          : bool :=
  match hc with
  | Hubcap1 i b' hc' =>
    match sub 0 v i with
    | 1 => hubcap_cover_rec v (b' + (b' + b)) hc'
    | _ => false
    end
  | Hubcap2 i j b' hc' =>
    match sub 0 v i, sub 0 v j with
    | 2, 2 => hubcap_cover_rec v (b' + b) hc'
    | 1, 1 => hubcap_cover_rec v (b' + (b' + b)) hc'
    | _, _ => false
    end
  | Hubcap0 =>
    negb (posz b)
  end.

Definition hubcap_cover hc :=
  let b := dboundK nhub in
  let bb := decz (b + b) in
  let v := tally_hubcap hc in
  and3b (size v =d nhub) (negb (v 0)) (hubcap_cover_rec v bb hc).

Definition hubcap_rot j := rot_part (if j is S (S j') then j' else nhub + j - 2).

Lemma fit_hubcap_rot : forall (x : g) p, arity x = nhub -> exact_fitp x p ->
  forall j, j < nhub -> exact_fitp (iter j face (inv_face2 x)) (hubcap_rot j p).
Proof.
move=> x p Hxn Hxp; have Hn := (ltnW (ltnW (ltnW (HgF x)))); rewrite Hxn in Hn.
case/andP: (Hxp); rewrite Hxn; move/eqP=> Ep _.
case=> [|[|j]] Hj; rewrite -?iter_f.
- rewrite -(iter_face_arity x) Hxn -(leq_add_sub Hn) /hubcap_rot addn0.
  by rewrite /inv_face2 /= !Eface -fitp_rot -?Ep ?leq_subr.
- rewrite -(iter_face_arity x) Hxn -(leq_add_sub (ltnW Hn)) /hubcap_rot addn1.
  by rewrite subSS /inv_face2 /= Enode Eface -fitp_rot -?Ep ?leq_subr.
by rewrite /hubcap_rot /inv_face2 /= !Enode -fitp_rot -?Ep //; do 3 apply ltnW.
Qed.

Definition hub_subn i j := (if j <= i then i else i + nhub) - j.

Lemma hub_subn_hub : forall i j, i < nhub -> j < nhub -> (hub_subn i j) <= nhub.
Proof.
move=> i j Hi Hj; rewrite /hub_subn leq_sub_add.
case: (leqP j i) => Hij; first by apply: (leq_trans (ltnW Hi)); apply leq_addl.
by rewrite leq_add2r; apply ltnW.
Qed.

Lemma iter_hub_subn : forall i j, j < nhub -> forall x : g, arity x = nhub ->
  iter (hub_subn i j) face (iter j face x) = iter i face x.
Proof.
move=> i j Hj x Hxn; rewrite -iter_addn addnC /hub_subn leq_add_sub //.
  by case (j <= i); last by rewrite iter_addn -Hxn iter_face_arity.
by case Hij: (j <= i); last by apply: (leq_trans (ltnW Hj)); apply leq_addl.
Qed.

Fixpoint hubcap_fit (p : part) (hc : hubcap) {struct hc} : bool :=
  match hc with
  | Hubcap1 j b hc' =>
    check_dbound2 (hubcap_rot j p) b && hubcap_fit p hc'
  | Hubcap2 j1 j2 b hc' =>
    check_2dbound2 (hubcap_rot j1 p) (hub_subn j2 j1) b && hubcap_fit p hc'
  | Hubcap0 =>
    true
  end.

Lemma hubcap_fit_bound : forall (x : g) p hc, size_part p = nhub ->
  posz (dscore x) -> hubcap_cover hc && hubcap_fit p hc -> negb (exact_fitp x p).
Proof.
move=> x p hc Ep Hx Hhc; apply/idP => Exp; case/andP: (Exp); rewrite Ep.
move/eqP=> Hxn _; case/idPn: Hx; case/andP: Hhc; case/and3P.
set v := tally_hubcap hc; set b0 := dboundK nhub; move/eqP=> Ev Hv0 Hhc Hhcp.
pose vb (v' : natseq) := forall i, sub 0 v' i <= sub 0 v i.
have Hvb: forall v' i, vb (incr_sub v' i) -> sub 0 v' i < sub 0 v i /\ vb v'.
  move=> v' i Hv'; split; first by move: (Hv' i); rewrite sub_incr_sub set11.
  by move=> j; apply: leq_trans (Hv' j); rewrite sub_incr_sub leq_addl.
pose x' := inv_face2 x.
pose db2 (v' : natseq) (y : g) :=
  let b := dbound2 rt0 rs0 y in
  let i := findex face x' y in
  match sub 0 v' i, sub 0 v i with
  | 1, 1 => (b + b)%Z
  | n, _ => iter n (addz b) 0
  end.
have Hxx': cface x x' by rewrite 2!cface1r /x' /inv_face2 !Enode connect0.
have Edb2: forall v' i, vb (incr_sub v' i) -> i < nhub ->
    let y := iter i face x' in let b := dbound2 rt0 rs0 y in
    let is11 := (sub 0 v' i =d 0) && (sub 0 v i =d 1) in
    let bb := if is11 then (b + b)%Z else b in
    sumz (db2 (incr_sub v' i)) (cface x') = (bb + sumz (db2 v') (cface x'))%Z.
  move=> v' i Hv' Hi y b is11 bb; rewrite -Hxn (arity_cface Hxx') in Hi.
  rewrite 2!(sumz_setID (set1 y) _ (cface x')) addzA; congr addz.
    have Ex'y: setI (cface x') (set1 y) =1 set1 y.
      move=> z; rewrite /setI andbC; case: (y =P z) => // <-.
      by rewrite /y fconnect_iter.
    rewrite !(eq_sumz_r Ex'y) !sumz_set1 /db2 /= /y findex_iter //.
    rewrite sub_incr_sub set11 /= /bb /is11; case/Hvb: Hv'.
    by case: (sub 0 v' i) (sub 0 v i) => [|[|m]] [|[|k]] // _ _; rewrite addz0.
  apply: eq_sumz_l => z; move/andP=> [Hyz Hz]; rewrite /db2 sub_incr_sub.
  case: (i =P findex face x' z) => // Di; case/eqP: Hyz.
  by rewrite /y Di; apply iter_findex.
have Hdb2: negb (posz (decz (b0 + b0) + sumz (db2 v) (cface x'))).
  have Hvbv: vb v by move=> i; apply leqnn.
  move: (decz (addz b0 b0)) Hvbv Hhc Hhcp => b.
  rewrite {1 3}/v -{2}[b]subz0 addzC addz_subA -oppz_sub -leq0z sub0z.
  elim: (hc) b => [|i b' hc' Hrec|j i b' hc' Hrec] b /= Hiv'.
  - rewrite -(@eq_sumz g (@zconst g 0)).
      by rewrite sumz_const leq0z oppz_opp addzC /= addz0.
    by move=> y; rewrite /db2 /= sub_default.
  - case Dvi: (sub 0 v i) (Hvb _ _ Hiv') => [|[|k]] // [Hiv Hv'] Hhc'.
    move/andP=> [Hip Hhc'p]; rewrite ltnS leqn0 in Hiv.
    case: (leqP nhub i) => Hi; first by rewrite sub_default ?Ev in Dvi.
    apply: {Hrec Hv' Hhc' Hhc'p}(leqz_trans (Hrec _ Hv' Hhc' Hhc'p)).
    rewrite leqz_opp2 Edb2 // Dvi Hiv /= !addzA leqz_add2r {b}.
    rewrite addzC -addzA leqz_add2l {db2 Edb2}.
    have Hx'p := fit_hubcap_rot Hxn Exp Hi.
    rewrite (arity_cface Hxx') -(arity_iter_face i x') in Hxn.
    by apply leqz_add2; exact (check_dbound2P Hxn Hx'p Hip).
  case Dvi: (sub 0 v i) (Hvb _ _ Hiv') => [|[|[|k]]] // [Hiv Hjv'];
    case Dvj: (sub 0 v j) (Hvb _ _ Hjv') => [|[|[|k']]] // [Hjv Hv'] Hhc'.
  - move/andP=> [Hijp Hhc'p]; rewrite !ltnS !leqn0 in Hiv Hjv.
    case: (leqP nhub i) => Hi; first by rewrite sub_default ?Ev in Dvi.
    case: (leqP nhub j) => Hj; first by rewrite sub_default ?Ev in Dvj.
    apply: {Hrec Hv' Hhc' Hhc'p}(leqz_trans (Hrec _ Hv' Hhc' Hhc'p)).
    rewrite leqz_opp2 !Edb2 // Dvi Dvj Hiv Hjv /= !addzA leqz_add2r addzC {b}.
    rewrite -!addzA leqz_add2l addzC addzCA !addzA -addzA {db2 Edb2}.
    have Hx'p := fit_hubcap_rot Hxn Exp Hj; rewrite (arity_cface Hxx') in Hxn.
    rewrite -(iter_hub_subn i Hj Hxn); rewrite -(arity_iter_face j x') in Hxn.
    apply leqz_add2; exact (check_2dbound2P Hxn Hx'p (hub_subn_hub Hi Hj) Hijp).
  move/andP=> [Hijp Hhc'p]; rewrite !ltnS in Hiv Hjv.
  case: (leqP nhub i) => Hi; first by rewrite sub_default ?Ev in Dvi.
  case: (leqP nhub j) => Hj; first by rewrite sub_default ?Ev in Dvj.
  apply: {Hrec Hv' Hhc' Hhc'p}(leqz_trans (Hrec _ Hv' Hhc' Hhc'p)).
  rewrite leqz_opp2 !Edb2 // Dvi Dvj !andbF /= !addzA leqz_add2r {b}.
  rewrite addzC {db2 Edb2}leqz_add2l addzC.
  have Hx'p := fit_hubcap_rot Hxn Exp Hj; rewrite (arity_cface Hxx') in Hxn.
  rewrite -(iter_hub_subn i Hj Hxn); rewrite -(arity_iter_face j x') in Hxn.
  exact (check_2dbound2P Hxn Hx'p (hub_subn_hub Hi Hj) Hijp).
set db := (b0 + sumz (dbound2 rt0 rs0) (cface x'))%Z.
suffice: ~ posz (decz (db + db)).
  move=> H; apply/idP => Hx; case: H; move: (dscore_cap2 rf Hg Hxn Hx).
  rewrite -/rs0 -/rt0 -/b0 (eq_sumz_r (same_cface Hxx')) -/db.
  by rewrite decz_def -addzA; case: db => [[|n]|n].
apply: negP; apply: etrans Hdb2 {p Ep Exp vb Hvb Edb2 Hhcp}; congr negb.
congr posz; rewrite !decz_def -!(addzC (-(1))) -!addzA; congr addz.
rewrite /db -!addzA; congr addz; rewrite addzCA -sumz_add; congr addz.
apply: eq_sumz_l => y Hy; rewrite {}/db2.
move: (dbound2 rt0 rs0 y) => b; set i := findex face x' y.
have Hi: i < nhub by rewrite -Hxn (arity_cface Hxx'); apply: findex_max.
case Hi0: (sub 0 v i =d 0).
  by case/idP: Hv0; rewrite -(eqP Hi0) mem_sub ?Ev.
case Dvi: (sub 0 v i) (Hi0) => [|[|[|k]]] //=; first by rewrite addz0.
case/eqP: {b Ev Hv0}Hi0; rewrite /v.
move: v Dvi (decz (b0 + b0)) Hhc => v Dvi.
elim: hc => [|j b' hc' Hrec|j1 j2 b' hc' Hrec] b /=; try by case i.
  rewrite sub_incr_sub; case: (j =P i) => [->|_]; first by rewrite Dvi.
  by case: (sub 0 v j) => [|[|k']] //; apply: Hrec.
rewrite !sub_incr_sub; case: (j1 =P i) => [->|_]; first by rewrite Dvi.
case: (sub 0 v j1) => [|[|[|k1]]] //;
 (case: (j2 =P i) => [->|_]; first by rewrite Dvi);
 case: (sub 0 v j2) => [|[|[|k2]]] //; exact: Hrec.
Qed.

End Hubcap.

Unset Implicit Arguments.


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

Require Export Qhomographic_sign.
Require Export Qhomographic_Qpositive_to_Qpositive.
Require Export Qhomographic_sign_properties.

Unset Standard Proposition Elimination Names.

Definition new_a (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (fst (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))).

Definition new_b (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (snd
       (fst
          (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero)))).

Definition new_c (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  fst
    (snd
       (snd
          (fst
             (snd
                (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))))).

Definition new_d (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  snd
    (snd
       (snd
          (fst
             (snd
                (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero))))).

Definition new_p (a b c d : Z) (p : Qpositive)
  (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p) :=
  snd (snd (Qhomographic_sign a b c d p H_Qhomographic_sg_denom_nonzero)).

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_pos_1 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 (0 <
  Zsgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero))%Z ->
 homographicAcc (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_p a b c d p H_Qhomographic_sg_denom_nonzero).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H : Qhomographic_sign a b c d p H_hsign = (1%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      apply Zsgn_12.
      assumption.

      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros; assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      apply Zsgn_12.
      assumption.

      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros; assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      apply Zsgn_12.
      assumption.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      apply Zsgn_12.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_12 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_pos_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 (Zsgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero) <= 0)%Z ->
 homographicAcc (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
   (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
   (new_p a b c d p H_Qhomographic_sg_denom_nonzero).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H : Qhomographic_sign a b c d p H_hsign = (1%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec 0 na H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec 0 nb H3).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec 0 na H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec 0 nb H3).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      apply (Zsgn_14 _ z).
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_pos_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_pos_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      apply False_ind.
      elim a1.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      apply (Zsgn_14 _ z).
      intros.
      elim a1.
      intros.
      apply Zlt_le_weak.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      generalize (sg_pos_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_14 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_le_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_neg_1 :
 forall (a b c d : Z) (p : Qpositive)
   (H_hsign : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_hsign = (-1)%Z ->
 (Zsgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign) < 0)%Z ->
 homographicAcc (- new_a a b c d p H_hsign) (- new_b a b c d p H_hsign)
   (new_c a b c d p H_hsign) (new_d a b c d p H_hsign)
   (new_p a b c d p H_hsign).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq__minus_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H :
   Qhomographic_sign a b c d p H_hsign = ((-1)%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq__minus_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.

      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intros.
      elim a0.
      intros.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.

      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intros.
      elim a0.
      intros.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      apply False_ind.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_compat.
      assumption.
      assumption.
      apply Zsgn_11.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      assumption.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      apply Zsgn_11.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intros.
      case H0.
      intro.
      elim a0.
      intros.
      apply False_ind.
      generalize (Zsgn_11 (na + nb) z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (na + nb)%Z.
      assumption.
      assumption.
      intro.
      elim a0.
      intros.
      assumption.
Defined.

Lemma Qhomographic_Qpositive_to_Q_homographicAcc_neg_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_hsign : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_hsign = (-1)%Z ->
 (0 <= Zsgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign))%Z ->
 homographicAcc (new_a a b c d p H_hsign) (new_b a b c d p H_hsign)
   (- new_c a b c d p H_hsign) (- new_d a b c d p H_hsign)
   (new_p a b c d p H_hsign).
Proof.
 intros a b c d p H_hsign ad_neq_bc l1_eq__minus_one z.
 set (na := new_a a b c d p H_hsign) in *.
 set (nb := new_b a b c d p H_hsign) in *.
 set (nc := new_c a b c d p H_hsign) in *.
 set (nd := new_d a b c d p H_hsign) in *.
 set (l3 := new_p a b c d p H_hsign) in *.
 assert
  (H :
   Qhomographic_sign a b c d p H_hsign = ((-1)%Z, (na, (nb, (nc, nd)), l3))).
 unfold na, nb, nc, nd, l3 in |- *.
 rewrite <- l1_eq__minus_one.
 unfold new_a, new_b, new_c, new_d, new_p in |- *.
 replace (h_sign a b c d p H_hsign) with
  (fst (Qhomographic_sign a b c d p H_hsign)); [ idtac | reflexivity ];
  repeat rewrite <- pair_1; reflexivity.
      destruct l3 as [p0| p0| ].
      (* l3 = (nR p0) *)
      apply homographicAcc_wf.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec na 0 H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec nb 0 H3).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (nR p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      discriminate e.
      (* l3 = (dL p0) *)
      apply homographicAcc_wf.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      assumption.
      intros.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      case (Z_le_lt_eq_dec na 0 H1).
      intro.
      apply False_ind.
      elim H2.
      intros.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      assumption.
      intros.
      elim a0.
      intros.
      elim H2.
      intros.
      case (Z_le_lt_eq_dec nb 0 H3).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      intro.
      rewrite e.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nc H5).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_lt_le_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      discriminate e.
      generalize (sg_neg_2 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      case H0.
      intro.
      case s.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      apply Zle_neg_opp.
      assumption.
      intro.
      elim a0.
      intros.
      elim H2.
      intros.
      elim H4.
      intros.
      case (Z_le_lt_eq_dec 0 nd H6).
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zlt_trans with (nc + nd)%Z.
      rewrite Zplus_0_r_reverse with 0%Z.
      apply Zplus_le_lt_compat.
      assumption.
      assumption.
      case (sg_neg_1 a b c d p H_hsign na nb nc nd (dL p0) H).
      intro.
      elim a1.
      intros.
      assumption.
      intro.
      apply False_ind.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      apply (Zsgn_13 _ z).
      elim a1.
      intros.
      assumption.
      intro.
      rewrite <- e.
      simpl in |- *.
      apply Zle_refl.
      intro.
      discriminate e.
      (* l3 = One *)
      apply homographicacc0.
      reflexivity.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
      rewrite <- Zopp_plus_distr.
      apply Zlt_neg_opp.
      generalize (sg_neg_1 a b c d p H_hsign na nb nc nd One H).
      intro.
      case H0.
      intros.
      elim a0.
      intros.
      assumption.
      intro.
      apply False_ind.
      elim a0.
      intros.
      generalize (Zsgn_13 _ z).
      intro.
      apply Zlt_irrefl with 0%Z.
      apply Zle_lt_trans with (na + nb)%Z.
      assumption.
      assumption.
Defined.


Require Export SystemFR.TypeErasureLemmas.
Require Export SystemFR.ReducibilityDefinition.
Require Export SystemFR.AnnotatedTermLemmas.

Lemma open_reducible_same:
  forall Θ Γ t T Θ' Γ' t' T',
    [ Θ; Γ ⊨ t : T ] ->
    Θ = Θ' ->
    Γ = Γ' ->
    t = t' ->
    T = T' ->
    [ Θ'; Γ' ⊨ t' : T' ].
Proof.
  steps.
Qed.

Ltac erase_open := repeat
  (progress rewrite erase_type_open in * by (steps; eauto with annot)) ||
  (progress rewrite erase_term_open in * by (steps; eauto with annot)) ||
  (progress rewrite erase_type_topen in * by (steps; eauto with annot)) ||
  (progress rewrite erase_term_topen in * by (steps; eauto with annot)).

Ltac side_conditions :=
  repeat rewrite erased_context_support in *;
  try solve [ t_subset_erase; auto ];
  eauto 2 with fv;
  eauto 2 with wf;
  eauto 2 with twf;
  eauto 2 with erased;
  try solve [ eapply_anywhere fv_context_support; eauto 2 ].


Definition p := true.
Obligation Tactic := idtac.
Require Import Program.
Unset Program Cases.
Time Program Fixpoint f (n : nat) {struct n} : nat :=
  match p with false => n | _ =>
    match p with false => n | _ =>
      match p with false => n | _ =>
        match p with false => n | _ =>
          match p with false => n | _ =>
            match p with false => n | _ =>
              match p with false => n | _ =>
                match p with false => n | _ =>
                  match p with false => n | _ =>
                    match n with
                    | 0 => 0
                    | S n => S (f n)
                    end
                  end
                end
              end
            end
          end
        end
      end
    end
  end.

Require Import Lia.
Require Import Omega.
Require Import ssreflect.
Inductive limitedNat {n} : Type :=
| lim i : i < n -> limitedNat.
Definition test i j (H: (i < j) /\ True) : @limitedNat (S j).
Proof.
  refine (lim (S i) _). omega.
Defined.

    ltac:(lazymatch goal with H : ?i < ?j |- _ => idtac H end)
    end)).
  refine (lim (S i) (match H with conj IJ _ =>
    ltac:(lazymatch goal with H : ?i < ?j |- _ => idtac H end)
    end)).
  lia.
  (match H with conj IJ _ => ltac:(lia) end).
 :=
  lim (S i) _.
  (match H with conj IJ _ => ltac:(lia) end).
  Lemma test (n: nat) : nat. Proof.
  Fail idtac n.
  destruct n eqn:B.
  Fail idtac B.
  Fail idtac n.
match goal with
| H : _ = _ |- _ => idtac H
end.
destruct n eqn:B. idtac B. exact 0. Defined.
exact 0. Defined.
From Coq Require Import String.
From Coq Require Import List.

Import ListNotations.
Inductive Expression : Type :=
| EEmptyList
| EVar (s : string)
| EMap (l : list (Expression * Expression)).

Fixpoint variables (e : Expression) : list string :=
  match e with
  | EEmptyList => []
  | EVar x => [x]
  | EMap l => fold_right (fun '(a, b) r => app (app (variables a) (variables b)) r) [] l
  end.
Lemma equiv l :
  fold_right (fun '(a, b) r => app (app (variables a) (variables b)) r) [] l =
  (fix fp l :=
    match l with
    | [] => []
    | (a,b)::xs => app (app (variables a) (variables b)) (fp xs)
    end) l.
Proof. now induction l; [|destruct a; rewrite <-IHl]. Qed.

Require Import iris.algebra.base.
Lemma foo : ∀ {A : Set} {P : A → Prop} (a : A), (∀ x, ¬ (P x)) → ¬ (∀ x, P x).
intros * a H Hn.
eapply (H a), Hn.
intros.
firstorder.
intuition.
tauto.

Goal let f := plus in f (0 + 0) 0 = 0.
  cbv beta delta. cbv iota beta.
  intro f.
  cbv delta. (* let f := (fix add ...) in f ((fix add ...) 0 0) 0 = 0 *)
  intro f.
  cbv delta;clear f.

Require Import Lia.
From Coq Require Export ZArith NPeano.
Lemma foo2 : forall (z:Z), (z >=0)%Z -> { n : nat | Z.of_nat n = z }.
Proof. intros z. exists (Z.to_nat z). apply Z2Nat.id. lia. Qed.

From Coq.ssr Require Import ssreflect.
From Coq Require Export EqdepFacts PArith NArith ZArith NPeano.

Lemma foo : forall (z:Z), (z >=0)%Z -> exists n : nat , Z.of_nat n = z.
Proof. intros z. exists (Z.to_nat z). apply Z2Nat.id. lia. Qed.
Lemma to_nat2 : Z -> nat. intros z. Fail destruct (foo z). Abort.

Lemma to_nat2 (z : Z) (H : (z >= 0)%Z): nat. destruct (foo2 z H) as [n _]. exact n. Defined.

About Z.
From mathcomp.ssreflect Require Import ssrnat.
Search _ (forall (z:Z), (z >=0)%Z -> { n : nat | Z.to_nat z = n }).
Search _ (forall (z:Z), (z >=0)%Z -> exists n : nat , Z.to_nat z = n).
Search _ (_ >= 0 -> Z.abs _ = _).
Require Import Lia.

Inductive foo := .

Inductive bar := .

Require Import Lia.
From Coq.ssr Require Import ssreflect.
Lemma baz : 1 = 2 -> 3 = 4.
move => Hi. have {Hi} -Hi: 2 = 3 by lia. lia.
Qed.

Lemma foo (H:True) : True -> True.
Proof.
  move => {H} -H.
  exact I.
Qed.