Require Import Compare_dec.
Require Import Utils.

Require Import Le Lt.
Require Import Plus.

Definition varBump n l i := match nat_compare i l with
	Lt => i |
	_ => n + i
end.

Definition varSubst l b i := match nat_compare i l with
	Lt => i |
	Eq => l + b |
	Gt => pred i
end.

Lemma lt_ltdHi n l i : ~(i < l)->ltd l (S n + i).
	intro.
	apply lt_ltd.
	simpl.
	apply le_n_S.
	rewrite <- plus_comm.
	apply le_plus_trans.
	exact (not_lt _ _ H).
Qed.
Implicit Arguments lt_ltdHi [l i].

Lemma varBumpLo n l i : (i < l)->(varBump n l i = i).
	intro.
	unfold varBump.
	rewrite (proj1 (nat_compare_lt _ _) H).
	reflexivity.
Qed.

Lemma varBumpHi n l i : ~(i < l)->(varBump n l i = n + i).
	intro.
	unfold varBump.
	destruct (nat_compare_spec i l);try reflexivity.
	exact (match H H0 with end).
Qed.

Lemma varSubstLt l b i : (i < l)->(varSubst l b i = i).
	intro.
	unfold varSubst.
	rewrite (proj1 (nat_compare_lt _ _) H).
	reflexivity.
Qed.

Lemma varSubstEq l b i : (i = l)->varSubst l b i = l + b.
	intro.
	unfold varSubst.
	rewrite (proj2 (nat_compare_eq_iff _ _) H).
	reflexivity.
Qed.

Lemma varSubstGt l b i : (i > l)->(varSubst l b i = pred i).
	intro.
	unfold varSubst.
	rewrite (proj1 (nat_compare_gt _ _) H).
	reflexivity.
Qed.

Lemma varBump_Bump n1 n2 l1 l2 i : (l1 <= l2)->
(varBump n2 (n1 + l2) (varBump n1 l1 i) = varBump n1 l1 (varBump n2 l2 i)).
	intro.
	destruct (lt_dec i l1).

	assert (i < l2).
		exact (le_trans _ _ _ l H).
	rewrite varBumpLo with (1 := l).
	rewrite varBumpLo with (1 := H0).
	rewrite varBumpLo with (1 := l).
	apply varBumpLo.
	apply le_trans with (1 := H0).
	apply le_plus_r.

	rewrite varBumpHi with (1 := n).
	destruct (lt_dec i l2).
		rewrite varBumpLo with (1 := l).
		rewrite varBumpHi with (1 := n).
		apply varBumpLo.
		apply plus_lt_compat_l with (1 := l).

		rewrite varBumpHi with (1 := n0).
		rewrite varBumpHi;[| intro;apply n0;apply plus_lt_reg_l with (1 := H0)].
		rewrite varBumpHi;
		[|
			intro;
			apply n;
			apply le_trans with (2 := H0);
			apply le_n_S;
			apply le_plus_r
		].
		rewrite plus_assoc.
		rewrite <- (plus_comm n1).
		rewrite <- plus_assoc.
		reflexivity.
Qed.

Lemma varBumpDiv a b n l i : (n <= b)->(varBump a (l + n) (varBump b l i) = varBump (a + b) l i).
	intro.
	destruct (lt_dec i l).

	rewrite varBumpLo with (1 := l0).
	rewrite varBumpLo with (1 := l0).
	apply varBumpLo.
	apply le_trans with (1 := l0).
	apply le_plus_l.

	rewrite varBumpHi with (1 := n0).
	rewrite varBumpHi with (1 := n0).
	rewrite <- plus_assoc.
	apply varBumpHi.
	intro.
	apply n0.
	apply plus_lt_reg_l with n.
	rewrite <- (plus_comm l).
	apply le_trans with (2 := H0).
	apply le_n_S.
	apply plus_le_compat_r with (1 := H).
Qed.

Lemma varBump_Subst n x l b i :
varBump n (x + l) (varSubst l b i) = varSubst l (varBump n x b) (varBump n (S x + l) i).
	destruct (lt_dec i (S x + l)).

	rewrite varBumpLo with (1 := l0).
	destruct (lt_eq_lt_dec i l);[destruct s |].
		rewrite varSubstLt with (1 := l1).
		rewrite varSubstLt with (1 := l1).
		apply varBumpLo.
		apply le_trans with (1 := l1).
		apply le_plus_r.

		rewrite varSubstEq with (1 := e).
		rewrite varSubstEq with (1 := e).
		assert (forall k,varBump l O k = l + k).
			intro.
			apply varBumpHi.
			apply lt_n_O.
		rewrite <- H.
		rewrite <- plus_comm.
		rewrite varBump_Bump with (1 := le_O_n _).
		apply H.

		rewrite varSubstGt with (1 := l1).
		rewrite varSubstGt with (1 := l1).
		apply varBumpLo.
		destruct i.
			destruct lt_n_O with (1 := l1).
		simpl in l0 |- *.
		apply lt_S_n with (1 := l0).

	rewrite varBumpHi with (1 := n0).
	assert (l < i).
		apply not_lt.
		intro.
		apply n0.
		apply le_trans with (1 := H).
		simpl.
		rewrite plus_n_Sm.
		apply le_plus_r.
	rewrite varSubstGt with (1 := H).
	rewrite varSubstGt;[| apply le_trans with (1 := H);apply le_plus_r].
	destruct i.
		destruct lt_n_O with (1 := H).
	rewrite <- plus_n_Sm.
	simpl.
	apply varBumpHi.
	intro.
	apply n0.
	simpl.
	apply lt_n_S with (1 := H0).
Qed.

Lemma varSubst_Bump n l1 l2 b i : (l1 <= l2)->
(varSubst (n + l2) b (varBump n l1 i) = varBump n l1 (varSubst l2 b i)).
	intro.
	destruct (lt_eq_lt_dec i l2);[destruct s |].

	rewrite varSubstLt with (1 := l).
	destruct (lt_dec i l1).
		rewrite varBumpLo with (1 := l0).
		apply varSubstLt.
		apply le_trans with (1 := l).
		apply le_plus_r.

		rewrite varBumpHi with (1 := n0).
		apply varSubstLt.
		apply plus_lt_compat_l with (1 := l).

	rewrite varSubstEq with (1 := e).
	rewrite e.
	clear i e.
	rewrite varBumpHi with (1 := le_not_lt _ _ H).
	rewrite varBumpHi;[| apply le_not_lt;apply le_trans with (1 := H);apply le_plus_l].
	rewrite varSubstEq with (1 := eq_refl _).
	rewrite <- plus_assoc.
	reflexivity.

	rewrite varSubstGt with (1 := l).
	rewrite varBumpHi;[| apply le_not_lt;apply le_trans with (2 := l);apply le_S with (1 := H)].
	rewrite varSubstGt with (1 := plus_lt_compat_l _ _ _ l).
	destruct i.
		destruct lt_n_O with (1 := l).
	rewrite <- plus_n_Sm.
	simpl.
	rewrite varBumpHi.
		reflexivity.
	apply le_not_lt.
	exact (le_trans _ _ _ H (le_S_n _ _ l)).
Qed.

Lemma varSubstDiv n l1 l2 b i : (l1 <= l2 <= l1 + n)->(varSubst l2 b (varBump (S n) l1 i) = varBump n l1 i).
	intro.
	destruct H.
	destruct (lt_dec i l1).

	rewrite varBumpLo with (1 := l).
	rewrite varBumpLo with (1 := l).
	apply varSubstLt.
	apply le_trans with (1 := l) (2 := H).

	rewrite varBumpHi with (1 := n0).
	rewrite varBumpHi with (1 := n0).
	apply varSubstGt.
	simpl.
	apply le_n_S.
	apply le_trans with (1 := H0).
	rewrite <- plus_comm.
	apply plus_le_compat_l.
	apply not_lt with (1 := n0).
Qed.

Lemma varSubst_Subst x l b1 b2 i : varSubst (x + l) b1 (varSubst l b2 i) =
varSubst l (varSubst x b1 b2) (varSubst (S x + l) b1 i).
	destruct (lt_eq_lt_dec i (S x + l));[destruct s |].

	rewrite varSubstLt with (1 := l0).
	destruct (lt_eq_lt_dec i l);[destruct s |].
		rewrite varSubstLt with (1 := l1).
		rewrite varSubstLt with (1 := l1).
		apply varSubstLt.
		apply le_trans with (1 := l1).
		apply le_plus_r.

		rewrite varSubstEq with (1 := e).
		rewrite varSubstEq with (1 := e).
		assert (forall k,varBump l O k = l + k).
			intro.
			apply varBumpHi.
			apply lt_n_O.
		rewrite <- H.
		rewrite <- plus_comm.
		rewrite varSubst_Bump with (1 := le_O_n _).
		apply H.

		rewrite varSubstGt with (1 := l1).
		rewrite varSubstGt with (1 := l1).
		apply varSubstLt.
		destruct i.
			destruct lt_n_O with (1 := l1).
		simpl in l0 |- *.
		apply lt_S_n with (1 := l0).

	rewrite varSubstEq with (1 := e).
	subst i.
	rewrite varSubstGt with (l := l);[| simpl;apply le_n_S;apply le_plus_r].
	rewrite varSubstGt with (l := l);[| simpl;apply le_n_S;rewrite <- plus_comm;rewrite plus_assoc;apply le_plus_r].
	simpl.
	apply varSubstEq with (1 := eq_refl _).

	rewrite varSubstGt with (1 := l0).
	rewrite varSubstGt with (l := l);[| apply le_trans with (2 := l0);apply le_n_S;apply le_plus_r].
	destruct i.
		destruct lt_n_O with (1 := l0).
	simpl in l0 |- *.
	pose proof (lt_S_n _ _ l0).
	clear l0.
	rewrite varSubstGt with (1 := H).
	rewrite varSubstGt with (l := l);[| apply le_trans with (2 := H);apply le_n_S;apply le_plus_r].
	reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From Coq Require Import Omega.

Section InductionExercises.

Fixpoint triple (n : nat) : nat :=
  if n is n'.+1 then (triple n').+3
  else n.

Lemma triple_mul3 n :
  triple n = 3 * n.
Proof.
  elim: n.
  - by [].
  - move=> n IHn //=.
    rewrite IHn.
    About mulnS.
    rewrite mulnS.
    move=>//=.
    Undo.
    done.

  Restart.

  by elim: n => //= n IHn; rewrite IHn mulnS.

  Restart.

  by elim: n=> //= n ->; rewrite mulnS.
Qed.

Lemma double_inj m n :
  m + m = n + n -> m = n.
Proof.
  elim: m n.
  - rewrite addn0.
    case.
    + rewrite add0n. done.
    + move=> n. rewrite addSn addnS. by [].
    move=> n IHn m.
    rewrite addnS addSn.
    case: m.
    + rewrite add0n. by [].
    move=> m.
    rewrite !addnS !addSn.
    case.
    move/IHn.
    Search _ (?n = ?m -> ?n.+1 = ?m.+1).
    About eq_S.
    apply: eq_S.
Qed.

