(** * Definition of appartness relationConstructive Algebraic Structures *)
(** Catherine Lelay. Sep. 2015 *)

Unset Kernel Term Sharing.

Require Export UniMath.Algebra.DivisionRig.
Require Export UniMath.Algebra.Domains_and_Fields.
Require Export UniMath.Algebra.Apartness.

Require Import UniMath.MoreFoundations.Tactics.

(** ** Predicats in a rig with a tight appartness relation *)

Definition isnonzeroCR (X : rig) (R : tightap X) := R 1%rig 0%rig.
Definition isConstrDivRig (X : rig) (R : tightap X) :=
  isnonzeroCR X R × (∏ x : X, R x 0%rig -> multinvpair X x).

(** ** Constructive rig with division *)

Definition ConstructiveDivisionRig :=
  ∑ X : rig,
  ∑ R : tightap X,
        isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1
      × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2
      × isConstrDivRig X R.
Definition ConstructiveDivisionRig_rig : ConstructiveDivisionRig -> rig := pr1.
Coercion ConstructiveDivisionRig_rig : ConstructiveDivisionRig >-> rig.
Definition ConstructiveDivisionRig_apsetwith2binop : ConstructiveDivisionRig -> apsetwith2binop.
Proof.
  intros X.
  exists (pr1 (pr1 (pr1 X)),,(pr1 (pr2 X))).
  split.
  exact (_,,(pr1 (pr2 (pr2 X)))).
  exact (_,,(pr1 (pr2 (pr2 (pr2 X))))).
Defined.

Definition CDRap {X : ConstructiveDivisionRig} : hrel X := λ x y : X, (pr1 (pr2 X)) x y.
Definition CDRzero {X : ConstructiveDivisionRig} : X := 0%rig.
Definition CDRone {X : ConstructiveDivisionRig} : X := 1%rig.
Definition CDRplus {X : ConstructiveDivisionRig} : binop X := λ x y : X, op1 (X := ConstructiveDivisionRig_apsetwith2binop X) x y.
Definition CDRmult {X : ConstructiveDivisionRig} : binop X := λ x y : X, op2 (X := ConstructiveDivisionRig_apsetwith2binop X) x y.

Declare Scope CDR_scope.
Delimit Scope CDR_scope with CDR.
Local Open Scope CDR_scope.

Notation "x ≠ y" := (CDRap x y) (at level 70, no associativity) : CDR_scope.
Notation "0" := CDRzero : CDR_scope.
Notation "1" := CDRone : CDR_scope.
Notation "x + y" := (CDRplus x y) : CDR_scope.
Notation "x * y" := (CDRmult x y) : CDR_scope.

Definition CDRinv {X : ConstructiveDivisionRig} (x : X) (Hx0 : x ≠ 0) : X :=
  (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0)).
Definition CDRdiv {X : ConstructiveDivisionRig} (x y : X) (Hy0 : y ≠ 0) : X :=
  CDRmult x (CDRinv y Hy0).

(** Lemmas *)

Section CDR_pty.

Context {X : ConstructiveDivisionRig}.

Lemma isirrefl_CDRap :
  ∏ x : X, ¬ (x ≠ x).
Proof.
  exact (pr1 (pr1 (pr2 (pr1 (pr2 X))))).
Qed.
Lemma issymm_CDRap :
  ∏ x y : X, x ≠ y -> y ≠ x.
Proof.
  exact (pr1 (pr2 (pr1 (pr2 (pr1 (pr2 X)))))).
Qed.
Lemma iscotrans_CDRap :
  ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z.
Proof.
  exact (pr2 (pr2 (pr1 (pr2 (pr1 (pr2 X)))))).
Qed.
Lemma istight_CDRap :
  ∏ x y : X, ¬ (x ≠ y) -> x = y.
Proof.
  exact (pr2 (pr2 (pr1 (pr2 X)))).
Qed.

Lemma isnonzeroCDR : (1 : X) ≠ (0 : X).
Proof.
  exact (pr1 (pr2 (pr2 (pr2 (pr2 X))))).
Qed.

Lemma islunit_CDRzero_CDRplus :
  ∏ x : X, 0 + x = x.
Proof.
  now apply riglunax1.
Qed.
Lemma isrunit_CDRzero_CDRplus :
  ∏ x : X, x + 0 = x.
Proof.
  now apply rigrunax1.
Qed.
Lemma isassoc_CDRplus :
  ∏ x y z : X, x + y + z = x + (y + z).
Proof.
  now apply rigassoc1.
Qed.
Lemma iscomm_CDRplus :
  ∏ x y : X, x + y = y + x.
Proof.
  now apply rigcomm1.
Qed.
Lemma islunit_CDRone_CDRmult :
  ∏ x : X, 1 * x = x.
Proof.
  now apply riglunax2.
Qed.
Lemma isrunit_CDRone_CDRmult :
  ∏ x : X, x * 1 = x.
Proof.
  now apply rigrunax2.
Qed.
Lemma isassoc_CDRmult :
  ∏ x y z : X, x * y * z = x * (y * z).
Proof.
  now apply rigassoc2.
Qed.
Lemma islinv_CDRinv :
  ∏ (x : X) (Hx0 : x ≠ (0 : X)),
    (CDRinv x Hx0) * x = 1.
Proof.
  intros x Hx0.
  apply (pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0))).
Qed.
Lemma isrinv_CDRinv :
  ∏ (x : X) (Hx0 : x ≠ (0 : X)),
    x * (CDRinv x Hx0) = 1.
Proof.
  intros x Hx0.
  apply (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 X)))) x Hx0))).
Qed.
Lemma islabsorb_CDRzero_CDRmult :
  ∏ x : X, 0 * x = 0.
Proof.
  now apply rigmult0x.
Qed.
Lemma israbsorb_CDRzero_CDRmult :
  ∏ x : X, x * 0 = 0.
Proof.
  now apply rigmultx0.
Qed.
Lemma isldistr_CDRplus_CDRmult :
  ∏ x y z : X, z * (x + y) = z * x + z * y.
Proof.
  now apply rigdistraxs.
Qed.

Lemma apCDRplus :
  ∏ x x' y y' : X,
    x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (isapbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X)).
Qed.
Lemma CDRplus_apcompat_l :
  ∏ x y z : X, y + x ≠ z + x -> y ≠ z.
Proof.
  intros x y z.
  exact (islapbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X) _ _ _).
Qed.
Lemma CDRplus_apcompat_r :
  ∏ x y z : X, x + y ≠ x + z -> y ≠ z.
Proof.
  exact (israpbinop_op1 (X := ConstructiveDivisionRig_apsetwith2binop X)).
Qed.

Lemma apCDRmult :
  ∏ x x' y y' : X,
    x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (isapbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X)).
Qed.
Lemma CDRmult_apcompat_l :
  ∏ x y z : X, y * x ≠ z * x -> y ≠ z.
Proof.
  intros x y z.
  exact (islapbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X) _ _ _).
Qed.
Lemma CDRmult_apcompat_l' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x.
Proof.
  intros x y z Hx Hap.
  refine (CDRmult_apcompat_l (CDRinv x Hx) _ _ _).
  rewrite !isassoc_CDRmult, isrinv_CDRinv, !isrunit_CDRone_CDRmult.
  exact Hap.
Qed.
Lemma CDRmult_apcompat_r :
  ∏ x y z : X, x * y ≠ x * z -> y ≠ z.
Proof.
  exact (israpbinop_op2 (X := ConstructiveDivisionRig_apsetwith2binop X)).
Qed.
Lemma CDRmult_apcompat_r' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z.
Proof.
  intros x y z Hx Hap.
  refine (CDRmult_apcompat_r (CDRinv x Hx) _ _ _).
  rewrite <- !isassoc_CDRmult, islinv_CDRinv, !islunit_CDRone_CDRmult.
  exact Hap.
Qed.

Lemma CDRmultapCDRzero :
  ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0.
Proof.
  intros x y Hmult.
  split.
  - apply CDRmult_apcompat_l with y.
    rewrite islabsorb_CDRzero_CDRmult.
    exact Hmult.
  - apply CDRmult_apcompat_r with x.
    rewrite israbsorb_CDRzero_CDRmult.
    exact Hmult.
Qed.

Close Scope CDR_scope.

End CDR_pty.

(** ** Constructive commutative rig with division *)

Definition ConstructiveCommutativeDivisionRig :=
  ∑ X : commrig,
  ∑ R : tightap X,
        isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1
      × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2
      × isConstrDivRig X R.
Definition ConstructiveCommutativeDivisionRig_commrig :
  ConstructiveCommutativeDivisionRig -> commrig := pr1.
Coercion ConstructiveCommutativeDivisionRig_commrig :
  ConstructiveCommutativeDivisionRig >-> commrig.

Definition ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig :
  ConstructiveCommutativeDivisionRig -> ConstructiveDivisionRig :=
  λ X, (pr1 (pr1 X),,pr1 (pr2 (pr1 X))) ,, (pr2 X).
Coercion ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig :
  ConstructiveCommutativeDivisionRig >-> ConstructiveDivisionRig.

