Require Import Arith.
Require Import Omega.
Require Import Psatz.

Require Import kernel_numeric.
Require Import kernel_graph.
Require Import graph_constructions.

(**
Graph constructions properties.
**)

(*
Search (_ + _ = _ + _  -> _ = _).
*)

(* Dodana tocka trditve. *)
(*#####>*)

Theorem graph_add_point_clear_point_more (G : Graph):
  V (graph_add_point_clear G) = 1 + (V G).
Proof.
  auto.
Qed.

Theorem graph_add_point_clear_edges_part1 (G : Graph):
  all x : (V G),
    ((if (E_decidable (graph_add_point_clear G) (V G) x)
    then 1 else 0) = 0).
Proof.
  intros x p.
  destruct (E_decidable (graph_add_point_clear G) G x).
  - destruct e.
    omega.
  - auto.
Qed.

Theorem graph_add_point_clear_edges_part2 (G : Graph):
  count G (E_decidable (graph_add_point_clear G) G) =
  sum' G (fun x : nat => 0).
Proof.
  unfold count.
  apply change_sum.
  intros j p.
  pose (graph_add_point_clear_edges_part1 G j p). (* tu bi rad ' (crtico)*)
  apply e.
Qed.

Theorem graph_add_point_clear_edges_part3 (G : Graph):
  count G (E_decidable (graph_add_point_clear G) G) = 0.
  rewrite graph_add_point_clear_edges_part2.
  rewrite (sum_n_krat_k (V G) 0).
  auto.
Qed.

Theorem graph_add_point_clear_edges_part4 (G : Graph):
  (all x : V G , all y : V G,
  ((if E_decidable G x y then 1 else 0) =
  (if E_decidable (graph_add_point_clear G) x y then 1 else 0))).
Proof.
  intros x p y q.
  destruct (E_decidable (graph_add_point_clear G) x y); destruct (E_decidable G x y); auto.
  - destruct e; absurd (G x y); destruct H0; auto.
  - absurd ((graph_add_point_clear G) x y). (* Se to da drugace? *)
    + auto.
    + simpl.
      auto.
Qed.

Theorem graph_add_point_clear_edges (G : Graph):
  edges (graph_add_point_clear G) = edges G.
Proof.
  unfold edges.
  replace (V (graph_add_point_clear G)) with (S (V G)).
  - rewrite sum'_S.
    replace (sum' G (fun x : nat => count x (E_decidable (graph_add_point_clear G) x)))
      with (sum' G (fun x : nat => count x (E_decidable G x))).
    + replace (count G (E_decidable (graph_add_point_clear G) G)) with 0.
      * auto.
      * rewrite graph_add_point_clear_edges_part3.
        auto.
    + apply change_sum.
      intros j p.
      apply change_sum.
      intros i q.
      (* tega spodaj ne maram inline *)
      (* tegale: (Nat.lt_trans i j (V G) q p) *)
      (* ali se da drugace? -> ja uporabim assert*)
      apply (graph_add_point_clear_edges_part4 G j p i (Nat.lt_trans i j (V G) q p)).
  - replace (S (V G)) with (1 + (V G)).
    + apply (graph_add_point_clear_point_more G).
    + omega.
Qed.

(*#####<*)
(* Dodana tocka trditve. *)

(* Stozec trditve. *)

Theorem stozec_ima_tocko_vec:
  (forall G : Graph, V (graph_add_point_full G) = 1 + (V G)).
Proof.
  intro.
  auto.
Qed.

Theorem stozec_edges_part1 (G : Graph):
  all x : (V G),
    ((if (E_decidable (graph_add_point_full G) (V G) x)
    then 1 else 0) = 1).
Proof.
  intros x p.
  destruct (E_decidable (graph_add_point_full G) G x).
  - auto.
  - absurd ((graph_add_point_full G) G x).
    + auto.
    + simpl.
      auto.
Qed.

Theorem stozec_edges_part2 (G : Graph):
  count G (E_decidable (graph_add_point_full G) (V G)) =
  sum' G (fun x : nat => 1).
Proof.
  unfold count.
  apply change_sum.
  intros j p.
  apply (stozec_edges_part1 G j p).
Qed.

Theorem stozec_edges_part3 (G : Graph):
  count G (E_decidable (graph_add_point_full G) G) = (V G).
  rewrite stozec_edges_part2.
  rewrite (sum_n_krat_k (V G) 1).
  omega.
Qed.

Theorem stozec_edges_part4 (G : Graph):
  (all x : V G , all y : V G,
  ((if E_decidable G x y then 1 else 0) =
  (if E_decidable (graph_add_point_full G) x y then 1 else 0))).
Proof.
  intros x p y q.
  destruct (E_decidable (graph_add_point_full G) x y).
  - destruct e; destruct (E_decidable G x y); auto; absurd (G x y); auto.
    + apply H.
    + omega.
  - destruct (E_decidable G x y); auto.
    absurd((graph_add_point_full G) x y); auto.
    simpl; auto.
Qed.

(*
Search (_ + _ = _ + _ -> _ = _).
*)
(*
Search (_ + _ = _ + _).
*)
(*
Search (_ = _ -> _ + _ = _ + _ ).
*)

Theorem krajsanje (p n m : nat):
  (n = m) -> (p + n = p + m).
Proof.
  omega.
Qed.

Theorem stozec_ima_vec_povezav (G : Graph):
  edges (graph_add_point_full G) = (V G) + edges G.
Proof.
  unfold edges.
  replace (V (graph_add_point_full G)) with (S (V G)). (* try omega. ne dela zakaj? *)
  - rewrite sum'_S.
    rewrite stozec_edges_part3.
    apply krajsanje.
    apply change_sum.
    intros j p.
    unfold count.
    apply change_sum.
    intros i q.
    (* V naslednji vrstici rewrite; auto dela apply pa ne. *)
    rewrite (stozec_edges_part4 G j p i (Nat.lt_trans i j (V G) q p)); auto.
  - rewrite stozec_ima_tocko_vec.
    (* Moram popraviti definicijo stozca pa bo slo tole brez omega. *)
    omega.
Qed.


(** Load required packages. **)

Require Export Setoid Plus List Sorted Constructive_sets Utf8_core.

(** Unicode (UTF8) notations. **)
Require Export Classical_Prop Utf8.
Require Export BinNums.
Require Import BinPos BinNat.

Local Open Scope Z_scope.

Notation "x ⇒ y" := (x -> y)
  (at level 99, y at level 200, right associativity): type_scope.

Notation "x ⇔ y" := (x <-> y) (at level 95, no associativity): type_scope.

Notation "∃ ! x .. y , p" :=
  (ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
  (at level 200, x binder, right associativity,
   format "'[' '∃'  !  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

(** Useful symbols: ∀ ∃ ⇒ ⇔ ∧ ∨ ¬ ≠ ≤ ≥ ℕ ℤ ∈ ∉ ⊂ ∑ ∏ **)

(** Axioms for the integers. **)

Parameter Z : Set.

Parameter add mult : Z → Z → Z.
Parameter neg : Z → Z.
Parameter zero one : Z.
Notation "0" := zero.
Notation "1" := one.
Infix "+" := add.
Infix "*" := mult.
Notation "- x" := (neg x).
Notation "- 0" := (neg 0) (only parsing).
Notation "- 1" := (neg 1).
Definition sub a b := a + -b.
Infix "-" := sub.
Theorem Dan : ∀ P : Prop, P ∨ ¬ P.
Proof.
intros.
auto.
pose proof (classic P) as H0.
exact H0.
Qed.

Axiom A1 : ∀ a b   : Z, a + b = b + a.
Axiom A2 : ∀ a b c : Z, (a + b) + c = a + (b + c).
Axiom A3 : ∀ a     : Z, a + 0 = a.
Axiom A4 : ∀ a     : Z, a + -a = 0.
Axiom M1 : ∀ a b   : Z, a * b = b * a.
Axiom M2 : ∀ a b c : Z, (a * b) * c = a * (b * c).
Axiom M3 : ∀ a     : Z, a * 1 = a.
Axiom D1 : ∀ a b c : Z, (a + b) * c = a * c + b * c.

Lemma S1 : ∀ a b c : Z, a = b ⇒ a + c = b + c.
Proof.
  intros a b c H.
  congruence.
Qed.

Lemma S2 : ∀ a b c : Z, a = b ⇒ a * c = b * c.
Proof.
  intros a b c H.
  congruence.
Qed.

(** Homework assignment problems are given below. **)

Theorem A1P1 :  forall a : Z, 0 + a = a.
Proof.
   intros.
pose proof (A1 0 a).
rewrite A3 in H.
exact H.
Qed.

Theorem A1P2 :  forall a : Z, -a + a = 0.
Proof.
intros.
pose proof ( A1 (-a) a).
rewrite A4 in H.
exact H.
Qed.

Theorem A1P3 :  forall a : Z, 1 * a = a.
Proof.
intros.
pose proof (M1 1 a).
rewrite M3 in H.
exact H.
Qed.

Theorem A1P4 :  forall a b : Z, a + b = 0 ⇒ b = -a.
Proof.
intros.
apply (S1 (a+b) 0 (-a)) in H.
rewrite A1 in H.
rewrite <-A2 in H.
rewrite A1P2 in H.
rewrite A1 in H.
rewrite A3 in H.
rewrite A1 in H.
rewrite A3 in H.
exact H.
Qed.
Theorem U:  forall a : Z, -a= - (a).
Proof.
intros.
reflexivity.
Qed.

Theorem A1P5 :  forall a : Z, -(-a) = a.
Proof.
intros.
pose proof ( A4 (-a)).
apply (S1 _ _ a) in H.
rewrite A1P1 in H.
rewrite A1 in H.
rewrite <-A2 in H.
rewrite A4 in H.
rewrite A1P1 in H.
exact H.
Qed.

Theorem A1P6 :  forall a : Z, 0 * a = 0.
Proof.
intros.
  pose proof (A3 0).
  (* Multiply both sides by a *)
  apply (S2 (0+0) 0 a) in H.
  (* Undo the previous step in order to show you a different way
     to do the same thing *)
  Undo.
  (* Multiply both sides by a. Blank spaces _ mean "fill in the blank
     with the obvious thing" *)
  apply (S2 _ 0 a) in H.
  rewrite D1 in H.
  apply (S1 _ _ (-(0*a))) in H.
  rewrite A2 in H.
  (* If you want to use Axiom A2 backwards (i.e. replace "a+(b+c)"
     with "(a+b)+c", instead of replacing "(a+b)+c" with "a+(b+c)")
     then you need to use "rewrite <-A2" instead of "rewrite A2" *)
  rewrite <-A2 in H.
  (* Undo previous step, which was only for demonstration purposes *)
  rewrite A2 in H.
  rewrite A4, A3 in H.
  exact H.
Qed.
Theorem D7 :  forall a : Z,  a*0 = 0.
Proof.
intros.
  pose proof (A3 0).
  (* Multiply both sides by a *)
  apply (S2 (0+0) 0 a) in H.
  (* Undo the previous step in order to show you a different way
     to do the same thing *)
  Undo.
  (* Multiply both sides by a. Blank spaces _ mean "fill in the blank
     with the obvious thing" *)
  apply (S2 _ 0 a) in H.
  rewrite D1 in H.
  apply (S1 _ _ (-(0*a))) in H.
  rewrite A2 in H.
  (* If you want to use Axiom A2 backwards (i.e. replace "a+(b+c)"
     with "(a+b)+c", instead of replacing "(a+b)+c" with "a+(b+c)")
     then you need to use "rewrite <-A2" instead of "rewrite A2" *)
  rewrite <-A2 in H.
  (* Undo previous step, which was only for demonstration purposes *)
  rewrite A2 in H.
  rewrite A4, A3 in H.
rewrite M1 in H.
  exact H.
Qed.

Theorem A1P7 :  forall a : Z, -1 * a = -a.
Proof.
intros.
pose proof (D1 1 (-1) a).
rewrite A4 in H.
rewrite A1P6 in H.
rewrite A1P3 in H.
rewrite A1 in H.
apply  (S1  _ _ (-a))in H.
rewrite A1 in H.
rewrite A3 in H.
rewrite A2 in H.
rewrite A4 in H.
rewrite A3 in H.
symmetry in H.
exact H.
Qed.
Theorem NOW :  forall a : Z, a* -1 = -a.
Proof.
intros.
pose proof (A1P7 a).
rewrite M1 in H.
exact H.
Qed.

Theorem A1P8 :  forall a b : Z, -a * -b = a * b.
Proof.
intros.
pose proof (M2 ((-a)*(-b)) (-1) (-1)).
rewrite A1P7 in H.
rewrite A1P5 in H.
rewrite M3 in H.
rewrite M1 in H.
rewrite M2 in H.
rewrite M1 in H.
rewrite M2 in H.
rewrite M1 in H.
rewrite M2 in H.
rewrite A1P7 in H.
rewrite A1P5 in H.
rewrite M1 in H.
rewrite M1 in H.
rewrite NOW in H.
rewrite A1P5 in H.
symmetry.
rewrite M1 in H.
exact H.
Qed.

Theorem A1P9 :  forall a b : Z, a + b = a ⇒ b = 0.
Proof.
intros.
apply (S1 (a+b) a (-a)) in H.
rewrite A2 in H.
rewrite A4 in H.
rewrite A1 in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
exact H.
Qed.

Definition ℤ := (Full_set Z).
Definition P := Ensemble.
Infix "∋" := (In Z) (at level 70).
Notation "x ∈ S" := (S ∋ x) (at level 70).
Notation "x ∉ S" := (¬(x ∈ S)) (at level 70).
Infix "⊂" := (Included Z) (at level 70).
Notation "∅" := (Empty_set Z).
Notation "{ x : A | P }" := (λ x : A, P).

Definition divide (x y : Z) := exists z, y = z*x.
Notation "( x | y )" := (divide x y).

(** Definition of ±, used in problem 5. **)
Definition pm (a b : Z) := (a = b ∨ a = -b).
Notation " a = ± b " := (pm a b) (at level 60).

(** Homework assignment problems are given below. **)

Parameter ℕ : P(Z).

Definition lt (a b : Z) := b-a ∈ ℕ.
Infix "<" := lt.
Notation "x > y" := (y < x) (only parsing).
Notation "x ≠ ± y" := (¬ (x = ± y)) (at level 60).

Definition prime (p : Z) :=
  p ≠ ± 1 ∧ ∀ d : Z, (d | p) ⇒ d = ± 1 ∨ d = ± p.

Axiom W1 : ∀ S : P(Z), (S ≠ ∅) ⇒ (S ⊂ ℕ) ⇒ ∃ m : Z, m ∈ S ∧ ∀ x : Z, x ∈ S ⇒ m < x ∨ m = x.
Lemma WOP : ∀ S : P(Z), (∃ x : Z, S x) ⇒ (∀ x : Z, S x ⇒ x ∈ ℕ) ⇒
 ∃ s : Z, S s ∧ ∀ t : Z, S t ⇒ s < t ∨ s = t.
Proof.
  intros S [x H] H0.
  destruct (W1 S) as [y H1]; try eauto.
  intros H1.
  subst S.
  contradiction H.
Qed.

Axiom legal : ∃ a : Z, a ≠ 0.
(* I used this axiom, because if it is not true all the numbers will be equal to zero,
so to distingush the integers from module 1 *)

Theorem G : ∀a b : Z, a -b = a+ -b.
Proof.
intros.
tauto.
Qed.
Theorem PORRA : -0=0.
Proof.
pose proof (A1 0 (-0)).
rewrite A1P1 in H.
rewrite A1P2 in H.
exact H.
Qed.
Theorem lt_N : ℕ = {x : Z | 0 < x}.
Proof.
  apply Extensionality_Ensembles.
  split.
  - unfold Included.
    intros x H.
    unfold In, lt, sub.
    rewrite <-(A3 x), A2, A4, A3.
    exact H.
  - unfold Included.
    intros x H.
    unfold In, lt, sub in H.
    rewrite <-(A3 x), A2, A4, A3 in H.
    exact H.
Qed.

Theorem lt_N_elt : ∀ x : Z, x ∈ ℕ ⇔ x > 0.
Proof.
  split;
  unfold In, lt, sub;
  rewrite <-(A3 x), A2, A4;
  intros H;
  exact H.
Qed.
Definition cprime (a b : Z) := (∀ q : Z ,( (q | a) ∧ (q | b) )-> q=1 ∨  q=(-1)).
Notation " a $ b " := (cprime a b)(at level 60) .

Theorem O1 : ∀ a b c : Z, a < b ⇒ a + c < b + c.
Proof.
  unfold lt, sub.
  intros a b c H.
  rewrite <-(A1P7), M1, D1, M1, A1P7, M1, A1P7, A2, (A1 c), A2, A1P2, A3.
  exact H.
Qed.

Axiom O2 : ∀ a b c : Z, a < b ⇒ c > 0 ⇒ a * c < b * c.

Axiom T : ∀ a : Z,
(a > 0 ∧ a ≠ 0 ∧ ¬a < 0) ∨
(¬a > 0 ∧ a = 0 ∧ ¬a < 0) ∨
(¬a > 0 ∧ a ≠ 0 ∧ a < 0).
Lemma Putz : 0 ≠ 1.
Proof.
pose proof legal.
case ( classic ( 0=1)).
intros.
destruct H.
apply ( S2 0 1 x) in H0.
rewrite A1P6, A1P3    in H0.
symmetry in H0.
tauto.
intros.
tauto.
Qed.

Lemma I778 : 1>0.
destruct (T (1)) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
tauto.
pose proof Putz.
symmetry in H1.
tauto.
apply (O1  1 0 (-1) ) in H2.
rewrite A4 in H2.
rewrite  A1 in H2.
rewrite A3 in H2.
pose proof ( O2 0 (-1) (-1) ).
apply H in H2.
rewrite A1P6 in H2.
rewrite A1P7 in H2.
rewrite A1P5 in H2.
tauto.
tauto.
Qed.

Notation "x > y" := (y < x) (only parsing).
Notation "x <= y" := (x < y ∨ x = y).
Notation "x ≤ y" := (x < y ∨ x = y) (at level 70).
Notation "x >= y" := (x > y ∨ x = y).
Notation "x ≥ y" := (x > y ∨ x = y) (at level 70).
Notation "x < y < z" := (x < y ∧ y < z).
Notation "x <= y < z" := (x <= y ∧ y < z).
Notation "x ≤ y < z" :=
  (x ≤ y ∧ y < z) (at level 70, y at next level).

Theorem AGORA :  ℕ ≠ ∅.
pose proof (lt_N_elt 1).
destruct H.
unfold lt in H.
pose proof I778.
apply H0 in H1.
unfold not.
intros.
rewrite H2 in H1 .
contradiction.
Qed.

Lemma I7 :  forall a b: Z, a>b -> ¬(a<b).
Proof.
intros.
apply (O1 b a (-a)) in H.
rewrite A4 in H.
destruct (T (b+ -a)) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
tauto.
tauto.
pose proof (Dan (a<b)).
destruct H3.
apply (O1 a b (-a)) in H3.
rewrite A4 in H3.
contradiction.
exact H3.
Qed.
Lemma I9 :  forall a b: Z, a=b -> ¬(a<b).
Proof.
intros.
apply (S1 a b (-a)) in H.
rewrite A4 in H.
destruct (T (b+ -a)) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
symmetry in H.
tauto.
pose proof (Dan (a<b)).
destruct H3.
apply (O1 a b (-a)) in H3.
rewrite A4 in H3.
tauto.
exact H3.
symmetry in H.
tauto.
Qed.

Lemma I8 :  forall a b: Z, a=0 -> ¬(a<0).
Proof.
intros.
destruct (T (a)) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
tauto.
tauto.
contradiction.
Qed.
Theorem OBVIO : 0=0.
Proof.
tauto.
Qed.
Theorem PORRA2 : ∀ a: Z, a=a.
Proof.
intros.
tauto.
Qed.

Lemma Y : ∀ a b: Z,
(a > b ∧ a ≠ b ∧ ¬a < b) ∨
(¬a > b ∧ a = b ∧ ¬a < b) ∨
(¬a > b ∧ a ≠ b ∧ a < b).
Proof.
intros.
destruct (T (a-b)) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
apply (O1 0 (a-b) b) in H0.
rewrite A1P1 in H0.
rewrite G in H0.
rewrite A2 in H0.
rewrite A1P2 in H0.
rewrite A3 in H0.
pose proof (Dan (a=b)).
destruct H.
apply (S1 a b (-b)) in H.
rewrite A4 in H.
tauto.
pose proof (Dan (a<b)).
destruct H3.
apply (O1 a b (-b)) in H3.
rewrite A4 in H3.
rewrite <-G in H3.
tauto.
pose proof (conj H0 H).
pose proof (conj H4 H3).
left.
tauto.
pose proof (Dan (a<b)).
destruct H.
apply (O1 a b (-b)) in H.
rewrite A4 in H.
rewrite <-G in H.
tauto.
pose proof (Dan (b<a)).
destruct H3.
apply (O1 b a (-b)) in H3.
rewrite A4 in H3.
rewrite <-G in H3.
tauto.
apply (S1 (a-b) 0 b) in H1.
rewrite G in H1.
rewrite A2 in H1.
rewrite A1P1 in H1.
rewrite A1P2 in H1.
rewrite A3 in H1.
pose proof (conj H0 H).
pose proof (conj H4 H3).
tauto.

apply (O1 (a-b) 0 b) in H2.
rewrite G in H2.
rewrite A2 in H2.
rewrite A1P1 in H2.
rewrite A1P2 in H2.
rewrite A3 in H2.
pose proof (Dan (b<a)).
destruct H.
apply (O1 b a (-b)) in H.
rewrite A4 in H.
rewrite <-G in H.
tauto.
pose proof (Dan (a=b)).
destruct H3.
apply (S1 a b (-b)) in H3.
rewrite A4 in H3.
tauto.
tauto.
Qed.
Theorem A1P11 : ∀ a b : Z, a * b = 0 ⇒ a = 0 ∨ b = 0.
Proof.
  intros a b H.
  pose proof (T (a*b)) as J.
  destruct (T a) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
  - destruct (T b) as [[H3 [H4 H5]] | [[H3 [H4 H5]] | [H3 [H4 H5]]]].
    + pose proof (O2 0 a b) as H6.
      rewrite A1P6 in H6.
      tauto.
    + tauto.
    + pose proof (O2 b 0 a) as H6.
      rewrite A1P6, M1 in H6.
      tauto.
  - tauto.
  - destruct (T b) as [[H3 [H4 H5]] | [[H3 [H4 H5]] | [H3 [H4 H5]]]].
    + pose proof (O2 a 0 b) as H6.
      rewrite A1P6 in H6.
      tauto.
    + tauto.
    + apply (O1 _ _ (-a)) in H2.
      apply (S1 _ _ (-(a*b))) in H.
      rewrite A4, A1P1 in H2, H.
      pose proof (O2 b 0 (-a)) as H6.
      rewrite A1P6, M1, <-A1P7, M2, ? A1P7 in H6.
      symmetry in H.
      pose proof (T (-(a*b))) as H7.
      tauto.
Qed.
Theorem A1P10 : ∀ a b : Z,  a*b = a ⇒ b = 1 ∨ a=0.
Proof.
intros.
apply ( S1 (a*b) a (-a)) in H.
rewrite A4 in H.
rewrite M1 in H.
rewrite <-A1P7 in H.
rewrite <-D1 in H.
apply A1P11 in H.
case H.
intros.
apply (S1 (b + -1) 0 1) in H0.
rewrite A1P1 in H0.
rewrite A2 in H0.
rewrite A1P2 in H0.
rewrite A3 in H0.
left.
exact H0.
intros.
right.
exact H0.
Qed.
Lemma R1 : forall a b : Z, a>b <-> b<a.
Proof.
intros.
split.
tauto.
tauto.
Qed.
Lemma I3 :  forall a b : Z, a>b -> -a<(-b).
Proof.
intros.
pose proof (R1 a b).
destruct H0.
apply R1 in H.
apply (O1 b a (-a-b)) in H.
rewrite A1 in H.
rewrite G in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
rewrite <-A2 in H.
rewrite A4 in H.
rewrite A1P1 in H.
exact H.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import coqutil.Word.Bitwidth32.
Require Import bedrock2.Array.
Require Import bedrock2.SepCalls bedrock2.SepAutoArray bedrock2.SepAuto.
Require Import bedrock2.TransferSepsOrder.
Require Import coqutil.Map.Interface.
Require Import coqutil.Datatypes.OperatorOverloading bedrock2.OperatorOverloading.
Local Open Scope oo_scope.
Local Open Scope conversion_parse_scope. Local Open Scope conversion_print_scope.
Require Import bedrock2.ListIndexNotations. Local Open Scope list_index_scope.
Require Import bedrock2.SepBulletPoints. Local Open Scope sep_bullets_scope.
Close Scope list_scope. Close Scope Z_scope. (* TODO *)

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Add Ring wring : (Properties.word.ring_theory (word := word))
        ((*This preprocessing is too expensive to be always run, especially if
           we do many ring_simplify in a sequence, in which case it's sufficient
           to run it once before the ring_simplify sequence.
           preprocess [autorewrite with rew_word_morphism],*)
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Context (cmd: Type).
  Context (wp: cmd -> mem -> (mem -> Prop) -> Prop).

  Context (memmove_call: forall dst src n: word, cmd).

  Hypothesis memmove_ok: forall m (dst src n: word) s d R1 R2 (post: mem -> Prop),
      sep (src :-> s : array ptsto (word.of_Z 1)) R1 m /\
      sep (dst :-> d : array ptsto (word.of_Z 1)) R2 m /\
      List.length s = Z.to_nat (word.unsigned n) /\
      List.length d = Z.to_nat (word.unsigned n) /\
      Z.lt (word.unsigned n * 2) (2 ^ 32) /\ (* TODO inequalities and number literals *)
      (forall m',
          sep (dst :-> s : array ptsto (word.of_Z 1)) R2 m' ->
          post m') ->
      wp (memmove_call dst src n) m post.

  Hint Rewrite Z.div_1_r Nat2Z.id : fwd_rewrites.

  Lemma memmove_usage_correct: forall (n p: nat) addr (vs: list byte) R m,
      List.length vs = (p + n + p + n + p)%nat ->
      (* if p=0, sep disjointness only implies <= but not <, but do we need < ? *)
      Z.lt (Z.of_nat (List.length vs) * 2) (2 ^ 32) ->
      sep (addr :-> vs : array ptsto (word.of_Z 1)) R m ->
      wp (memmove_call (word.add addr (word.of_Z (Z.of_nat p)))
                       (word.add addr (word.of_Z (Z.of_nat (p + n + p))))
                       (word.of_Z (Z.of_nat n)))
         m (fun m' => sep
           (addr :-> vs[p := vs[p + n + p :][:n]] : array ptsto (word.of_Z 1)) R m').
  Proof.
    intros.
    (* apply call lemma *)
    eapply memmove_ok.
    (* precondition #1 (separation logic assertion for src) *)
    scancel_asm.
      (* Currently manual hint: We will only need merging for dst, but not for src, so
         we can remove the split/merge that was posed *)
      clear_split_sepclause_stack.
    (* precondition #2 (separation logic assertion for dst) *)
    scancel_asm.
    (* precondition #3 (length of src) *)
    split; [listZnWords| ].
    (* precondition #4 (length of dst) *)
    split; [listZnWords| ].
    (* precondition #5 (bounds) *)
    split; [ZnWords| ].
    (* introduce postcondition and prettify *)
    intro_new_mem.
    transfer_sep_order. (* also clears old mem hyps and renames mem *)
    list_simpl_in_hyps.
    (* prove that computed state implies final postcondition *)
    list_simpl_in_goal.
    replace (n + p)%nat with (p + n)%nat at 1 by lia. (* TODO canonicalization for nat *)
    scancel_asm.
  Qed.

  Context (sample_call: word -> word -> cmd).

  Hypothesis sample_call_correct:
    forall (m : mem) (a1 n : word) (vs: list word) (R post: mem -> Prop),
      sep (a1 :-> vs : word_array) R m /\
      List.length vs = Z.to_nat (word.unsigned n) /\
      (forall m':mem,
        sep (a1 :-> vs[5 := vs[5] * (word.of_Z (word := word) 2)] : word_array) R m' ->
        post m') ->
      wp (sample_call a1 n) m post.

  (* even this small example needs higher-than-default printing depth to fully display
     the intermediate goals... *)
  Set Printing Depth 100000.

  Definition sample_call_usage_goal :=
    forall (ws: list word) (R: mem -> Prop) (addr: word) (m: mem),
      (16 <= List.length ws)%nat ->
      (addr --> ws * R) m ->
      wp (sample_call (addr + (2 * 4) to word) (10 to word))
         m (fun m' => (addr --> ws[7 := ws[7] * 2 to word] * R) m').

  Lemma use_sample_call_with_tactics_unfolded: sample_call_usage_goal.
  Proof.
    unfold sample_call_usage_goal. intros.
    eapply sample_call_correct.

    (* prove precondition and after intro-ing postcondition, merge back with same lemma
       as used for proving precondition: *)
    use_sep_asm.
    split_ith_left_and_cancel_with_fst_right 0%nat.
    finish_impl_ecancel.
    split. 1: listZnWords.
    intros m' HM'.
    pop_split_sepclause_stack_step m'.
    list_simpl_in_hyps.
    list_simpl_in_goal.
    scancel_asm.
  Qed.

  Lemma use_sample_call_automated: sample_call_usage_goal.
  Proof.
    unfold sample_call_usage_goal. intros.
    eapply sample_call_correct.
    scancel_asm. split. 1: listZnWords.
    intro_new_mem.
    list_simpl_in_hyps.
    list_simpl_in_goal.
    scancel_asm.
  Qed.
End WithParameters.


Require Import Reals Psatz Lra RelationClasses.
From Coquelicot Require Import Continuity
  Rcomplements Derive Hierarchy AutoDerive Rbar Complex
  RInt RInt_analysis Derive_2d Compactness.
From Coq Require Import ssreflect ssrfun ssrbool.
Close Scope boolean_if_scope.
Require Import Program.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Require Import helpers complex_core.

Open Scope program_scope.
Open Scope general_if_scope.

Open Scope R.

Section Homotopy.

Definition SmoothFun g r t:=
  differentiable_pt g r t /\
  differentiable_pt (fun p q => Derive (g p) q) r t /\
  differentiable_pt (fun p q => Derive (g ^~ q) p) r t /\
  continuity_2d_pt (fun u v => Derive (fun z => Derive (fun t => g z t) v) u) r t /\
  continuity_2d_pt (fun u v => Derive (fun z => Derive (fun t => g t z) u) v) r t
.

Definition SmoothPath g1 g2 r t:=
  locally_2d (SmoothFun g1) r t /\
  locally_2d (SmoothFun g2) r t.

Ltac differentiable_pt_compute_derive:=
  eapply differentiable_pt_ext;
         first ( move => p q; replace_Derive; reflexivity).
Ltac continuity_2d_compute_derive:=
  eapply continuity_2d_pt_ext; first (
    move => *;
      eapply Derive_ext; first (
        move => *; replace_Derive; reflexivity
      )
  );
  eapply continuity_2d_pt_ext;
         first ( move => p q; replace_Derive; reflexivity).

Ltac compute_smooth:=
  move => r t; repeat split;
  try continuity_2d_compute_derive;
  try differentiable_pt_compute_derive;
  try apply: differentiable_continuity_pt;
  auto_differentiable_pt; auto_derive; auto.

Lemma smooth_cos_between: forall r1 r2 r t,
  SmoothFun (fun r' t' => (r' * r1 + (1 - r') * r2) * cos t') r t.
Proof. compute_smooth. Qed.

Lemma smooth_sin_between: forall r1 r2 r t,
  SmoothFun (fun r' t' => (r' * r1 + (1 - r') * r2) * sin t') r t.
Proof. compute_smooth. Qed.

Lemma smooth_cos: forall r t,
  SmoothFun (fun r t => r * cos t) r t.
Proof. compute_smooth. Qed.

Lemma smooth_sin: forall r t,
  SmoothFun (fun r t => r * sin t) r t.
Proof. compute_smooth. Qed.

Lemma smooth_line: forall z w r t,
  SmoothFun (fun r t => r * z + (1-r) * w ) r t.
Proof. compute_smooth. Qed.

Lemma smooth_path_plus: forall g h r t,
  locally_2d (SmoothFun g) r t ->
  locally_2d (SmoothFun h) r t ->
  locally_2d (SmoothFun (fun r' t' => g r' t' + h r' t')) r t.
Proof.
  move => g h r t Sg Sh.
  have Sgh := locally_2d_and _ _ _ _ Sg Sh.
  apply: locally_2d_impl_strong Sgh.
  apply locally_2d_forall.
  rewrite /SmoothFun.
  move => u v H.
  move: H.
  copy => /locally_2d_singleton H_loc H.

  Tactic Notation "ext_Derive_plus" hyp(H) tactic(ext) tactic(t1) tactic(t2):=
    ext; first (
     apply: locally_2d_impl H;
     apply locally_2d_forall => p q H;
     rewrite Derive_plus;[
           reflexivity
           | t1; tauto
           | t2; tauto
    ]).

  Tactic Notation "ext_Derive_Derive_plus" hyp(H) constr(v)
     tactic(t1) tactic(t2):=
    apply: continuity_2d_pt_ext_loc; first(
      apply: locally_2d_impl_strong H;
      apply locally_2d_forall => p q /v H;
      apply: Derive_ext_loc;
      apply: filter_imp H => p' H;
      rewrite Derive_plus;
      [ reflexivity
      | t1; tauto
      | t2; tauto
      ]).

  repeat split.
  1: auto_differentiable_pt; tauto.
  - ext_Derive_plus H (eapply differentiable_pt_ext_loc)
      (apply: (@differentiable_pt_ex_right g))
      (apply: (@differentiable_pt_ex_right h)).
      auto_differentiable_pt; tauto.
  - ext_Derive_plus H (eapply differentiable_pt_ext_loc)
      (apply: (@differentiable_pt_ex_left g))
      (apply: (@differentiable_pt_ex_left h)).
      auto_differentiable_pt; tauto.
  - ext_Derive_Derive_plus H (locally_2d_1d_const_y)
      (apply: (@differentiable_pt_ex_right g))
      (apply: (@differentiable_pt_ex_right h))
      .
    ext_Derive_plus H (eapply continuity_2d_pt_ext_loc)
      (apply: (@differentiable_pt_ex_left (fun p => Derive (g p))))
      (apply: (@differentiable_pt_ex_left (fun p => Derive (h p)))).
      apply continuity_2d_pt_plus; tauto.
  - ext_Derive_Derive_plus H (locally_2d_1d_const_x)
      (apply: (@differentiable_pt_ex_left g))
      (apply: (@differentiable_pt_ex_left h)).
    ext_Derive_plus H (eapply continuity_2d_pt_ext_loc)
      (apply: (@differentiable_pt_ex_right (fun p p' => Derive (g ^~ p')p)))
      (apply: (@differentiable_pt_ex_right (fun p p' => Derive (h ^~ p')p))).
      apply continuity_2d_pt_plus; tauto.
Qed.

Lemma SmoothPath'_ext: forall f g r t,
  (forall x y , f x y = g x y) ->
  SmoothFun f r t -> SmoothFun g r t.
Proof.
  move => f g r t ext H.
  rewrite /SmoothFun in H.
  repeat split.
  - eapply differentiable_pt_ext.
    move => *.
    symmetry.
    apply ext.
    tauto.
  - eapply differentiable_pt_ext.
      move => *.
      eapply Derive_ext.
        move => *.
        symmetry.
        apply ext.
    tauto.

  - eapply differentiable_pt_ext.
      move => *.
      eapply Derive_ext.
        move => *.
        symmetry.
        apply ext.
    tauto.
  - eapply continuity_2d_pt_ext.
      move => *.
      eapply Derive_ext.
        move => *.
        eapply Derive_ext.
          move => *.
        apply ext.
    tauto.
  - eapply continuity_2d_pt_ext.
      move => *.
      eapply Derive_ext.
        move => *.
        eapply Derive_ext.
          move => *.
        apply ext.
    tauto.
Qed.

Lemma smooth_path_const : forall z r t,
  SmoothFun (fun _ _ => z) r t.
Proof.
  move => z r t.
  apply (@SmoothPath'_ext (fun x y => x*z + (1-x)*z)).
  move => *.
  field_simplify; auto.
  apply smooth_line.
Qed.

Lemma smooth_translate: forall z g r t,
  locally_2d (SmoothFun g) r t ->
  SmoothFun (fun r' t' => z + g r' t') r t.
Proof.
  move => z g r t H.
  apply locally_2d_singleton.
  have := smooth_path_const z.
  move => /(locally_2d_forall _ r t) H'.
  have := smooth_path_plus H' H.
  auto.
Qed.

Lemma smooth_circ: forall z r t,
  SmoothPath (fun r t => z.1 + r * cos t)
             (fun r t => z.2 + r * sin t) r t.
Proof.
  move => z r t.
  split.
  - apply locally_2d_forall.
    move => u v.
    apply smooth_translate.
    apply locally_2d_forall.
    move => *.
    apply: smooth_cos.
  - apply locally_2d_forall.
    move => u v.
    apply smooth_translate.
    apply locally_2d_forall.
    move => *.
    apply smooth_sin.
Qed.

Lemma smooth_translate_circ: forall z w r1 r2 r t,
  SmoothPath (fun r' t' => (r' * z.1 + (1-r')*w.1 + (r'*r1 + (1-r')*r2) * cos t'))
             (fun r' t' => (r' * z.2 + (1-r')*w.2 + (r'*r1 + (1-r')*r2) * sin t'))
             r t.
Proof.
  move => z w r1 r2 r t.
  split.
  - have := smooth_line z.1 w.1.
    move => /(locally_2d_forall _ r t) H'.
    have := smooth_cos_between r1 r2.
    move => /(locally_2d_forall _ r t) H''.
    apply: smooth_path_plus H' H''.
  - have := smooth_line z.2 w.2.
    move => /(locally_2d_forall _ r t) H'.
    have := smooth_sin_between r1 r2.
    move => /(locally_2d_forall _ r t) H''.
    apply: smooth_path_plus H' H''.
Qed.
End Homotopy.

Local Ltac diff_help_ex_derive :=
  match goal with
  | H: differentiable_pt_lim (fun _ _ => ?f _ _) ?x _ _ _
    |- ex_derive (fun _ => ?f _ _) ?x =>
      apply (differentiable_pt_lim_left H)
  | H: differentiable_pt_lim ?f ?x _ _ _
    |- ex_derive (fun _ => ?f _ _) ?x =>
      apply (differentiable_pt_lim_left H)
  | H: differentiable_pt_lim ?f ?x _ _ _
    |- ex_derive (?f _) ?x =>
      apply (differentiable_pt_lim_left H)

  | H: differentiable_pt_lim (fun _ _ => ?f _ _) _ ?y _ _
    |- ex_derive (fun _ => ?f _ _) ?y =>
      apply (differentiable_pt_lim_right H)
  | H: differentiable_pt_lim ?f _ ?y _ _
    |- ex_derive (fun _ => ?f _ _) ?y =>
      apply (differentiable_pt_lim_right H)
  | H: differentiable_pt_lim ?f _ ?y _ _
    |- ex_derive (?f _) ?y =>
      apply (differentiable_pt_lim_right H)
  end.
Local Hint Extern 4 (ex_derive _ _) => (by diff_help_ex_derive) : teardown_leaf.
Local Hint Extern 2 (differentiable_pt _ _ _)  =>
  (match goal with
  | H: differentiable_pt_lim ?f ?x ?y _ _ |- (differentiable_pt ?f ?x ?y) =>
    try (now (eexists; eexists; eauto))
  end) : teardown_leaf.

Local Hint Extern 5 (ex_derive _ _ ) => (
  match goal with
  | H: differentiable_pt ?f ?x ?y |- ex_derive ?g ?y =>
     move:H => /differentiable_pt_ex_derive; tauto
  | H: differentiable_pt ?f ?x ?y |- ex_derive ?g ?x =>
     move:H => /differentiable_pt_ex_derive; tauto
  end
  ) : teardown_leaf.

Lemma path_independence_part_1: forall
    (u v: R -> R -> R) udx udy vdx vdy
    (g1 g2: R -> R -> R) g2_r g2_t g1_r g1_t r t,
  differentiable_pt_lim u (g1 r t) (g2 r t) udx udy ->
  differentiable_pt_lim v (g1 r t) (g2 r t) vdx vdy ->
  differentiable_pt_lim g1 r t (g1_r r t) (g1_t r t) ->
  differentiable_pt_lim g2 r t (g2_r r t) (g2_t r t) ->
  differentiable_pt g1_t r t  ->
  differentiable_pt g1_r r t  ->
  differentiable_pt g2_t r t  ->
  differentiable_pt g2_r r t  ->
  Derive (g1_t ^~ t) r = Derive (g1_r r) t ->
  Derive (g2_t ^~ t) r = Derive (g2_r r) t ->
  vdx = - udy ->
  Derive(fun t0 =>
   (u (g1 r t0) (g2 r t0) * g1_r r t0) - v (g1 r t0) (g2 r t0) * (g2_r r t0)) t
  =
  Derive
  (fun r0  =>
   (u (g1 r0 t) (g2 r0 t) * g1_t r0 t - (v (g1 r0 t) (g2 r0 t) * g2_t r0 t))%R) r.
Proof.
  move => u v udx udy vdx vdy g1 g2 g2_r g2_t g1_r g1_t r t.
  move => du dv dg1 dg2 dg1t dg1r dg2t dg2r swapdiff1 swapdiff2 CR_eq//=.
  move: dg1t => [? [? dg1t]].
  move: dg1r => [? [? dg1r]].
  move: dg2t => [? [? dg2t]].
  move: dg2r => [? [? dg2r]].
  set p := RHS.
  have ug : ( differentiable_pt_lim (fun r t => u (g1 r t) (g2 r t))
                r t (udx * (g1_r r t) + udy * (g2_r r t))
                    (udx * (g1_t r t) + udy * (g2_t r t))
            )by
    apply differentiable_pt_lim_comp; auto.
  have vg : ( differentiable_pt_lim (fun r t => v (g1 r t) (g2 r t))
                r t (vdx * (g1_r r t) + vdy * (g2_r r t))
                    (vdx * (g1_t r t) + vdy * (g2_t r t))
            )by
    apply differentiable_pt_lim_comp; auto.

  `Begin eq p. { rewrite {}/p.

  | {(   Derive _ _ - Derive _ _   )}

    rewrite ?Derive_minus; auto_derive_teardown.

  | {(   Derive _ r * _ + _ * Derive _ r - (Derive _ r * _ + _ * Derive _ r))}
    rewrite ?Derive_mult; auto_derive_teardown.

  | {(  (udx * (g1_r r t) + udy * (g2_r r t)) * _ + _ - _ )%R}
    do 2 apply Rplus_eq_compat_r;
    apply Rmult_eq_compat_r.
    pose hu := fun r' t' => u (g1 r' t') (g2 r' t').
    rewrite -/(hu ^~ t).
    eapply (differentiable_pt_lim_unique _ _ _ _ _ _).
  | {(  _ - ((vdx * g1_r r t + vdy * (g2_r r t)) * _ + _) )%R}
    rewrite ?Rplus_assoc;
    apply Rplus_eq_compat_l;
    apply Ropp_eq_compat;
    apply Rplus_eq_compat_r;
    apply Rmult_eq_compat_r;
    idtac .
    pose hv := fun r' t' => v (g1 r' t') (g2 r' t').
    rewrite -/(hv ^~ t).
    eapply (differentiable_pt_lim_unique _ _ _ _ _ _).
  `Done.
  }
  move ->.
  set q := LHS.
  `Begin eq q. { rewrite {}/q.

  | {(   Derive _ _ - Derive _ _   )}
    rewrite ?Derive_minus; auto_derive_teardown.

  | {(   Derive _ _ * _ + _ * Derive _ _ - (Derive _ _ * _ + _ * Derive _ _))}
     rewrite ?Derive_mult; auto_derive_teardown.

  | {(  (udx * (g1_t r t) + udy * (g2_t r t)) * _ + _ - _ )%R}
    do 2 apply Rplus_eq_compat_r;
    apply Rmult_eq_compat_r.
    pose hu := fun r' t' => u (g1 r' t') (g2 r' t').
    rewrite -/(hu r).
    eapply (differentiable_pt_lim_unique _ _ _ _ _ _).
  | {(  _ - ((vdx * g1_t r t + vdy * (g2_t r t)) * _ + _) )%R}
    rewrite ?Rplus_assoc;
    apply Rplus_eq_compat_l;
    apply Ropp_eq_compat;
    apply Rplus_eq_compat_r;
    apply Rmult_eq_compat_r;
    idtac .
    pose hv := fun r' t' => v (g1 r' t') (g2 r' t').
    rewrite -/(hv r).
    eapply (differentiable_pt_lim_unique _ _ _ _ _ _).
  `Done.
  }
  move ->.
  rewrite swapdiff1 swapdiff2 ?CR_eq.
  lra.
Unshelve.
2: apply ug.
2: apply vg.
2: apply ug.
2: apply vg.
Qed.

Lemma path_independence_part_2_real:
  forall (u v u' v': R -> R -> R) r t g1 g2,
  let g:= fun p q => (g1 p q, g2 p q) in
  let f:= fun z => (u z.1 z.2, v z.1 z.2) in
  let f':= fun z => (u' z.1 z.2, v' z.1 z.2) in
  SmoothPath g1 g2 r t ->
  Holo f f' (g r t) ->
  let g_t := fun p q => (Derive (g1 p) q, Derive (g2 p) q) in
  let g_r := fun p q => (Derive (g1 ^~ q) p, Derive (g2 ^~ q) p) in
  Derive ( fun t0 => Re (f (g r t0) * g_r r t0 ))%C t =
  Derive ( fun r0 => Re (f (g r0 t) * g_t r0 t ))%C r
.
Proof.
  move => u v u' v' r t g1 g2 g f f' [g1_smooth g2_smooth] .
  move => holo.
  move => g_t g_r.
  simpl.
  pose g1_r p q := Derive (g1 ^~ q) p.
  pose g2_r p q := Derive (g2 ^~ q) p.
  pose g1_t p q := Derive (g1 p) q .
  pose g2_t p q := Derive (g2 p) q .
  under Derive_ext => t0.
    set p := Derive _ _ .
    replace p with (g1_r r t0).
    set q := Derive _ _ .
    replace q with (g2_r r t0).
  over.
  rewrite /p  //= .
  rewrite /p  //= .
  symmetry.
  under Derive_ext => r0.
    set p := Derive _ _ .
    replace p with (g1_t r0 t).
    set q := Derive _ _ .
    replace q with (g2_t r0 t).
  over.
  rewrite /p  //= .
  rewrite /p  //= .
  symmetry.
  move: g1_smooth; copy => /locally_2d_singleton [? [?[?[??]]]] g1_smooth.
  move: g2_smooth; copy => /locally_2d_singleton [? [?[?[??]]]] g2_smooth.
  move: holo; copy => /holo_differentiable_pt_lim_real ?
                      /holo_differentiable_pt_lim_imaginary ?.
  simpl in *.

  eapply (@path_independence_part_1 u v _ _ _ _ g1 g2 _ _ _ _ r t);
    try apply Schwarz;
    try eauto;
    try apply: differentiable_pt_unique; eauto.

  3: lra.
  1: apply: locally_2d_impl g1_smooth.
  2: apply: locally_2d_impl g2_smooth.
  all: apply locally_2d_forall => x y
    [/differentiable_pt_ex_derive ?
    [/differentiable_pt_ex_derive ?
    [/differentiable_pt_ex_derive ? ?]]];
    tauto.
Qed.

Open Scope C.

(* I suspect that the proposition I'm working with
are actually decidable anyway, so this is probably overkill*)
Import Logic.Classical_Prop.

Ltac expand_nice :=
    move => [[+ +] [ [?[?[?[??]]]] [?[?[?[??]]]]]];
    copy => /holo_differentiable_pt_lim_imaginary ?
            /holo_differentiable_pt_lim_real ?;
    copy => /(continuous_comp _ fst) /= Cu';
    move => /(continuous_comp _ snd) /= Cv'.
Lemma not_not_impl: forall (P:Prop), ~ ~ P <-> P.
Proof.
  move => P. tauto.
Qed.

Section PathIndependence .
  Variables (a b c d:R).
  Variables (g1 g2 : R -> R -> R ).

  Hypothesis cled: c < d.

  Let g:= fun p q => (g1 p q, g2 p q).
  Let g_t := fun p q => (Derive (g1 p) q, Derive (g2 p) q).
  Let g_r := fun p q => (Derive (g1 ^~ q) p, Derive (g2 ^~ q) p).

  Hypothesis smooth: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
    SmoothPath g1 g2 r t.

  Lemma unif_r: forall (P: R -> R -> Prop) r, c <= r <= d ->
    (forall r' t', c <= r' <= d -> Rmin a b <= t' <= Rmax a b ->
      locally_2d P r' t') ->
    locally r ( fun r0 =>
        forall t0, Rmin a b <= t0 <= Rmax a b ->
        P r0 t0).
  Proof.
    move => P r rbd pH.
    move : pH => /(_ r) => {}nicer.
    pose delta := fun t =>
      match (Rle_dec (Rmin a b) t, Rle_dec t (Rmax a b) ) with
      | (left p1, left p2) => proj1_sig (@locally_2d_ex_dec
          _ r t
          (ltac:(move => *; apply (@classic _ ) ))
          (@nicer t rbd (conj p1 p2) ))

      | _ => pos_half
      end.
    destruct (@compactness_value_1d (Rmin a b) (Rmax a b) delta).
    exists x.
    move => r' r'bd t tbd.
    move: n => /(_ t tbd).
    rewrite not_not_impl.
    case => t0 [t0bd [+ xdel]].
    move: xdel.
    rewrite /delta.
    destruct_match; try lra.
    destruct_match; try lra.
    set del' := locally_2d_ex_dec _ _ _ _ _ .
    move: del' => [del' dH] /= tballt0.
    apply dH.
    apply: Rlt_le_trans.
    2: apply tballt0.
    apply r'bd.
  Qed.

  Section DeriveHomotopy.

  Variables (u v u' v': R -> R -> R).
  Let f:= fun z => (u z.1 z.2, v z.1 z.2).
  Let f':= fun z => (u' z.1 z.2, v' z.1 z.2).

  Hypothesis holo_loc: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
      locally_2d ( fun r0 t0 =>  Holo f f' (g r0 t0)) r t.

  Hypothesis cts_derive: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
      locally_2d ( fun r0 t0 =>  continuous f' (g r0 t0)) r t.

  Ltac decompose_u_v :=
    match goal with
    | |- ex_derive (fun _ => u (_ _ _) (_ _ _)) _ =>
      first[ apply: (@differentiable_pt_comp_ex_derive_left u )|
             apply: (@differentiable_pt_comp_ex_derive_right u)]
    | |- ex_derive (fun _ => v (_ _ _) (_ _ _)) _ =>
      first[ apply: (@differentiable_pt_comp_ex_derive_left v )|
             apply: (@differentiable_pt_comp_ex_derive_right v)]
    end.

  Let nice r0 t0 :=
    CHolo f f' (g r0 t0) /\
    SmoothFun g1 r0 t0 /\
    SmoothFun g2 r0 t0.

  Lemma locally_nice: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->locally_2d nice r t.
  Proof.
    move => r t tbd rbd.
    move: holo_loc => /(_ r t tbd rbd ).
    move: cts_derive => /(_ r t tbd rbd ).
    move: smooth => /(_ r t tbd rbd ) [].
    move => H.
    move => {}H'; have {}H:= locally_2d_and _ _ r t H H'.
    move => {}H'; have {}H:= locally_2d_and _ _ r t H H'.
    move => {}H'; have {}H:= locally_2d_and _ _ r t H H'.
    apply: locally_2d_impl H.
    apply locally_2d_forall.
    move => *.
    rewrite /nice /CHolo.
    tauto.
  Qed.

  Lemma diff_integrand_t: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
    locally_2d (
        differentiable_pt (fun r0 t0 => Re(f (g r0 t0) * g_t r0 t0))) r t.
  Proof.
    move => r t rbd tbd.
    apply: locally_2d_impl (locally_nice  rbd tbd).
    apply locally_2d_forall.
    move => r0 t0 [[+ _] [[?[?[?[??]]]] [?[?[?[??]]]]]].
    copy => /holo_differentiable_pt_lim_real Du
            /holo_differentiable_pt_lim_imaginary Dv /=.
    simpl in *.
    auto_differentiable_pt.
    all: apply: differentiable_pt_comp.
    all: auto_differentiable_pt.
    all: eexists;eexists; now eauto.
  Qed.

  Lemma diff_integrand_r: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
    locally_2d (
        differentiable_pt (fun r0 t0 => Re(f (g r0 t0) * g_r r0 t0))) r t.
  Proof.
    move => r t rbd tbd.
    apply: locally_2d_impl (locally_nice  rbd tbd).
    apply locally_2d_forall.
    move => r0 t0 [[+ _] [[?[?[?[??]]]] [?[?[?[??]]]]]].
    copy => /holo_differentiable_pt_lim_real Du
            /holo_differentiable_pt_lim_imaginary Dv /=.
    simpl in *.
    auto_differentiable_pt.
    all: apply: differentiable_pt_comp.
    all: auto_differentiable_pt.
    all: eexists;eexists; now eauto.
  Qed.
  Local Ltac foo x y :=
    let smooth := fresh in
      move => /(_ x y)[+ smooth];
      copy => /holo_differentiable_pt_lim_real ?
              /holo_differentiable_pt_lim_imaginary ?;
      case: smooth => /locally_2d_singleton [? [H Q]] [/locally_2d_singleton [?[??]] c];
      simpl in *.

  Ltac auto_2d_continuous :=
    repeat ( teardown
      (fail "no topology shenanigans")
      (apply: continuity_2d_pt_plus)
      (unfold_alg; apply: continuity_2d_pt_mult)
      (apply: continuity_2d_pt_mult)
      (apply: continuity_2d_pt_minus)
      (apply: continuity_2d_pt_opp)
      (fail "inv doesn't matter")
      (fail "pair doesn't matter"));
  auto with teardown_leaf.

  Lemma D: forall r,
    c <= r <= d ->
      is_derive (fun r0 => RInt (fun t0 => Re(f (g r0 t0) * g_t r0 t0 ))%C a b) r
      (RInt (fun t0 => Derive (fun r0 => Re(f (g r0 t0) * g_t r0 t0 )%C) r) a b).
  Proof.
    move => r rbd.
    apply is_derive_RInt_param.
    - apply: unif_r; auto.
      move => r' t' r'bd t'bd.
      apply: locally_2d_impl (diff_integrand_t r'bd t'bd).
      apply: locally_2d_forall.
      move => r0 t0 /differentiable_pt_ex_derive [_ H].
      tauto.
    - move => t tbd.
      move: locally_nice => /(_ _ _ rbd tbd) nice'.
      eapply continuity_2d_pt_ext_loc. {
        apply: locally_2d_impl nice'.
        apply: locally_2d_forall => r0 t0.
        copy.
        expand_nice.
        move => [[+ _] _].
        copy => /holo_differentiable_pt_lim_real
                /differentiable_pt_lim_unique [Du'1 Du'2]
                /holo_differentiable_pt_lim_imaginary
                /differentiable_pt_lim_unique [Dv'1 Dv'2].
        simpl in *.
        rewrite Derive_minus ?Derive_mult ?Derive_plus /=.
        rewrite (@Derive_comp_2_left u g1 g2).
        rewrite (@Derive_comp_2_left v g1 g2).
        rewrite Du'1 Du'2 Dv'1 Dv'2.
        reflexivity.
        all: try decompose_u_v.
        all: auto_differentiable_pt; auto_derive_teardown.
        1: apply differentiable_pt_comp_ex_derive_left.
        4: apply differentiable_pt_comp_ex_derive_left.
        all: auto_differentiable_pt; auto_derive_teardown.
      }
      move: nice' => /locally_2d_singleton.
      expand_nice.
      simpl in *.
      Hint Extern 1 (continuity_2d_pt _ _ _) =>
        (match goal with
        | H : differentiable_pt ?f ?x ?y |- continuity_2d_pt ?f ?x ?y =>
          apply: differentiable_continuity_pt
        end) : teardown_leaf.
      auto_2d_continuous.
      all: apply: continuity_2d_pt_comp.
      all: auto_2d_continuous.
      3,6: apply: differentiable_continuity_pt; eexists; eexists ;eauto.
      all: apply/continuity_2d_pt_continuous; simpl;
        first [apply Cu' | apply Cv']; auto_cts.
    - apply: filter_imp.
      1: move => r' H;
         apply: ex_RInt_continuous;
         exact H.
      apply: unif_r; auto.
      move => r' t' r'bd t'bd.
      apply: locally_2d_impl (diff_integrand_t r'bd t'bd).
      apply locally_2d_forall.
      move => r0 t0 /differentiable_pt_ex_derive H.
      apply: ex_derive_continuous.
      tauto.
  Qed.

  Lemma path_independence_part_3_real:
    forall r, c <= r <= d ->
      is_derive (fun r0 => RInt (fun t0 : R => Re (f (g r0 t0) * g_t r0 t0)) a b) r
     (Re(f (g r b) * g_r r b - f (g r a) * g_r r a )%C).
  Proof.
    move => r rbd.
    have D := D rbd.
    erewrite RInt_ext in D.
    2:{ move => x xbd.
      rewrite -(@path_independence_part_2_real u v u' v').
      reflexivity.
      apply smooth; lra.
      move: (@holo_loc r x rbd (ltac:(lra))) => /locally_2d_singleton.
      auto.
    }
    rewrite RInt_Derive in D.
    - apply: D.
    - move => t0 t0bd.
      move: (diff_integrand_r rbd t0bd) =>
        /locally_2d_singleton /differentiable_pt_ex_derive.
        tauto.
    - simpl.
      move => t tbd.
      eapply continuous_ext_loc. {
        move : (locally_nice rbd tbd) => /locally_2d_1d_const_x H.
        apply: filter_imp H => t'.
        copy.
        expand_nice.

        move => [[+ _] _].
        copy => /holo_differentiable_pt_lim_real
                /differentiable_pt_lim_unique [Du'1 Du'2]
                /holo_differentiable_pt_lim_imaginary
                /differentiable_pt_lim_unique [Dv'1 Dv'2].
        simpl in *.
        rewrite Derive_minus ?Derive_mult ?Derive_plus /=.
        rewrite (@Derive_comp_2_right u g1 g2).
        rewrite (@Derive_comp_2_right v g1 g2).
        rewrite Du'1 Du'2 Dv'1 Dv'2.
        reflexivity.
        all: auto_derive_teardown.
        all: apply differentiable_pt_comp_ex_derive_right.
        all: auto_derive_teardown.
      }
      move: (locally_nice rbd tbd) => /locally_2d_singleton.
      expand_nice.
      simpl in *.
      auto_cts.
      1,3,8,10: apply continuous_comp_2.
      all: auto_cts.
      all: try now (apply: ex_derive_continuous; auto_derive_teardown).
      1,3: apply: ex_derive_continuous;
           apply differentiable_pt_comp_ex_derive_right.
      all: auto_differentiable_pt.
      2: repeat match goal with
      | H: continuity_2d_pt _ _ _ |- _ => move: H
      end;
      move => _ _ _ ;
      move /continuity_2d_pt_continuous_right; auto.
      repeat match goal with
      | H: continuity_2d_pt _ _ _ |- _ => move: H
      end;
      move => _ + _ _ ;
      move /continuity_2d_pt_continuous_right; auto.
  Qed.
  End DeriveHomotopy.

  Variables (f f': C -> C).

  Hypothesis holo_loc: forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->
      locally_2d ( fun r0 t0 =>  CHolo f f' (g r0 t0)) r t.

  Let nice r0 t0 :=
    CHolo f f' (g r0 t0) /\
    SmoothFun g1 r0 t0 /\
    SmoothFun g2 r0 t0.

  Lemma locally_nice': forall r t,
    c <= r <= d ->
    Rmin a b <= t <= Rmax a b ->locally_2d nice r t.
  Proof.
    move => r t tbd rbd.
    move: holo_loc => /(_ r t tbd rbd ).
    move: smooth => /(_ r t tbd rbd ) [].
    move => H.
    rewrite /CHolo.
    move => {}H'; have {}H:= locally_2d_and _ _ r t H H'.
    move => {}H'; have {}H:= locally_2d_and _ _ r t H H'.
    apply: locally_2d_impl H.
    apply locally_2d_forall.
    move => *.
    rewrite /nice /CHolo.
    tauto.
  Qed.
  Lemma integrand_cts:
      (forall r t, c <= r <= d ->
                  Rmin a b <= t <= Rmax a b ->
      locally_2d (fun r' t' =>
        continuous (fun t0 => f (g r' t0) * g_t r' t0) t') r t).
  Proof.
    move => r t rbd tbd.
    move: (locally_nice' rbd tbd) => H.
    apply: locally_2d_impl H.
    apply: locally_2d_forall.
    move => u v.
    copy.
    move => [[/is_derive_continuous ? _] _].
    expand_nice.
    rewrite /g /g_t.
    auto_cts.
    - apply continuous_comp; auto_cts;
      apply: ex_derive_continuous; auto_derive_teardown.
    - apply: (@continuity_2d_pt_continuous_right
        (fun r' t' => (Derive (g1 r') t'))).
      apply: differentiable_continuity_pt.
      auto.
    - apply: (@continuity_2d_pt_continuous_right
        (fun r' t' => (Derive (g2 r') t'))).
      apply: differentiable_continuity_pt.
      auto.
  Qed.
  Local Ltac prod_int :=
      rewrite -?ex_RInt_prod;
      apply ex_RInt_continuous => z /(inside a'bd b'bd) zbd;
      apply: integrand_cts; eauto.

  Lemma path_independence_part_4:
    forall r, c <= r <= d ->
    is_derive (fun r0 =>
      RInt (V:=C_R_CompleteNormedModule)
        (fun t0 : R => f (g r0 t0) * g_t r0 t0) a b) r
      (f (g r b) * g_r r b - f (g r a) * g_r r a )%C.
  Proof.
    move => r rbd.
    eapply is_derive_ext_loc.
      move: (unif_r rbd integrand_cts) => H.
      apply: filter_imp H.
      move => r' *.
      rewrite [RHS]split_cint /compose; last by
        rewrite -ex_RInt_prod; apply ex_RInt_continuous => * //=; auto.
    reflexivity.
    rewrite -[x in is_derive _ _ x]ReImSplit.
    apply/is_derive_pair; split.
    - pose u := fun p q => (f (p,q)).1.
      pose v := fun p q => (f (p,q)).2.
      pose u' := fun p q => (f' (p,q)).1.
      pose v' := fun p q => (f' (p,q)).2.
      apply (@path_independence_part_3_real u v u' v' ); auto.
      + move => r' t' r'bd t'bd.
        apply: locally_2d_impl (holo_loc  r'bd t'bd).
        apply locally_2d_forall.
        rewrite /CHolo.
        move => r0 t0 [H _].
        eapply is_derive_ext with (f0:=f).
          move => t.
          rewrite /u /v -?surjective_pairing //=.
        rewrite /u' /v' -?surjective_pairing //=.
      + move => r' t' r'bd t'bd.
        apply: locally_2d_impl (holo_loc  r'bd t'bd).
        apply locally_2d_forall.
        move => r0 t0 [_ H].
        eapply continuous_ext with (f0:=f').
          move => t.
          rewrite /u' /v' -?surjective_pairing //=.
        auto.
    - pose u := fun p q => Ropp (f (p,q)).2.
      pose v := fun p q => (f (p,q)).1.
      pose u' := fun p q => Ropp (f' (p,q)).2.
      pose v' := fun p q => (f' (p,q)).1.
      pose h := fun z => (u z.1 z.2, v z.1 z.2).
      pose h' := fun z => (u' z.1 z.2, v' z.1 z.2).
      have hf : forall z, h z = Ci * f z by
        move => z; rewrite /h/u/v //=/Cmult;
        simplify_as_R2 LHS;
        simplify_as_R2 RHS;
        rewrite -?surjective_pairing.
      have hf' : forall z, h' z = Ci * f' z by
        move => z; rewrite /h'/u'/v' //=/Cmult;
        simplify_as_R2 LHS;
        simplify_as_R2 RHS;
        rewrite -?surjective_pairing.
      have toRe: forall r t, Im ( f (g r t) * g_t r t) = Ropp (Re (h (g r t) * g_t r t)). {
        move => r' t'.
        rewrite /h /u/v /g//=.
        simpl.
        field_simplify_eq; auto.
      }
      eapply is_derive_ext_loc.
        move : (unif_r rbd locally_nice') => H.
        apply: filter_imp H.
        move => r' nice'.
        under RInt_ext => x _.
          rewrite toRe.
        over.
        rewrite RInt_opp.
      reflexivity.
      1: {
        apply ex_RInt_continuous.
        move => z zbd.
        simpl.
        move: (nice' z zbd).
        copy => [[[holo _] _]].
        copy => [[[/is_derive_continuous ? _] _]].
        expand_nice.
        auto_cts.
        2-4: apply: ex_derive_continuous.
        3: apply differentiable_pt_comp_ex_derive_right.
        all: auto_derive_teardown.
        rewrite /u.
        auto_cts.
        apply: continuous_comp; last auto_cts.
        apply (@continuous_comp_2 _ _ _ _ _ _ (fun x y => f (x,y))) .
        Set Printing Implicit.
        1,2: apply: ex_derive_continuous; auto_derive_teardown.
        apply/ cts_topology_1.
        apply: ex_derive_continuous.
        eapply ex_derive_ext.
          move => t; rewrite -surjective_pairing.
        reflexivity.
        eexists.
        apply holo.
      }
      have ->: (Im (f (g r b) * g_r r b - f (g r a) * g_r r a)) =
                 (opp (Re(h (g r b) * g_r r b - h (g r a) * g_r r a))) by
        rewrite /opp /=/g/h/u/v; field_simplify_eq.
      apply: is_derive_opp.

      apply: (@path_independence_part_3_real u v u' v' ); auto.
      + move => r0 t0 r0bd t0bd.
        apply: locally_2d_impl (holo_loc r0bd t0bd).
        apply locally_2d_forall.
        move => r' t' [H _].
        eapply is_derive_ext.
          move => t.
          rewrite -/(h t) hf.
        reflexivity.
        rewrite -/(h' (g r' t')) hf'.
        apply: Holo_mult.
        auto.
      + move => r0 t0 r0bd t0bd.
        apply: locally_2d_impl (holo_loc r0bd t0bd).
        apply locally_2d_forall.
        move => r' t' [_ H].
        rewrite -/h'.
        eapply continuous_ext.
          move => x.
          rewrite hf'.
         reflexivity.
        simpl.
        auto_cts.
  Qed.

  Lemma path_independence_line:
    (forall r1 r2,
      (g r1 a = g r2 a) /\
      (g r1 b = g r2 b)) ->
    RInt (V:=C_R_CompleteNormedModule)
      (fun t0 : R => (f (g c t0) * g_t c t0)) a b =
    RInt (V:=C_R_CompleteNormedModule)
      (fun t0 : R => (f (g d t0) * g_t d t0)) a b .
  Proof.
    move => loop.
    pose h := fun r => RInt (V:=C_R_CompleteNormedModule)
       (fun t0 : R => f (g r t0) * g_t r t0) a b.
    change (h c = h d).
    apply:eq_is_derive; last by [].
    move => r tbd.
    evar_last.
    apply: path_independence_part_4; first by [].
    rewrite /g_r.
    under Derive_ext => r'.
      move: (loop c r') =>  [_ /pair_equal_spec [<- _]].
    over.
    rewrite Derive_const.
    under Derive_ext => r'.
      move: (loop c r') =>  [_ /pair_equal_spec [_ <-]].
    over.
    rewrite Derive_const.
    under Derive_ext => r'.
      move: (loop c r') =>  [/pair_equal_spec [<- _] _].
    over.
    rewrite Derive_const.
    under Derive_ext => r'.
      move: (loop c r') =>  [/pair_equal_spec [_ <-] _].
    over.
    rewrite Derive_const.
    rewrite /zero /= /prod_zero /zero /= ?Cmult_0_r.
    field_simplify_eq.
    auto.
  Qed.

  Lemma path_independence_loop:
      (forall r,  c <= r <= d ->
                  (g r a = g r b) /\
                  (g_r r a = g_r r b)) ->
    RInt (V:=C_R_CompleteNormedModule)
      (fun t0 : R => (f (g c t0) * g_t c t0)) a b =
    RInt (V:=C_R_CompleteNormedModule)
      (fun t0 : R => (f (g d t0) * g_t d t0)) a b .
  Proof.
    move => loop.
    pose h := fun r => RInt (V:=C_R_CompleteNormedModule)
       (fun t0 : R => f (g r t0) * g_t r t0) a b.
    change (h c = h d).
    apply:eq_is_derive; last by [].
    move => r rbd.
    evar_last.
    apply: path_independence_part_4; first by [].
    move: (loop _ rbd) => [-> ->].
    field_simplify_eq.
    auto.
  Qed.
End PathIndependence.


From stdpp Require Import prelude.
From AML Require Import Signature Pattern Substitution.

Class ReachabilitySignature `{signature} := {next : Sigma}.

Section sec_basic_definitions.

Context `{ReachabilitySignature}.

Definition EX ϕ := PApp (POp next) ϕ.
Definition AX ϕ := ¬ₚ (EX (¬ₚ ϕ)).
Definition can_transition := EX pTop.
Definition is_final := ¬ₚ can_transition.

End sec_basic_definitions.

Declare Scope ml_reach_scope.

Bind Scope ml_reach_scope with ReachabilitySignature.

Notation "∙ x" := (EX x) (at level 41) : ml_reach_scope.
Notation "∘ x" := (AX x) (at level 41) : ml_reach_scope.

Open Scope ml_reach_scope.

Section sec_definitions.

Context `{ReachabilitySignature}.

Definition can_reach_in_one_step (ϕ ψ : Pattern) : Pattern := ϕ →ₚ ∙ ϕ.

Definition AF X ϕ := μₚ X (ϕ ∨ₚ (AX (PSVar X) ∧ₚ can_transition)).
Definition wAF X ϕ := νₚ X (ϕ ∨ₚ (AX (PSVar X) ∧ₚ can_transition)).

Definition EF X ϕ := μₚ X (ϕ ∨ₚ EX (PSVar X)).
Definition wEF X ϕ := νₚ X (ϕ ∨ₚ EX (PSVar X)).

End sec_definitions.

Infix "→ₖ" := can_reach_in_one_step (at level 59, no associativity) : ml_reach_scope.


Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Import Lia.
Require Import Wf.
From Equations Require Import Equations.

Require Export DecSort MinMax.
Require Export mBidAsk.
Require Export DecList.
Require Export mMatching.
Require Export Quantity.
Require Export mFair_Bid.
Require Export mFair_Ask.
Require Export MQFair.
Require Export MatchingAlter.
Require Export mUM.

Section UM_Process.

Hypothesis unique_timestampbid:forall b1 b2, (btime b1 = btime b2) -> b1 = b2.
Hypothesis unique_timestampask:forall s1 s2, (stime s1 = stime s2) -> s1 = s2.

(*
Note1: It is natural to believe that the bids and asks comes with
non-zero quanttity. It is easy to ensure that all the zero quantity bids
or zero quantity asks are removed from the system on arrival.
These assertions below are denoted as NZB and NZA respectively.

Note2: Since no bid or asks is of non-zero quantity a matching can be
assumed to have non-zero transactions. This assertion is represented as
NZT.

Note3: Each bid or ask is assigned a unique time stamp and unique id
on arrival. So it is easy to see that we do not have two bids or asks with
same ids in the lists B and A. These assertions are denoted as NDA and NDB.
Similarly, since a bid or ask has a unique time-stamp and they are sorted by
using their time-stamp, they have complete order. This means we can assert that the sorting criteria is anti-symmetric. These assertations are denoted as
Hanti.

Now we state our main theorems.
*)

Definition UM B A:=
replace_column
(UM_aux (sort by_dbp B) (sort by_sp A) 0 0) (uniform_price (sort by_dbp B) (sort by_sp A)).

(*Bellow three lemmas can be moved to lower level*)
Lemma idb_sort (B:list Bid):
NoDup (idbs_of B) -> NoDup (idbs_of (sort by_dbp B)).
Proof. assert(perm (idbs_of B) (idbs_of (sort by_dbp B))). apply idb_perm.
eauto. intros. eapply perm_nodup. eauto. eauto. Qed.

Lemma ida_sort (A:list Ask):
NoDup (idas_of A) -> NoDup (idas_of (sort by_sp A)).
Proof. assert(perm (idas_of A) (idas_of (sort by_sp A))). apply ida_perm.
eauto. intros. eapply perm_nodup. eauto. eauto. Qed.

Lemma fair_sort (M:list fill_type)(B:list Bid)(A:list Ask):
Is_fair M (sort by_dbp B) (sort by_sp A) -> Is_fair M B A.
Proof. unfold Is_fair. unfold fair_on_asks. unfold fair_on_bids.
intros. destruct H. split. intros. split. apply H in H2.
apply H2. destruct H1. split. eauto. eauto. auto. auto. auto.
apply H in H2.
apply H2. destruct H1. split. eauto. eauto. auto. auto. auto.
intros. split. apply H0 in H2.
apply H2. destruct H1. split. eauto. split. destruct H5.  eauto.
apply H5. auto. auto.
apply H0 in H2.
apply H2. destruct H1. destruct H5. split. eauto. eauto. auto. auto. Qed.

(*Following Theorem says the The processs UM is Individual Rational
and Uniform matching. Note that Is_uniform is defined as IR
and Uniform matching*)
Theorem UM_Is_Uniform (B:list Bid)(A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA:NoDup (idas_of A))
(NDB:NoDup (idbs_of B)):
Is_uniform (UM B A) B A.
Proof. intros. intros. assert(HA:Sorted by_sp (sort by_sp A)).
       apply sort_correct. apply by_sp_P. apply by_sp_P.
       intros. assert(HB:Sorted by_dbp (sort by_dbp B)).
       apply sort_correct. apply by_dbp_P. apply by_dbp_P.
       split.
               { unfold UM. apply replace_column_is_uniform. }
               { split.
                 { split.
                    { split.
                      { unfold All_matchable. intros.
                         eapply UM_aux_is_Ind_Rat with (B:=(sort by_dbp B)) in HA.
                        unfold Is_IR in HA. unfold UM in H. apply HA in H.
                        unfold rational in H. lia. auto. auto. auto.
                      }
                      { split.
                       { intros. unfold UM.
                         replace (ttqb (replace_column
                         (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)
                         (uniform_price (sort by_dbp B) (sort by_sp A))) b) with
                         (ttqb (UM_aux (sort by_dbp B) (sort by_sp A) 0 0) b).
                         apply UM_aux_ttqb. auto. apply idb_sort.
                         auto. apply ida_sort. auto.
                         apply replace_column_ttqb.
                       }
                       { intros. unfold UM.
                         replace (ttqa (replace_column
                         (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)
                          (uniform_price (sort by_dbp B) (sort by_sp A))) a) with
                          (ttqa (UM_aux (sort by_dbp B) (sort by_sp A) 0 0) a).
                         apply UM_aux_ttqa. auto. apply idb_sort.
                         auto. apply ida_sort. auto.
                         apply replace_column_ttqa.
                       }
                     }
                   }
                   { split. unfold UM.
                     replace (bids_of (replace_column
                     (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)
                     (uniform_price (sort by_dbp B) (sort by_sp A)))) with
                     (bids_of (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)).
                     assert(bids_of (UM_aux (sort by_dbp B)
                     (sort by_sp A) 0 0) [<=] (sort by_dbp B)).
                     apply UM_aux_subset_bidsB. eauto.
                     apply replace_column_bids.
                     unfold UM.
                     replace (asks_of (replace_column
                     (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)
                     (uniform_price (sort by_dbp B) (sort by_sp A)))) with
                     (asks_of (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)).
                     assert(asks_of (UM_aux (sort by_dbp B)
                     (sort by_sp A) 0 0) [<=] (sort by_sp A)).
                     apply UM_aux_subset_asksA. eauto.
                     apply replace_column_asks.
                   }
                }
                { eapply UM_aux_is_Ind_Rat with (B:=(sort by_dbp B)) in HA.
                  auto. all:auto.
                }
             }
          Qed.

(*This Theorem says that UM is fair matching.*)
Theorem UM_FAIR (B:list Bid)(A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA:NoDup (idas_of A))
(NDB:NoDup (idbs_of B)):
Is_fair (UM B A) B A.
Proof.  assert(HA:Sorted by_sp (sort by_sp A)).
                        apply sort_correct. apply by_sp_P. apply by_sp_P.
                        intros. assert(HB:Sorted by_dbp (sort by_dbp B)).
                        apply sort_correct. apply by_dbp_P. apply by_dbp_P.
                        unfold UM.
                        assert(Is_fair (UM_matching (sort by_dbp B) (sort by_sp A))
                        (sort by_dbp B) (sort by_sp A)). eapply UM_Fair.
                         all:try auto. apply idb_sort.
                         auto. apply ida_sort. auto.
                        auto. auto. unfold UM_matching in H.
                        apply fair_sort in H. auto.
Qed.

(*This Theorem says that UM is maximum amongst all the uniform matchings*)

Theorem UM_Maximum (B:list Bid)(A:list Ask)(M:list fill_type)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA:NoDup (idas_of A))
(NDB:NoDup (idbs_of B))
(NZT: forall m : fill_type, In m M -> tq m > 0):
Is_uniform M B A ->
QM((UM B A))>=QM(M).
Proof.  unfold UM. intros.
        replace (QM (replace_column
        (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)
        (uniform_price (sort by_dbp B) (sort by_sp A))))
        with (QM (UM_aux (sort by_dbp B) (sort by_sp A) 0 0)).
        apply UM_aux_optimal.
        all: auto. eauto. eauto. apply ida_sort. auto.
        apply idb_sort. auto. apply sort_correct.
        apply by_dbp_P. apply by_dbp_P.
        apply sort_correct. apply by_sp_P. apply by_sp_P.
        split. apply H. split. destruct H. destruct H0.
        apply match_inv with (M':=M)(B':=(sort by_dbp B))(A':=(sort by_sp A)) in H0.
        auto. auto. eauto. eauto. apply H.
        eapply replace_column_size.
Qed.

End UM_Process.


Require Export desargues2D.

Module Desargues2Dfinal2  (DecPoints: FSetInterface.WS) (M: RankProjectiveSpace DecPoints).

Module Export Desargues_2D_final := Desargues2Dfinal DecPoints M.

Lemma new_scheme : forall
(A' : Point)
(B' : Point)
(C' : Point)
(A : Point)
(B : Point)
(C : Point)
(O : Point)
(rABC : rk (triple A B C) = 3)
(rA'B'C' : rk (triple A' B' C') = 3)
(rABO : rk (triple A B O) = 3)
(rACO : rk (triple A C O) = 3)

(rBB'O : rk (triple B B' O) = 2)
(rCC'O : rk (triple C C' O) = 2)

(alpha : Point)
(beta : Point)
(gamma : Point)
(rABgamma : rk (triple A B gamma) = 2)
(rA'B'gamma : rk (triple A' B' gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(rA'C'beta : rk (triple A' C' beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)

(H : A' [==] O), rk (triple alpha beta gamma) <= 2.
Proof.
intros.
rewrite H in *;clear H.

assert (rk(couple B gamma)=1).
eapply (uniq_inter A B O B').
eapply rk_triple_ABC_couple_AB; eassumption.
eapply rk_triple_ABC_couple_AB; eassumption.
setoid_replace (triple A B B) with (couple A B) by fsetdecide_no_hyps.
assert (rk(couple A B)=2).
eapply rk_triple_ABC_couple_AB; eassumption.
omega.
setoid_replace (triple O B' B) with (triple B B' O) by fsetdecide_no_hyps; omega.
omega.
omega.
assert (rk (quadruple A B O B') >=rk(triple A B O)).
apply matroid2; fsetdecide_no_hyps.
omega.

assert (rk(couple C beta)=1).
eapply (uniq_inter A C O C').
eapply rk_triple_ABC_couple_AB; eassumption.
eapply rk_triple_ABC_couple_AC; eassumption.
setoid_replace (triple A C C) with (couple A C) by fsetdecide_no_hyps.
assert (rk(couple A C)=2).
eapply rk_triple_ABC_couple_AC; eassumption.
omega.
setoid_replace (triple O C' C) with (triple C C' O) by fsetdecide_no_hyps; omega.
omega.
omega.
assert (rk (quadruple A C O C') >=rk(triple A C O)).
apply matroid2; fsetdecide_no_hyps.
omega.

rewrite <- (couple_rk2 B gamma) by assumption.
rewrite <- (couple_rk2 C beta) by assumption.
setoid_replace (triple alpha C B) with (triple B C alpha) by fsetdecide_no_hyps; omega.
Qed.

Section desargues_theorem.

Variables A' B' C' : Point.
Variables A B C : Point.

Variables O : Point.

Variable rABC : rk(triple A B C)=3.
Variable rA'B'C' : rk(triple A' B' C')=3.
Variable rABCA'B'C'O : rk(union (triple A B C) (union (triple A' B' C') (singleton O)))=3.

Variable rABO : rk(triple A B O)=3.
Variable rACO :rk(triple A C O)=3.
Variable rBCO : rk (triple B C O)=3.

Variable rAA'O : rk(triple A A' O)=2.
Variable rBB'O : rk(triple B B' O)=2.
Variable rCC'O : rk(triple C C' O)=2.

Variable rAA' : rk(couple A A')=2.
Variable rBB' : rk(couple B B')=2.
Variable rCC' : rk(couple C C')=2.

Variables alpha beta gamma : Point.

Variable rABgamma : rk(triple A B gamma)=2.
Variable rA'B'gamma : rk(triple A' B' gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable rA'C'beta : rk(triple A' C' beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rB'C'alpha : rk(triple B' C' alpha) =2.

Lemma Desargues_plane : rk (triple alpha beta gamma) <= 2.
Proof.
elim (eq_point_dec_rk A' O); intro HA'.
assert (A' [==] O) by (apply couple_rk2; auto); clear HA'.
apply (new_scheme A' B' C' A B C O); auto.

elim (eq_point_dec_rk B' O); intro HB'.
assert (B' [==] O) by (apply couple_rk2; auto).
setoid_replace (triple alpha beta gamma) with (triple beta gamma alpha) by fsetdecide_no_hyps.
apply (new_scheme B' C' A' B C A O); try assumption.
setoid_replace (triple B C A) with (triple A B C) by fsetdecide_no_hyps; auto.
setoid_replace (triple B' C' A') with (triple A' B' C') by fsetdecide; auto.
setoid_replace (triple B A O) with (triple A B O) by fsetdecide; auto.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide; auto.
setoid_replace (triple B' A' gamma) with (triple A' B' gamma) by fsetdecide; auto.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide; auto.

elim (eq_point_dec_rk C' O); intro HC'.
assert (C'[==]O) by (apply couple_rk2; auto).
setoid_replace(triple alpha beta gamma) with (triple gamma beta alpha) by fsetdecide.
apply (new_scheme C' B' A' C B A O); try assumption.
setoid_replace (triple C B A) with (triple A B C) by fsetdecide; auto.
setoid_replace (triple C' B' A') with (triple A' B' C') by fsetdecide; auto.
setoid_replace (triple C B O) with (triple B C O) by fsetdecide; auto.
setoid_replace (triple C A O) with (triple A C O) by fsetdecide; auto.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide; auto.
setoid_replace (triple C' B' alpha) with (triple B' C' alpha) by fsetdecide; auto.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide; auto.
setoid_replace (triple C' A' beta) with (triple A' C' beta) by fsetdecide; auto.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide; auto.

eapply (Desargues_plane A' B' C' A B C O); eauto.
Qed.

End desargues_theorem.
End Desargues2Dfinal2.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e243m9_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e190m11_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(**
Limits
*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Local Open Scope type_scope.
Local Open Scope mor_disp_scope.

Section Creates_Limits.

(* TODO: consider implicitness of argument *)
Definition creates_limit
  {C : category}
  (D : disp_cat C)
  {J : graph} (F : diagram J (total_category D))
  {x : C} (L : cone (mapdiagram (pr1_category D) F)  x)
  (isL : isLimCone _ x L) : UU
:=
  ∑ (CC : iscontr
      ( ∑ (d : D x)
          (δ : ∏ j : vertex J, d -->[coneOut L j] (pr2 (dob F j))),
          forms_cone(c:=(x,,d)) F (λ j, (coneOut L j ,, δ j))))
  , isLimCone _ _ (make_cone _ (pr2 (pr2 (iscontrpr1 CC)))).

Definition creates_limits {C : category} (D : disp_cat C) : UU
:=
  ∏ (J : graph) (F : diagram J (total_category D))
    (x : C) (L : cone (mapdiagram (pr1_category D) F)  x)
    (isL : isLimCone _ x L),
  creates_limit _ _ _ isL.

End Creates_Limits.

Section creates_preserves.

Context {C : category}
        (D : disp_cat C)
        (H : creates_limits D)
        (J : graph)
        (X : Lims_of_shape J C).

Notation π := (pr1_category D).

Definition total_limits : Lims_of_shape J (total_category D).
Proof.
  intro d.
  set (πd := mapdiagram π d).
  set (LL := X πd).
  set (L := pr1 LL).
  set (c := pr1 L).
  set (isL := pr2 LL). cbn in isL.
  set (XR := H _ d _ _ isL).
  unfold creates_limit in XR.
  cbn.
  use (make_LimCone _ _ _ (pr2 XR)).
Defined.

Lemma pr1_preserves_limit (d : diagram J (total_category D))
  (x : total_category D) (CC : cone d x) : preserves_limit π _ x CC.
Proof.
  intro H1.
  set (XR := X (mapdiagram π d)).
  use is_z_iso_isLim.
  - apply X.
  - match goal with |[ |- is_z_isomorphism ?foo ] => set (T:= foo) end.
    destruct X as [[a L] isL]. cbn in isL.
    clear XR.
    set (tL := H _ _ _ _ isL).
    unfold creates_limit in tL.
    set (RR := pr1 tL).
    set (RT1 := pr2 tL).
(*
    set (RX := isLim_is_iso _ (make_LimCone _ _ CC H1) _ _ RT1).
    cbn in RX.
    set (XR := @functor_on_is_iso_is_iso _ _ π _ _ _ RX).
    cbn in XR.
    match goal with |[ H : is_iso ?f |- _ ] => set (T':= f) end.
*)

    set (RX := isLim_is_z_iso _ (make_LimCone _ _ _ RT1) _ _ H1).
    set (XR := @functor_on_is_z_isomorphism _ _ π _ _ _ RX).
    match goal with |[ H : is_z_isomorphism ?f |- _ ] => set (T':= f) end.

    assert (X0 : T' = T).
    {

      clear XR.
      clear RX.
      unfold T.
      unfold T'.
      apply (limArrowUnique (make_LimCone _ _ _ isL)) .
      intro j.
      set (RRt := make_LimCone _ _ _ RT1).
      set (RRtt := limArrowCommutes RRt x CC j).
      set (RH := maponpaths (#π)%Cat RRtt).
      cbn in RH.
      apply RH.
    }
    rewrite <- X0.
    apply XR.
Defined.

End creates_preserves.

(* *)


Require Import
  Coq.ZArith.ZArith
  Hask.Control.Monad
  Data.Either
  Pact.Lib
  Pact.Bltn
  Pact.SemTy
  Pact.Lang.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Import ListNotations.

Definition add : Z → Z → Z := Z.add.
Definition sub : Z → Z → Z := Z.sub.

Definition arity1 `(f : ty → ty') : ty → PactM ty' :=
  λ n, pure (f n).

Definition arity2 `(f : ty → ty' → ty'') : ty → PactM (ty' → PactM ty'') :=
  λ n, pure (λ m, pure (f n m)).

Definition SemBltn {τ} (bltn : Builtin τ) : SemTy τ :=
  match bltn with
  | AddInt => arity2 add
  | SubInt => arity2 sub
  end.


(*********************************************************************************

 Colimits of 1-types

 Contents:
 1. Initial object
 2. Coproducts
 3. Extensivity

 *********************************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInOneTypes.
Require Import UniMath.Bicategories.Limits.CommaObjects.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Colimits.Coproducts.
Require Import UniMath.Bicategories.Colimits.Extensive.

Local Open Scope cat.

(**
 1. Initial object
 *)
Definition empty_one_type
  : one_types
  := empty_HLevel 2.

Definition empty_is_biinitial_one_types
  : is_biinitial empty_one_type.
Proof.
  use make_is_biinitial.
  - exact (λ _, fromempty).
  - exact (λ _ _ _ z, fromempty z).
  - exact (λ _ _ _ _ _, funextsec _ _ _ (λ z, fromempty z)).
Defined.

Definition biinitial_obj_one_types
  : biinitial_obj one_types
  := empty_one_type ,, empty_is_biinitial_one_types.

Definition strict_biinitial_one_types
  : is_strict_biinitial_obj empty_one_type.
Proof.
  refine (empty_is_biinitial_one_types ,, _).
  intros X f.
  use weq_is_adjoint_equivalence.
  apply isweqtoempty.
Defined.

(**
 2. Coproducts
 *)
Definition coprod_one_types
           (X Y : one_type)
  : one_type.
Proof.
  use make_one_type.
  - exact (X ⨿ Y).
  - apply isofhlevelssncoprod.
    + apply X.
    + apply Y.
Defined.

Definition bincoprod_cocone_one_types
           (X Y : one_types)
  : bincoprod_cocone X Y.
Proof.
  use make_bincoprod_cocone.
  - exact (coprod_one_types X Y).
  - exact inl.
  - exact inr.
Defined.

Section CoprodUMP.
  Context (X Y : one_types).

  Definition binprod_cocone_has_binprod_ump_1_one_types
    : bincoprod_ump_1 (bincoprod_cocone_one_types X Y).
  Proof.
    intros Z.
    use make_bincoprod_1cell.
    - cbn ; intro z.
      induction z as [ x | y ].
      + exact (bincoprod_cocone_inl Z x).
      + exact (bincoprod_cocone_inr Z y).
    - use make_invertible_2cell.
      + intro ; apply idpath.
      + apply one_type_2cell_iso.
    - use make_invertible_2cell.
      + intro ; apply idpath.
      + apply one_type_2cell_iso.
  Defined.

  Definition binprod_cocone_has_binprod_ump_2_one_types
    : bincoprod_ump_2 (bincoprod_cocone_one_types X Y).
  Proof.
    intros Z φ ψ α β.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros γ₁ γ₂ ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
         use funextsec ; intro z ;
         induction z as [ x | y ] ;
         [ exact (eqtohomot (pr12 γ₁) x @ !(eqtohomot (pr12 γ₂) x))
         | exact (eqtohomot (pr22 γ₁) y @ !(eqtohomot (pr22 γ₂) y)) ]).
    - simple refine (_ ,, _ ,, _).
      + cbn ; intro z.
        induction z as [ x | y ].
        * exact (α x).
        * exact (β y).
      + abstract
          (use funextsec ;
           intro z ; cbn ;
           apply idpath).
      + abstract
          (use funextsec ;
           intro z ; cbn ;
           apply idpath).
  Defined.

  Definition binprod_cocone_has_binprod_ump_one_types
    : has_bincoprod_ump (bincoprod_cocone_one_types X Y).
  Proof.
    split.
    - exact binprod_cocone_has_binprod_ump_1_one_types.
    - exact binprod_cocone_has_binprod_ump_2_one_types.
  Defined.
End CoprodUMP.

Definition has_bincoprod_one_types
  : has_bincoprod one_types
  := λ X Y,
     bincoprod_cocone_one_types X Y
     ,,
     binprod_cocone_has_binprod_ump_one_types X Y.

Definition one_types_with_biinitial_bincoprod
  : bicat_with_biinitial_bincoprod
  := one_types ,, biinitial_obj_one_types ,, has_bincoprod_one_types.

(**
 3. Extensivity
 *)
Section OneTypesDisjoint.
  Notation "∁" := one_types_with_biinitial_bincoprod.

  Context (X Y : ∁).

  Let ι₁ : X --> pr1 (bincoprod_of ∁ X Y)
    := bincoprod_cocone_inl (pr1 (bincoprod_of ∁ X Y)).
  Let ι₂ : Y --> pr1 (bincoprod_of ∁ X Y)
    := bincoprod_cocone_inr (pr1 (bincoprod_of ∁ X Y)).

  Definition one_types_inl_inr
    : has_comma_ump (@biinitial_comma_cone ∁ _ _ _ ι₁ ι₂).
  Proof.
    split.
    - intro Z.
      use make_comma_1cell.
      + intro z.
        exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))).
      + use make_invertible_2cell.
        * intro z.
          exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))).
        * apply one_type_2cell_iso.
      + use make_invertible_2cell.
        * intro z.
          exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z))).
        * apply one_type_2cell_iso.
      + abstract
          (use funextsec ;
           intro z ;
           exact (fromempty (negpathsii1ii2 _ _ (comma_cone_cell Z z)))).
    - intros Z φ ψ α β p.
      use iscontraprop1.
      + abstract
          (use invproofirrelevance ;
           intros τ₁ τ₂ ;
           use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
           use funextsec ;
           intro z ;
           exact (fromempty (φ z))).
      + simple refine (_ ,, _ ,, _).
        * intro z.
          exact (fromempty (φ z)).
        * abstract
            (use funextsec ;
             intro z ;
             exact (fromempty (φ z))).
        * abstract
            (use funextsec ;
             intro z ;
             exact (fromempty (φ z))).
  Defined.

  Definition one_types_inr_inl
    : has_comma_ump (@biinitial_comma_cone ∁ _ _ _ ι₂ ι₁).
  Proof.
    split.
    - intro Z.
      use make_comma_1cell.
      + intro z.
        exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))).
      + use make_invertible_2cell.
        * intro z.
          exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))).
        * apply one_type_2cell_iso.
      + use make_invertible_2cell.
        * intro z.
          exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z))).
        * apply one_type_2cell_iso.
      + abstract
          (use funextsec ;
           intro z ;
           exact (fromempty (negpathsii2ii1 _ _ (comma_cone_cell Z z)))).
    - intros Z φ ψ α β p.
      use iscontraprop1.
      + abstract
          (use invproofirrelevance ;
           intros τ₁ τ₂ ;
           use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
           use funextsec ;
           intro z ;
           exact (fromempty (φ z))).
      + simple refine (_ ,, _ ,, _).
        * intro z.
          exact (fromempty (φ z)).
        * abstract
            (use funextsec ;
             intro z ;
             exact (fromempty (φ z))).
        * abstract
            (use funextsec ;
             intro z ;
             exact (fromempty (φ z))).
  Defined.
End OneTypesDisjoint.

Section OneTypesUniversal.
  Notation "∁" := one_types_with_biinitial_bincoprod.

  Context {X Y Z : ∁}
          (h : Z --> pr1 (bincoprod_of ∁ X Y)).

  Let ι₁ : one_types ⟦ X , pr1 (bincoprod_of ∁ X Y) ⟧
    := inl.
  Let ι₂ : one_types ⟦ Y , pr1 (bincoprod_of ∁ X Y) ⟧
      := inr.

  Let κ₁ : one_types ⟦ hfp_HLevel 3 _ h , Z ⟧
    := hfpg' ι₁ h.
  Let κ₂ : one_types ⟦ hfp_HLevel 3 _ h , Z ⟧
    := hfpg' ι₂ h.

  Definition one_types_universal_coprod_map
             (W : @bincoprod_cocone
                    ∁
                    (hfp_HLevel 3 ι₁ h)
                    (hfp_HLevel 3 ι₂ h))
    : ∏ (z : pr1 Z)
        (q : pr1 X ⨿ pr1 Y)
        (p : h z = q),
      pr11 W.
  Proof.
    intros z q.
    induction q as [ x | y ].
    - intro p.
      refine (bincoprod_cocone_inl W _).
      exact ((x ,, z) ,, p).
    - intro p.
      refine (bincoprod_cocone_inr W _).
      exact ((y ,, z) ,, p).
  Defined.

  Definition one_types_universal_coprod_map_idpath
             (W : @bincoprod_cocone
                    ∁
                    (hfp_HLevel
                       3
                       (bincoprod_cocone_inl (pr1 (bincoprod_of ∁ X Y)))
                       h)
                    (hfp_HLevel
                       3
                       (bincoprod_cocone_inr (pr1 (bincoprod_of ∁ X Y)))
                       h))
             (z : pr1 Z)
             (q : pr1 X ⨿ pr1 Y)
             (p : h z = q)
    : one_types_universal_coprod_map W z q p
      =
      one_types_universal_coprod_map W z (h z) (idpath _).
  Proof.
    induction p.
    apply idpath.
  Defined.

  Section Universal.
    Context {W : one_types}
            {φ ψ : Z --> W}
            (α : κ₁ · φ ==> κ₁ · ψ)
            (β : κ₂ · φ ==> κ₂ · ψ).

    Definition one_types_universal_coprod_cell_help
               (z : pr1 Z)
               (q : pr111 (bincoprod_of ∁ X Y))
               (p : h z = q)
      : φ z = ψ z.
    Proof.
      cbn in z, p, q.
      induction q as [ x | y ].
      - exact (α ((x ,, z) ,, p)).
      - exact (β ((y ,, z) ,, p)).
    Defined.

    Definition one_types_universal_coprod_cell_help_eq
               (z : pr1 Z)
               (q : pr111 (bincoprod_of ∁ X Y))
               (p : h z = q)
      : one_types_universal_coprod_cell_help z (h z) (idpath _)
        =
        one_types_universal_coprod_cell_help z q p.
    Proof.
      induction p.
      apply idpath.
    Qed.

    Definition one_types_universal_coprod_cell
      : φ ==> ψ
      := λ z, one_types_universal_coprod_cell_help z (h z) (idpath _).

    Definition one_types_universal_coprod_cell_inl
      : funhomotsec (hfpg' inl h) one_types_universal_coprod_cell = α.
    Proof.
      use funextsec.
      intro z.
      unfold funhomotsec, one_types_universal_coprod_cell.
      exact (one_types_universal_coprod_cell_help_eq _ _ (pr2 z)).
    Qed.

    Definition one_types_universal_coprod_cell_inr
      : funhomotsec (hfpg' inr h) one_types_universal_coprod_cell = β.
    Proof.
      use funextsec.
      intro z.
      unfold funhomotsec, one_types_universal_coprod_cell.
      exact (one_types_universal_coprod_cell_help_eq _ _ (pr2 z)).
    Qed.

    Definition one_types_universal_coprod_unique
      : isaprop
          (∑ (γ : φ ==> ψ),
           bincoprod_cocone_inl (make_bincoprod_cocone Z κ₁ κ₂) ◃ γ = α
           ×
           bincoprod_cocone_inr (make_bincoprod_cocone Z κ₁ κ₂) ◃ γ = β).
    Proof.
      use invproofirrelevance.
      intros τ₁ τ₂.
      use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ].
      use funextsec.
      intro z.
      pose (q := h z).
      assert (p : h z = q).
      {
        apply idpath.
      }
      induction q as [ x | y ].
      - exact (eqtohomot (pr12 τ₁) ((x ,, z) ,, p)
               @ !(eqtohomot (pr12 τ₂) ((x ,, z) ,, p))).
      - exact (eqtohomot (pr22 τ₁) ((y ,, z) ,, p)
               @ !(eqtohomot (pr22 τ₂) ((y ,, z) ,, p))).
    Qed.
  End Universal.

  Definition one_types_universal_coprod
    : has_bincoprod_ump
        (@make_bincoprod_cocone
           ∁
           (hfp_HLevel 3 _ h)
           (hfp_HLevel 3 _ h)
           Z
           (hfpg' inl h)
           (hfpg' inr h)).
  Proof.
    split.
    - intro W.
      use make_bincoprod_1cell.
      + intro z ; cbn.
        exact (one_types_universal_coprod_map W z (h z) (idpath _)).
      + use make_invertible_2cell.
        * intro z.
          induction z as [ [ x z ] p ] ; cbn in *.
          exact (!one_types_universal_coprod_map_idpath W z (inl x) p).
        * apply one_type_2cell_iso.
      + use make_invertible_2cell.
        * intro z.
          induction z as [ [ x z ] p ] ; cbn in *.
          exact (!one_types_universal_coprod_map_idpath W z (inr x) p).
        * apply one_type_2cell_iso.
    - intros W φ ψ α β.
      use iscontraprop1.
      + apply one_types_universal_coprod_unique.
      + simple refine (_ ,, _ ,, _).
        * exact (one_types_universal_coprod_cell α β).
        * exact (one_types_universal_coprod_cell_inl α β).
        * exact (one_types_universal_coprod_cell_inr α β).
  Defined.
End OneTypesUniversal.

Definition is_extensive_one_types
  : is_extensive one_types_with_biinitial_bincoprod.
Proof.
  intros X Y.
  split.
  - refine (_ ,, _ ,, _ ,, _).
    + apply one_types_isInjective_fully_faithful_1cell ; cbn.
      apply isweqonpathsincl.
      apply isinclii1.
    + apply one_types_isInjective_fully_faithful_1cell ; cbn.
      apply isweqonpathsincl.
      apply isinclii2.
    + exact (one_types_inl_inr X Y).
    + exact (one_types_inr_inl X Y).
  - use is_universal_from_pb_alt.
    + exact one_types_has_pb.
    + intros Z h.
      exact (one_types_universal_coprod h).
Defined.


Set Implicit Arguments.

Section Stream.
  Variable A : Type.

  CoInductive Stream : Type :=
  | Cons : A -> Stream -> Stream.

  Definition head (l : Stream) : A :=
    match l with
    | Cons x _ => x
    end.

  Definition tail (l : Stream) : Stream :=
    match l with
    | Cons _ l' => l'
    end.

  Definition frob (l : Stream) : Stream :=
    match l with
    | Cons x l' => Cons x l'
    end.

  Theorem frob_id :
    forall (l : Stream),
      l = frob l.
  Proof.
    intros; destruct l; auto.
  Qed.

  Fixpoint nth_tail (n : nat) (l : Stream) : Stream :=
    match n with
    | 0 => l
    | S n => nth_tail n (tail l)
    end.

  Lemma tail_nth_tail_comm :
    forall (n : nat) (l : Stream),
      nth_tail n (tail l) = tail (nth_tail n l).
  Proof.
    induction n; intros; simpl; repeat rewrite IHn; auto.
  Qed.

  Theorem nth_tail_assoc :
    forall (n m : nat) (l : Stream),
      nth_tail n (nth_tail m l) = nth_tail (n+m) l.
  Proof.
    induction n; intros; simpl.
    - auto.
    - repeat rewrite tail_nth_tail_comm.
      rewrite IHn; auto.
  Qed.
End Stream.


(precise)admin@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Concise.

Coq < Variables B C : Prop.
B is assumed
C is assumed

Coq < Require Import Classical.

Coq < Goal ((B -> C) /\ ~C) -> ~B.
1 subgoal

  B : Prop
  C : Prop
  ============================
   (B -> C) /\ ~ C -> ~ B

Unnamed_thm < intros.
1 subgoal

  B : Prop
  C : Prop
  H : (B -> C) /\ ~ C
  ============================
   ~ B

Unnamed_thm < elim H.
1 subgoal

  B : Prop
  C : Prop
  H : (B -> C) /\ ~ C
  ============================
   (B -> C) -> ~ C -> ~ B

Unnamed_thm < intro.
1 subgoal

  B : Prop
  C : Prop
  H : (B -> C) /\ ~ C
  H0 : B -> C
  ============================
   ~ C -> ~ B

Unnamed_thm < intro.
1 subgoal

  B : Prop
  C : Prop
  H : (B -> C) /\ ~ C
  H0 : B -> C
  H1 : ~ C
  ============================
   ~ B

Unnamed_thm < tauto.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
tauto.

Unnamed_thm is defined

Coq <


Require Import Bedrock.Examples.AutoSep.

Fixpoint countNonzero (ws : list W) : nat :=
  match ws with
    | nil => O
    | w :: ws => if weq w $0 then countNonzero ws else S (countNonzero ws)
  end.

Definition mainS := SPEC("arr", "len") reserving 3
  Al arr,
  PRE[V] [| V "len" = length arr |] * array arr (V "arr")
  POST[R] [| R = countNonzero arr |] * array arr (V "arr").

Definition m := bmodule "m" {{
  bfunction "main"("arr", "len", "acc", "index", "value") [mainS]
    "acc" <- 0;;

    [After prefix Approaching all
      PRE[V] [| V "acc" = countNonzero prefix |]
      POST[R] [| R = countNonzero all |] ]
    For "index" Holding "value" in "arr" Size "len"
      Where (Value <> 0) {
      "acc" <- "acc" + 1
    };;

    Return "acc"
  end
}}.

Lemma countNonzero_app : forall ws2 ws1,
  countNonzero (ws1 ++ ws2) = countNonzero ws1 + countNonzero ws2.
  induction ws1; simpl; intuition;
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; intuition.
Qed.

Lemma skip : forall val x,
  wneb val 0 <> true
  -> forall ws, x = natToW (countNonzero ws)
    -> x = countNonzero (ws ++ val :: nil).
  intros; subst; rewrite countNonzero_app; simpl;
    unfold wneb, natToW in *;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; intuition.
Qed.

Lemma increment : forall val x,
  wneb val 0 = true
  -> forall ws, x = natToW (countNonzero ws)
    -> x ^+ $1 = natToW (countNonzero (ws ++ val :: nil)).
  intros; subst; rewrite countNonzero_app; simpl;
    unfold wneb, natToW in *;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; discriminate || post; auto.
Qed.

Hint Immediate skip increment.
Hint Resolve tt.

Theorem mOk : moduleOk m.
  vcgen; abstract (for0; sep_auto; eauto).
Qed.


Require Import Coq.Lists.List.
Require Import MirrorShard.Expr.

Set Implicit Arguments.
Set Strict Implicit.

Section over_types.
  Variable types : list type.

  Inductive Quant : Type :=
  | QAll  : variables -> Quant -> Quant
  | QEx   : variables -> Quant -> Quant
  | QBase : Quant.

  (** NOTE: For efficiency, the outer-most quantifier should be
   ** the deepest quantifier
   **)
  (** NOTE:
   ** For forward reasoning we need to invert the quantifiers.
   ** i.e. All quantifiers should become uvar and
   **      Ex quantifiers should become var
   **)
  Fixpoint quantD (ex_env all_env : env types) (qs : Quant) (k : env types -> env types -> Prop) : Prop :=
    match qs with
      | QBase => k ex_env all_env
      | QAll vs qs => quantD ex_env all_env qs (fun ex_env all_env => forallEach vs (fun all_ext => k ex_env (all_env ++ all_ext)))
      | QEx vs qs => quantD ex_env all_env qs (fun ex_env all_env => existsEach vs (fun ex_ext => k (ex_env ++ ex_ext) all_env))
    end.

  Fixpoint appendQ (q1 q2 : Quant) : Quant :=
    match q1 with
      | QBase => q2
      | QAll vs q1 => QAll vs (appendQ q1 q2)
      | QEx vs q1 => QEx vs (appendQ q1 q2)
    end.

  Theorem quantD_app : forall qs' qs meta_env vars_env k,
    quantD meta_env vars_env (appendQ qs qs') k <->
    quantD meta_env vars_env qs' (fun meta_env vars_env => quantD meta_env vars_env qs k).
  Proof.
    clear; induction qs; simpl; intros; try rewrite IHqs; try reflexivity.
  Qed.

  Fixpoint gatherEx (qs : Quant) : variables :=
    match qs with
      | QBase => nil
      | QAll _ qs => gatherEx qs
      | QEx vs qs => gatherEx qs ++ vs
    end.

  Fixpoint gatherAll (qs : Quant) : variables :=
    match qs with
      | QBase => nil
      | QAll vs qs => gatherAll qs ++ vs
      | QEx _ qs => gatherAll qs
    end.

  Theorem quantD_impl : forall qs meta_env vars_env (k k' : _ -> _ -> Prop),
    quantD meta_env vars_env qs k ->
    (forall a b,
      typeof_env a = gatherEx qs ->
      typeof_env b = gatherAll qs ->
      k (meta_env ++ a) (vars_env ++ b) ->
      k' (meta_env ++ a) (vars_env ++ b)) ->
    quantD meta_env vars_env qs k'.
  Proof.
    clear. induction qs; simpl; intros; try (eapply IHqs; [ eauto | ]); simpl in *; intros; instantiate; simpl in *;
    repeat match goal with
             | [ |- existsEach _ _ ] => eapply existsEach_sem
             | [ |- forallEach _ _ ] => eapply forallEach_sem; intros
             | [ H : existsEach _ _ |- _ ] =>
               eapply existsEach_sem in H; destruct H
             | [ H : forallEach _ _ |- _ ] =>
               eapply forallEach_sem in H; [ | solve [ eauto ] ]
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- exists x, _ /\ _ ] =>
               eexists; split; [ solve [ eauto ] | ]
             | [ |- _ ] => rewrite app_ass in *
           end.
    { eapply H0; eauto. subst. rewrite <- H2. unfold typeof_env. rewrite map_app. auto. }
    { eapply H0; eauto. subst. rewrite <- H1. unfold typeof_env. rewrite map_app. auto. }
    { specialize (H0 nil nil). repeat rewrite app_nil_r in *. auto. }
  Qed.

  Require Import Tactics.

  Theorem gatherEx_appendQ : forall q1 q2,
    gatherEx (appendQ q1 q2) = gatherEx q2 ++ gatherEx q1.
  Proof.
    induction q1; simpl; intros; think; repeat (rewrite app_nil_r || rewrite app_ass); auto.
  Qed.

  Theorem gatherAll_appendQ : forall q1 q2,
    gatherAll (appendQ q1 q2) = gatherAll q2 ++ gatherAll q1.
  Proof.
    induction q1; simpl; intros; think; repeat (rewrite app_nil_r || rewrite app_ass); auto.
  Qed.

  Definition qex (ls : list tvar) (q : Quant) : Quant :=
    match ls with
      | nil => q
      | _ => QEx ls q
    end.

  Definition qall (ls : list tvar) (q : Quant) : Quant :=
    match ls with
      | nil => q
      | _ => QAll ls q
    end.

  Lemma quantD_qex_QEx : forall U G a b P,
    quantD U G (QEx a b) P <-> quantD U G (qex a b) P.
  Proof. clear.
    destruct a; simpl in *; split; intros; auto.
    { eapply quantD_impl; eauto; intros. simpl in *. rewrite app_nil_r in *. auto. }
    { eapply quantD_impl; eauto; intros. simpl in *. rewrite app_nil_r in *. auto. }
  Qed.

  Lemma quantD_qall_QAll : forall U G a b P,
    quantD U G (QAll a b) P <-> quantD U G (qall a b) P.
  Proof. clear.
    destruct a; simpl in *; split; intros; auto.
    { eapply quantD_impl; eauto; intros. simpl in *. rewrite app_nil_r in *. auto. }
    { eapply quantD_impl; eauto; intros. simpl in *. rewrite app_nil_r in *. auto. }
  Qed.

  Lemma appendQ_assoc : forall a b c,
    appendQ (appendQ a b) c = appendQ a (appendQ b c).
  Proof.
    clear. induction a; simpl; intros; try f_equal; eauto.
  Qed.

  Lemma appendQ_QBase_r : forall a, appendQ a QBase = a.
  Proof. clear. induction a; simpl; intros; think; auto. Qed.

  Lemma appendQ_QAll : forall a b v,
    appendQ a (QAll v b) = appendQ (appendQ a (QAll v QBase)) b.
  Proof. clear.
    induction a; simpl; intros; try rewrite IHa; eauto.
  Qed.
  Lemma appendQ_QEx : forall a b v,
    appendQ a (QEx v b) = appendQ (appendQ a (QEx v QBase)) b.
  Proof. clear.
    induction a; simpl; intros; try rewrite IHa; eauto.
  Qed.

  Lemma QAll_inj_False : forall a b,
    QAll a b = b -> False.
  Proof. clear.
    induction b; simpl; intros; try congruence; auto.
  Qed.

  Lemma QEx_inj_False : forall a b,
    QEx a b = b -> False.
  Proof. clear.
    induction b; simpl; intros; try congruence; auto.
  Qed.

  Fixpoint qsize (q : Quant) : nat :=
    match q with
      | QBase => 0
      | QAll _ q
      | QEx _ q => S (qsize q)
    end.

  Lemma qsize_appendQ : forall a b,
    qsize (appendQ a b) = qsize a + qsize b.
  Proof.
    clear; induction a; simpl in *; auto.
  Qed.

  Ltac apply_eq f H :=
    match type of H with
      | ?X = ?Y =>
        assert (f X = f Y); [ f_equal; apply H | ]
    end.

  Lemma appendQ_proper : forall a b c,
    appendQ a b = appendQ c b ->
    a = c.
  Proof.
    clear. induction a; destruct c; simpl; intros; try congruence;
    repeat match goal with
             | [ H : QAll _ _ = QAll _ _ |- _ ] => inversion H; clear H; subst
             | [ H : QEx _ _ = QEx _ _ |- _ ] => inversion H; clear H; subst
           end; try solve [ f_equal; eauto ]; exfalso.
    { apply_eq qsize H. simpl in *; rewrite qsize_appendQ in H0. omega. }
    { apply_eq qsize H. simpl in *; rewrite qsize_appendQ in H0. omega. }
    { apply_eq qsize H. simpl in *; rewrite qsize_appendQ in H0. omega. }
    { apply_eq qsize H. simpl in *; rewrite qsize_appendQ in H0. omega. }
  Qed.

End over_types.