(** Write a tail-recursive variation of the [addn] function
    (let's call it [addn_iter]). *)
Fixpoint add_iter (n m : nat) {struct n}: nat :=
  if n is n'.+1 then S (add_iter n' m)
  else m.

Lemma add_iter_correct m n :
  add_iter m n = m + n.
Proof.
  move: n.
  elim.
  Restart.
  by elim/nat_ind: n.
  Restart.
  by move: n; elim.
Qed.

Fixpoint fib (n : nat) : nat :=
  if n is (n''.+1 as n').+1 then fib n'' + fib n'
  else n.
Arguments fib n : simpl nomatch.

Lemma leq_add1l p m n :
  m <= n -> m <= p + n.
Proof.
  (* Search _ ((is_true (?m <= ?n)) -> (is_true (?n <= ?p)) -> (is_true (?m <= ?p))). *)
  (* Search _ ((?m <= ?n) -> _). *)

  (* leq_trans      forall n m p : nat, m <= n -> n <= p -> m <= p *)
  (* leq_ltn_trans  forall n m p : nat, m <= n -> n < p -> m < p *)

  (* leq_sub2r  forall p m n : nat, m <= n -> m - p <= n - p *)
  (* addnBA     forall m n p : nat, p <= n -> m + (n - p) = m + n - p *)
  (* addnBAC    forall m n p : nat, n <= m -> m - n + p = m + p - n *)
  (* addnBCA    forall m n p : nat, p <= m -> p <= n -> m + (n - p) = n + (m - p) *)
  (* addnABC    forall m n p : nat, p <= m -> p <= n -> m + (n - p) = m - p + n *)
  (* subnBA     forall m n p : nat, p <= n -> m - (n - p) = m + p - n *)

  move=> H.
Admitted.

Lemma fib_monotone m n :
  m <= n -> fib m <= fib n.
Proof.
Admitted.

Lemma fib_add_succ m n :
  fib (m + n).+1 = fib m.+1 * fib n.+1 + fib m * fib n.
Admitted.

End InductionExercises.

(* Thanks to Mike Potanin for pointing me to this example *)
(* https://en.wikipedia.org/wiki/Eckmann–Hilton_argument *)

Section EckmannHilton.

Context {X : Type}.
Variables f1 f2 : X -> X -> X.

Variable e1 : X.
Hypothesis U1 : left_id e1 f1 * right_id e1 f1.

Variables e2 : X.
Hypothesis U2 : left_id e2 f2 * right_id e2 f2.

Hypothesis I : interchange f1 f2.

Lemma units_same :
  e1 = e2.
Admitted.

Lemma operations_equal :
  f1 =2 f2.
Admitted.

Lemma I1 : interchange f1 f1.
Admitted.

Lemma operations_comm :
  commutative f1.
Admitted.

Lemma operations_assoc :
  associative f1.
Admitted.

End EckmannHilton.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_Rlt_trans.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
Proof.
  intros x y z.
  intros hxy hyz.
  unfold "<=" in hxy.
  destruct hxy as [ hxy | heq ].
  {
    apply Rlt_trans with y.
    { exact hxy. }
    { exact hyz. }
  }
  {
    subst y.
    exact hyz.
  }
Qed.


(* A simple test on how to extract code from something written in coq *)
Section square_root.
Require Import Compare_dec.

(* define the search of some nat with the prop n*n <= m -> n is square of m *)
Fixpoint square_root (n:nat) (m:nat): nat :=
  if le_lt_dec (n*n) m then
  if le_lt_dec (S n * S n) m then S n else n
  else
    match n with
    | 0 => 0
    | 1 => 1
    | (S (S n')) => square_root n' m
    end.

(* define some handy call *)
Definition square (n:nat) : nat := square_root n n.

(* test some examples which get not extracted *)
Compute (square 0).
Compute (square 1).
Compute (square 4).
Compute (square 16).
Compute (square 6).
Compute (square 250).
Compute (square 400).
Compute (square 600).

End square_root.

Require Extraction.
Extraction Language Ocaml.
Set Extraction AccessOpaque.

(* extract the specs *)
Extraction "square_root.ml" square.
(* also generates some interface file mli with the type definitions *)


(* week-03_induction-over-binary-trees.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 27 Aug 2020 *)

(* Your name: Koo Zhengqun
   Your e-mail address: zhengqun.koo@u.nus.edu
   Your student number: A0164207L
 *)

(* Your name: Bobbie Soedirgo
   Your e-mail address: sram-b@comp.nus.edu.sg
   Your student number: A0181001A
 *)

(* Your name: Kuan Wei Heng
   Your e-mail address: kuanwh@u.nus.edu
   Your student number: A0121712X
 *)

(* ********** *)

Inductive binary_tree (V : Type) : Type :=
| Leaf : V -> binary_tree V
| Node : binary_tree V -> binary_tree V -> binary_tree V.

(* ********** *)

Definition specification_of_mirror (mirror : forall V : Type, binary_tree V -> binary_tree V) : Prop :=
  (forall (V : Type)
          (v : V),
      mirror V (Leaf V v) =
      Leaf V v)
  /\
  (forall (V : Type)
          (t1 t2 : binary_tree V),
      mirror V (Node V t1 t2) =
      Node V (mirror V t2) (mirror V t1)).

(* ***** *)

(* Exercise 9a *)

(** This proof goes mostly the same way as the one for relative number of leaves and nodes in the lecture notes. We induct on [t] and apply the hypotheses in the inductive case. We also destruct within the cases to keep the assumptions clean.

    We show that the specification of the mirror function is indeed unambiguous, as proven below:
 *)
Proposition there_is_at_most_one_mirror_function :
  forall mirror1 mirror2 : forall V : Type, binary_tree V -> binary_tree V,
    specification_of_mirror mirror1 ->
    specification_of_mirror mirror2 ->
    forall (V : Type)
           (t : binary_tree V),
      mirror1 V t = mirror2 V t.
Proof.
  intros mirror1 mirror2.
  intros S_mirror1 S_mirror2.
  intros V t.
  induction t as [ v | t1 IHt1 t2 IHt2 ].
  - unfold specification_of_mirror in S_mirror1.
    destruct S_mirror1 as [S_Leaf1 _].
    unfold specification_of_mirror in S_mirror2.
    destruct S_mirror2 as [S_Leaf2 _].
    rewrite -> (S_Leaf2 V v).
    exact (S_Leaf1 V v).
  - unfold specification_of_mirror in S_mirror1.
    destruct S_mirror1 as [_ S_Node1].
    unfold specification_of_mirror in S_mirror2.
    destruct S_mirror2 as [_ S_Node2].
    (** Here we can do forward rewrites and end it with [reflexivity], or we can do it slightly differently and save one proof step:
     *)
    (*
    rewrite -> (S_Node1 V t1 t2).
    rewrite -> (S_Node2 V t1 t2).
    rewrite -> IHt1.
    rewrite -> IHt2.
    reflexivity.
     *)
    rewrite -> (S_Node2 V t1 t2).
    rewrite <- IHt1.
    rewrite <- IHt2.
    exact (S_Node1 V t1 t2).
Qed.

(* ********** *)

Definition specification_of_number_of_leaves (number_of_leaves : forall V : Type, binary_tree V -> nat) : Prop :=
  (forall (V : Type)
          (v : V),
      number_of_leaves V (Leaf V v) =
      1)
  /\
  (forall (V : Type)
          (t1 t2 : binary_tree V),
      number_of_leaves V (Node V t1 t2) =
      number_of_leaves V t1 + number_of_leaves V t2).

(* Exercise 9b *)

(** The other two works exactly the same as 9a, modulo the specifications and the names involved. We also reach the same conclusion: the specifications are unambiguous.
 *)
Proposition there_is_at_most_one_number_of_leaves_function :
  forall nol1 nol2 : forall V : Type, binary_tree V -> nat,
    specification_of_number_of_leaves nol1 ->
    specification_of_number_of_leaves nol2 ->
    forall (V : Type)
           (t : binary_tree V),
      nol1 V t = nol2 V t.
Proof.
  intros nol1 nol2.
  intros S_nol1 S_nol2.
  intros V t.
  induction t as [ v | t1 IHt1 t2 IHt2 ].
  - unfold specification_of_number_of_leaves in S_nol1.
    destruct S_nol1 as [S_Leaf1 _].
    unfold specification_of_number_of_leaves in S_nol2.
    destruct S_nol2 as [S_Leaf2 _].
    rewrite -> (S_Leaf2 V v).
    exact (S_Leaf1 V v).
  - unfold specification_of_number_of_leaves in S_nol1.
    destruct S_nol1 as [_ S_Node1].
    unfold specification_of_number_of_leaves in S_nol2.
    destruct S_nol2 as [_ S_Node2].
    rewrite -> (S_Node2 V t1 t2).
    rewrite <- IHt1.
    rewrite <- IHt2.
    exact (S_Node1 V t1 t2).
Qed.

Definition specification_of_number_of_nodes (number_of_nodes : forall V : Type, binary_tree V -> nat) : Prop :=
  (forall (V : Type)
          (v : V),
      number_of_nodes V (Leaf V v) =
      0)
  /\
  (forall (V : Type)
          (t1 t2 : binary_tree V),
      number_of_nodes V (Node V t1 t2) =
      S (number_of_nodes V t1 + number_of_nodes V t2)).

(* Exercise 9c *)

Proposition there_is_at_most_one_number_of_nodes_function :
  forall non1 non2 : forall V : Type, binary_tree V -> nat,
    specification_of_number_of_nodes non1 ->
    specification_of_number_of_nodes non2 ->
    forall (V : Type)
           (t : binary_tree V),
      non1 V t = non2 V t.
Proof.
  intros non1 non2.
  intros S_non1 S_non2.
  intros V t.
  induction t as [ v | t1 IHt1 t2 IHt2 ].
  - unfold specification_of_number_of_nodes in S_non1.
    destruct S_non1 as [S_Leaf1 _].
    unfold specification_of_number_of_nodes in S_non2.
    destruct S_non2 as [S_Leaf2 _].
    rewrite -> (S_Leaf2 V v).
    exact (S_Leaf1 V v).
  - unfold specification_of_number_of_nodes in S_non1.
    destruct S_non1 as [_ S_Node1].
    unfold specification_of_number_of_nodes in S_non2.
    destruct S_non2 as [_ S_Node2].
    rewrite -> (S_Node2 V t1 t2).
    rewrite <- IHt1.
    rewrite <- IHt2.
    exact (S_Node1 V t1 t2).
Qed.

(* ********** *)

(* end of week-03_induction-over-binary-trees.v *)


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import micromega.Lia.
From Coq Require Import Lists.List.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Int. Import Znat.
From Coq Require Import Setoids.Setoid.
From Coq Require Import Logic.FunctionalExtensionality.
Require Coq.derive.Derive.
Import ListNotations.

From ATL Require Import ATL Common CommonTactics Tactics GenPushout LetLifting.

Definition im2colmini K W RR (w : (list (list R))) (x : list R) :=
    GEN [ k < K ]
      GEN [ p < W ]
        SUM [ r < RR ]
        |[ p + r <? K ]| (w _[ k ; r ] * x _[ p + r ])%R.

Definition im2col B K W C RR (w x : (list (list (list R)))) :=
    GEN [ n < B ]
    GEN [ k < K ]
    GEN [ p < W ]
    SUM [ c < C ]
    SUM [ r < RR ]
    (w _[ k ; c ; r ] * x _[ n ; c ; p + r ])%R.

Hint Unfold im2col im2colmini : examples.

Section Mini.
  Variables (K W RR : Z) (w : (list (list R))) (x : list R).
  Derive im2colminilifted SuchThat
     ((0 < RR)%Z ->
     im2colmini K W RR w x = im2colminilifted) As miniim2col.
  Proof.
    reschedule.

    setoid_rewrite <- guard_mul_r.

    rw^ @lbind_helper for (fun e => _ * e)%R.

    time rw ll_sum.

    rw @ll_gen.

    rw @ll_gen_indep.

    done.
  Defined.
End Mini.

Section Im2col.
  Variables (B K W C RR : Z) (w x : (list (list (list R)))).
  Derive im2col_lifted SuchThat
         (im2col B K W C RR w x =
          im2col_lifted) As im2col_sched.
  Proof.
    reschedule.

    rw^ @lbind_helper for (fun e => _ * e)%R.

    rw @ll_sum.

    rw @ll_sum.

    rw @ll_gen.

    rw @ll_gen_indep.

    rw @ll_gen.

    done.
  Qed.
End Im2col.

Hint Unfold im2col_lifted im2colminilifted : examples.

Goal forall B K W C RR w x,
    im2col_lifted B K W C RR w x =
    tlet x0
  := GEN [ i < B ]
         GEN [ i0 < W ]
         GEN [ i1 < C ]
         GEN [ i2 < RR ]
         x _[ i; i1; i0 + i2]
    in GEN [ n' < B ]
           GEN [ n'0 < K ]
           GEN [ n'1 < W ]
           SUM [ n'2 < C ]
           SUM [ n'3 < RR ]
           (w _[ n'0; n'2; n'3] * x0 _[ n'; n'1; n'2; n'3])%R.
Proof. reflexivity. Qed.

Goal forall K W RR w x,
    im2colminilifted K W RR w x =
    tlet x0 := GEN [ i < W ]
                   GEN [ i0 < RR ]
                   (|[ i + i0 <? K ]| x _[ i + i0])
    in GEN [ n' < K ]
           GEN [ n'0 < W ]
           SUM [ n'1 < RR ]
           (w _[ n'; n'1] * x0 _[ n'0; n'1])%R.
Proof. reflexivity. Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section playfair_alternate_interior_angles.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma playfair__alternate_interior :  playfair_s_postulate -> alternate_interior_angles_postulate.
Proof.
intros playfair A B C D Hts HPar.
assert(~ Col B A C) by (destruct Hts; auto).
assert(HD' := ex_conga_ts B A C A C B).
destruct HD' as [D' []]; Col.
apply (conga_trans _ _ _ D' C A).
CongA.
assert_diffs.
apply out2__conga; [|apply out_trivial; auto].
apply (col_one_side_out _ A).
assert (HP := playfair A B C D C D' C).
destruct HP; Col.
apply l12_21_b; CongA; Side.
apply invert_one_side; exists B; split; Side.
Qed.

End playfair_alternate_interior_angles.


Set Implicit Arguments.
Require Import Lia List.
From Undecidability.HOU Require Import std.lists.basics std.misc std.decidable.
Import ListNotations.

Section Reductions.

  Variable (X Y Z: Type).
  Implicit Types (P: X -> Prop) (Q: Y -> Prop) (R: Z -> Prop).

  Definition reduction {X Y: Type} (P: X -> Prop) (Q: Y -> Prop) :=
    exists f, forall x, P x <-> Q (f x).

  Notation "P ⪯ Q" := (reduction P Q) (at level 60).

  Lemma reduction_transitive P Q R:
    P ⪯ Q -> Q ⪯ R -> P ⪯ R.
  Proof.
    intros [f H1] [g H2]; exists (f >> g).
    intros x; rewrite H1, H2. reflexivity.
  Qed.

  Lemma reduction_reflexive P: P ⪯ P.
  Proof.
    exists id; reflexivity.
  Qed.

End Reductions.

#[export] Hint Resolve reduction_reflexive reduction_transitive : core.
Notation "P ⪯ Q" := (reduction P Q) (at level 60).


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.

(* Definitions of FP, JLFP and JLDP priority relations. *)
Module Priority.

  Import SporadicTaskset ArrivalSequence.

  Section PriorityDefs.

    Variable Task: eqType.
    Variable Job: eqType.

    (* We define an FP policy as a relation between tasks, ... *)
    Definition FP_policy := rel Task.

    (* ...JLFP policy as a relation between jobs, ... *)
    Definition JLFP_policy := rel Job.

    (* ...and JLDP as any time-dependent relation between jobs. *)
    Definition JLDP_policy := time -> rel Job.

  End PriorityDefs.

  (* Since FP policies are also JLFP and JLDP policies, we define
     next conversion functions to do the generalization. *)
  Section Generalization.

    (* Consider any arrival sequence of jobs spawned by tasks. *)
    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> Task.

    (* We show how to convert FP to JLFP,... *)
    Definition FP_to_JLFP (task_hp: FP_policy Task) :=
      fun (jhigh jlow: Job) =>
        task_hp (job_task jhigh) (job_task jlow).

    (* ...FP to JLDP, ... *)
    Definition FP_to_JLDP (task_hp: FP_policy Task) :=
      fun (t: time) => FP_to_JLFP task_hp.

    (* ...and JLFP to JLDP. *)
    Definition JLFP_to_JLDP (job_hp: JLFP_policy Job) :=
      fun (t: time) => job_hp.

  End Generalization.

  (* Next we define properties of an FP policy. *)
  Section PropertiesFP.

    (* Assume that jobs are spawned by tasks. *)
    Context {Job: eqType}.
    Context {Task: eqType}.
    Variable job_task: Job -> Task.

    (* Let task_priority be any FP policy. *)
    Variable task_priority: FP_policy Task.

    (* Now we define the properties. *)

    (* Whether the FP policy is reflexive. *)
    Definition FP_is_reflexive := reflexive task_priority.

    (* Whether the FP policy is irreflexive. *)
    Definition FP_is_irreflexive := irreflexive task_priority.

    (* Whether the FP policy is transitive. *)
    Definition FP_is_transitive := transitive task_priority.

    Section Antisymmetry.

      (* Consider any task set ts. *)
      Variable ts: seq Task.

      (* First we define whether task set ts is totally ordered with
         the priority. *)
      Definition FP_is_total_over_task_set :=
        total_over_list task_priority ts.

      (* Then we define whether an FP policy is antisymmetric over task set ts, i.e.,
         whether the task set has unique priorities. *)
      Definition FP_is_antisymmetric_over_task_set :=
        antisymmetric_over_list task_priority ts.

    End Antisymmetry.

  End PropertiesFP.

  (* Next, we define properties of a JLFP policy. *)
  Section PropertiesJLFP.

    (* Consider any JLFP policy. *)
    Context {Job: eqType}.
    Variable arr_seq: arrival_sequence Job.

    Variable job_priority: JLFP_policy Job.

    (* Now we define the properties. *)

    (* Whether the JLFP policy is reflexive. *)
    Definition JLFP_is_reflexive := reflexive job_priority.

    (* Whether the JLFP policy is irreflexive. *)
    Definition JLFP_is_irreflexive := irreflexive job_priority.

    (* Whether the JLFP policy is transitive. *)
    Definition JLFP_is_transitive := transitive job_priority.

    (* Whether the JLFP policy is total over the arrival sequence. *)
    Definition JLFP_is_total :=
      forall j1 j2,
        arrives_in arr_seq j1 ->
        arrives_in arr_seq j2 ->
        job_priority j1 j2 || job_priority j2 j1.

  End PropertiesJLFP.

  (* Next, we define properties of a JLDP policy. *)
  Section PropertiesJLDP.

    (* Consider any JLDP policy. *)
    Context {Job: eqType}.
    Variable arr_seq: arrival_sequence Job.

    Variable job_priority: JLDP_policy Job.

    (* Now we define the properties. *)

    (* Whether the JLDP policy is reflexive. *)
    Definition JLDP_is_reflexive :=
      forall t, reflexive (job_priority t).

    (* Whether the JLDP policy is irreflexive. *)
    Definition JLDP_is_irreflexive :=
      forall t, irreflexive (job_priority t).

    (* Whether the JLDP policy is transitive. *)
    Definition JLDP_is_transitive :=
      forall t, transitive (job_priority t).

    (* Whether the JLDP policy is total. *)
    Definition JLDP_is_total :=
      forall j1 j2 t,
        arrives_in arr_seq j1 ->
        arrives_in arr_seq j2 ->
        job_priority t j1 j2 || job_priority t j2 j1.

  End PropertiesJLDP.

  (* Next we define some known FP policies. *)
  Section KnownFPPolicies.

    Context {Job: eqType}.
    Context {Task: eqType}.
    Variable task_period: Task -> time.
    Variable task_deadline: Task -> time.
    Variable job_task: Job -> Task.

    (* Rate-monotonic orders tasks by smaller periods. *)
    Definition RM (tsk1 tsk2: Task) :=
      task_period tsk1 <= task_period tsk2.

    (* Deadline-monotonic orders tasks by smaller relative deadlines. *)
    Definition DM (tsk1 tsk2: Task) :=
      task_deadline tsk1 <= task_deadline tsk2.

    Section Properties.

      (* RM is reflexive. *)
      Lemma RM_is_reflexive : FP_is_reflexive RM.
      Proof.
        unfold FP_is_reflexive, reflexive, RM.
        by intros tsk; apply leqnn.
      Qed.

      (* RM is transitive. *)
      Lemma RM_is_transitive : FP_is_transitive RM.
      Proof.
        unfold FP_is_transitive, transitive, RM.
        by intros y x z; apply leq_trans.
      Qed.

      (* DM is reflexive. *)
      Lemma DM_is_reflexive : FP_is_reflexive DM.
      Proof.
        unfold FP_is_reflexive, reflexive, DM.
        by intros tsk; apply leqnn.
      Qed.

      (* DM is transitive. *)
      Lemma DM_is_transitive : FP_is_transitive DM.
      Proof.
        unfold FP_is_transitive, transitive, DM.
        by intros y x z; apply leq_trans.
      Qed.

    End Properties.

  End KnownFPPolicies.

  (* In this section, we define known JLFP policies. *)
  Section KnownJLFPPolicies.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_deadline: Job -> time.

    Variable arr_seq: arrival_sequence Job.

    (* We define earliest deadline first (EDF) as ordering jobs by absolute deadlines. *)
    Definition EDF (j1 j2: Job) :=
      job_arrival j1 + job_deadline j1 <= job_arrival j2 + job_deadline j2.

    Section Properties.

      (* EDF is reflexive. *)
      Lemma EDF_is_reflexive : JLFP_is_reflexive EDF.
      Proof.
        by intros j; apply leqnn.
      Qed.

      (* EDF is transitive. *)
      Lemma EDF_is_transitive : JLFP_is_transitive EDF.
      Proof.
        by intros y x z; apply leq_trans.
      Qed.

      (* EDF is total. *)
      Lemma EDF_is_total : JLFP_is_total arr_seq EDF.
      Proof.
        unfold EDF; intros x y ARRx ARRy.
        case (leqP (job_arrival x + job_deadline x)
                    (job_arrival y + job_deadline y));
          [by rewrite orTb | by move/ltnW => ->].
      Qed.

    End Properties.

  End KnownJLFPPolicies.

  (* In this section, we define the notion of a possible interfering task. *)
  Section PossibleInterferingTasks.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Section FP.

      (* Assume an FP policy. *)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...and let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under FP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task with higher priority. *)
      Definition higher_priority_task :=
        higher_eq_priority tsk_other tsk &&
        (tsk_other != tsk).

    End FP.

    Section JLFP.

      (* Let tsk be the task to be analyzed ... *)
      Variable tsk: sporadic_task.

      (* ...and let tsk_other be another task. *)
      Variable tsk_other: sporadic_task.

      (* Under JLFP/JLDP scheduling with constrained deadlines, tsk_other can only interfere
         with tsk if it is a different task. *)
      Definition different_task := tsk_other != tsk.

    End JLFP.

  End PossibleInterferingTasks.

End Priority.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.

Section Sound.

Context {L: Language}
        {minL: MinimumLanguage L}
        {MD: Model}
        {SM: Semantics L MD}
        {tminSM: TrivialMinimumSemantics L MD SM}.

Lemma sound_modus_ponens:
  forall x y m,
    m |= (x --> y) -> m |= x -> m |= y.
Proof.
  intros.
  rewrite sat_impp in H.
  apply H; auto.
Qed.

Lemma sound_axiom1:
  forall x y m,
    m |= x --> y --> x.
Proof.
  intros.
  rewrite !sat_impp.
  intros ? ?; auto.
Qed.

Lemma sound_axiom2:
  forall x y z m,
    m |= (x --> y --> z) --> (x --> y) --> (x --> z).
Proof.
  intros.
  rewrite !sat_impp.
  intros ? ? ?.
  specialize (H H1).
  specialize (H0 H1).
  auto.
Qed.

End Sound.


Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrnat.

Lemma foo : forall n: nat, n + 0 = n.
Proof.
  intros.
  induction n.
  do 2 (try (move => n)).
  reflexivity.
  done.
Qed.


Definition choice A B :=
  forall (R:A->B->Prop),
  (forall x:A, exists y:B, R x y) ->
  exists f:A->B, forall x:A, R x (f x).

Axiom choice_axiom : forall A B, choice A B.

Definition unique_choice A B (E:B->B->Prop) :=
  forall (R:A->B->Prop),
  (forall x:A, exists y:B, R x y) ->
  (forall x y y', R x y -> (R x y' <-> E y y')) ->
  exists f:A->B, forall x:A, R x (f x).


Theorem eq_trans : forall (A:Set) (a b c:A), a = b -> b = c -> a = c.
Proof.
 intros A a b c H.
 pattern b.
 apply eq_ind with A a.
 trivial.
 assumption.
Qed.

Theorem eq_trans' : forall (A:Set) (a b c:A), a = b -> b = c -> a = c.
Proof.
 intros A a b c H; rewrite H.
 trivial.
Qed.

Theorem eq_trans'' : forall (A:Set) (a b c:A), a = b -> b = c -> a = c.
Proof.
 intros A a b c H H0.
 rewrite H; assumption.
Qed.


Inductive day : Type :=
  | monday : day
  | tuesday: day
  | wednesday: day
  | thursday: day
  | friday: day
  | saturday: day
  | sunday: day.

Definition next_weekday (d: day) : day :=
  match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => monday
    | saturday => monday
    | sunday => monday
  end.

Eval compute in (next_weekday friday).
Eval compute in (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

Check next_weekday.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Pnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import BinPos.

(**********************************************************************)
(** Properties of the injection from binary positive numbers to Peano
    natural numbers *)

(** Original development by Pierre Crégut, CNET, Lannion, France *)

Require Import Le.
Require Import Lt.
Require Import Gt.
Require Import Plus.
Require Import Mult.
Require Import Minus.
Require Import Compare_dec.

Local Open Scope positive_scope.
Local Open Scope nat_scope.

(** [nat_of_P] is a morphism for addition *)

Lemma Pmult_nat_succ_morphism :
 forall (p:positive) (n:nat), Pmult_nat (Psucc p) n = n + Pmult_nat p n.
Proof.
intro x; induction x as [p IHp| p IHp| ]; simpl in |- *; auto; intro m;
 rewrite IHp; rewrite plus_assoc; trivial.
Qed.

Lemma nat_of_P_succ_morphism :
 forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
Proof.
  intro; change (S (nat_of_P p)) with (1 + nat_of_P p) in |- *;
   unfold nat_of_P in |- *; apply Pmult_nat_succ_morphism.
Qed.

Theorem Pmult_nat_plus_carry_morphism :
 forall (p q:positive) (n:nat),
   Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n.
Proof.
intro x; induction x as [p IHp| p IHp| ]; intro y;
 [ destruct y as [p0| p0| ]
 | destruct y as [p0| p0| ]
 | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
 intro m;
 [ rewrite IHp; rewrite plus_assoc; trivial with arith
 | rewrite IHp; rewrite plus_assoc; trivial with arith
 | rewrite Pmult_nat_succ_morphism; rewrite plus_assoc; trivial with arith
 | rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
Qed.

Theorem nat_of_P_plus_carry_morphism :
 forall p q:positive, nat_of_P (Pplus_carry p q) = S (nat_of_P (p + q)).
Proof.
intros; unfold nat_of_P in |- *; rewrite Pmult_nat_plus_carry_morphism;
 simpl in |- *; trivial with arith.
Qed.

Theorem Pmult_nat_l_plus_morphism :
 forall (p q:positive) (n:nat),
   Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
Proof.
intro x; induction x as [p IHp| p IHp| ]; intro y;
 [ destruct y as [p0| p0| ]
 | destruct y as [p0| p0| ]
 | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
 [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp;
    rewrite plus_assoc_reverse; rewrite plus_assoc_reverse;
    rewrite (plus_permute m (Pmult_nat p (m + m)));
    trivial with arith
 | intros m; rewrite IHp; apply plus_assoc
 | intros m; rewrite Pmult_nat_succ_morphism;
    rewrite (plus_comm (m + Pmult_nat p (m + m)));
    apply plus_assoc_reverse
 | intros m; rewrite IHp; apply plus_permute
 | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
Qed.

Theorem nat_of_P_plus_morphism :
 forall p q:positive, nat_of_P (p + q) = nat_of_P p + nat_of_P q.
Proof.
intros x y; exact (Pmult_nat_l_plus_morphism x y 1).
Qed.

(** [Pmult_nat] is a morphism for addition *)

Lemma Pmult_nat_r_plus_morphism :
 forall (p:positive) (n:nat),
   Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
Proof.
intro y; induction y as [p H| p H| ]; intro m;
 [ simpl in |- *; rewrite H; rewrite plus_assoc_reverse;
    rewrite (plus_permute m (Pmult_nat p (m + m)));
    rewrite plus_assoc_reverse; auto with arith
 | simpl in |- *; rewrite H; auto with arith
 | simpl in |- *; trivial with arith ].
Qed.

Lemma ZL6 : forall p:positive, Pmult_nat p 2 = nat_of_P p + nat_of_P p.
Proof.
intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism;
 trivial.
Qed.

(** [nat_of_P] is a morphism for multiplication *)

Theorem nat_of_P_mult_morphism :
 forall p q:positive, nat_of_P (p * q) = nat_of_P p * nat_of_P q.
Proof.
intros x y; induction x as [x' H| x' H| ];
 [ change (xI x' * y)%positive with (y + xO (x' * y))%positive in |- *;
    rewrite nat_of_P_plus_morphism; unfold nat_of_P at 2 3 in |- *;
    simpl in |- *; do 2 rewrite ZL6; rewrite H; rewrite mult_plus_distr_r;
    reflexivity
 | unfold nat_of_P at 1 2 in |- *; simpl in |- *; do 2 rewrite ZL6; rewrite H;
    rewrite mult_plus_distr_r; reflexivity
 | simpl in |- *; rewrite <- plus_n_O; reflexivity ].
Qed.

(** [nat_of_P] maps to the strictly positive subset of [nat] *)

Lemma ZL4 : forall p:positive,  exists h : nat, nat_of_P p = S h.
Proof.
intro y; induction y as [p H| p H| ];
 [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *;
    simpl in |- *; change 2 with (1 + 1) in |- *;
    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1;
    rewrite H1; auto with arith
 | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *;
    simpl in |- *; change 2 with (1 + 1) in |- *;
    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2;
    rewrite H2; auto with arith
 | exists 0; auto with arith ].
Qed.

(** Extra lemmas on [lt] on Peano natural numbers *)

Lemma ZL7 : forall n m:nat, n < m -> n + n < m + m.
Proof.
intros m n H; apply lt_trans with (m := m + n);
 [ apply plus_lt_compat_l with (1 := H)
 | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
Qed.

Lemma ZL8 : forall n m:nat, n < m -> S (n + n) < m + m.
Proof.
intros m n H; apply le_lt_trans with (m := m + n);
 [ change (m + m < m + n) in |- *; apply plus_lt_compat_l with (1 := H)
 | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
Qed.

(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
    from [compare] on [positive])

    Part 1: [lt] on [positive] is finer than [lt] on [nat]
*)

Lemma nat_of_P_lt_Lt_compare_morphism :
 forall p q:positive, (p ?= q) Eq = Lt -> nat_of_P p < nat_of_P q.
Proof.
intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ];
 intro H2;
 [ unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; do 2 rewrite ZL6;
    apply ZL7; apply H; simpl in H2; assumption
 | unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; apply ZL8;
    apply H; simpl in H2; apply Pcompare_Gt_Lt; assumption
 | simpl in |- *; discriminate H2
 | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
    elim (Pcompare_Lt_Lt p q H2);
    [ intros H3; apply lt_S; apply ZL7; apply H; apply H3
    | intros E; rewrite E; apply lt_n_Sn ]
 | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
    apply ZL7; apply H; assumption
 | simpl in |- *; discriminate H2
 | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6;
    elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *;
    apply lt_O_Sn
 | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q);
    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
    apply lt_n_S; apply lt_O_Sn
 | simpl in |- *; discriminate H2 ].
Qed.

(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
    from [compare] on [positive])

    Part 1: [gt] on [positive] is finer than [gt] on [nat]
*)

Lemma nat_of_P_gt_Gt_compare_morphism :
 forall p q:positive, (p ?= q) Eq = Gt -> nat_of_P p > nat_of_P q.
Proof.
intros p q GT. unfold gt.
apply nat_of_P_lt_Lt_compare_morphism.
change ((q ?= p) (CompOpp Eq) = CompOpp Gt).
rewrite <- Pcompare_antisym, GT; auto.
Qed.

(** [nat_of_P] is a morphism for [Pcompare] and [nat_compare] *)

Lemma nat_of_P_compare_morphism : forall p q,
 (p ?= q) Eq = nat_compare (nat_of_P p) (nat_of_P q).
Proof.
 intros p q; symmetry.
 destruct ((p ?= q) Eq) as [ | | ]_eqn.
 rewrite (Pcompare_Eq_eq p q); auto.
 apply <- nat_compare_eq_iff; auto.
 apply -> nat_compare_lt. apply nat_of_P_lt_Lt_compare_morphism; auto.
 apply -> nat_compare_gt. apply nat_of_P_gt_Gt_compare_morphism; auto.
Qed.

(** [nat_of_P] is hence injective. *)

Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q.
Proof.
intros.
apply Pcompare_Eq_eq.
rewrite nat_of_P_compare_morphism.
apply <- nat_compare_eq_iff; auto.
Qed.

(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
    from [compare] on [positive])

    Part 2: [lt] on [nat] is finer than [lt] on [positive]
*)

Lemma nat_of_P_lt_Lt_compare_complement_morphism :
 forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q) Eq = Lt.
Proof.
 intros. rewrite nat_of_P_compare_morphism.
 apply -> nat_compare_lt; auto.
Qed.

(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
    from [compare] on [positive])

    Part 2: [gt] on [nat] is finer than [gt] on [positive]
*)

Lemma nat_of_P_gt_Gt_compare_complement_morphism :
 forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q) Eq = Gt.
Proof.
 intros. rewrite nat_of_P_compare_morphism.
 apply -> nat_compare_gt; auto.
Qed.

(** [nat_of_P] is strictly positive *)

Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n.
induction p; simpl in |- *; auto with arith.
intro m; apply le_trans with (m + m); auto with arith.
Qed.

Lemma lt_O_nat_of_P : forall p:positive, 0 < nat_of_P p.
intro; unfold nat_of_P in |- *; apply lt_le_trans with 1; auto with arith.
apply le_Pmult_nat.
Qed.

(** Pmult_nat permutes with multiplication *)

Lemma Pmult_nat_mult_permute :
 forall (p:positive) (n m:nat), Pmult_nat p (m * n) = m * Pmult_nat p n.
Proof.
  simple induction p. intros. simpl in |- *. rewrite mult_plus_distr_l. rewrite <- (mult_plus_distr_l m n n).
  rewrite (H (n + n) m). reflexivity.
  intros. simpl in |- *. rewrite <- (mult_plus_distr_l m n n). apply H.
  trivial.
Qed.

Lemma Pmult_nat_2_mult_2_permute :
 forall p:positive, Pmult_nat p 2 = 2 * Pmult_nat p 1.
Proof.
  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
Qed.

Lemma Pmult_nat_4_mult_2_permute :
 forall p:positive, Pmult_nat p 4 = 2 * Pmult_nat p 2.
Proof.
  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
Qed.

(** Mapping of xH, xO and xI through [nat_of_P] *)

Lemma nat_of_P_xH : nat_of_P 1 = 1.
Proof.
  reflexivity.
Qed.

Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p.
Proof.
  intros.
  change 2 with (nat_of_P 2).
  rewrite <- nat_of_P_mult_morphism.
  f_equal.
Qed.

Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p).
Proof.
  intros.
  change 2 with (nat_of_P 2).
  rewrite <- nat_of_P_mult_morphism, <- nat_of_P_succ_morphism.
  f_equal.
Qed.

(**********************************************************************)
(** Properties of the shifted injection from Peano natural numbers to
    binary positive numbers *)

(** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *)

Theorem nat_of_P_o_P_of_succ_nat_eq_succ :
 forall n:nat, nat_of_P (P_of_succ_nat n) = S n.
Proof.
induction n as [|n H].
reflexivity.
simpl; rewrite nat_of_P_succ_morphism, H; auto.
Qed.

(** Miscellaneous lemmas on [P_of_succ_nat] *)

Lemma ZL3 :
 forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n).
Proof.
induction n as [| n H]; simpl;
 [ auto with arith
 | rewrite plus_comm; simpl; rewrite H;
    rewrite xO_succ_permute; auto with arith ].
Qed.

Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n).
Proof.
induction n as [| n H]; simpl;
 [ auto with arith
 | rewrite <- plus_n_Sm; simpl; simpl in H; rewrite H;
    auto with arith ].
Qed.

(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *)

Theorem P_of_succ_nat_o_nat_of_P_eq_succ :
 forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p.
Proof.
intros.
apply nat_of_P_inj.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ, nat_of_P_succ_morphism; auto.
Qed.

(** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity
    on [positive] *)

Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id :
 forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p.
Proof.
intros; rewrite P_of_succ_nat_o_nat_of_P_eq_succ, Ppred_succ; auto.
Qed.

(**********************************************************************)
(** Extra properties of the injection from binary positive numbers to Peano
    natural numbers *)

(** [nat_of_P] is a morphism for subtraction on positive numbers *)

Theorem nat_of_P_minus_morphism :
 forall p q:positive,
   (p ?= q) Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q.
Proof.
intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r;
 [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith
 | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ].
Qed.

Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p.
Proof.
intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1;
 rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S;
 apply le_minus.
Qed.

Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q).
Proof.
intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q);
 intros k H; rewrite H; rewrite plus_comm; simpl in |- *;
 apply le_n_S; apply le_plus_r.
Qed.

(** Comparison and subtraction *)

Lemma Pcompare_minus_r :
 forall p q r:positive,
   (q ?= p) Eq = Lt ->
   (r ?= p) Eq = Gt ->
   (r ?= q) Eq = Gt -> (r - p ?= r - q) Eq = Lt.
Proof.
intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
 rewrite nat_of_P_minus_morphism;
 [ rewrite nat_of_P_minus_morphism;
    [ apply plus_lt_reg_l with (p := nat_of_P q); rewrite le_plus_minus_r;
       [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
          rewrite plus_assoc; rewrite le_plus_minus_r;
          [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
             apply nat_of_P_lt_Lt_compare_morphism;
             assumption
          | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
             apply ZC1; assumption ]
       | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
          assumption ]
    | assumption ]
 | assumption ].
Qed.

Lemma Pcompare_minus_l :
 forall p q r:positive,
   (q ?= p) Eq = Lt ->
   (p ?= r) Eq = Gt ->
   (q ?= r) Eq = Gt -> (q - r ?= p - r) Eq = Lt.
Proof.
intros p q z; intros; apply nat_of_P_lt_Lt_compare_complement_morphism;
 rewrite nat_of_P_minus_morphism;
 [ rewrite nat_of_P_minus_morphism;
    [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
       rewrite le_plus_minus_r;
       [ rewrite le_plus_minus_r;
          [ apply nat_of_P_lt_Lt_compare_morphism; assumption
          | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
             apply ZC1; assumption ]
       | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
          assumption ]
    | assumption ]
 | assumption ].
Qed.

(** Distributivity of multiplication over subtraction *)

Theorem Pmult_minus_distr_l :
 forall p q r:positive,
   (q ?= r) Eq = Gt ->
   (p * (q - r) = p * q - p * r)%positive.
Proof.
intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism;
 rewrite nat_of_P_minus_morphism;
 [ rewrite nat_of_P_minus_morphism;
    [ do 2 rewrite nat_of_P_mult_morphism;
       do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r
    | apply nat_of_P_gt_Gt_compare_complement_morphism;
       do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *;
       elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l;
       exact (nat_of_P_gt_Gt_compare_morphism y z H) ]
 | assumption ].
Qed.


(* author: Dimitur Krustev *)
(* started: 20170521 *)

Require Import Arith List.

Fixpoint replicate {A: Type} (n: nat) (x: A) : list A :=
  match n with
  | 0 => nil
  | S n => x :: replicate n x
  end.

Lemma cons_replicate_swap: forall (A: Type) (n: nat) (x: A),
  x :: replicate n x = replicate n x ++ x::nil.
Proof.
  induction n; auto.
  intros. simpl. rewrite IHn. reflexivity.
Qed.

Section RLE.

Variable A: Type.
Variable Adec: forall x y: A, {x = y} + {x <> y}.

Let RLEncHelper := fix RLEncHelper (n: nat) (x: A) (xs: list A) : list (nat * A) :=
  match xs with
  | nil => (n, x)::nil
  | x1::xs => match Adec x x1 with
    | left Heq => RLEncHelper (S n) x xs
    | right Hneq => (n, x) :: RLEncHelper 1 x1 xs
    end
  end.

Definition RLEnc (xs: list A) : list (nat * A) :=
  match xs with
  | nil => nil
  | x::xs => RLEncHelper 1 x xs
  end.

Definition RLDec (nxs: list (nat * A)) : list A :=
  flat_map (fun nx => let '(n, x) := nx in replicate n x) nxs.

Lemma RLEncHelper_correct: forall n x xs, RLDec (RLEncHelper n x xs) = replicate n x ++ xs.
Proof.
  intros. revert n x. induction xs; auto.
  { intros. simpl. destruct (Adec x a) as [Heq | Hneq].
    - subst. rewrite IHxs. simpl.
      change ((a :: replicate n a) ++ xs = replicate n a ++ a :: xs).
      rewrite cons_replicate_swap.
      rewrite <- app_assoc. reflexivity.
    - simpl. rewrite IHxs. reflexivity.
  }
Qed.

Theorem RLEnc_correct: forall xs, RLDec (RLEnc xs) = xs.
Proof.
  destruct xs.
  - simpl. reflexivity.
  - simpl. apply RLEncHelper_correct.
Qed.

End RLE.

Recursive Extraction RLDec RLEnc.


Require Import GHC.Base.
(* _==_ notation *)

Require Import ZArith.
Require Import ZArith.BinInt.

(* Hand-translated version of the prelude definitions
   of these functions. *)

Fixpoint take {a:Type} (n:Z) (xs:list a) : list a :=
  if (n <=? 0)%Z then nil
  else match xs with
       | nil => nil
       | cons y ys => cons y (take (n - 1) ys)
       end.

Fixpoint drop {a:Type} (n:Z) (xs:list a) : list a :=
  if (n <=? 0)%Z then xs
  else match xs with
       | nil => nil
       | cons y ys => drop (n - 1) ys
       end.

(* TODO: mark impossible case with default. *)

Fixpoint scanr {a b:Type} (f : a -> b -> b) (q0 : b)
        (xs: list a) :=
 match xs with
 | nil => (cons q0 nil)
 | cons y ys => match (scanr f q0 ys) with
               | cons q qs => cons (f y q) (cons q qs)
               | nil => nil  (* impossible case  *)
               end
end.

Definition splitAt {a : Type}(n:Z)(xs:list a) :=
  (take n xs, drop n xs).

Definition replicate {a:Type}(n:Z): a -> list a.
destruct (0 <=? n)%Z eqn:E; [|exact (fun _ => nil)].
apply Zle_bool_imp_le in E.
apply natlike_rec2 with (P := fun _ => a -> list a)(z := n).
- exact (fun _ => nil).
- intros n1 Pf rec x. exact (cons x (rec x)).
- exact E.
Defined.


Require Import Program.Basics.
From hahn Require Import Hahn.

Set Implicit Arguments.
Local Open Scope program_scope.

Section AuxRel.

  Definition clos_sym {A : Type} (r : relation A) : relation A :=
    r ∪ r⁻¹.

  Definition clos_refl_sym {A : Type} (r : relation A) : relation A :=
    (r ∪ r⁻¹)^?.

  Definition eq_opt {A : Type} (a: option A) : A -> Prop :=
    fun b =>
      match a with
      | None => False
      | Some a => eq a b
      end.

  Definition compl_rel {A : Type} (r : relation A) : relation A :=
    fun a b => ~ r a b.

  Definition inj_dom {A B : Type} (s : A -> Prop) (f : A -> B) :=
    forall (x y : A) (SX : s x) (SY: s y) (EQ : f x = f y),
      x = y.

  Definition restr_fun {A B : Type} (s : A -> Prop) (f g : A -> B) :=
    fun x => if excluded_middle_informative (s x) then f x else g x.

  Definition fixset {A : Type} (s : A -> Prop) (f : A -> A) :=
    forall (x : A) (SX : s x), f x = x.

  Definition downward_total {A : Type} (r : relation A) :=
    forall x y z (Rxz : r x z) (Ryz : r y z), clos_refl_sym r x y.

  Definition set_map {A B : Type} (f : A -> B) (s : B -> Prop) :=
    fun x => s (f x).

End AuxRel.

Notation "⊤₁" := set_full.
Notation "⊤₂" := (fun _ _ => True).

Notation "a ⁼" := (clos_refl_sym a) (at level 1, format "a ⁼").
Notation "a ^=" := (clos_refl_sym a) (at level 1, only parsing).
Notation "f ⋄₁ s"  := (set_map f s) (at level 39).
Notation "f □₁ s" := (set_collect f s) (at level 39).
Notation "f ⋄ r"  := (map_rel f r) (at level 45).
Notation "f □ r"  := (collect_rel f r) (at level 45).

Hint Unfold
     clos_sym clos_refl_sym
     inj_dom restr_fun set_map
     eq_opt compl_rel fixset : unfolderDb.

Section Props.

Variables A B C : Type.
Variables s s' s'' : A -> Prop.
Variables p p' p'' : B -> Prop.
Variables r r' r'' : relation A.

(******************************************************************************)
(** ** clos_sym/clos_refl_sym properties *)
(******************************************************************************)

Lemma csE : r^⋈  ≡ r ∪ r⁻¹.
Proof. basic_solver. Qed.

Lemma crsE : r⁼ ≡ ⦗⊤₁⦘ ∪ r ∪ r⁻¹.
Proof. basic_solver. Qed.

Lemma crs_cs : r⁼ ≡ ⦗⊤₁⦘ ∪ r^⋈.
Proof. basic_solver. Qed.

Lemma cs_union : (r ∪ r')^⋈  ≡ r^⋈ ∪ r'^⋈.
Proof. basic_solver. Qed.

Lemma crs_union : (r ∪ r')⁼  ≡ r⁼ ∪ r'⁼.
Proof. basic_solver. Qed.

Lemma cs_cross : (s × s')^⋈ ≡ s × s' ∪ s' × s.
Proof. basic_solver. Qed.

Lemma crs_cross : (s × s')⁼ ≡ ⦗⊤₁⦘ ∪ s × s' ∪ s' × s.
Proof. basic_solver. Qed.

Lemma cs_restr : (restr_rel s r)^⋈ ≡ restr_rel s r^⋈.
Proof. basic_solver. Qed.

Lemma crs_restr1 : (restr_rel s r)⁼ ≡ ⦗⊤₁⦘ ∪ restr_rel s r^⋈.
Proof. basic_solver 10. Qed.

Lemma crs_restr2 : restr_rel s r⁼ ≡ restr_rel s ⦗⊤₁⦘ ∪ restr_rel s r^⋈.
Proof. basic_solver 10. Qed.

(******************************************************************************)
(** ** symmetry of relations *)
(******************************************************************************)

Lemma cr_sym : symmetric r -> symmetric r^?.
Proof. basic_solver. Qed.

Lemma cs_sym : symmetric r^⋈.
Proof. basic_solver. Qed.

Lemma crs_sym : symmetric r⁼.
Proof. basic_solver. Qed.

Lemma eqv_sym : forall (s : A -> Prop), symmetric ⦗s⦘.
Proof. basic_solver. Qed.

Lemma union_sym : symmetric r -> symmetric r' -> symmetric (r ∪ r').
Proof. basic_solver. Qed.

Lemma inter_sym : symmetric r -> symmetric r' -> symmetric (r ∩ r').
Proof. basic_solver. Qed.

Lemma minus_sym : symmetric r -> symmetric r' -> symmetric (r \ r').
Proof. basic_solver. Qed.

Lemma transp_sym : symmetric r -> symmetric r⁻¹.
Proof. basic_solver. Qed.

Lemma restr_sym : symmetric r -> symmetric (restr_rel s r).
Proof. basic_solver. Qed.

(******************************************************************************)
(** ** dom/codom properties *)
(******************************************************************************)

Lemma dom_singl_rel (x y : A) : dom_rel (singl_rel x y) ≡₁ eq x.
Proof. basic_solver. Qed.

Lemma codom_singl_rel (x y : A) : codom_rel (singl_rel x y) ≡₁ eq y.
Proof. basic_solver. Qed.

Lemma dom_seq : dom_rel (r ⨾ r') ⊆₁ dom_rel r.
Proof. basic_solver. Qed.

Lemma dom_minus : dom_rel (r \ r') ⊆₁ dom_rel r.
Proof. basic_solver. Qed.

(* TODO : rename *)
Lemma seq_codom_dom_inter : codom_rel r ∩₁ dom_rel r' ≡₁ ∅ -> r ⨾ r' ≡ ∅₂.
Proof.
  unfold set_equiv, set_subset; ins; desf.
  unfold same_relation; splits; [|basic_solver].
  unfold seq, inclusion.
  intros x y [z HH].
  specialize (H z).
  apply H.
  basic_solver.
Qed.

(******************************************************************************)
(** ** cross_rel properties *)
(******************************************************************************)

Lemma cross_union_l : s × (s' ∪₁ s'') ≡ s × s' ∪ s × s''.
Proof. basic_solver. Qed.

Lemma cross_union_r : (s ∪₁ s') × s'' ≡ s × s'' ∪ s' × s''.
Proof. basic_solver. Qed.

Lemma cross_inter_l : (s ∩₁ s') × s'' ≡ ⦗s⦘ ⨾ s' × s''.
Proof. basic_solver. Qed.

Lemma cross_inter_r : s × (s' ∩₁ s'') ≡ s × s' ⨾ ⦗s''⦘.
Proof. basic_solver. Qed.

Lemma seq_cross_eq x : s × eq x ⨾ eq x × s' ≡ s × s'.
Proof. basic_solver 10. Qed.

(* Lemma seq_eqv_cross : ⦗q⦘ ⨾ s × s' ⨾ ⦗q'⦘ ≡ (q ∩₁ s) × (q' ∩₁ s'). *)
(* Proof. basic_solver. Qed. *)

Lemma restr_cross : restr_rel s r ≡ r ∩ s × s.
Proof. basic_solver. Qed.

Lemma seq_cross_singl_l x y : s' x -> s × s' ⨾ singl_rel x y ≡ s × eq y.
Proof.
  ins.
  autounfold with unfolderDb.
  splits; ins; splits; desf; eauto.
Qed.

Lemma seq_cross_singl_r x y : s y -> singl_rel x y ⨾ s × s' ≡ eq x × s'.
Proof.
  ins.
  autounfold with unfolderDb.
  splits; ins; splits; desf; eauto.
Qed.

(******************************************************************************)
(** ** transp properties *)
(******************************************************************************)

Lemma transp_singl_rel (x y : A) : (singl_rel x y)⁻¹ ≡ singl_rel y x.
Proof. basic_solver. Qed.

Lemma transp_sym_equiv : symmetric r -> r⁻¹ ≡ r.
Proof. basic_solver. Qed.

Lemma sym_transp_equiv : symmetric r <-> r⁻¹ ≡ r.
Proof.
  split.
  { basic_solver. }
  intros HH.
  red. ins. by apply HH.
Qed.

(* TODO : rename *)
Lemma seq_transp_sym : symmetric r -> ⦗ s ⦘ ⨾ r ⨾ ⦗ s' ⦘ ≡ (⦗ s' ⦘ ⨾ r ⨾ ⦗ s ⦘)⁻¹.
Proof.
  ins.
  rewrite !transp_seq.
  rewrite !seqA.
  rewrite !transp_sym_equiv; auto.
  rewrite !transp_eqv_rel.
  done.
Qed.

(******************************************************************************)
(** ** set_collect properties *)
(******************************************************************************)

Lemma set_collect_eq_dom (f g : A -> B) (EQ : eq_dom s f g) :
  f □₁ s ≡₁ g □₁ s.
Proof.
  unfolder in *.
  split.
  { ins. desf.
    specialize (EQ y H).
    eauto. }
  ins. desf. eauto.
Qed.

(* Note that inclusion in other direction doesn't hold.
   For example, if `f` is constant and `a <> b`, then
   `f □₁ (eq a ∩₁ eq b) ≡₁ ∅` and `f □₁ eq a ∩₁ f □₁ eq b ≡₁ f □₁ eq a`.
 *)
Lemma set_collect_inter (f g : A -> B) :
  f □₁ (s ∩₁ s') ⊆₁ f □₁ s ∩₁ f □₁ s'.
Proof. basic_solver. Qed.

Lemma set_collect_dom (f : A -> B) :
  f □₁ dom_rel r ≡₁ dom_rel (f □ r).
Proof.
  unfolder.
  split; intros x HH; desf; eauto.
  repeat eexists. eauto.
Qed.

Lemma set_collect_eq_opt (f : A -> B) (a : option A) :
  f □₁ eq_opt a ≡₁ eq_opt (option_map f a).
Proof. unfold eq_opt, option_map. basic_solver. Qed.

Lemma set_collect_compose (f : A -> B) (g : B -> C) :
  g □₁ (f □₁ s) ≡₁ (g ∘ f) □₁ s.
Proof.
  autounfold with unfolderDb. unfold set_subset.
  ins; splits; ins; splits; desf; eauto.
Qed.

Lemma set_collect_updo (f : A -> B) (a : A) (b : B) (NC : ~ s a) :
  (upd f a b) □₁ s ≡₁ f □₁ s.
Proof.
  assert (forall x: A, s x -> x <> a).
  { ins. intros HH. by subst. }
  unfolder.
  splits; unfold set_subset; ins.
  all: desf; eexists; splits; eauto.
  all: rewrite updo; auto.
Qed.

Lemma set_collect_restr_fun (f g : A -> B) :
  s' ⊆₁ s -> (restr_fun s f g) □₁ s' ≡₁ f □₁ s'.
Proof.
  clear.
  unfolder. ins. split.
  all :
    ins; desc;
    eexists; split; eauto;
    destruct (excluded_middle_informative (s y));
    eauto; exfalso; intuition.
Qed.

Lemma set_collect_if_then (ft fe: A -> B) (HH : s ⊆₁ s') :
  (fun e : A =>
     if excluded_middle_informative (s' e)
     then ft e
     else fe e) □₁ s ≡₁ ft □₁ s.
Proof.
  unfolder. split; ins; desf; eauto.
  2: eexists; splits; eauto; desf.
  all: by exfalso; match goal with H : ~ _ |- _ => apply H end; apply HH.
Qed.

Lemma set_collect_if_else (ft fe: A -> B) (HH : s ∩₁ s' ⊆₁ ∅) :
  (fun e : A =>
     if excluded_middle_informative (s' e)
     then ft e
     else fe e) □₁ s ≡₁ fe □₁ s.
Proof.
  unfolder. split; ins; desf; eauto.
  2: eexists; splits; eauto; desf.
  all: exfalso; eapply HH; split; eauto.
Qed.

(******************************************************************************)
(** ** collect_rel properties *)
(******************************************************************************)

(* Lemma collect_rel_eq_dom : *)
(*   forall (s s': A -> Prop) (EQs: eq_dom s f g) (EQs': eq_dom s' f g), *)
(*   f □ (⦗ s ⦘ ⨾ r ⨾ ⦗ s' ⦘) ≡ g □ (⦗ s ⦘ ⨾ r ⨾ ⦗ s' ⦘). *)
(* Proof. *)
(*   ins. *)
(*   unfolder. *)
(*   splits; ins; desf; repeat eexists; eauto; symmetry. *)
(*   { by apply EQs. } *)
(*   by apply EQs'. *)
(* Qed. *)

Lemma collect_rel_restr_eq_dom (f g : A -> B) (EQ : eq_dom s f g) :
  f □ (restr_rel s r) ≡ g □ (restr_rel s r).
Proof.
  unfolder. split.
  { ins; desf; repeat eexists; eauto;
      symmetry; eapply EQ; auto. }
  ins; desf; repeat eexists; eauto;
    symmetry; eapply EQ; auto.
Qed.

Lemma collect_rel_singl (f : A -> B) x y :
  f □ singl_rel x y ≡ singl_rel (f x) (f y).
Proof. basic_solver 42. Qed.

Lemma collect_rel_transp (f : A -> B) :
  f □ r⁻¹ ≡ (f □ r)⁻¹.
Proof. basic_solver 42. Qed.

Lemma collect_rel_eqv (f : A -> B) :
  f □ ⦗ s ⦘ ≡ ⦗ f □₁ s ⦘.
Proof.
  unfolder.
  splits; ins; desf; eauto.
  eexists. eexists.
  splits; eauto.
Qed.

Lemma collect_rel_interi (f : A -> B) :
  f □ (r ∩ r') ⊆ (f □ r) ∩ (f □ r').
Proof. basic_solver 10. Qed.

Lemma collect_rel_seqi (f : A -> B) :
  f □ (r ⨾ r') ⊆ (f □ r) ⨾ (f □ r').
Proof. basic_solver 30. Qed.

Lemma collect_rel_seq (f : A -> B)
      (INJ : inj_dom (codom_rel r ∪₁ dom_rel r') f) :
  f □ (r ⨾ r') ≡ (f □ r) ⨾ (f □ r').
Proof.
  split;
    [by apply collect_rel_seqi|].
  unfolder.
  ins; desf; eauto.
  repeat eexists; eauto.
  erewrite INJ; eauto;
    unfolder; eauto.
Qed.

Lemma collect_rel_cr (f : A -> B) (rr : relation A) :
  f □ rr^? ⊆  (f □ rr)^?.
Proof.
  unfolder. ins; desf; auto.
  right. eexists. eexists. eauto.
Qed.

Lemma collect_rel_ct (f : A -> B) (rr : relation A) :
  f □ rr⁺ ⊆ (f □ rr)⁺.
Proof.
  unfolder. ins. desf.
  induction H.
  { apply ct_step. eexists. eexists. splits; eauto. }
  eapply t_trans; eauto.
Qed.

Lemma collect_rel_crt (f : A -> B) (rr : relation A) :
  f □ rr＊ ⊆  (f □ rr)＊.
Proof.
  by rewrite <- !cr_of_ct,
             <- collect_rel_ct,
             <- collect_rel_cr.
Qed.

Lemma collect_rel_irr (f : A -> B) (Irr : irreflexive (f □ r)):
  irreflexive r.
Proof. generalize Irr. basic_solver 10. Qed.

Lemma collect_rel_acyclic (f : A -> B) (ACYC : acyclic (f □ r)):
  acyclic r.
Proof.
  red. red.
  assert (forall x y, r⁺ x y -> x <> y) as AA.
  2: { ins. eapply AA; eauto. }
  ins. induction H; intros BB; subst.
  { eapply ACYC. apply ct_step. red.
    eexists. eexists. splits; eauto. }
  eapply ACYC.
  apply collect_rel_ct.
  red. eexists. eexists. splits.
  { eapply t_trans; eauto. }
  all: done.
Qed.

Lemma collect_rel_compose (f : A -> B) (g : B -> C) :
  g □ (f □ r) ≡ (g ∘ f) □ r.
Proof.
  unfolder. unfold compose.
  ins; splits; ins; splits; desf; eauto.
  do 2 eexists. splits; eauto.
Qed.

Lemma collect_rel_fixset (f : A -> A) (FIX : fixset s f) :
  f □ restr_rel s r ≡ restr_rel s r.
Proof.
  unfolder in *.
  split; ins; desf.
  2: { do 2 eexists. splits; eauto. }
  assert (f x' = x') as HX.
  { specialize (FIX x'). auto. }
  assert (f y' = y') as HY.
  { specialize (FIX y'). auto. }
  splits; congruence.
Qed.

Lemma collect_rel_if_then
      (ft fe: A -> B) (DOM : dom_rel r ⊆₁ s) (CODOM : codom_rel r ⊆₁ s) :
  (fun e : A =>
     if excluded_middle_informative (s e)
     then ft e
     else fe e) □ r ≡ ft □ r.
Proof.
  unfolder. split; ins; desf; eauto.
  4: do 2 eexists; splits; eauto; desf.
  1,3,5: by exfalso; match goal with H : ~ _ |- _ => apply H end;
    eapply CODOM; eexists; eauto.
  all: by exfalso; match goal with H : ~ _ |- _ => apply H end;
    eapply DOM; eexists; eauto.
Qed.

Lemma collect_rel_if_else
      (ft fe: A -> B) (DOM : dom_rel r ∩₁ s ⊆₁ ∅) (CODOM : codom_rel r ∩₁ s ⊆₁ ∅) :
  (fun e : A =>
     if excluded_middle_informative (s e)
     then ft e
     else fe e) □ r ≡ fe □ r.
Proof.
  unfolder. split; ins; desf; eauto.
  4: do 2 eexists; splits; eauto; desf.
  1,2,4: by exfalso; eapply DOM; split; [eexists|]; eauto.
  all: exfalso; eapply CODOM; split; [eexists|]; eauto.
Qed.

(******************************************************************************)
(** ** set_map properties *)
(******************************************************************************)

Lemma set_map_union (f : A -> B) :
  f ⋄₁ (p ∪₁ p') ⊆₁ f ⋄₁ p ∪₁ f ⋄₁ p'.
Proof. basic_solver. Qed.

Lemma set_map_inter (f : A -> B) :
  f ⋄₁ (p ∩₁ p') ⊆₁ f ⋄₁ p ∩₁ f ⋄₁ p'.
Proof. basic_solver. Qed.

(******************************************************************************)
(** ** set_map/set_collect properties *)
(******************************************************************************)

Lemma collect_map_in_set (f : A -> B) :
  f □₁ (f ⋄₁ p) ⊆₁ p.
Proof. basic_solver. Qed.

Lemma set_in_map_collect (f : A -> B) :
  s ⊆₁ f ⋄₁ (f □₁ s).
Proof. basic_solver. Qed.

(******************************************************************************)
(** ** inj_dom properties *)
(******************************************************************************)

Lemma inj_dom_union
      (f : A -> B)
      (INJ : inj_dom s f)
      (INJ' : inj_dom s' f)
      (DISJ : set_disjoint (f □₁ s) (f □₁ s')) :
  inj_dom (s ∪₁ s') f.
Proof.
  unfolder in *.
  ins; desf;
    try (by exfalso; eapply DISJ; eauto).
  { by apply INJ. }
    by apply INJ'.
Qed.

Lemma inj_dom_eq (f : A -> B) (a : A) :
  inj_dom (eq a) f.
Proof. basic_solver. Qed.

Lemma inj_dom_eq_opt (f : A -> B) (a : option A) :
  inj_dom (eq_opt a) f.
Proof. basic_solver. Qed.

(******************************************************************************)
(** ** fixset properties *)
(******************************************************************************)

Lemma fixset_union (f : A -> A) :
  fixset (s ∪₁ s') f <-> fixset s f /\ fixset s' f.
Proof. clear; unfolder; split; ins; intuition. Qed.

Lemma fixset_eq_dom (f g : A -> A) (EQD : eq_dom s f g) :
  fixset s f <-> fixset s g.
Proof.
  unfolder in *.
  split; ins;
    specialize (EQD x SX);
    specialize (H x SX);
    congruence.
Qed.

Lemma fixset_set_fixpoint (f : A -> A) :
  fixset s f -> s ≡₁ f □₁ s.
Proof.
  autounfold with unfolderDb; unfold set_subset.
  intros FIX.
  splits.
  { ins. eexists.
    specialize (FIX x).
    splits; eauto. }
  ins; desf.
  erewrite (FIX y); auto.
Qed.

Lemma fixset_swap (f' : A -> B) (g' : B -> A) :
  fixset s (g' ∘ f') -> fixset (f' □₁ s) (f' ∘ g').
Proof.
  unfolder.
  intros FIX x [y [DOM Fy]].
  unfold compose.
  rewrite <- Fy.
  fold (compose g' f' y).
  rewrite FIX; auto.
Qed.

(******************************************************************************)
(** ** TODO : structure other properties *)
(******************************************************************************)

Lemma seq_eqv : ⦗ s ⦘ ⨾ ⦗ s' ⦘ ≡ ⦗ s ∩₁ s' ⦘.
Proof. basic_solver. Qed.

Lemma set_compl_inter_id : set_compl s ∩₁ s ≡₁ ∅.
Proof. basic_solver. Qed.

Lemma eq_opt_someE (a : A) : eq_opt (Some a) ≡₁ eq a.
Proof. basic_solver. Qed.

Lemma eq_opt_noneE : eq_opt (None : option A) ≡₁ ∅.
Proof. basic_solver. Qed.

Lemma empty_irr : r ≡ ∅₂ -> irreflexive r.
Proof. basic_solver. Qed.

Lemma restr_fun_fst (f g : A -> B) x :
  s x -> restr_fun s f g x = f x.
Proof. clear. unfolder. basic_solver. Qed.

Lemma restr_fun_snd (f g : A -> B) x :
  ~ s x -> restr_fun s f g x = g x.
Proof. clear. unfolder. basic_solver. Qed.

Lemma set_subset_union_minus : s ⊆₁ s \₁ s' ∪₁ s'.
Proof.
  by unfold set_minus, set_union, set_subset; clear; intros; tauto.
Qed.

Lemma set_union_minus : s' ⊆₁ s -> s ≡₁ s \₁ s' ∪₁ s'.
Proof.
  intros.
  unfold set_equiv; splits;
    [by apply set_subset_union_minus|basic_solver].
Qed.

Lemma union_minus : r' ⊆ r -> r ≡ r \ r' ∪ r'.
Proof.
  intros H.
  unfold same_relation; splits.
  { by apply inclusion_union_minus. }
  basic_solver.
Qed.

Lemma minus_eqv_absorb_rr : r' ⨾ ⦗ s ⦘ ≡ ∅₂ -> (r \ r') ⨾ ⦗ s ⦘ ≡ r ⨾ ⦗ s ⦘.
Proof.
  unfolder.
  ins; splits; ins; desf.
  eexists; splits; eauto.
Qed.

Lemma minus_eqv_absorb_rl : ⦗ s ⦘ ⨾ r' ≡ ∅₂ -> ⦗ s ⦘ ⨾ (r \ r') ≡ ⦗ s ⦘ ⨾ r.
Proof.
  unfolder.
  ins; splits; ins; desf.
  eexists; splits; eauto.
Qed.

Lemma minus_disjoint : r ∩ r' ≡ ∅₂ -> r \ r' ≡ r.
Proof. clear. basic_solver 5. Qed.

Lemma cross_minus_compl_l : s × s' \ (set_compl s) × s'' ≡ s × s'.
Proof.
  unfolder; splits; ins; splits; desf; unfold not; ins; desf.
Qed.

Lemma cross_minus_compl_r : s × s' \ s'' × (set_compl s') ≡ s × s'.
Proof.
  unfolder; splits; ins; splits; desf; unfold not; ins; desf.
Qed.

Lemma set_minus_inter_set_compl : s \₁ s' ≡₁ s ∩₁ set_compl s'.
Proof. basic_solver. Qed.

Lemma minus_inter_compl : r \ r' ≡ r ∩ compl_rel r'.
Proof. basic_solver. Qed.

Lemma compl_top_minus : forall (r : relation A), compl_rel r ≡ (fun _ _ => True) \ r.
Proof. basic_solver. Qed.

Lemma minus_union_r : forall (r r' r'': relation A), r \ (r' ∪ r'') ≡ (r \ r') ∩ (r \ r'').
Proof.
  unfolder; splits; ins; desf; splits; auto.
  unfold not; basic_solver.
Qed.

Lemma compl_union : compl_rel (r ∪ r')  ≡ compl_rel r ∩ compl_rel r'.
Proof.
  rewrite !compl_top_minus; by apply minus_union_r.
Qed.

Lemma seq_eqv_inter : ⦗s⦘ ⨾ (r ∩ r') ⨾ ⦗s'⦘ ≡ (⦗s⦘ ⨾ r ⨾ ⦗s'⦘) ∩ (⦗s⦘ ⨾ r' ⨾ ⦗s'⦘).
Proof.
  rewrite !seq_eqv_lr.
  unfold inter_rel.
  unfold same_relation, inclusion.
  splits; ins; splits; desf.
Qed.

Lemma seq_eqv_inter_rr :
        r ∩ (r' ⨾ ⦗s⦘) ≡ r ∩ r' ⨾ ⦗s⦘.
Proof. basic_solver. Qed.

Lemma map_collect_id (f : A -> B) :
  r ⊆ f ⋄ (f □ r).
Proof. basic_solver 10. Qed.

Lemma set_subset_inter_l (LL : s ⊆₁ s'' \/ s' ⊆₁ s'') :
  s ∩₁ s' ⊆₁ s''.
Proof.
  desf.
  all: rewrite LL.
  all: basic_solver.
Qed.

Lemma set_minus_remove_l (IN : s ⊆₁ s') :
  s \₁ s'' ⊆₁ s'.
Proof. generalize IN. basic_solver. Qed.

Lemma restr_set_subset
      (SUBS : s' ⊆₁ s)
      (EQ   : restr_rel s r ≡ restr_rel s r') :
  restr_rel s' r ≡ restr_rel s' r'.
Proof.
  unfolder in *.
  destruct EQ as [INCL INCR].
  splits; ins; splits; desf;
    [ apply (INCL x y) | apply (INCR x y) ];
    auto.
Qed.

Lemma restr_set_union :
  restr_rel (s ∪₁ s') r ≡
    restr_rel s r ∪ restr_rel s' r ∪
    ⦗ s ⦘ ⨾ r ⨾ ⦗ s' ⦘ ∪ ⦗ s' ⦘ ⨾ r ⨾ ⦗ s ⦘.
Proof.
  unfolder.
    by splits; ins; desf; splits; eauto; left; left; [left|right].
Qed.

Lemma restr_set_inter :
  restr_rel (s ∩₁ s') r ≡ restr_rel s r ∩ restr_rel s' r.
Proof.
  unfolder.
  splits; ins; desf.
Qed.

Lemma restr_inter_absorb_l :
  restr_rel s r ∩ restr_rel s r' ≡ r ∩ restr_rel s r'.
Proof. basic_solver. Qed.

Lemma restr_inter_absorb_r :
  restr_rel s r ∩ restr_rel s r' ≡ restr_rel s r ∩ r'.
Proof. basic_solver. Qed.

Lemma restr_irrefl_eq (IRRFLX: irreflexive r):
  forall x:A, (restr_rel (eq x) r) ≡ ∅₂.
Proof. basic_solver. Qed.

Lemma restr_clos_trans : (restr_rel s r)⁺ ⊆ restr_rel s r⁺.
Proof.
  unfold inclusion, restr_rel; ins.
  induction H; desf; splits; eauto using t_step, t_trans.
Qed.

Lemma rt_dom_ri (HH : r ⊆ ⦗ s ⦘ ⨾ r) : r＊ ⨾ ⦗ s ⦘ ⊆ (r ⨾ ⦗ s ⦘)＊.
Proof.
  rewrite rtE at 1.
  rewrite seq_union_l.
  apply inclusion_union_l; [basic_solver|].
  rewrite HH at 1.
  rewrite clos_trans_rotl.
  rewrite !seqA.
  rewrite <- ct_end.
  rewrite inclusion_t_rt.
  basic_solver.
Qed.

Lemma restr_clos_trans_eq (Hrestr : r ≡ restr_rel s r) :
  clos_trans (r) ≡ restr_rel s (clos_trans (r)).
Proof.
  split; [|basic_solver].
  rewrite <- restr_clos_trans.
  by rewrite Hrestr at 1.
Qed.

Lemma clos_refl_trans_union_ext (Hrr : r ⨾ r ≡ ∅₂) (Hrr' : r ⨾ r' ≡ ∅₂) :
  (r ∪ r')＊ ≡ r'＊ ⨾ r^?.
Proof.
  clear r'' s s' s'' p p' p'' B C.
  rewrite crE, seq_union_r, seq_id_r.
  rewrite rt_unionE.
  rewrite <- cr_of_ct with (r := (r ⨾ r'＊)).
  rewrite crE, seq_union_r.
  apply union_more.
  { basic_solver. }
  arewrite (r ⨾ r'＊ ≡ r).
  { rewrite <- cr_of_ct, crE, seq_union_r.
    arewrite (r ⨾ r'⁺ ≡ ∅₂).
    { split; [|basic_solver].
      intros x y HH.
      destruct HH as [z [HA HB]].
      induction HB.
      { eapply Hrr'. unfolder. eauto. }
      intuition. }
    basic_solver. }
  arewrite (r⁺ ≡ r); auto.
  split.
  { intros x y HH.
    induction HH; auto.
    exfalso. eapply Hrr. unfolder. eauto. }
  red. ins. constructor. auto.
Qed.

Lemma clos_trans_union_ext (Hrr : r ⨾ r ≡ ∅₂) (Hrr' : r ⨾ r' ≡ ∅₂) :
  (r ∪ r')⁺ ≡ r'⁺ ∪ r'＊ ⨾ r.
Proof.
  rewrite ct_unionE.
  arewrite ((r ⨾ r'＊)⁺ ≡ r); auto.
  unfold same_relation; splits.
  { unfold inclusion; ins.
    induction H.
    { eapply seq_rtE_r in H.
      unfold union in H; desf.
      repeat unfold seq in *; desf.
      exfalso.
      eapply Hrr'.
      eexists; splits; eauto. }
    exfalso.
    eapply Hrr.
    unfold seq; exists y; splits; eauto. }
  rewrite seq_rtE_r.
  unfold inclusion; ins.
  eapply clos_trans_mori.
  2: { eapply t_step. eauto. }
  apply inclusion_union_r1.
Qed.

Lemma set_compl_union_id : s ∪₁ set_compl s ≡₁ ⊤₁.
Proof.
  split; [basic_solver|].
  intros x _.
  destruct (classic (s x)).
  { by left. }
    by right.
Qed.

Lemma set_split : s' ∪₁ s'' ≡₁ ⊤₁ -> s ≡₁ s ∩₁ s' ∪₁ s ∩₁ s''.
Proof.
  unfolder. intros [_ HS].
  split; [|basic_solver].
  intros x Sx.
  specialize (HS x I).
  basic_solver.
Qed.

Lemma set_split_comlete : s' ≡₁ s' ∩₁ s ∪₁ s' ∩₁ (set_compl s).
Proof.
  (* copy paste of previous lemma because of section variables :( *)
  unfolder.
  split; [|basic_solver].
  intros x Sx.
  pose proof set_compl_union_id as [_ HH].
  specialize (HH x I).
  unfolder in HH.
  basic_solver.
Qed.

Lemma eqv_l_set_compl_eqv_l : r ⊆ ⦗s⦘ ⨾ r ∪ r' -> ⦗set_compl s⦘ ⨾ r ⊆ r'.
Proof.
  rewrite !seq_eqv_l.
  intros Hr x y [nSx Rxy].
  apply Hr in Rxy.
  unfolder in Rxy. desf.
Qed.

Lemma dom_r2l_rt (HH : r ⨾ ⦗s⦘ ⊆ ⦗s⦘ ⨾ r') : r＊ ⨾ ⦗s⦘ ⊆ ⦗s⦘ ⨾ r'＊.
Proof.
  unfolder in *. ins. desf.
  induction H.
  { edestruct HH; eauto. split; auto.
      by apply rt_step. }
  { split; auto. apply rt_refl. }
  destruct IHclos_refl_trans2; auto.
  destruct IHclos_refl_trans1; auto.
  split; auto.
  eapply transitive_rt; eauto.
Qed.

Lemma inter_trans : transitive r -> transitive r' -> transitive (r ∩ r').
Proof.
  clear.
  unfolder.
  intros TR TR' x y z.
  specialize (TR x y z).
  specialize (TR' x y z).
  intuition.
Qed.

Lemma immediate_in : immediate r ⊆ r.
Proof. basic_solver. Qed.

Lemma immediate_inter :
  (immediate r) ∩ r' ⊆ immediate (r ∩ r').
Proof. basic_solver. Qed.

Lemma immediate_transp :
  (immediate r)⁻¹ ≡ immediate (r⁻¹).
Proof. basic_solver. Qed.

Lemma trans_prcl_immediate_seqr_split x y
      (TRANS : transitive r) (PRCL : downward_total r) (IMM : (immediate r) x y) :
  r ⨾ ⦗ eq y ⦘ ≡ (eq x ∪₁ dom_rel (r ⨾ ⦗ eq x ⦘)) × eq y.
Proof.
  red; split.
  { unfolder.
    intros z y' [Rzy EQy].
    split; auto.
    assert (r^= z x) as Rzx.
    { eapply PRCL; eauto; desf.
      by apply immediate_in. }
    unfolder in *.
    unfold clos_refl_sym in Rzx.
    desf; eauto.
    exfalso. eapply IMM0; eauto. }
  unfolder.  ins. desf.
  { splits; desf.
    by apply immediate_in. }
  splits; desf.
  eapply TRANS; eauto.
  by apply immediate_in.
Qed.

Lemma clos_refl_trans_ind_step_left
        (R : relation A) (P : A -> Prop) x y (Px : P x)
        (rtR : R＊ x y)
        (STEP : forall z z', P z -> R z z' -> R＊ z' y -> P z') :
    P y.
Proof.
  generalize dependent Px.
  induction rtR; auto.
  { intros Px.
    specialize (STEP x y).
    apply STEP; auto.
    apply rt_refl. }
  intros Px.
  apply IHrtR2; auto.
  apply IHrtR1; auto.
  ins. eapply STEP; eauto.
  eapply rt_trans; eauto.
Qed.

Lemma set_equiv_exp_equiv :
  s ≡₁ s' <-> forall x : A, s x <-> s' x.
Proof.
  split.
  { apply set_equiv_exp. }
  intros HH. by split; red; ins; apply HH.
Qed.

Lemma minus_eqv_r : r ⨾ ⦗ s ⦘ \ r' ≡ (r \ r') ⨾ ⦗ s ⦘.
Proof.
basic_solver 21.
Qed.

End Props.

Require Import Setoid.

Add Parametric Morphism A : (@symmetric A) with signature
  same_relation ==> iff as symmetric_more.
Proof. unfolder. ins. desf. split; ins; auto. Qed.

Add Parametric Morphism A : (@clos_sym A) with signature
  inclusion ==> inclusion as clos_sym_mori.
Proof. basic_solver. Qed.

Add Parametric Morphism A : (@clos_sym A) with signature
  same_relation  ==> same_relation as clos_sym_more.
Proof. basic_solver. Qed.

Add Parametric Morphism A : (@clos_refl_sym A) with signature
  inclusion ==> inclusion as clos_refl_sym_mori.
Proof. basic_solver. Qed.

Add Parametric Morphism A : (@clos_refl_sym A) with signature
  same_relation  ==> same_relation as clos_refl_sym_more.
Proof. basic_solver. Qed.

Add Parametric Morphism A : (@compl_rel A) with signature
  same_relation ==> same_relation as compl_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@compl_rel A) with signature
  inclusion --> inclusion as compl_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@downward_total A) with signature
    same_relation ==> iff as downward_total_more.
Proof.
  intros x y EQ. unfold downward_total. split; ins.
  eapply clos_refl_sym_more; [symmetry|]; eauto.
  2: eapply clos_refl_sym_more; eauto.
  all: apply EQ in Rxz.
  all: apply EQ in Ryz.
  all: eapply H; eauto.
Qed.

Add Parametric Morphism A B : (@eq_dom A B) with signature
    set_equiv ==> eq ==> eq ==> iff as eq_dom_more.
Proof.
  intros s s' Heq f g.
  unfold eq_dom.
  split; ins;
    specialize (H x);
    apply H; auto;
    apply Heq; auto.
Qed.

Add Parametric Morphism A B : (@eq_dom A B) with signature
    set_subset --> eq ==> eq ==> impl as eq_dom_mori.
Proof. basic_solver. Qed.

Add Parametric Morphism A B : (@inj_dom A B) with signature
    set_equiv ==> eq ==> iff as inj_dom_more.
Proof.
  intros s s' Heq f. red.
  unfold inj_dom in *.
  splits; ins; specialize (H x y); apply H; auto; apply Heq; auto.
Qed.

Add Parametric Morphism A B : (@inj_dom A B) with signature
  set_subset --> eq ==> impl as inj_dom_mori.
Proof. basic_solver. Qed.

Add Parametric Morphism A : (@fixset A) with signature
    set_equiv ==> eq ==> iff as fixset_more.
Proof.
  intros s s' Heq f. red.
  unfold fixset.
  splits; ins; specialize (H x); apply H; auto; apply Heq; auto.
Qed.

Add Parametric Morphism A : (@fixset A) with signature
  set_subset --> eq ==> impl as fixset_mori.
Proof. unfold impl, fixset. basic_solver. Qed.

Add Parametric Morphism A : (@set_compl A) with signature
  set_equiv ==> set_equiv as set_compl_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_compl A) with signature
  set_subset --> set_subset as set_compl_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
  eq ==> set_equiv ==> set_equiv as set_collect_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_collect A B) with signature
  eq ==> set_subset ==> set_subset as set_collect_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_map A B) with signature
  eq ==> set_equiv ==> set_equiv as set_map_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A B : (@set_map A B) with signature
  eq ==> set_subset ==> set_subset as set_map_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@dom_rel A) with signature
   inclusion ==> set_subset as dom_rel_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@dom_rel A) with signature
   same_relation ==> set_equiv as dom_rel_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@codom_rel A) with signature
   inclusion ==> set_subset as codom_rel_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@codom_rel A) with signature
   same_relation ==> set_equiv as codom_rel_more.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_minus A) with signature
  set_equiv ==> set_equiv ==> set_equiv as set_minus_more.
Proof. red; unfolder; splits; ins; desf; split; eauto. Qed.

Add Parametric Morphism A : (@set_minus A) with signature
  set_subset ==> set_subset --> set_subset as set_minus_mori.
Proof. red; unfolder; splits; ins; desf; eauto. Qed.


From mathcomp
     Require Import all_ssreflect.

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

Definition mySet (M : Type) := M -> Prop.
Definition belong {M : Type} (A : mySet M) (x : M) :
  Prop := A x.

Notation "x ∈ A" := (belong A x) (at level 11).

Axiom axiom_mySet : forall (M :Type) (A : mySet M),
    forall (x : M), (x ∈ A) \/ ~(x ∈ A).

Definition myEmptySet  {M : Type} : mySet M := fun _ => False.
Definition myMotherSet {M : Type} : mySet M := fun _ => True.

Definition mySub {M} :=
  fun (A B : mySet M) => (forall (x : M), (x ∈ A) -> (x ∈ B)).
Notation "A ⊂ B" := (mySub A B) (at level 11).

Section Relation_Of_Inclustion.
  Variable M : Type.

  Lemma Sub_Mother (A : mySet M) : A ⊂ myMotherSet.
  Proof. by []. Qed.

  Lemma Sub_Empty (A : mySet M) : myEmptySet ⊂ A.
  Proof. by []. Qed.

  Lemma rfl_Sub (A : mySet M) : (A ⊂ A).
  Proof. by []. Qed.

  Lemma transitive_Sub (A B C : mySet M):
    (A ⊂ B) -> (B ⊂ C) -> (A ⊂ C).
  Proof.
    move => H1 H2 t H3.
    apply: H2.
    apply: H1.
    apply: H3.
  Qed.

End Relation_Of_Inclustion.

Definition eqmySet {M : Type} :=
    fun (A B : mySet M) => (A ⊂ B /\ B ⊂ A).
Axiom axiom_ExteqmySet : forall {M :Type} (A B : mySet M), eqmySet A B -> A = B.

Section equal_sign.
  Variable Mother : Type.

  Lemma rfl_eqS (A : mySet Mother) : A = A.
  Proof. by []. Qed.

  Lemma sym_eqS (A B : mySet Mother) : A = B -> B = A.
  Proof.
    move => H.
    rewrite H.
    apply rfl_eqS.
  Qed.
End equal_sign.

Definition myComplement {M :Type} (A : mySet M) : mySet M :=
  fun (x : M) => ~(A x).
Notation "A ^c" := (myComplement A) (at level 11).

Definition myCup {M : Type} (A B : mySet M) : mySet M :=
  fun (x : M) => (x ∈ A) \/ (x ∈ B).

Notation "A ∪ B" := (myCup A B) (at level 11).

Definition myCap {M : Type} (A B : mySet M) : mySet M :=
  fun (x : M) => (x ∈ A) /\ (x ∈ B).

Notation "A ∩ B" := (myCap A B) (at level 11).

Definition mySetDiff {M : Type} (A B : mySet M) : mySet M :=
  fun (x : M) => (x ∈ A) /\ (x ∈ (myComplement B)).

Notation "A \ B" := (mySetDiff A B) (at level 11).

Section Set_Operation.
  Variable M : Type.

  Lemma cEmpty_Mother: (@myEmptySet M)^c = myMotherSet.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    apply conj.
    rewrite /mySub /myComplement //.
    rewrite /mySub.
    move => x Hfull.
    rewrite /belong.
    rewrite /myMotherSet /belong in Hfull.
    rewrite /myComplement /myEmptySet.
      by [].
  Qed.

  Lemma cc_cancel (A : mySet M) : (A^c)^c = A.
  Proof.
    apply: axiom_ExteqmySet; rewrite /eqmySet.
    apply: conj.
    rewrite /mySub /myComplement => x H //.
    move : (axiom_mySet A x); by case.
    rewrite /mySub /myComplement => x H //.
  Qed.

  Lemma cMother_Empty: (@myMotherSet M)^c = myEmptySet.
  Proof.
    rewrite -cEmpty_Mother.
    rewrite cc_cancel.
    by [].
  Qed.

  Lemma myUnionCompMother (A : mySet M) : A ∪ (A^c) = myMotherSet.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet /mySub; apply: conj => [x | x H1].
    -by case.
    -case: (axiom_mySet A x).
     move => HAx.
     apply: or_introl; apply HAx.
     move => HAx.
     by apply: or_intror.
  Qed.

  Lemma myIntersectionCompEmpty (A : mySet M) : A ∩ (A^c) = myEmptySet.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet /mySub.
    split => x.
    case => HA HnA.
    rewrite /myEmptySet.
    apply: HnA HA.
    by [].
  Qed.

  Lemma myCupUnionRule (A B C : mySet M) : (A ∪ B) ∪ C = A ∪ (B ∪ C).
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    apply conj => x [H1 | H2].
    -case H1 => t.
     apply: or_introl; apply t.
     apply: or_intror; apply: or_introl; apply t.
     apply: or_intror; apply: or_intror; apply H2.
     apply: or_introl; apply: or_introl; apply H1.
    -case H2 => t.
     apply: or_introl; apply: or_intror; apply t.
     apply: or_intror; apply t.
  Qed.

  Lemma myCapUnionRule (A B C: mySet M) : A ∩ (B ∩ C) = (A ∩ B) ∩ C.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    apply: conj => x [H1 H2].
    apply conj. apply conj.
    apply: H1.
    move: H2; by case.
    move: H2; by case.
    apply: conj.
    move: H1; by case.
    apply: conj.
    move: H1; by case.
    by [].
  Qed.

  Lemma mySetCommutativeCup (A B: mySet M): A ∪ B = B ∪ A.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split => t.
    case => H1.
      by right. by left.
    case => H1.
      by right. by left.
  Qed.

  Lemma mySetCommutativeCap (A B: mySet M): A ∩ B = B ∩ A.
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split => t.
    case => H1 H2.
    split; by[].
    case => H1 H2.
    split; by [].
  Qed.

  Lemma myCapDistributeRule (A B C: mySet M): A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C).
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split; move => t.
    case => H1.
    case => H2.
    left; split; by [].
    right; split; by [].
    case; case => H1 H2.
    split. by [].
    left. by [].
    split. by [].
    right. by[].
  Qed.

  Lemma mySetDemorgan_1 (A B: mySet M): (A ∪ B)^c = (A^c) ∩ (B^c).
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split.
    move => x HABc.
    split.
    rewrite /myComplement /not.
    move => H1.
    apply: HABc.
    left.
    apply H1.
    rewrite /myComplement /not.
    move => H1.
    apply: HABc.
    by right.
    move => x.
    case => H1 H2 H3.
    apply: H1.
    by case: H3.
  Qed.

  Lemma mySetDemorgan_2 (A B: mySet M): (A ∩ B)^c = (A^c) ∪ (B^c).
    move: (cc_cancel ((A^c) ∪ (B^c))) (cc_cancel (A ∩ B)).
    move => Hcc_cancel_or Hcc_cancel_and.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split.
    rewrite -Hcc_cancel_and -Hcc_cancel_or.
    rewrite mySetDemorgan_1.
    rewrite Hcc_cancel_and.
    rewrite cc_cancel cc_cancel.
      by [].
    rewrite -Hcc_cancel_or.
    rewrite mySetDemorgan_1.
    rewrite cc_cancel cc_cancel.
      by [].
  Qed.

  Lemma mySetDiffSelfEmpty (A: mySet M): A \ A = myEmptySet.
  Proof.
    rewrite -(myIntersectionCompEmpty A).
    by rewrite /mySetDiff.
  Qed.

  Lemma mySetDiffEq (A B: mySet M): B \ A = A^c ∩ B.
  Proof.
    rewrite -mySetCommutativeCap.
    by rewrite /mySetDiff /myCap.
  Qed.

  Lemma mySetDiffComplement (A B: mySet M): (B \ A)^c = A ∪ (B^c).
  Proof.
    move: (cc_cancel (A ∪ (B^c))).
    move => H1.
    rewrite -H1.
    rewrite mySetDemorgan_1 cc_cancel mySetDiffEq.
      by [].
  Qed.

  Lemma mySetDiffDistCap (A B C: mySet M): C \ (A ∩ B) = (C \ A) ∪ (C \ B).
  Proof.
    rewrite mySetDiffEq mySetDemorgan_2.
    rewrite mySetCommutativeCap.
    rewrite myCapDistributeRule.
      by rewrite mySetDiffEq mySetCommutativeCap.
  Qed.

End Set_Operation.

Definition myMap {M1 M2 : Type} (A: mySet M1) (B: mySet M2) (f: M1 -> M2) :=
  (forall (x : M1), (x ∈ A) -> ((f x) ∈ B)).
Notation "f |: A |→ B" := (myMap A B f) (at level 11).

Definition MapCompsite {M1 M2 M3: Type} (f: M2 -> M3) (g: M1 -> M2): M1 -> M3 := fun (x: M1) => f (g x).

Notation "f ・ g" := (MapCompsite f g) (at level 11).

(* 像の形式化 *)
Definition ImgOf
           {M1 M2 : Type} (f: M1 -> M2)
           {A : mySet M1} {B : mySet M2} (_ : f |: A |→ B) : mySet M2 :=
  fun (y : M2) => (exists (x : M1), y = f x /\ x ∈ A).

(* 単射の形式化 *)
Definition mySetInj {M1 M2 : Type} (f: M1 -> M2) (A : mySet M1) (B : mySet M2) (_ : f |: A |→ B) :=
  forall (x y : M1), (x ∈ A) -> (y ∈ A) -> (f x = f y) -> (x = y).
(* 全射の形式化 *)
Definition mySetSur {M1 M2 : Type} (f: M1 -> M2) (A : mySet M1) (B : mySet M2) (_ : f |: A |→ B) :=
  forall (y : M2), (y ∈ B) -> (exists (x : M1), (x ∈ A) -> (f x = y)).
(* 全単射の形式化 *)
Definition mySetBi {M1 M2 : Type} (f: M1 -> M2) (A : mySet M1) (B : mySet M2) (fAB : f |: A |→ B) :=
  (mySetInj fAB) /\ (mySetSur fAB).

Definition myMapId {M : Type} (A: mySet M) (f: M -> M) :=
  forall (x : M), (x ∈ A) -> (x = f x).

(* formalize of inverse mapping. g is inverse mapping of f. *)

Section Mapping.
  Variables M1 M2 M3 : Type.
  Variable f : M2 -> M3.
  Variable g : M1 -> M2.
  Variable A : mySet M1.
  Variable B : mySet M2.
  Variable C : mySet M3.
  Hypothesis gAB : g |: A |→ B.
  Hypothesis fBC : f |: B |→ C.

  Lemma transitive_Inj (fgAC : (f ・ g) |: A |→ C) :
    mySetInj fBC -> mySetInj gAB -> mySetInj fgAC.
  Proof.
    rewrite /mySetInj => Hinjf Hinjg x y HxA HyA H.
    apply: (Hinjg x y HxA HyA).
    apply: (Hinjf (g x) (g y)).
    apply: gAB HxA.
    apply: gAB HyA.
    apply: H.
  Qed.

  Lemma CompoTrans : (f ・ g) |: A |→ C.
  Proof.
    move: gAB fBC.
    rewrite /MapCompsite /myMap => Hab Hbc t Ha.
    move: (Hbc (g t) (Hab t Ha)).
      by [].
  Qed.

  Lemma ImSub : (ImgOf gAB) ⊂ B.
  Proof.
    rewrite /mySub => x; case => x0; case => H1 H2.
    rewrite H1; apply: gAB; apply: H2.
  Qed.

End Mapping.

Section MappingProblem.
  Variables M1 M2 : Type.
  Variable f : M1 -> M2.
  Variable g : M2 -> M1.
  Variable idM1 : M1 -> M1.
  Variable idM2 : M2 -> M2.
  Variables A A1 A2 : mySet M1.
  Variables B B1 B2 B3 B4 B5 : mySet M2.
  Hypothesis fAB : f |: A |→ B.
  Hypothesis gBA : g |: B |→ A.
  Hypothesis fA1B1 : f |: A1 |→ B1.
  Hypothesis fA2B2 : f |: A2 |→ B2.
  Hypothesis fA1cupA2_B3 : f |: (A1 ∪ A2) |→ B3.
  Hypothesis fA1capA2_B4 : f |: (A1 ∩ A2) |→ B4.
  Hypotheses fAdiffA1_B5: f |: (A \ A1) |→ B5.
  Hypotheses idA : myMapId A idM1.
  Hypotheses idB : myMapId B idM2.

  (* A1 ⊂ A2 ならば f(A1) ⊂ f(A2) *)
  Lemma ImgSub: A1 ⊂ A2 -> (ImgOf fA1B1) ⊂ (ImgOf fA2B2).
  Proof.
    rewrite /mySub => HS.
    move => x.
    case => x0; case => H1 H2.
    rewrite /ImgOf.
    exists x0.
    split.
    apply: H1.
    apply: HS.
    apply: H2.
  Qed.

  (* f(A1 ∪ A2) = f(A1) ∪ f(A2) *)
  Lemma ImgCup: (ImgOf fA1cupA2_B3) = (ImgOf fA1B1) ∪ (ImgOf fA2B2).
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split.
    rewrite /mySub /ImgOf.
    move => x.
    case => x0.
    case => H1.
    case => H2.
    +left.
     exists x0; split.
     apply: H1.
     apply: H2.
    +right.
     exists x0; split.
     apply: H1.
     apply: H2.
    rewrite /mySub /ImgOf.
    move => x.
    case; case => x0; case => fx H1; exists x0.
    split.
    apply: fx.
    left; by [].
    split.
    apply: fx.
    right; by[].
  Qed.

  (* f(A1 ∩ A2) ⊂ f(A1) ∩ f(A2) *)
  Lemma ImgCap: (ImgOf fA1capA2_B4) ⊂ ((ImgOf fA1B1) ∩ (ImgOf fA2B2)).
  Proof.
    rewrite /mySub.
    move => x.
    case => x0.
    case => fx.
    case => H1 H2.
    rewrite /ImgOf.
    split; exists x0.
    split.
    apply: fx.
    apply: H1.
    split.
    apply: fx.
    apply: H2.
  Qed.

  (* A1 ⊂ A2 -> A2^c ⊂ A1^c *)
  Lemma Contraposition: A1 ⊂ A2 -> (A2^c) ⊂ (A1^c).
  Proof.
    rewrite /mySub /myComplement /not /belong.
    move => H1 x H2 H3.
    apply /H2 /(H1 x) /H3.
  Qed.

  (* A1 ⊂ A -> f(A)\f(A1) ⊂ f(A\A1) *)
  Lemma diffImgOf: A1 ⊂ A -> (ImgOf fAB) \ (ImgOf fA1B1) ⊂ (ImgOf fAdiffA1_B5).
  Proof.
    rewrite /mySub /mySetDiff /belong /ImgOf /myComplement /not.
    move => H1 x2.
    case.
    case.
    move => x1.
    case.
    move => H2 H3 H4.
    exists x1.
    split.
    apply /H2.
    split.
    apply /H3.
    move => H5.
    apply /H4.
    exists x1.
    split.
    -apply /H2.
    -apply /H5.
  Qed.

  Lemma diffImgOf': (ImgOf fAB) \ (ImgOf fA1B1) ⊂ (ImgOf fAdiffA1_B5).
  Proof.
    rewrite /mySub /mySetDiff /belong /ImgOf /myComplement /not.
    move => x2.
    case.
    case.
    move => x1.
    case.
    move => H1 H2.
    exists x1.
    split.
    -apply: H1.
     split.
     apply: H2.
     move => H3.
    -apply: b.
     exists x1.
     split.
     +apply: H1.
      apply: H3.
  Qed.

  Lemma Identity_Compsite_R: (myMapId A idM1) -> (f ・ idM1) |: A |→ B.
  Proof.
    rewrite /myMapId /MapCompsite.
    move => H1 x1 H2.
    rewrite -H1.
    apply : fAB.
    apply /H2.
    apply /H2.
  Qed.

  Lemma Identity_Compsite_L: (myMapId B idM2) -> (idM2 ・ f) |: A |→ B.
  Proof.
    rewrite /myMapId /MapCompsite.
    move => H1 x1 H2.
    rewrite -H1; apply: fAB; apply: H2.
  Qed.

End MappingProblem.

Variable M :finType.

Definition p2S (pA: pred M) : mySet M :=
  fun (x : M) => if (x \in pA) then True else False.

Notation "\{ x 'in' pA \}" := (p2S pA).

Section finiteSet_UsingFintype.
  Lemma Mother_predT : myMotherSet = \{ x in M \}.
  Proof.
      by [].
  Qed.

  Lemma myFinBelongP (x : M) (pA : pred M): reflect (x ∈ \{ x in pA \}) (x \in pA).
  Proof.
    rewrite /belong /p2S; apply/ (iffP idP) => H1.
    -by rewrite (_ : (x \in pA) = true).
     -+have testH : (x \in pA) || ~~(x \in pA).
     set t := x \in pA.
       by case: t.
     move: testH.
     case/orP => [| Harg]; first by [].
     rewrite (_ : (x \in pA) = false) in H1; first by [].
     by apply : negbTE.
  Qed.

  Lemma myFinSubsetP (pA pB : pred M) :
    reflect (\{ x in pA \} ⊂ \{ x in pB \}) (pA \subset pB).
  Proof.
    rewrite /mySub; apply/ (iffP idP) => H.
    -move => x /myFinBelongP => H2.
     apply /myFinBelongP.
     move: H => /subsetP.
       by rewrite /sub_mem; apply.
    -apply/ subsetP.
     rewrite /sub_mem=> x /myFinBelongP => HpA.
       by apply/ myFinBelongP; apply H.
  Qed.

  Lemma Mother_Sub (pA : pred M) :
    myMotherSet ⊂ \{ x in pA \} -> forall x, x ∈ \{ x in pA \}.
  Proof.
    rewrite Mother_predT => /myFinSubsetP => H x; apply /myFinBelongP.
      by apply: predT_subset.
  Qed.

  Lemma transitive_Sub' (pA pB pC : pred M):
    \{ x in pA \} ⊂ \{ x in pB \} ->
    \{ x in pB \} ⊂ \{ x in pC \} ->
    \{ x in pA \} ⊂ \{ x in pC \}.
  Proof.
    move /myFinSubsetP => HAB /myFinSubsetP => HBC.
    apply /myFinSubsetP /(subset_trans HAB HBC).
  Qed.

  Lemma transitive_Sub'' (pA pB pC : pred M):
    \{ x in pA \} ⊂ \{ x in pB \} ->
    \{ x in pB \} ⊂ \{ x in pC \} ->
    \{ x in pA \} ⊂ \{ x in pC \}.
  Proof.
    apply: transitive_Sub.
  Qed.
End finiteSet_UsingFintype.


(** * Unit Interval Lemmas *)

Require Export Reals.
Require Export Psatz.

Open Scope R_scope.

Lemma mult_by_lt_1 : forall a b c,
  0 < a < 1 ->
  0 < b < 1 ->
  0 < c < 1 ->
  a = b*c ->
  a < b.
Proof.
  intros.
  assert (c < 1). lra.
  assert (/ 1 <  / c). apply Rinv_lt_contravar; lra.
  assert (a * / 1 < a * / c). apply Rmult_lt_compat_l; lra.
  assert (a * / 1 < b * c * / c). rewrite <- H2. assumption.
  rewrite Rmult_assoc in H6.
  rewrite Rinv_r in H6; lra.
Qed.

Lemma plus_by_gt_0 : forall a b c,
  0 < c < 1 ->
  a = b + c ->
  b < a.
Proof.
  intros.
  rewrite H0.
  lra.
Qed.

Lemma one_minus_p : forall a,
  0 < a < 1 ->
  0 < 1 - a < 1.
Proof.
  intro. lra.
Qed.

Lemma negation_flip : forall a b,
  a < b ->
  (1-a) > (1-b).
Proof.
  intros.
  apply Ropp_gt_contravar in H.
  apply Rplus_gt_compat_l with (r:=1) in H.
  unfold Rminus; assumption.
Qed.

Lemma divide_by_lt : forall a b,
  0 < a < 1 ->
  0 < b < 1 ->
  a < b ->
  0 < a / b < 1.
Proof.
  intros.
  apply Rmult_lt_compat_r with (r:= /b) in H1.
  rewrite Rinv_r in H1; try lra.
  assert (0 < a * / b). apply Rmult_lt_0_compat; try lra.
  apply Rinv_0_lt_compat; lra.
  lra.
  apply Rinv_0_lt_compat; lra.
Qed.

Lemma mult_stable: forall a b,
  0 < a < 1 ->
  0 < b < 1 ->
  0 < a * b < 1.
Proof.
  intros.
  assert (0<a*b).
  apply Rmult_lt_0_compat; lra.
  assert (a*b < 1*1).
  apply Rmult_gt_0_lt_compat; lra.
  lra.
Qed.

Lemma mult_lt_0_compat : forall p a,
  0 < p < 1 ->
  (0 < a <-> 0 < p * a).
Proof.
  split; intros.
  + apply Rmult_lt_0_compat; lra.
  + apply Rlt_gt in H0.
    apply Rmult_gt_compat_l with (r:=/p) in H0.
    rewrite <- Rmult_assoc in H0.
    rewrite Rinv_l in H0; lra.
    apply Rinv_0_lt_compat. lra.
Qed.

Lemma mult_le_0_compat : forall p a,
  0 < p < 1 ->
  (0 <= a <-> 0 <= p * a).
Proof.
  split; intros.
  + apply Rmult_le_pos; lra.
  + apply Rle_ge in H0.
    apply Rmult_ge_compat_l with (r:=/p) in H0.
    rewrite <- Rmult_assoc in H0.
    rewrite Rinv_l in H0; lra.
    destruct H.
    apply Rinv_0_lt_compat in H. lra.
Qed.

Lemma in_0_1_open : forall p a b,
  0 < p < 1 ->
  0 < a < 1 ->
  0 < b < 1 ->
  0 < p * a + (1 - p) * b < 1.
Proof.
  intros.
  destruct H.
  apply conj.
  + apply Rplus_lt_0_compat.
    apply Rmult_lt_0_compat; lra.
    apply Rmult_lt_0_compat; lra.
  + destruct Rle_or_lt with (r1:=a) (r2:=b).
    - assert (p * b + (1 - p) * b < 1). lra.
      assert (p * a <= p * b).
      eapply Rmult_le_compat_l; lra.
      lra.
    - assert (p * a + (1 - p) * a < 1). lra.
      assert ((1- p) * b <= (1 - p) * a).
      eapply Rmult_le_compat_l; lra.
      lra.
Qed.

Lemma in_0_1_closed : forall p a b,
  0 < p < 1 ->
  0 <= a <= 1 ->
  0 <= b <= 1 ->
  0 <= p * a + (1 - p) * b <= 1.
Proof.
  intros.
  destruct H.
  apply conj.
  + apply Rplus_le_le_0_compat.
    apply Rmult_le_pos; lra.
    apply Rmult_le_pos; lra.
  + destruct Rle_or_lt with (r1:=a) (r2:=b).
    - assert (p * b + (1 - p) * b <= 1). lra.
      assert (p * a <= p * b).
      eapply Rmult_le_compat_l; lra.
      lra.
    - assert (p * a + (1 - p) * a <= 1). lra.
      assert ((1- p) * b <= (1 - p) * a).
      eapply Rmult_le_compat_l; lra.
      lra.
Qed.

Lemma sum_to_0 : forall p a b,
 0 < p < 1 ->
 0 <= a <= 1 ->
 0 <= b <= 1 ->
( p * a + (1-p) * b = 0 <-> (a = 0 /\ b = 0) ).
Proof.
  split; intros.
  + assert (0 * a <= p * a).
    apply Rmult_le_compat_r; lra. rewrite Rmult_0_l in H3.
    assert (0 * b <= (1-p) * b).
      apply Rmult_le_compat_r; lra. rewrite Rmult_0_l in H4.
    assert  (p * a = 0). lra.
    assert ((1 - p) * b = 0). lra.
    split.
    apply Rmult_integral in H5. lra.
    apply Rmult_integral in H6. lra.
  + destruct H2.
    rewrite H2, H3.
    lra.
Qed.

Lemma sum_to_1 : forall p a b,
 0 < p < 1 ->
 0 <= a <= 1 ->
 0 <= b <= 1 ->
( p * a + (1-p) * b = 1 <-> (a = 1 /\ b = 1) ).
Proof.
  split; intros.
  + destruct H.
    assert (a < 1 \/ a = 1). lra.
    assert (b < 1 \/ b = 1). lra.
    destruct H4, H5.
  (* First 3 cases contradict premise H *)
    - apply Rmult_lt_compat_l with (r:=p) in H4; trivial.
      rewrite Rmult_1_r in H4.
      apply Rmult_lt_compat_l with (r:=(1-p)) in H5; try lra.
    - apply Rmult_lt_compat_l with (r:=p) in H4; trivial.
      rewrite Rmult_1_r in H4.
      rewrite H5 in H2. rewrite Rmult_1_r in H2.
      lra.
    - apply Rmult_lt_compat_l with (r:=(1-p)) in H5; try lra.
      rewrite Rmult_1_r in H5.
      rewrite H4 in H2. rewrite Rmult_1_r in H2.
      lra.
    - lra.
  + destruct H2.
    rewrite H2, H3.
    lra.
Qed.

(* Connected to some_state_true *)

Lemma sum_to_gt_0 : forall p a b,
 0 < p < 1 ->
 0 <= a <= 1 ->
 0 <= b <= 1 ->
( 0 < p * a + (1-p) * b <-> (0 < a \/ 0 < b) ).
Proof.
  split; intros.
  + assert (0 < p * a \/ 0 < (1-p) * b). lra.
    destruct H3.
    - left.
      apply mult_lt_0_compat with (p:=p) (a:=a); assumption.
    - right.
      apply mult_lt_0_compat with (p:=(1-p)) (a:=b); lra.
  + destruct H2.
    - apply mult_lt_0_compat with (p:=p) in H2; trivial.
      destruct H1.
      apply mult_le_0_compat with (p:=(1-p)) in H1; lra.
    - apply mult_lt_0_compat with (p:=(1-p)) in H2; try lra.
      destruct H0.
      apply mult_le_0_compat with (p:=p) in H0; try lra.
Qed.

(*

Lemma sum_to_lt_1 : forall p a b,
 0 < p < 1 ->
 0 <= a <= 1 ->
 0 <= b <= 1 ->
( p * a + (1-p) * b < 1 <-> (a < 1 \/ b < 1) ).

*)

Lemma scale_eq : forall p a,
  0 < p < 1 ->
  p * a + (1 - p) * a = a.
Proof.
  intros.
  lra.
Qed.

Lemma scale_lt : forall p a b r,
  0 < p < 1 ->
  a < r ->
  b < r ->
  p * a + (1 - p) * b < r.
Proof.
  intros.
  rewrite <- scale_eq with (p:=p); trivial.
  apply Rplus_lt_compat.
  - apply Rmult_lt_compat_l; lra.
  - apply Rmult_lt_compat_l; lra.
Qed.

Lemma scale_gt : forall p a b r,
  0 < p < 1 ->
  a > r ->
  b > r ->
  p * a + (1 - p) * b > r.
Proof.
  intros.
  rewrite <- scale_eq with (p:=p); trivial.
  apply Rplus_gt_compat.
  - apply Rmult_gt_compat_l; lra.
  - apply Rmult_gt_compat_l; lra.
Qed.