Definition CCDRap {X : ConstructiveCommutativeDivisionRig} : hrel X := λ x y : X, CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y.
Definition CCDRzero {X : ConstructiveCommutativeDivisionRig} : X := 0%rig.
Definition CCDRone {X : ConstructiveCommutativeDivisionRig} : X := 1%rig.
Definition CCDRplus {X : ConstructiveCommutativeDivisionRig} : binop X := λ x y : X, CDRplus (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y.
Definition CCDRmult {X : ConstructiveCommutativeDivisionRig} : binop X := λ x y : X, CDRmult (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x y.

Declare Scope CCDR_scope.
Delimit Scope CCDR_scope with CCDR.
Local Open Scope CCDR_scope.

Notation "x ≠ y" := (CCDRap x y) (at level 70, no associativity) : CCDR_scope.
Notation "0" := CCDRzero : CCDR_scope.
Notation "1" := CCDRone : CCDR_scope.
Notation "x + y" := (CCDRplus x y) : CCDR_scope.
Notation "x * y" := (CCDRmult x y) : CCDR_scope.

Definition CCDRinv {X : ConstructiveCommutativeDivisionRig} (x : X) (Hx0 : x ≠ CCDRzero) : X :=
  CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X) x Hx0.
Definition CCDRdiv {X : ConstructiveCommutativeDivisionRig} (x y : X) (Hy0 : y ≠ CCDRzero) : X :=
  CCDRmult x (CCDRinv y Hy0).

(** Lemmas *)

Section CCDR_pty.

Context {X : ConstructiveCommutativeDivisionRig}.

Lemma isirrefl_CCDRap :
  ∏ x : X, ¬ (x ≠ x).
Proof.
  exact (isirrefl_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma issymm_CCDRap :
  ∏ x y : X, x ≠ y -> y ≠ x.
Proof.
  exact (issymm_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma iscotrans_CCDRap :
  ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z.
Proof.
  exact (iscotrans_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma istight_CCDRap :
  ∏ x y : X, ¬ (x ≠ y) -> x = y.
Proof.
  exact (istight_CDRap (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.

Lemma isnonzeroCCDR : (1 : X) ≠ (0 : X).
Proof.
  exact isnonzeroCDR.
Qed.

Lemma islunit_CCDRzero_CCDRplus :
  ∏ x : X, 0 + x = x.
Proof.
  now apply riglunax1.
Qed.
Lemma isrunit_CCDRzero_CCDRplus :
  ∏ x : X, x + 0 = x.
Proof.
  now apply rigrunax1.
Qed.
Lemma isassoc_CCDRplus :
  ∏ x y z : X, x + y + z = x + (y + z).
Proof.
  now apply rigassoc1.
Qed.
Lemma iscomm_CCDRplus :
  ∏ x y : X, x + y = y + x.
Proof.
  now apply rigcomm1.
Qed.
Lemma islunit_CCDRone_CCDRmult :
  ∏ x : X, 1 * x = x.
Proof.
  now apply riglunax2.
Qed.
Lemma isrunit_CCDRone_CCDRmult :
  ∏ x : X, x * 1 = x.
Proof.
  now apply rigrunax2.
Qed.
Lemma isassoc_CCDRmult :
  ∏ x y z : X, x * y * z = x * (y * z).
Proof.
  now apply rigassoc2.
Qed.
Lemma iscomm_CCDRmult :
  ∏ x y : X, x * y = y * x.
Proof.
  now apply rigcomm2.
Qed.
Lemma islinv_CCDRinv :
  ∏ (x : X) (Hx0 : x ≠ (0 : X)),
    (CDRinv (X := X) x Hx0) * x = 1.
Proof.
  exact (islinv_CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma isrinv_CCDRinv :
  ∏ (x : X) (Hx0 : x ≠ (0 : X)),
    x * (CDRinv (X := X) x Hx0) = 1.
Proof.
  exact (isrinv_CDRinv (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma islabsorb_CCDRzero_CCDRmult :
  ∏ x : X, 0 * x = 0.
Proof.
  now apply rigmult0x.
Qed.
Lemma israbsorb_CCDRzero_CCDRmult :
  ∏ x : X, x * 0 = 0.
Proof.
  now apply rigmultx0.
Qed.
Lemma isldistr_CCDRplus_CCDRmult :
  ∏ x y z : X, z * (x + y) = z * x + z * y.
Proof.
  now apply rigdistraxs.
Qed.
Lemma isrdistr_CCDRplus_CCDRmult :
  ∏ x y z : X, (x + y) * z = x * z + y * z.
Proof.
  intros x y z.
  rewrite !(iscomm_CCDRmult _ z).
  now apply rigdistraxs.
Qed.

Lemma apCCDRplus :
  ∏ x x' y y' : X,
    x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (apCDRplus (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRplus_apcompat_l :
  ∏ x y z : X, y + x ≠ z + x -> y ≠ z.
Proof.
  exact (CDRplus_apcompat_l (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRplus_apcompat_r :
  ∏ x y z : X, x + y ≠ x + z -> y ≠ z.
Proof.
  exact (CDRplus_apcompat_r (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.

Lemma apCCDRmult :
  ∏ x x' y y' : X,
    x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (apCDRmult (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRmult_apcompat_l :
  ∏ x y z : X, y * x ≠ z * x -> y ≠ z.
Proof.
  exact (CDRmult_apcompat_l (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRmult_apcompat_l' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x.
Proof.
  exact (CDRmult_apcompat_l' (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRmult_apcompat_r :
  ∏ x y z : X, x * y ≠ x * z -> y ≠ z.
Proof.
  exact (CDRmult_apcompat_r (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.
Lemma CCDRmult_apcompat_r' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z.
Proof.
  exact (CDRmult_apcompat_r' (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.

Lemma CCDRmultapCCDRzero :
  ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0.
Proof.
  exact (CDRmultapCDRzero (X := ConstructiveCommutativeDivisionRig_ConstructiveDivisionRig X)).
Qed.

Close Scope CCDR_scope.

End CCDR_pty.

(** ** Constructive Field *)

Definition ConstructiveField :=
  ∑ X : commring,
  ∑ R : tightap X,
        isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op1
      × isapbinop (X := (pr1 (pr1 X)) ,, R) BinaryOperations.op2
      × isConstrDivRig X R.
Definition ConstructiveField_commring :
  ConstructiveField -> commring := pr1.
Coercion ConstructiveField_commring :
  ConstructiveField >-> commring.
Definition ConstructiveField_ConstructiveCommutativeDivisionRig :
  ConstructiveField -> ConstructiveCommutativeDivisionRig :=
  λ X, (commringtocommrig (pr1 X)) ,, (pr2 X).
Coercion ConstructiveField_ConstructiveCommutativeDivisionRig :
  ConstructiveField >-> ConstructiveCommutativeDivisionRig.

Definition CFap {X : ConstructiveField} : hrel X := λ x y : X, CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y.
Definition CFzero {X : ConstructiveField} : X := 0%ring.
Definition CFone {X : ConstructiveField} : X := 1%ring.
Definition CFplus {X : ConstructiveField} : binop X := λ x y : X, CCDRplus (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y.
Definition CFopp {X : ConstructiveField} : unop X := λ x : X, (- x)%ring.
Definition CFminus {X : ConstructiveField} : binop X := λ x y : X, CFplus x (CFopp y).
Definition CFmult {X : ConstructiveField} : binop X := λ x y : X, CCDRmult (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x y.

Declare Scope CF_scope.
Delimit Scope CF_scope with CF.
Local Open Scope CF_scope.

Notation "x ≠ y" := (CFap x y) (at level 70, no associativity) : CF_scope.
Notation "0" := CFzero : CF_scope.
Notation "1" := CFone : CF_scope.
Notation "x + y" := (CFplus x y) : CF_scope.
Notation "- x" := (CFopp x) : CF_scope.
Notation "x - y" := (CFminus x y) : CF_scope.
Notation "x * y" := (CFmult x y) : CF_scope.

Definition CFinv {X : ConstructiveField} (x : X) (Hx0 : x ≠ CFzero) : X :=
  CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) x Hx0.
Definition CFdiv {X : ConstructiveField} (x y : X) (Hy0 : y ≠ CFzero) : X :=
  CFmult x (CFinv y Hy0).

(** Lemmas *)

Section CF_pty.

Context {X : ConstructiveField}.

Lemma isirrefl_CFap :
  ∏ x : X, ¬ (x ≠ x).
Proof.
  exact (isirrefl_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma issymm_CFap :
  ∏ x y : X, x ≠ y -> y ≠ x.
Proof.
  exact (issymm_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma iscotrans_CFap :
  ∏ x y z : X, x ≠ z -> x ≠ y ∨ y ≠ z.
Proof.
  exact (iscotrans_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma istight_CFap :
  ∏ x y : X, ¬ (x ≠ y) -> x = y.
Proof.
  exact (istight_CCDRap (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.

Lemma isnonzeroCF : (1 : X) ≠ (0 : X).
Proof.
  exact (isnonzeroCCDR (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.

Lemma islunit_CFzero_CFplus :
  ∏ x : X, 0 + x = x.
Proof.
  now apply ringlunax1.
Qed.
Lemma isrunit_CFzero_CFplus :
  ∏ x : X, x + 0 = x.
Proof.
  now apply ringrunax1.
Qed.
Lemma isassoc_CFplus :
  ∏ x y z : X, x + y + z = x + (y + z).
Proof.
  now apply ringassoc1.
Qed.
Lemma islinv_CFopp :
  ∏ x : X, - x + x = 0.
Proof.
  now apply ringlinvax1.
Qed.
Lemma isrinv_CFopp :
  ∏ x : X, x + - x = 0.
Proof.
  now apply ringrinvax1.
Qed.

Lemma iscomm_CFplus :
  ∏ x y : X, x + y = y + x.
Proof.
  now apply ringcomm1.
Qed.
Lemma islunit_CFone_CFmult :
  ∏ x : X, 1 * x = x.
Proof.
  now apply ringlunax2.
Qed.
Lemma isrunit_CFone_CFmult :
  ∏ x : X, x * 1 = x.
Proof.
  now apply ringrunax2.
Qed.
Lemma isassoc_CFmult :
  ∏ x y z : X, x * y * z = x * (y * z).
Proof.
  now apply ringassoc2.
Qed.
Lemma iscomm_CFmult :
  ∏ x y : X, x * y = y * x.
Proof.
  now apply ringcomm2.
Qed.
Lemma islinv_CFinv :
  ∏ (x : X) (Hx0 : x ≠ 0),
    (CFinv x Hx0) * x = 1.
Proof.
  exact (islinv_CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma isrinv_CFinv :
  ∏ (x : X) (Hx0 : x ≠ 0),
    x * (CFinv x Hx0) = 1.
Proof.
  exact (isrinv_CCDRinv (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma islabsorb_CFzero_CFmult :
  ∏ x : X, 0 * x = 0.
Proof.
  now apply ringmult0x.
Qed.
Lemma israbsorb_CFzero_CFmult :
  ∏ x : X, x * 0 = 0.
Proof.
  now apply ringmultx0.
Qed.
Lemma isldistr_CFplus_CFmult :
  ∏ x y z : X, z * (x + y) = z * x + z * y.
Proof.
  now apply ringdistraxs.
Qed.
Lemma isrdistr_CFplus_CFmult :
  ∏ x y z : X, (x + y) * z = x * z + y * z.
Proof.
  intros.
  rewrite !(iscomm_CFmult _ z).
  now apply isldistr_CFplus_CFmult.
Qed.

Lemma apCFplus :
  ∏ x x' y y' : X,
    x + y ≠ x' + y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (apCCDRplus (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma CFplus_apcompat_l :
  ∏ x y z : X, y + x ≠ z + x <-> y ≠ z.
Proof.
  intros x y z.
  split.
  - exact (CCDRplus_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) _ _ _).
  - intros Hap.
    apply (CCDRplus_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X) (- x)).
    change ((y + x) + - x ≠ (z + x) + - x).
    rewrite !isassoc_CFplus, isrinv_CFopp, !isrunit_CFzero_CFplus.
    exact Hap.
Qed.
Lemma CFplus_apcompat_r :
  ∏ x y z : X, x + y ≠ x + z <-> y ≠ z.
Proof.
  intros x y z.
  rewrite !(iscomm_CFplus x).
  now apply CFplus_apcompat_l.
Qed.

Lemma apCFmult :
  ∏ x x' y y' : X,
    x * y ≠ x' * y' -> x ≠ x' ∨ y ≠ y'.
Proof.
  exact (apCCDRmult (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma CFmult_apcompat_l :
  ∏ x y z : X, y * x ≠ z * x -> y ≠ z.
Proof.
  exact (CCDRmult_apcompat_l (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma CFmult_apcompat_l' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> y * x ≠ z * x.
Proof.
  exact (CCDRmult_apcompat_l' (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma CFmult_apcompat_r :
  ∏ x y z : X, x * y ≠ x * z -> y ≠ z.
Proof.
  exact (CCDRmult_apcompat_r (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.
Lemma CFmult_apcompat_r' :
  ∏ x y z : X, x ≠ 0 -> y ≠ z -> x * y ≠ x * z.
Proof.
  exact (CCDRmult_apcompat_r' (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.

Lemma CFmultapCFzero :
  ∏ x y : X, x * y ≠ 0 -> x ≠ 0 ∧ y ≠ 0.
Proof.
  exact (CCDRmultapCCDRzero (X := ConstructiveField_ConstructiveCommutativeDivisionRig X)).
Qed.

End CF_pty.

Close Scope CF_scope.


Require Export ProjectiveGeometry.Dev.rank_space_or_higher_properties.

(*****************************************************************************)
(** Proof of 3D lemmas about Desargues **)

Ltac my_classical_left :=
match goal with
| H : _ |- _ \/ ?c = ?d => destruct (Nat.eq_dec c d); [right; assumption | left]
end.

Section s_desargues3DLemmas.

Context `{RPSOH : RankProjectiveSpaceOrHigher}.
Context `{EP : EqDecidability Point}.

Lemma rbA_scheme
     : forall a b c A B C alpha : Point,
       forall gamma O0 : Point,
       rk (triple a A O0) = 2 ->
       rk (triple b B O0) = 2 ->
       rk (triple c C O0) = 2 ->
       rk (triple a b c) = 3 ->
       rk (union (triple A B C) (triple a b c)) >= 4 ->
       rk (triple a b gamma) = 2 ->
       rk (triple b c alpha) = 2 ->
       rk (couple A O0) = 2 -> rk (couple b A) = 2.
intros a b c A B C alpha gamma O raAO rbBO rcCO rabc rABCabc rabgamma rbcalpha rAO.
apply rk_couple1.
intros HbA.
assert (rk(union (triple A B C) (triple a b c))<=3).
assert (rk(add O (union (triple A a B) (triple b C c)))<=3).
assert (rk(union(triple A a B) (couple b O))<=2).
generalize (matroid3 (triple a A O) (triple B b O)).
setoid_replace (union (triple a A O) (triple B b O))
                 with (union (triple A a B) (couple b O))
                 by (unfold Equal; split; clear_all;fsetdecide).
rewrite HbA in *.
rewrite raAO.
setoid_replace (triple A B O) with (triple B A O) in rbBO by (clear_all;fsetdecide).
rewrite rbBO.
assert (rk(inter (triple a A O) (triple B A O))>=rk(couple A O)).
apply matroid2.
fsetdecide.
rewrite rAO in H0.
omega.
generalize (matroid3 (union(triple A a B) (couple b O)) (triple c C O)).
setoid_replace (union (union (triple A a B) (couple b O)) (triple c C O))
with (add O (union (triple A a B) (triple b C c))) by (clear_all;fsetdecide).
rewrite rcCO.
assert (rk(inter (union (triple A a B) (couple b O)) (triple c C O))>=rk(singleton O)).
apply matroid2;clear_all;fsetdecide.
rewrite rk_singleton in H1.
omega.
assert (rk(union (triple A B C) (triple a b c))<=rk(add O (union (triple  A a B) (triple b C c)))).
apply matroid2;clear_all;fsetdecide.
omega.
omega.
Qed.

Lemma sublemma : forall
(b : Point)
(c : Point)
(A : Point)
(B : Point)
(C : Point)
(alpha : Point)
(beta : Point)
(gamma : Point)
(O : Point)
(rbBO : rk (triple b B O) = 2)
(rcCO : rk (triple c C O) = 2)
(rABC : rk (triple A B C) = 3)
(rABgamma : rk (triple A B gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)
(rbcalpha : rk (triple b c alpha) = 2)
(rAO : rk (couple A O) = 2)
(rBO : rk (couple B O) = 2)
(rCO : rk (couple C O) = 2)
(raAO : rk (triple A A O) = 2)
(rabc : rk (triple A b c) = 3)
(rABCabc : rk (union (triple A B C) (triple A b c)) >= 4)
(rabgamma : rk (triple A b gamma) = 2)
(racbeta : rk (triple A c beta) = 2)
(rcC : rk (couple c C) = 2),
rk (couple A beta) = 1.
Proof.
intros.
eapply (uniq_inter A c A C) with (P:=A) (Q:=beta); try eassumption.
setoid_replace (couple A c) with (couple c A) by (clear_all;fsetdecide).
eapply (rbA_scheme A c b A C B alpha beta O); try eassumption.
setoid_replace (triple A c b) with (triple A b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple A c b) with (triple A b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide); assumption.
eapply rk_triple_ABC_couple_AC; eassumption.
setoid_replace (triple A c A) with (couple c A) by (clear_all;fsetdecide).
assert (rk (couple c A)=2).
eapply (rbA_scheme A c b A C B alpha); try eassumption.
setoid_replace (triple A c b) with (triple A b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple A c b) with (triple A b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide); assumption.
omega.
setoid_replace (triple A C A) with (couple A C) by (clear_all;fsetdecide).
assert (rk(couple A C)=2).
eapply rk_triple_ABC_couple_AC; eassumption.
omega.
omega.
omega.
setoid_replace (quadruple A c A C) with (triple A c C) by (clear_all;fsetdecide).
assert (rk (union (triple A C c) (couple O beta))>=3).
generalize (matroid3 (union (triple A C c) (couple O beta)) (triple b B O)).
assert (rk (union (union (triple A C c) (couple O beta)) (triple b B O)) >= rk (union (triple A B C) (triple A b c))).
apply matroid2; (clear_all;fsetdecide).
assert (rk (inter (union (triple A C c) (couple O beta)) (triple b B O))>= rk (singleton O)).
apply matroid2; (clear_all;fsetdecide).
rewrite rk_singleton in H1.
omega.
assert (rk (add beta (triple A c C))>=3).
generalize (matroid3 (add beta (triple A c C)) (triple c C O)).
assert (rk (union (add beta (triple A c C)) (triple c C O)) >= rk (union (triple A C c) (couple O beta)) ).
apply matroid2; (clear_all;fsetdecide).
assert (rk (inter (add  beta (triple A c C)) (triple c C O))>=rk(couple c C)).
apply matroid2; (clear_all;fsetdecide).
omega.
generalize (matroid3 (triple A c C) (triple A c beta)).
assert (rk (union (triple A c C) (triple A c beta)) >=rk(add beta (triple A c C))).
apply matroid2; (clear_all;fsetdecide).
assert (rk  (inter (triple A c C) (triple A c beta)) >= rk (couple c A)).
apply matroid2; (clear_all;fsetdecide).
assert (Hrew:(rk(couple c A)=2)).
apply (rbA_scheme A c b A C B alpha beta O).
setoid_replace (triple A A O) with (couple A O) by (clear_all;fsetdecide); assumption.
assumption.
assumption.
setoid_replace (triple A c b) with (triple A b c) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace  (triple A c b)  with  (triple A b c)  by (clear_all;fsetdecide); assumption.
assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by (clear_all;fsetdecide); assumption.
assumption.
rewrite Hrew in H3 by assumption.
omega.
Qed.

Lemma sublemma'' : forall
(a : Point)
(b : Point)
(c : Point)
(A : Point)
(B : Point)
(C : Point)
(alpha : Point)
(beta : Point)
(gamma : Point)
(O : Point)
(raAO : rk (triple a A O) = 2)
(rbBO : rk (triple b B O) = 2)
(rcCO : rk (triple c C O) = 2)
(rABC : rk (triple A B C) = 3)
(rabc : rk (triple a b c) = 3)
(rABCabc : rk (union (triple A B C) (triple a b c)) >= 4)
(rABgamma : rk (triple A B gamma) = 2)
(rabgamma : rk (triple a b gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(racbeta : rk (triple a c beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)
(rbcalpha : rk (triple b c alpha) = 2)
(rAO : rk (couple A O) = 2)
(rBO : rk (couple B O) = 2)
(rCO : rk (couple C O) = 2)
(a0 : a = A)
(a1 : c = C),
rk (couple A gamma) = 1.
Proof.
intros; subst.
eapply (uniq_inter A B A b) with (P:=A) (Q:=gamma).
apply (rk_triple_ABC_couple_AB A B C rABC).
setoid_replace (couple A b) with (couple b A) by (clear_all;fsetdecide).
apply (rbA_scheme A b C A B C alpha gamma O).
setoid_replace (triple A A O) with (couple A O) by (clear_all;fsetdecide); assumption.
assumption.
setoid_replace (triple C C O) with (couple C O) by (clear_all;fsetdecide); assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
setoid_replace (triple A B A) with (couple A B) by (clear_all;fsetdecide).
assert (rk (couple A B)=2).
eapply rk_triple_ABC_couple_AB; eassumption.
omega.
setoid_replace (triple A b A) with (couple b A) by (clear_all;fsetdecide).
assert (rk (couple b A) =2).
apply (rbA_scheme A b C A B C alpha gamma O).
setoid_replace (triple A A O) with (couple A O) by (clear_all;fsetdecide); assumption.
assumption.
setoid_replace (triple C C O) with (couple C O) by (clear_all;fsetdecide); assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
omega.
omega.
omega.

setoid_replace (quadruple A B A b) with (triple A B b) by (clear_all;fsetdecide).
generalize (matroid3 (triple A B b) (triple A B C)).
assert ( rk (union (triple A B C) (triple A b C)) <= rk (union (triple A B b) (triple A B C))).
apply matroid2; (clear_all;fsetdecide).
assert (rk (inter (triple A B b) (triple A B C))>= rk(couple A B)).
apply matroid2; (clear_all;fsetdecide).
assert (rk(couple A B)=2).
eapply rk_triple_ABC_couple_AB; eassumption.
rewrite H2 in H1.
omega.
Qed.

Lemma a_not_gamma_scheme : forall
(a : Point)
(b : Point)
(c : Point)
(A : Point)
(B : Point)
(C : Point)
(alpha : Point)
(beta : Point)
(gamma : Point)
(O : Point)
(raAO : rk (triple a A O) = 2)
(rbBO : rk (triple b B O) = 2)
(rcCO : rk (triple c C O) = 2)
(rABC : rk (triple A B C) = 3)
(rabc : rk (triple a b c) = 3)
(rABCabc : rk (union (triple A B C) (triple a b c)) >= 4)
(rABgamma : rk (triple A B gamma) = 2)
(rabgamma : rk (triple a b gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(racbeta : rk (triple a c beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)
(rbcalpha : rk (triple b c alpha) = 2)
(raA : rk (couple a A) = 2)
(rcC : rk (couple c C) = 2)
(rbB : rk (couple b B) = 2),
rk (couple a gamma) = 2 \/ rk (triple gamma alpha beta) = 2.
Proof.
intros.
my_classical_left.
rename n into HnotDes.
apply rk_couple1.
intro.
rewrite H0 in *;clear H0.

assert (rk (couple gamma A) = 1 \/ rk (triple gamma B O) <= 2).
apply (uniq_inter_spec_bis A gamma B O).

setoid_replace (triple gamma B A) with (triple A B gamma) by (clear_all;fsetdecide);omega.
setoid_replace (triple gamma O A) with (triple gamma A O)   by (clear_all;fsetdecide);omega.
elim H0;intro;clear H0.
intuition.

elim (eq_dec B O);intro.
rewrite H0 in *; clear H0.

assert (   rk (union (triple c C O) (triple O C alpha)) + rk (couple O C) <=
       rk (triple c C O) + rk (triple O C alpha)).
apply (matroid3_useful); auto.
(clear_all;fsetdecide).
assert (rk (couple O C) = 2).
eapply (rk_triple_ABC_couple_BC);eauto.
assert ( rk (union (triple c C O) (triple O C alpha)) <= 2).
omega.

elim (eq_dec c alpha);intro.
rewrite H4 in *; clear H4.
intuition.

assert(H5 := rk_couple1 c alpha H4).
assert (  rk
         (union (union (triple c C O) (triple O C alpha)) (triple b c alpha)) + rk (couple c alpha) <=
       rk (union (triple c C O) (triple O C alpha)) + rk (triple b c alpha)  ).
apply (matroid3_useful); auto.
(clear_all;fsetdecide).
assert ( rk (union (union (triple c C O) (triple O C alpha)) (triple b c alpha)) <= 2).
omega.
setoid_replace (union (union (triple c C O) (triple O C alpha)) (triple b c alpha))
                 with (add O (quadruple c C  alpha b)) in H6 by (unfold Equal; split;clear_all;fsetdecide).
setoid_replace (triple gamma A O) with (add O (couple gamma A)) in raAO by (clear_all;fsetdecide).
assert ( rk (add O (union (quadruple c C alpha b) (couple gamma A))) <= 3).
apply double_flag;omega.
assert (rk (union (triple A O C) (triple gamma b c)) <=
           rk (add O (union (quadruple c C alpha b) (couple gamma A))) ).
apply matroid2;(clear_all;fsetdecide).
omega.

assert(H2 := rk_couple1 B O H0).
assert (rk (union (triple gamma B O) (triple b B O)) + rk (couple B O) <=
       rk (triple gamma B O) + rk (triple b B O)).
apply (matroid3_useful); auto.
(clear_all;fsetdecide).
assert (rk (union (triple gamma B O) (triple b B O)) <= 2).
omega.
elim (eq_dec gamma O);intro.
rewrite H5 in *;clear H5.

assert (rk (union (triple A B O) (triple b B O)) + rk (couple B O) <=
       rk (triple A B O) + rk (triple b B O)).

apply (matroid3_useful);(clear_all;fsetdecide).
assert ( rk (union (triple A B O) (triple b B O)) <= 2) by omega.

setoid_replace (union (triple A B O) (triple b B O)) with (add O (triple A B b)) in H5 by (clear_all;fsetdecide).
setoid_replace (triple c C O) with (add O (couple c C)) in rcCO by (clear_all;fsetdecide).

assert (  rk (add O (union (triple A B b) (couple c C))) <= 3).
apply (double_flag O (triple A B b)  (couple c C));omega.
setoid_replace (add O (union (triple A B b) (couple c C)))
with (union (triple A B C) (triple O b c)) in H7 by (clear_all;fsetdecide).
omega.

assert(H6 := rk_couple1 gamma O H5).
assert ( rk (union (triple gamma B O) (triple gamma A O)) + rk (couple gamma O) <=
       rk (triple gamma B O) + rk (triple gamma A O)).
apply matroid3_useful;auto.
(clear_all;fsetdecide).
assert ( rk (union (triple gamma B O) (triple gamma A O))<= 2).
omega.

assert (
  rk
         (union (union (triple gamma B O) (triple b B O))
            (union (triple gamma B O) (triple gamma A O))) +
       rk (triple gamma B O) <=
       rk (union (triple gamma B O) (triple b B O)) +
       rk (union (triple gamma B O) (triple gamma A O))).
apply matroid3_useful;auto.
(clear_all;fsetdecide).
assert (rk (union (union (triple gamma B O) (triple b B O))
          (union (triple gamma B O) (triple gamma A O))) <= 2).
omega.
setoid_replace (union (union (triple gamma B O) (triple b B O))
          (union (triple gamma B O) (triple gamma A O)))  with (add O (quadruple A B gamma b)) in H10
          by (unfold Equal; split;clear_all;fsetdecide).
setoid_replace (triple c C O) with (add O (couple c C)) in rcCO by (clear_all;fsetdecide).
assert (rk (add O (union (quadruple A B gamma b) (couple c C))) <= 3).
apply double_flag;omega.
assert (rk (union (triple A B C) (triple gamma b c)) <=
rk (add O (union (quadruple A B gamma b) (couple c C)))).
apply matroid2.
clear_all;fsetdecide.
omega.
Qed.

Lemma A_not_beta_scheme : forall
(a : Point)
(b : Point)
(c : Point)
(A : Point)
(B : Point)
(C : Point)
(alpha : Point)
(beta : Point)
(gamma : Point)
(O : Point)
(raAO : rk (triple a A O) = 2)
(rbBO : rk (triple b B O) = 2)
(rcCO : rk (triple c C O) = 2)
(rABC : rk (triple A B C) = 3)
(rabc : rk (triple a b c) = 3)
(rABCabc : rk (union (triple A B C) (triple a b c)) >= 4)
(rABgamma : rk (triple A B gamma) = 2)
(rabgamma : rk (triple a b gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(racbeta : rk (triple a c beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)
(rbcalpha : rk (triple b c alpha) = 2)
(raA : rk (couple a A) = 2)
(rcC : rk (couple c C) = 2)
(rbB : rk (couple b B) = 2),
rk (couple A beta) = 2 \/ rk (triple alpha beta gamma) = 2.
Proof.
intros.
my_classical_left.
rename n into HnotDes.
apply rk_couple1.
intro.
rewrite H0 in *;clear H0.

assert (   rk (union (triple a beta O) (triple a c beta)) + rk (couple a beta) <=
       rk (triple a beta O) + rk (triple a c beta)).
apply  (matroid3_useful (triple a beta O) (triple a c beta) (couple a beta));clear_all;fsetdecide.
assert (rk (union (triple a beta O) (triple a c beta)) <=  2) by omega.
setoid_replace (union (triple a beta O) (triple a c beta)) with (quadruple a c beta O) in H1 by (clear_all;fsetdecide).

elim (eq_dec c O).
intro.
rewrite H2 in * ;clear H2.

elim (eq_dec B alpha); intro.
rewrite H2 in *;clear H2.

setoid_replace (triple beta alpha gamma) with (triple alpha beta gamma) in rABgamma by (clear_all;fsetdecide).
intuition.

assert(HH := rk_couple1 B alpha H2).
assert (rk (union (triple b O alpha) (triple b B O)) + rk (couple b O) <=
       rk (triple b O alpha) + rk (triple b B O)).
apply matroid3_useful.
clear_all;fsetdecide.
assert (rk (union (triple b O alpha) (triple b B O)) <=2).
assert (rk(couple b O)=2).
eapply rk_triple_ABC_couple_BC; eassumption.
omega.
assert (rk
         (union (union (triple b O alpha) (triple b B O)) (triple B C alpha)) +
       rk (couple B alpha) <=
       rk (union (triple b O alpha) (triple b B O)) + rk (triple B C alpha)).
apply matroid3_useful.
clear_all;fsetdecide.
assert ( rk (union (union (triple b O alpha) (triple b B O)) (triple B C alpha))<=2).
omega.
setoid_replace (union (union (triple b O alpha) (triple b B O)) (triple B C alpha))
                 with (add O (quadruple b C alpha B)) in H6 by (unfold Equal; split;clear_all;fsetdecide).
setoid_replace (triple a beta O) with (add O (couple a beta)) in raAO by (clear_all;fsetdecide).
assert ( rk (add O (union (quadruple b C alpha B) (couple a beta))) <= 3).
apply double_flag; auto.
omega.
assert (rk (add O (union (quadruple b C alpha B) (couple a beta)))>=
           rk (union (triple beta B C) (triple a b O))).
apply matroid2;clear_all;fsetdecide.
omega.

intro.
cut (rk (add C (quadruple a c beta O)) <= 2).
intro.
assert ( rk (union (add C (quadruple a c beta O)) (triple b B O)) +
       rk (singleton O) <=
       rk (add C (quadruple a c beta O)) + rk (triple b B O)).
apply matroid3_useful.
clear_all;fsetdecide.
rewrite rk_singleton in H4.
assert ( rk (union (add C (quadruple a c beta O)) (triple b B O)) <= 3) by omega.

assert (rk (union (triple beta B C) (triple a b c)) <=
rk (union (add C (quadruple a c beta O)) (triple b B O))).
apply matroid2.
clear_all;fsetdecide.
omega.

assert (HH := rk_couple1 c O H2).
assert ( rk (union (triple c C O) (quadruple a c beta O)) + rk (couple c O) <=
       rk (triple c C O) + rk (quadruple a c beta O)).
apply (matroid3_useful).
clear_all;fsetdecide.
setoid_replace (add C (quadruple a c beta O)) with (union (triple c C O) (quadruple a c beta O)) by (unfold Equal; split; clear_all;fsetdecide).
omega.
Qed.

End s_desargues3DLemmas.


Require Import StructTact.StructTactics.
Require Import Core Notations Tactics IntLemmas PtrLemmas.

Proposition addr_ge_to_sem_cmp_lt : forall b m b1 b2 i1 i2,
    addr_ge m (b1, i1) (b2, i2) = Some b ->
    sem_cmp Clt (Vptr b1 i1) (tptr tschar) (Vptr b2 i2) (tptr tschar) m =
    Some (Val.of_bool (negb b)).
Proof.
  intros.
  eapply sem_Clt_Cge_ptr.
  eapply ptr_ge_to_sem_cmp;
    eassumption.
Qed.

Proposition distance_to_sem_cmp_lt : forall dist m b1 b2 i1 i2,
    distance m (b1, i1) (b2, i2) = Some (S dist) ->
    sem_cmp Clt (Vptr b1 i1) (tptr tschar)
            (Vptr b2 i2) (tptr tschar) m = Some Vtrue.
Proof.
  intros until i2; intro Dist.
  replace b1 with b2 in *.
  pose proof (dist_to_lt _ _ _ _ _ Dist) as LT.
  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence.
  all: try rewrite <- ptrofs_lt_signed_lt in LT;
    try bool_rewrite; try intuition.
  unfold sem_binarith.
  all: repeat break_match; simpl in *; try congruence.

  simpl in *.
  all: unfold classify_cmp in *.

  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence.
Qed.

Lemma dist_succ : forall m b b' ofs ofs' dist,
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    Mem.weak_valid_pointer m b' (Ptrofs.unsigned (ofs' + 1)%ptrofs) = true ->
    distance m (b', (Ptrofs.add ofs' Ptrofs.one)) (b, ofs) = Some dist.
Proof.
  unfold distance, snd; intros.
  break_match_hyp; [| discriminate].
  break_if; subst; [| discriminate].
  inversion H; clear H.
  assert (Ptrofs.unsigned ofs' < Ptrofs.max_unsigned)%Z.
  {
    assert ((Ptrofs.unsigned ofs') < (Ptrofs.unsigned ofs))%Z.
    {
      assert ((Z.to_nat (Ptrofs.unsigned ofs')
               <
               Z.to_nat (Ptrofs.unsigned ofs))%nat) by lia.
      unfold Ptrofs.unsigned in *.
      destruct ofs, ofs'; simpl in *.
      pose proof (Z2Nat.inj_lt intval0 intval) as Inj.
      destruct Inj.
      all: try lia.
    }
    assert (Ptrofs.unsigned ofs <= Ptrofs.max_unsigned)%Z.
    pose proof (Ptrofs.unsigned_range_2 ofs).
    all: try lia.
  }
  replace (addr_ge m (b, ofs) (b', (ofs' + 1)%ptrofs))
    with (Some true).
  f_equal.
  enough (S (Z.to_nat (Ptrofs.unsigned (ofs')%ptrofs)) =
             Z.to_nat (Ptrofs.unsigned (ofs' + 1)%ptrofs)) by lia.
  rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr, <-Z2Nat.inj_succ.
  reflexivity.
  apply Ptrofs.unsigned_range.
  replace (Ptrofs.unsigned 1%ptrofs) with 1 by reflexivity.
  pose proof Ptrofs.unsigned_range ofs'.
  lia.

  unfold addr_ge, ptr_ge in *.
  simpl in *.
  repeat break_if; subst.
  all: try discriminate; unfold Mem.weak_valid_pointer in *.
  all: repeat destruct_andb_hyp.
  all: repeat destruct_orb_hyp.
  all: try congruence.
  all: clear - H H2 Heqo.

  all: assert (Z.to_nat (Ptrofs.unsigned ofs') + 1 <=
          Z.to_nat (Ptrofs.unsigned ofs))%nat
    by lia.
  all: unfold Ptrofs.ltu.
  all: break_if.
  all: rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr in *.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 in * by reflexivity.
  all: replace (1)%nat with (Z.to_nat 1)%nat in H0 by reflexivity.
  all: rewrite <-Z2Nat.inj_add in H0.
  all: try rewrite <-Z2Nat.inj_le in H0.
  all: try apply Ptrofs.unsigned_range.
  all: try reflexivity.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 by reflexivity.
  all: pose proof Ptrofs.unsigned_range ofs'.
  all: try lia.
Qed.

Proposition distance_succ_no_overflow :  forall m b b' ofs ofs' dist,
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    Ptrofs.unsigned (ofs' + 1)%ptrofs = Ptrofs.unsigned ofs' + 1.
Proof.
  intros.
  unfold distance, snd in *; intros.
  break_match_hyp; [| discriminate].
  break_if; subst; [| discriminate].
  inversion H; clear H.
  assert (Ptrofs.unsigned ofs' < Ptrofs.max_unsigned)%Z.
  {
    assert ((Ptrofs.unsigned ofs') < (Ptrofs.unsigned ofs))%Z.
    {
      assert ((Z.to_nat (Ptrofs.unsigned ofs')
               <
               Z.to_nat (Ptrofs.unsigned ofs))%nat) by lia.
      unfold Ptrofs.unsigned in *.
      destruct ofs, ofs'; simpl in *.
      pose proof (Z2Nat.inj_lt intval0 intval) as Inj.
      destruct Inj.
      all: try lia.
    }
    assert (Ptrofs.unsigned ofs <= Ptrofs.max_unsigned)%Z.
    pose proof (Ptrofs.unsigned_range_2 ofs).
    all: try lia.
  }

  all: rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr in *.
  all: replace (Ptrofs.unsigned 1%ptrofs) with 1 in * by reflexivity.
  auto.
  destruct ofs'; simpl in *.
  nia.
Qed.

Proposition distance_O : forall m b1 b2 i1 i2,
    distance m (b1,i1) (b2,i2) = Some O <->
    ((b1,i1) = (b2,i2))%ptrofs
    /\ Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true.
Proof.
  intros.
  split; unfold distance; intro.
  -  repeat break_match; try congruence.
     unfold addr_ge, ptr_ge,
     Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu in *.
     repeat break_match; simpl in *;
       try congruence.
     + inversion Heqo.
       assert ((Ptrofs.unsigned i1) <= (Ptrofs.unsigned i2))%Z.
       { eapply ptrofs_le_unsigned_le.
         eassumption.
       }
       erewrite <- Z2Nat.inj_sub in H.
       inversion H.
       rewrite <- Z2Nat.inj_0 in H3.
       assert (Ptrofs.unsigned i2 - Ptrofs.unsigned i1 = 0)%Z.
       { eapply Z2Nat.inj.
         all: try nia. }
       assert (i2 = i1)%ptrofs.
       assert (Ptrofs.unsigned i2 = Ptrofs.unsigned i1)%Z by nia.
       apply (ptrofs_to_unsigned_eq).
       eassumption.
       split.
       * f_equal.
         symmetry; eassumption.
         symmetry; eassumption.
       * rewrite H1.
         destruct_andb_hyp. eassumption.
       * destruct i1; simpl; nia.
     + inversion Heqo.
       assert ((Ptrofs.unsigned i1) <= (Ptrofs.unsigned i2))%Z.
       { eapply ptrofs_le_unsigned_le.
         eassumption.
       }
       erewrite <- Z2Nat.inj_sub in H.
       inversion H.
       rewrite <- Z2Nat.inj_0 in H3.
       assert (Ptrofs.unsigned i2 - Ptrofs.unsigned i1 = 0)%Z.
       { eapply Z2Nat.inj.
         all: try nia. }
       assert (i1 = i2)%ptrofs.
       assert (Ptrofs.unsigned i1 = Ptrofs.unsigned i2)%Z by nia.
       apply (ptrofs_to_unsigned_eq).
       eassumption.
       split.
       * f_equal.
         symmetry; eassumption.
         eassumption.
       * rewrite H1.
         destruct_andb_hyp. eassumption.
       * destruct i1; simpl; nia.
  - break_and.
    inversion H.
    rewrite <- H3.
    rewrite <- H2.
    repeat break_match.
    f_equal.
    nia.
    repeat break_match; try congruence.
    unfold addr_ge, ptr_ge,
    Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
    Ptrofs.ltu in *.
    repeat break_match; simpl in *;
      try congruence.
    all: try nia.

    repeat break_match; try congruence.
    unfold addr_ge, ptr_ge,
    Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
    Ptrofs.ltu in *.
    repeat break_match; simpl in *;
      try congruence.

    all: destruct_andb_hyp; try intuition.
    all:unfold Mem.weak_valid_pointer in *;
      congruence.
Qed.

Lemma dist_succ_load : forall dist c m b ofs b' ofs' v,
    Mem.loadv c m (Vptr b' ofs') = Some v ->
    distance m (b', ofs') (b, ofs) = Some (S dist) ->
    distance m (b', (Ptrofs.add ofs' Ptrofs.one)) (b, ofs) = Some dist.
Proof.
  intros until v;
    intros Load Dist.
  eapply loaded_is_valid in Load.
  eapply dist_succ.
  eassumption.
  unfold Mem.weak_valid_pointer.
  replace (Ptrofs.unsigned (ofs' + 1)%ptrofs - 1)%Z with
      (Ptrofs.unsigned ofs')%Z.
  rewrite Load.
  intuition.
  eapply distance_succ_no_overflow in Dist.
  rewrite Dist.
  nia.
Qed.

Proposition addr_lt_ge_eq : forall b m b1 b2 i1 i2 ,
    addr_ge m (b1, i1) (b2, i2) = Some b
    <-> addr_lt m (b1, i1) (b2, i2) = Some (negb b).
Proof.
  intros.
  unfold addr_lt.
  simpl.
  destruct b.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
Qed.

Proposition addr_lt_ge_eq' : forall b m b1 b2 i1 i2 ,
    addr_lt m (b1, i1) (b2, i2) = Some b
    <-> addr_ge m (b1, i1) (b2, i2) = Some (negb b).
Proof.
  intros.
  unfold addr_lt.
  simpl.
  destruct b.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
  * unfold option_map.
    break_match.
    destruct b.
    all: try (intuition || congruence).
    all: try congruence.
Qed.

Proposition addr_ge_to_ge : forall b m b1 b2 i1 i2 ,
    addr_ge m (b1, i1) (b2, i2) = Some b
    -> (i2 <=u i1)%ptrofs = b.
Proof.
  intros.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
      simpl in *;
      try congruence.
Qed.

Proposition addr_lt_to_lt : forall b m b1 b2 i1 i2 ,
    addr_lt m (b1, i1) (b2, i2) = Some b
    -> (i1 <u i2)%ptrofs = b.
Proof.
  intros.
  unfold addr_lt in *.
  Locate addr_lt.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
      simpl in *;
      try congruence;
      try intuition.
  unfold Ptrofs.ltu in *.
  repeat break_match;
    simpl in *;
    try congruence;
    try nia.
Qed.

Proposition addr_lt_to_sem_cmp_lt : forall b m b1 b2 i1 i2,
  addr_lt m (b1, i1) (b2, i2) = Some b ->
     (sem_cmp Clt (Vptr b1 i1) (tptr tschar)
              (Vptr b2 i2) (tptr tschar) m = Some (Val.of_bool b)).
Proof.
  intros until i2; intro Addr.
  eapply sem_Clt_Cge_ptr'.
  eapply addr_lt_ge_eq' in Addr.
   eapply ptr_ge_to_sem_cmp;
     eassumption.
Qed.

Proposition addr_lt_trans : forall m b1 b2 i1 i2,
    addr_lt m (b1, (i1 + 1)%ptrofs) (b2, i2) = Some true ->
    Ptrofs.unsigned (i1 + 1)%ptrofs = Ptrofs.unsigned i1 + 1 ->
    Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true ->
    addr_lt m (b1, i1) (b2, i2) = Some true.
Proof.
  intros until i2;
    intro Addr; intro OF;
      intro Ptr.
  unfold addr_lt, Mem.weak_valid_pointer in *.
  unfold distance, sem_cmp, cmp_ptr, addr_lt, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence;
    simpl in *;
    try congruence;
    try intuition.
  unfold Ptrofs.ltu in *.
  repeat break_match;
    simpl in *;
    try congruence;
    rewrite OF in *;
    simpl in *;
    try nia.
  repeat destruct_andb_hyp;
    repeat destruct_orb_hyp;
    try congruence.
  Qed.

Proposition addr_lt_succ_to_sem_cmp : forall m b1 b2 i1 i2,
    addr_lt m (b1, (i1 + 1)%ptrofs) (b2, i2) = Some true ->
    Ptrofs.unsigned (i1 + 1)%ptrofs = Ptrofs.unsigned i1 + 1 ->
    Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true ->
    (sem_cmp Clt (Vptr b1 i1) (tptr tschar)
             (Vptr b2 i2) (tptr tschar) m = Some (Val.of_bool true)).
Proof.
  intros until i2;
    intro Addr; intro OF; intro Ptr.
  eapply addr_lt_trans in Addr.
  eapply addr_lt_to_sem_cmp_lt.
  all: eassumption.
Qed.

Proposition mem_load_inj_ptr : forall m b1 b2 b3 i1 i2 i3,
    Mem.load Mptr m b1 (Ptrofs.unsigned i1) = Some (Vptr b2 i2) ->
    Mem.load Mptr m b1 (Ptrofs.unsigned i1) = Some (Vptr b3 i3) ->
    b2 = b3 /\ i2 = i3.
Proof.
  intros until i3;
    intros Mem1 Mem2.
  split; rewrite Mem1 in Mem2;
    inversion Mem2; auto.
Qed.

Lemma ptr_ge_is_valid : forall m b1 b2 i1 i2 ,
  ptr_ge m b1 b2 i1 i2 = Some false ->
  Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i1) = true.
Proof.
  unfold Mem.weak_valid_pointer.
  intros.
  unfold distance, sem_cmp, cmp_ptr, addr_ge, ptr_ge,
  Val.cmplu_bool, Val.cmpu_bool, Ptrofs.cmpu,
  Val.cmp_different_blocks,
  classify_cmp in *.
  repeat break_match;
    try congruence; repeat destruct_andb_hyp;
      try congruence;
      repeat destruct_orb_hyp;
      try congruence.
  Qed.

Lemma ptrofs_le_unsigned_le_neg : forall a b,
  (a <=u b)%ptrofs = false <->
  not (Ptrofs.unsigned a <= Ptrofs.unsigned b)%Z.
Proof.
  split; intros; unfold not; intros.
  - unfold Ptrofs.ltu in H.
    destruct zlt; [nia | intuition].
  - unfold Ptrofs.ltu.
    destruct zlt; intuition.
Qed.


(* * FOL Reductions *)

From Undecidability.DiophantineConstraints Require Import H10C.
From Undecidability.DiophantineConstraints.Util Require Import H10UPC_facts.
From Undecidability.FOL Require Import Utils.FriedmanTranslationFragment Syntax.Facts Deduction.FragmentNDFacts Semantics.Tarski.FragmentSoundness Semantics.Tarski.FragmentFacts Syntax.BinSig Semantics.Kripke.FragmentCore  Semantics.Kripke.FragmentSoundness Semantics.Kripke.FragmentToTarski.
From Undecidability.Shared Require Import Dec.
From Undecidability.Shared.Libs.PSL Require Import Numbers.
From Coq Require Import Arith Lia List.
From Undecidability.FOL.Reductions Require Import H10UPC_to_FOL_constructions.

Import FragmentSyntax.

(* ** Validity *)

(*
Idea: The relation (###) has the following properties:#
#
#
#n ~ p: n is left component of p#
#
#
#p ~ n: p is right component of p#
#
#
#p ~ p: the special relationship of H10UPC#
#
#
#n ~ m: n = m. Special case n=0, m=1: #
#
          The instance h10 of H10UPC is a yes-instance. #
#
          This is to facilitate Friedman translation#
#
*)

Set Default Goal Selector "!".

(* The validity reduction.
    We assume a generic falsity flag and a list h10 for which we build a formula.
 *)
Section Fr_validity.

  Context {ff : falsity_flag}.
  Context {h10 : list h10upc}.
  Definition F_Fr := Fr (@F ff h10).
  (* We now define our standard model. *)
  Section FrInverseTransport.
    (* An element of the standard model is either a number or a pair. *)
    Inductive dom : Type := Num : nat -> dom | Pair : nat  -> nat -> dom.
    (* The interpretation of our single binary relation *)
    Definition dom_rel' (a : dom) (b:dom) : Prop := match (a,b) with
    | (Num  0, Num  1) => H10UPC_SAT h10
    | (Num n1, Num n2) => n1 = n2
    | (Num n1, Pair x2 _) => n1 = x2
    | (Pair _ y1, Num n2) => n2 = y1
    | (Pair x1 y1, Pair x2 y2) => h10upc_sem_direct ((x1, y1), (x2, y2))
    end.

    Local Instance IB : @interp _ (@extended_preds sig_binary) (dom) | 0.
    Proof using h10.
      split; intros [] v.
      - exact (H10UPC_SAT h10).
      - exact (dom_rel' (Vector.hd v) (Vector.hd (Vector.tl v))).
    Defined.
    #[local] Notation "rho ⊨ phi" := (sat rho (Fr phi)) (at level 20).
    (* Now we need rewrite helpers which transform our syntactic sugar into useful statements in the model *)
    Lemma IB_sFalse rho : rho ⊨ (∀ ∀ Pr $0 $1) <-> H10UPC_SAT h10.
    Proof.
    split.
    * intros H. specialize (H (Num 0) (Num 1)). cbn in H. apply H. intros Hf. congruence.
    * intros H d1 d2 Hc. apply H.
    Qed.
    Opaque sFalse.

    Notation dFalse := (H10UPC_SAT h10).
    Notation mDN P := ((P -> dFalse) -> dFalse).
    Notation dom_rel a b := (mDN (dom_rel' a b)).

    Lemma IB_sNot rho f : rho ⊨ (f → sFalse) <-> ((rho ⊨ f) -> H10UPC_SAT h10).
    Proof.
    split.
    * intros H. cbn in H. now rewrite IB_sFalse in H.
    * intros H. cbn. now rewrite IB_sFalse.
    Qed.

    Definition rho_canon' n (rho : nat -> dom) := rho n = Num 0 /\ rho (S n) = Num 0 /\ rho (S (S n)) = Num 1.
    Notation rho_canon rho := (rho_canon' 0 rho).
    Lemma IB_wFalse rho t : rho ⊨ wFalse t <-> dom_rel (rho t) (rho (S t)).
    Proof.
    split.
    * intros H. apply H.
    * intros H. unfold wFalse, Fr. intros P. apply H. apply P.
    Qed.
    Opaque wFalse.

    Lemma IB_dFalse rho t : rho t = Num 0 -> rho (S t) = Num 1 -> rho ⊨ wFalse t <-> dFalse.
    Proof.
    intros H1 H2. rewrite IB_wFalse. rewrite H1,H2. cbn. tauto.
    Qed.
    Opaque wFalse.

    Lemma IB_Not rho f t : rho ⊨ Not f t <-> ((rho ⊨ f) -> rho ⊨ wFalse t).
    Proof.
    split.
    * intros H. cbn in H. now rewrite IB_wFalse in H.
    * intros H. cbn. now rewrite IB_wFalse.
    Qed.
    Opaque Not.

    Lemma IB_F_zero rho : rho_canon rho -> rho ⊨ F_zero.
    Proof.
      intros (H0&H1&H2). cbn. rewrite !H0. tauto.
    Qed.

    Ltac dn := let H := fresh "H" in intros H; apply H.
    Lemma IB_N_e rho i n : rho i = n -> rho ⊨ N i -> mDN {m:nat | Num m = n}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * dn. now exists m.
    * intros H1. apply H; cbn -[dom_rel']. intros Hh. apply H1. rewrite Hrho in Hh. exfalso. apply (@h10_rel_irref (a,b) Hh).
    Qed.

    Lemma IB_N_i rho i n : rho i = Num n -> (rho) ⊨ N i.
    Proof. cbn. intros ->. dn. now destruct n as [|n'] eqn:Heq.
    Qed.
    Opaque N.

    Lemma IB_P'_e rho i n : rho i = n -> rho ⊨ P' i -> mDN {a:nat & {b:nat & n = Pair a b}}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * unfold P' in H. rewrite IB_sNot in H. intros Hc1. apply H.
      eapply IB_N_i, Hrho.
    * dn. now exists a, b.
    Qed.

    Lemma IB_P'_i rho i a b : rho i = (Pair a b) -> rho ⊨ P' i.
    Proof.
    unfold P'. rewrite IB_sNot. intros Hrho H. apply (@IB_N_e rho i (Pair a b)).
    1-2:easy. intros (m & Hm). congruence.
    Qed.
    Opaque P'.

    Lemma IB_P_e rho p l r ip il ir c :
        rho ip = p -> rho il = l -> rho ir = r
     -> rho ⊨ P ip il ir c -> {a:nat & {b:nat & p = Pair a b /\ l = Num a /\ r = Num b}}
     -> rho ⊨ c.
    Proof.
    intros Hp Hl Hr H [a [b [Hp' [Hl' Hr']]]]. cbn in H.
    rewrite Hp, Hl, Hr, Hp', Hl', Hr' in H. cbn in H. apply H.
    - eapply IB_P'_i. now rewrite Hp, Hp'.
    - eapply IB_N_i. now rewrite Hl, Hl'.
    - eapply IB_N_i. now rewrite Hr, Hr'.
    - dn. now destruct a.
    - dn. easy.
    Qed.

    Lemma mDN_sat rho phi : mDN (rho ⊨ phi) -> rho ⊨ phi.
    Proof.
      induction phi as [| |?[]|?[]] in rho|-*; cbn -[dom_rel']; intros H.
      - apply H. tauto.
      - intros Hc. apply H. intros Hc2. now apply Hc2.
      - intros H1. apply IHphi2. intros Hc. apply H. intros Hv. apply Hc, Hv, H1.
      - intros d. apply IHphi. intros Hc. apply H. intros Hc2. apply Hc, Hc2.
    Qed.

    Lemma IB_P_i rho ip il ir c : (forall a b, rho ip = (Pair a b)
                                 -> rho il = (Num a) -> rho ir = (Num b) -> rho ⊨ c)
                                 -> rho ⊨ P ip il ir c.
    Proof.
      intros Hc1 Hc3 Hc4 Hc5 Hpl Hpr.
      apply mDN_sat. intros Hc8.
      unshelve eapply (IB_P'_e (n:=rho ip) _ Hc3); [easy|]. intros [pa [pb Hp]].
      unshelve eapply (IB_N_e (n:=rho il) _ Hc4); [easy|]. intros [la Ha].
      unshelve eapply (IB_N_e (n:=rho ir) _ Hc5); [easy|]. intros [lb Hb].
      apply Hpl; cbn -[dom_rel']; intros Hpl'.
      apply Hpr; cbn -[dom_rel']; intros Hpr'.
      rewrite Hp in *.
      rewrite <-Ha in *.
      rewrite <-Hb in *. unfold dom_rel' in *.
      apply Hc8. destruct la; eapply (Hc1 pa pb); congruence.
    Qed.
    Opaque P.

    (* We show our model fulfills axiom 1 *)

    Lemma IB_F_succ_left rho : rho_canon rho -> rho ⊨ F_succ_left.
    Proof.
      intros (H0&H1&H2). unfold F_succ_left. intros n Hc1.
      rewrite IB_Not. intros Hc.
      rewrite IB_wFalse; cbn; rewrite H1, H2; intros _.
      eapply (IB_N_e (n:=n) (i:=0) eq_refl Hc1).
      intros [m Hnm]. cbn in Hc.
      specialize (Hc (Pair m 0) (Num (S m)) (Pair (S m) 0)).
      eapply IB_P_e in Hc; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; congruence.
      eapply IB_P_e in Hc; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; congruence.
      cbn in Hc. rewrite IB_dFalse in Hc. 2-3: cbv; congruence.
      apply Hc. dn. lia.
    Qed.

    (* We show we can extract constraints from our model *)

    Lemma IB_rel_e rho ipl ipr ia ib ic id t : rho ⊨ rel ipl ipr ia ib ic id t
                -> {a&{b&{c&{d|rho ipl=Pair a b
                            /\ rho ipr = Pair c d
                            /\ rho ia=Num a
                            /\ rho ib=Num b
                            /\ rho ic=Num c
                            /\ rho id=Num d
                            /\ h10upc_sem_direct ((a,b),(c,d))}}}}
                -> rho ⊨ t.
    Proof.
    intros H [a [b [c [d [Hpl [Hpr [Ha [Hb [Hc [Hd Habcd]]]]]]]]]].
    unfold rel in H.
    eapply IB_P_e in H; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; eassumption.
    eapply IB_P_e in H; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; eassumption.
    cbn in H.
    apply H. dn. rewrite Hpl, Hpr. easy.
    Qed.

    Lemma IB_rel_i rho ipl ipr ia ib ic id t :
                ({a&{b&{c&{d|rho ipl=Pair a b
                            /\ rho ipr = Pair c d
                            /\ rho ia=Num a
                            /\ rho ib=Num b
                            /\ rho ic=Num c
                            /\ rho id=Num d
                            /\ h10upc_sem_direct ((a,b),(c,d))}}}} -> rho ⊨ t)
             -> rho ⊨ rel ipl ipr ia ib ic id t.
    Proof.
    intros H.
    apply IB_P_i.
    intros a b Hpl Ha Hb. apply IB_P_i.
    intros c d Hpr Hc Hd Habcd. cbn -[dom_rel'] in Habcd.
    apply mDN_sat. intros Hc'. apply Habcd. intros Habcd'.
    apply Hc'. apply H. exists a,b,c,d. cbn in Habcd'.
    rewrite Hpl, Hpr in Habcd'. now repeat split.
    Qed.

    (* We show our model fulfills axiom 2 *)

    Lemma IB_F_succ_right rho : rho_canon rho -> rho ⊨ F_succ_right.
    Proof.
      intros (H0&H1&H2). unfold F_succ_right. intros p1 p2 p3 p4 p5 p6 p7 p8 a' y' c b a y x.
      apply IB_rel_i. cbn. intros [nx [ny [na [nb [Hp8 [Hp7 [Hx [Hy [Ha [Hb [Hr1l Hr1r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [nb' [ny' [nc [nb'' [Hp6 [Hp5 [Hb' [Hy' [Hc [Hb'' [Hr2l Hr2r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [ny'' [z [n'y [z' [Hp4 [Hp3 [Hy'' [Hz [H'y [Hz' [Hr3l Hr3r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [na' [z'' [n'a [z''' [Hp2 [Hp1 [Ha' [Hz'' [H'a [Hz''' [Hr4l Hr4r]]]]]]]]]]].
      unfold erel. cbn.
      rewrite IB_Not. intros H.
      rewrite H0 in *. cbn in H.
      specialize (H (Pair n'a (nc)) (Pair nx n'y)).
      eapply IB_P_e in H. 2-4: easy. 2: exists nx, n'y; cbn; firstorder.
      eapply IB_P_e in H. 2-4: easy. 2: exists n'a, nc; cbn; firstorder.
      cbn in H. rewrite IB_wFalse in H. rewrite IB_dFalse. 2-3: cbv; congruence.
      cbn -[dom_rel'] in H.
      assert (z=0 /\ z' = 0 /\ z'' = 0 /\ z''' = 0) as [-> [-> [-> ->]]].
      1:firstorder;congruence.
      assert (ny'' = ny /\ na' = na) as [-> ->].
      1:firstorder;congruence.
      assert (nb' = nb /\ ny' = ny) as [-> ->].
      1:firstorder;congruence.
      subst n'y. subst nc. subst n'a.
      rewrite <- IB_dFalse. 2: apply H1. 2: apply H2. apply IB_wFalse.
      apply H.
      dn. lia.
    Qed.

    (* We show we can encode constraints into our model *)

    (* rho_descr_phi describes that rho is defined by the solution to h10 *)
    Definition rho_descr_phi rho (φ:nat->nat) n :=
         forall k, k < n -> match rho k with Num n => n = (φ k) | _ => True end.
    Lemma IB_single_constr rho φ (n:nat) (h:h10upc) : rho_descr_phi rho φ n
                                           -> highest_var h < n
                                           -> rho_canon' n rho
                                           -> rho ⊨ translate_single h (S n)
                                           -> (h10upc_sem φ h -> dom_rel (rho (1+n)) (rho (2+n)))
                                           -> dom_rel (rho (1+n)) (rho (2+n)).
    Proof.
      intros Hrhophi Hmaxhall (Hr0&Hr1&Hr2).
      destruct h as [[a b][c d]]. unfold translate_single. cbn in Hmaxhall.
      intros Htr Hcon Hcon'. unfold erel in Htr. rewrite IB_Not in Htr.
      rewrite IB_dFalse in Htr. 2-3:easy. apply Htr.
      intros p2 p1.
      apply IB_P_i. cbn. intros na nb Hp1 Ha Hb.
      apply IB_P_i. cbn. intros nc nd Hp2 Hc Hd. rewrite Hp1, Hp2.
      intros Habcd.
      rewrite IB_dFalse. 2-3:easy.
      assert (na = φ a) as ->. 1: pose (@Hrhophi a) as Hp; rewrite Ha in Hp; apply Hp; lia.
      assert (nb = φ b) as ->. 1: pose (@Hrhophi b) as Hp; rewrite Hb in Hp; apply Hp; lia.
      assert (nc = φ c) as ->. 1: pose (@Hrhophi c) as Hp; rewrite Hc in Hp; apply Hp; lia.
      assert (nd = φ d) as ->. 1: pose (@Hrhophi d) as Hp; rewrite Hd in Hp; apply Hp; lia.
      apply Habcd. intros Habcd'.
      apply Hcon. 2: apply Hcon'.
      apply Habcd'.
    Qed.
    (* Helper for working with nested quantifiers *)

    Lemma IB_emplace_forall rho n i :
        (forall f, (fun k => if k <? n then f (k) else rho (k-n)) ⊨ i)
     -> rho ⊨ emplace_forall n i.
    Proof.
      intros H.
      induction n as [|n IH] in rho,H|-*.
      - cbn. eapply (sat_ext IB (rho := rho) (xi:=fun k => rho(k-0))).
        2: apply (H (fun _ => Num 0)).
        intros x. now rewrite Nat.sub_0_r.
      - intros d.
        specialize (IH (d.:rho)). apply IH. intros f.
        eapply (sat_ext IB (xi:=fun k => if k <? S n
                                         then (fun kk => if kk =? n then d
                                         else f kk) k else (rho) (k - S n))).
        2: eapply H.
        intros x.
        destruct (Nat.eq_dec x n) as [Hxn|Hnxn].
        + destruct (Nat.ltb_ge x n) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
          destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt. cbn.
          assert (x-n=0) as ->. 1: lia. cbn. destruct (Nat.eqb_eq x n) as [_ HH]. now rewrite HH.
        + destruct (x <? n) eqn:Hneq.
          * destruct (Nat.ltb_lt x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            cbn. destruct (Nat.eqb_neq x n) as [_ HH]. rewrite HH. 1: easy. lia.
          * destruct (Nat.ltb_ge x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_ge x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            assert (x-n=S(x-S n)) as ->. 1:lia. easy.
    Qed.
    Opaque emplace_forall.
    (* Final utility lemma: translate the entire list of constraints *)

    Lemma IB_translate_rec rho phi f e hv : rho_descr_phi rho phi hv
                            -> rho_canon' hv rho
                            -> (rho ⊨ f <-> dom_rel (rho (1+hv)) (rho (2+hv)))
                            -> highest_var_list e < hv
                            -> ((forall c, In c e -> h10upc_sem phi c) -> rho ⊨ f)
                            -> rho ⊨ translate_rec f (S hv) e.
    Proof.
    intros Hrhophi (Hr0&Hr1&Hr2) Hsat Hhv H.
    induction e as [|eh er IH] in H,Hsat,Hhv|-*.
    - apply H. intros l [].
    - cbn. intros Hts. apply IH.
      + easy.
      + cbn in Hhv. lia.
      + intros HH. rewrite Hsat. eapply (IB_single_constr (h:=eh)).
        * exact Hrhophi.
        * pose proof (@highest_var_list_descr (eh::er) eh ltac:(now left)). lia.
        * easy.
        * easy.
        * intros Hsem. rewrite <- Hsat. apply H. intros c [il|ir]. 2:now apply HH. congruence.
    Qed.
    (* We can now extract the constraints from our translate_constraints function*)

    Lemma less_ge a b : a >= b -> a <? b = false.
    Proof.
      intros H. rewrite Nat.ltb_nlt. lia.
    Qed.

    Lemma IB_aux_transport rho : rho_canon rho
                              -> rho ⊨ translate_constraints h10
                              -> H10UPC_SAT h10.
    Proof.
      intros (Hrho0&Hrho1&Hrho2).
      pose ((S (highest_var_list h10))) as h10vars.
      unfold translate_constraints. fold h10vars. intros H.
      cbn in H. rewrite Hrho1, Hrho2 in H.
      apply H. 2:easy.
      apply IB_emplace_forall. intros f.
      pose (fun n => match (f n) with (Num k) => k | _ => 0 end) as phi.
      eapply (IB_translate_rec (e:=h10) (hv:=h10vars) (phi:= phi)).
      - intros x HH. destruct (Nat.ltb_lt x h10vars) as [_ Hr]. rewrite Hr. 2:easy.
        unfold phi. now destruct (f x).
      - split. 2:split. all: rewrite less_ge; [|lia].
        1: rewrite <- Hrho0. 2: rewrite <- Hrho1. 3: rewrite <- Hrho2. all: f_equal; lia.
      - cbn -[dom_rel' Nat.leb Nat.sub]. easy.
      - lia.
      - intros HG. cbn -[dom_rel' Nat.leb Nat.sub].
        destruct (Nat.ltb_ge (S h10vars) h10vars) as [_ H1]. rewrite H1. 2:lia.
        destruct (Nat.ltb_ge (S (S h10vars)) h10vars) as [_ H2]. rewrite H2. 2:lia.
        assert (S h10vars-h10vars = 1) as ->. 1:lia.
        assert (S(S h10vars)-h10vars = 2) as ->. 1:lia.
        rewrite Hrho1, Hrho2. cbn. exists phi. easy.
    Qed.

    (* To conclude, we can wrap the axioms around it.*)
    Lemma IB_fulfills rho : rho ⊨ (@F ff h10) -> H10UPC_SAT h10.
    Proof.
      intros H. unfold F in H. pose (Num 0 .: Num 0 .: Num 1 .: rho) as nrho.
      assert (rho_canon nrho) as nrho_canon.
      1: split; easy.
      apply (@IB_aux_transport nrho), H.
      - easy.
      - now apply IB_F_zero.
      - now apply IB_F_succ_left.
      - now apply IB_F_succ_right.
    Qed.
  End FrInverseTransport.

  (* If F is valid, h10 has a solution: *)
  Lemma FrInverseTransport : valid (Fr (@F ff h10)) -> H10UPC_SAT h10.
  Proof.
    intros H. apply (@IB_fulfills (fun b => Num 0)). apply H.
  Qed.

End Fr_validity.

(* We also have classical provability, assuming LEM *)
Section classical_provability.
  Context {ff : falsity_flag}.
  Context {h10 : list h10upc}.

  Lemma classicalProvabilityTransport : H10UPC_SAT h10 -> nil ⊢C F (h10:=h10).
  Proof.
  intros [φ Hφ]. apply intuitionistic_is_classical. eapply transport_prove. exact Hφ.
  Qed.

  Lemma classicalProvabilityInverseTransport : nil ⊢C F (h10:=h10) -> H10UPC_SAT h10.
  Proof.
  intros H%(Fr_cl_to_min)%soundness. apply FrInverseTransport. intros D I rho.
  apply H. easy.
  Qed.
End classical_provability.