From CoqAlgs Require Export Ord.
From CoqAlgs Require Import BST.

Set Implicit Arguments.

Definition SplayTree (A : Type) : Type := BTree A.

Function smaller
  {A : Type} (leb : A -> A -> bool) (pivot : A) (h : SplayTree A) : SplayTree A :=
match h with
    | empty => empty
    | node v l r =>
        if leb v pivot
        then
          match r with
              | empty => node v l empty
              | node v' l' r' =>
                  if leb v' pivot
                  then (* v <= v' <= pivot *)
                    node v' (node v l l') (smaller leb pivot r')
                  else (* v <= pivot < v' *)
                    node v l (smaller leb pivot l')
          end
        else smaller leb pivot l
end.

Function bigger
  {A : Type} (leb : A -> A -> bool) (pivot : A) (h : SplayTree A) : SplayTree A :=
match h with
    | empty => empty
    | node v l r =>
        if leb v pivot
        then bigger leb pivot r
        else
          match l with
              | empty => node v empty r
              | node v' l' r' =>
                  if leb v' pivot
                  then (* v' <= pivot < v *)
                    node v (bigger leb pivot r') r
                  else (* pivot < v' <= v *)
                    node v' (bigger leb pivot l') (node v r' r)
          end
end.

Definition splay
  {A : Type} (leb : A -> A -> bool) (pivot : A) (h : SplayTree A) : SplayTree A * SplayTree A:=
    (smaller leb pivot h, bigger leb pivot h).

Definition insert
  {A : Type} (leb : A -> A -> bool) (x : A) (h : SplayTree A) : SplayTree A :=
    let (smaller, bigger) := splay leb x h
    in node x smaller bigger.

Function merge {A : Type} (leb : A -> A -> bool) (h1 h2 : SplayTree A) : SplayTree A :=
match h1 with
    | empty => h2
    | node v l r =>
        let '(l', r') := splay leb v h2
        in node v (merge leb l l') (merge leb r r')
end.

(** We can use [removeMin] and [remove] from BST.v *)

(** Properties [bigger]. *)

Lemma isEmpty_bigger_true :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (h : SplayTree A),
    isEmpty h = true -> isEmpty (bigger leb x h) = true.
Proof.
  intros.
  functional induction smaller leb x h;
  cbn in *; congruence.
Qed.

Lemma isEmpty_bigger_false :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (h : SplayTree A),
    isEmpty (bigger leb x h) = false -> isEmpty h = false.
Proof.
  intros.
  functional induction smaller leb x h;
  cbn in *; congruence.
Qed.

Lemma Elem_bigger :
  forall {A : Ord} {pivot : A} {h : SplayTree A},
    isBST cmp h ->
      forall x : A,
        Elem x (bigger cmp pivot h)
          <->
        Elem x h /\ x > pivot.
Proof.
  intros until h.
  functional induction bigger cmp pivot h;
  isBST; intro;
  rewrite ?Elem_node, ?IHs; auto;
  unfold comparison2bool in *;
  split; Elems'.
Qed.

Lemma isBST_bigger :
  forall (A : Ord) (pivot : A) (h : SplayTree A),
    isBST cmp h -> isBST cmp (bigger cmp pivot h).
Proof.
  intros until h.
  functional induction bigger cmp pivot h;
  isBST'; auto; intros.
    apply Elem_bigger in H; firstorder.
    apply Elem_bigger in H; firstorder.
    inv H.
      trich.
      specialize (H6 _ H1). specialize (H4 v' ltac:(auto)). trich.
Qed.

(** Properties of [smaller]. *)

Lemma isEmpty_smaller_true :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (h : SplayTree A),
    isEmpty h = true -> isEmpty (smaller leb x h) = true.
Proof.
  intros.
  functional induction smaller leb x h;
  cbn in *; congruence.
Qed.

Lemma isEmpty_smaller_false :
  forall {A : Type} {leb : A -> A -> bool} {x : A} {h : SplayTree A},
    isEmpty (smaller leb x h) = false -> isEmpty h = false.
Proof.
  intros.
  functional induction smaller leb x h;
  cbn in *; congruence.
Qed.

Lemma Elem_smaller : (* TODO: fix definition of isBST *)
  forall {A : Ord} {pivot : A} {h : SplayTree A},
    isBST cmp h ->
      forall x : A,
        Elem x (smaller cmp pivot h)
          <->
        Elem x h /\ x < pivot.
Proof.
  intros until h.
  functional induction smaller cmp pivot h;
  isBST; intro;
  rewrite ?Elem_node, ?IHs; auto;
  unfold comparison2bool in *;
  split; Elems'.
Admitted.

Lemma isBST_smaller :
  forall {A : Ord} {pivot : A} {h : SplayTree A},
    isBST cmp h -> isBST cmp (smaller cmp pivot h).
Proof.
  intros until h.
  functional induction smaller cmp pivot h;
  isBST'; try intro;
  rewrite ?Elem_smaller; Elems'.
    specialize (H6 v' ltac:(auto)). trich.
    specialize (H6 v' ltac:(auto)). trich.
Qed.

(** Properties of [splay]. *)

Lemma isEmpty_splay :
  forall {A : Type} {leb : A -> A -> bool} {x : A} {h l r : SplayTree A},
    splay leb x h = (l, r) ->
      isEmpty h = isEmpty l && isEmpty r.
Proof.
  intros until h.
  unfold splay. inv 1.
  functional induction smaller leb x h;
  try destruct l; cbn; trich.
    destruct (leb v x); cbn in *; congruence.
    destruct l2, (leb v x), (leb a x); cbn; trich.
      rewrite andb_false_r. reflexivity.
      destruct (leb a0 x); reflexivity.
      rewrite andb_false_r. reflexivity.
Qed.

Lemma Elem_splay :
  forall {A : Ord} {pivot : A} {h l r : SplayTree A},
    splay cmp pivot h = (l, r) ->
      isBST cmp h ->
        forall x : A, Elem x h <-> Elem x l \/ Elem x r.
Proof.
  unfold splay.
  inv 1. intros.
  rewrite Elem_smaller, Elem_bigger.
    2-3: assumption.
    firstorder. destruct (cmp_spec x pivot).
      admit. (* TODO: fix definition of isBST *)
      left. split; try left; auto.
      right; split; auto.
Admitted.

Lemma isBST_splay :
  forall {A : Ord} {pivot : A} {h l r : SplayTree A},
    splay cmp pivot h = (l, r) ->
      isBST cmp h -> isBST cmp (node pivot l r).
Proof.
  unfold splay.
  inv 1. isBST'.
    apply isBST_smaller. assumption.
    intro. rewrite Elem_smaller; Elems'.
    apply isBST_bigger. assumption.
    intro. rewrite Elem_bigger; Elems'.
Qed.

(** Properties of [insert]. *)

Lemma isEmpty_insert :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (h : SplayTree A),
    isEmpty (insert leb x h) = false.
Proof.
  intros. unfold insert.
  destruct (splay leb x h).
  cbn. reflexivity.
Qed.

Lemma Elem_insert :
  forall {A : Ord} {x : A} {h : SplayTree A},
    isBST cmp h ->
      forall y : A, Elem y (insert cmp x h) <-> y = x \/ Elem y h.
Proof.
  unfold insert, splay. intros.
  rewrite Elem_node, Elem_smaller, Elem_bigger; auto. split.
    firstorder.
    destruct (cmp_spec y x); firstorder.
Qed.

Lemma isBST_insert :
  forall {A : Ord} {x : A} {h : SplayTree A},
    isBST cmp h -> isBST cmp (insert cmp x h).
Proof.
  intros.
  unfold insert.
  destruct (splay cmp x h) eqn: Heq.
  eapply isBST_splay; eassumption.
Qed.

(** Properties of [merge]. *)

Lemma isEmpty_merge :
  forall {A : Type} (leb : A -> A -> bool) (h1 h2 : SplayTree A),
    isEmpty (merge leb h1 h2) = isEmpty h1 && isEmpty h2.
Proof.
  destruct h1; cbn; reflexivity.
Qed.

Lemma Elem_merge :
  forall {A : Ord} {h1 h2 : SplayTree A} {x : A},
    isBST cmp h1 -> isBST cmp h2 ->
      Elem x (merge cmp h1 h2)
        <->
      Elem x h1 \/ Elem x h2.
Proof.
  intros until h2.
  functional induction merge cmp h1 h2;
  intro; isBST.
    split; Elems.
    {
      pose (isBST_splay e0 H). inv i.
      rewrite (Elem_splay e0 H), ?Elem_node, IHs, IHs0; auto.
      split; Elems''.
    }
Qed.

Lemma isBST_merge :
  forall {A : Ord} {h1 h2 : SplayTree A},
    isBST cmp h1 -> isBST cmp h2 ->
      isBST cmp (merge cmp h1 h2).
Proof.
  intros until h2.
  functional induction merge cmp h1 h2;
  isBST.
    assumption.
    pose (isBST_splay e0 H). isBST'.
      apply IHs; assumption.
      intro. rewrite Elem_merge; Elems.
      apply IHs0; assumption.
      intro. rewrite Elem_merge; Elems.
Qed.


Require Import "F01_Defs".
Require Import Coq.Program.Equality.  (* needed for dependent induction *)
(** * IV. Affaiblissement par déclaration d'un type
Dans cette partie, nous étudions une deuxième forme d'affaiblissement de l'environnement : l'affaiblissement par ajout d'une déclaration d'une variable de terme. Cette fois, nous n'utilisons pas un prédicat inductif mais une fonction qui enlève une telle déclaration dans un environnement. En effet, nous pouvons nous permettre une telle fonction car quand on enlève une variable de terme dans un environnement bien formé il reste bien formé (ce qui n'était pas vrai pour les variables de type). *)

(** [remove_var] est la fonction telle que [remove_var x e] est l'environnement [e] dans lequel on a supprimé la déclaration de la variable de terme [x]. Si [x] est en fait une variable de type, le résultat a peu de sens. *)
Fixpoint remove_var x e {struct e} : env :=
  match e with
    | Nil => Nil
    | ConsK K e => match x with
                     | 0 => ConsK K e
                     | S x => ConsK K (remove_var x e)
                   end
    | ConsT T e => match x with
                     | 0 => e
                     | S x => ConsT (tshift_minus x T) (remove_var x e)
                   end
  end.
(**  *)

(** ** Préservation du typage  *)

(** Pour cet affaiblissement, nous n'avons montré la préservation que d'un des jugement de typage : [kinding]. On montre ensuite une réciproque (ce qui est plus intéressant). *)

(** Dans tous les lemmes qui suivent, les hypothèses [get_type e x = Some _] servent à s'assurer que la variable que l'on supprime est bien une variable de terme. Nous n'aurions pas besoin d'une telle hypothèse si nous avions choisi deux numérotations différentes pour les types et les sortes. *)

(**  *)
Lemma remove_var_get_kind_lt : forall X e x, X < x -> get_kind X e = get_kind X (remove_var x e).
(**  *)
Proof.
  induction X; intros.
  + destruct e.
    - reflexivity.
    - destruct x. inv H. reflexivity.
    - destruct x. inv H. reflexivity.
  + destruct e.
    - reflexivity.
    - destruct x. inv H. apply IHX. omega.
    - destruct x. inv H. apply IHX. omega.
Qed.
(**  *)

(**  *)
Lemma remove_var_get_kind_ge : forall X e x T, X >= x -> get_type x e = Some T -> get_kind (S X) e = get_kind X (remove_var x e).
(**  *)
Proof.
  induction X; intros.
  + destruct x. destruct e; try reflexivity.
    discriminate. inv H.
  + destruct e.
    - reflexivity.
    - destruct x. inv H0. simpl in H0.
      destruct (get_type x e) eqn:?. eapply IHX. omega.
      eassumption. discriminate.
    - destruct x. reflexivity.
      simpl in H0. destruct (get_type x e) eqn:?. eapply IHX. omega.
      eassumption. discriminate.
Qed.
(**  *)

(**  *)
Lemma kinding_remove_var : forall e x T K,
   kinding (remove_var x e) T K -> forall U, get_type x e = Some U -> wf e -> kinding e (tshift x T) K.
(**  *)
Proof.
  intros e x T K H U HU Hwf. dependent induction H; simpl.
  * destruct (leb x X) eqn:?; comp; econstructor; try eassumption.
    + erewrite remove_var_get_kind_ge; try eassumption.
    + erewrite remove_var_get_kind_lt; try eassumption.
  * constructor; eauto.
  * constructor. eapply IHkinding. reflexivity.
    simpl. rewrite HU. reflexivity. now constructor.
Qed.
(**  *)

(** ** Réciproque  *)

(** Ici, nous montrons donc une réciproque à l'affaiblissement : nous montrons que les jugements de typage [wf] et [kinding] qui n'utilisent que des variables de type sont préservés par suppression des variables de terme. *)

(** Une fois de plus, le lemme est prouvé par induction mutuelle sur [wf] et [kinding]. *)
Lemma remove_var_wf_kinding :
  (forall e, wf e -> forall x U, get_type x e = Some U -> wf (remove_var x e))
     /\
        (forall e T K, kinding e T K -> forall x U, get_type x e = Some U -> kinding (remove_var x e) (tshift_minus x T) K).
(**  *)
Proof.
  apply wf_kinding_ind_mut; intros; simpl.
  + constructor.
  + destruct x; constructor. assumption.
    simpl in H0. destruct (get_type x e) eqn:?; [|discriminate].
    inv H0. now apply (H _ t).
  + destruct x. assumption.
    simpl in H1. destruct (get_type x e) eqn:?; [|discriminate].
    inv H1. econstructor. now apply (H _ t).
    now apply (H0 _ t).
  + destruct (leb x X) eqn:?; econstructor; eauto.
    - rewrite leb_iff in Heqb.
      specialize (get_get _ _ _ _ _ e0 H0). intros.
      destruct X. inv Heqb. now contradiction H1. simpl.
      rewrite <- minus_n_O.
      erewrite <- remove_var_get_kind_ge; try eassumption.
      inv Heqb. now contradiction H1. omega.
    - erewrite <- remove_var_get_kind_lt. assumption.
      now rewrite leb_iff_conv in Heqb.
  + constructor; eauto.
  + constructor. eapply (H (S x)). simpl.
    rewrite H0. reflexivity.
Qed.
(** #<script src="jquery.min.js"></script>#
    #<script src="coqjs.js"></script># *)


Require Import Arith Lia Lists.List Logic.ConstructiveEpsilon.
Require Import Coq.ZArith.Znumtheory.
Definition Witness := constructive_indefinite_ground_description_nat.

Notation "x '<d' y" := ( exists k, x*k = y ) (at level 30).
Definition irred (p : nat) := p > 1 /\ forall n, n < p -> n <d p -> n = 1.
Definition list_prod l := fold_right mult 1 l.

Lemma irred_factor n :
  n > 1 -> { q | irred q /\ q <d n}.
Proof.
  intros Hn. apply Witness.
  - intros ?. admit.
  -
Admitted.

Definition factorization (n : nat) : n <> 0 ->
  { l : list nat | n = list_prod l /\ Forall irred l }.
Proof.
  intros Hn.
  induction n as [n rec] using lt_wf_rect.
  destruct n as [|[|n]]; try tauto.
  - exists nil; auto.
  - assert (H: S (S n) > 1) by lia.
    destruct (irred_factor _ H) as (q & irred_q & [x Hx]%Witness).
    destruct (rec x) as (lx & Hlx & ?).
    + destruct x, q, irred_q; lia.
    + lia.
    + exists (q :: lx). split.
      * now rewrite <-Hx, Hlx.
      * now constructor.
    + intros ?. decide equality.
Qed.


(** * Structural Properties for Permutation-based sequent calculi
    We prove useful versions of contraction and weakening starting from not useful ones.

    This can be used for any G3C style sequent calculus. We also provide helpers for dealing with inversion lemmas.
 **)
Require Import PslBase.Base PslBase.Lists.Dupfree.
Require Import forms toolbox.
Require  Permutation.
Require Import Permutations.
Require Import Coq.Program.Equality Coq.Sorting.Permutation.

Section UndupFacts.
  Ltac dec := repeat (destruct Dec).

  Lemma undup_equi_is_perm (A: list form) B: dupfree A -> dupfree B -> (A === B <-> A ≡P B).
  Proof.
    intros HA HB.
    split.
    - intro. apply NoDup_Permutation. apply (dupfree_Nodup A). auto.
      apply (dupfree_Nodup B). apply HB.    firstorder eauto.
    -   intro. split; intro x; rewrite H; auto.
  Qed.

  Lemma undup_perm (A B: list form): A ≡P B -> (undup A) ≡P (undup B).
  Proof.
    intros. induction H.
    - reflexivity.
    - simpl undup.  dec; firstorder eauto.
      + exfalso. apply n. rewrite<- H. auto.
      +  exfalso. apply n. rewrite H. auto.
    -

      simpl undup. dec; firstorder eauto; try congruence; try reflexivity.
      rewrite H0.  reflexivity. constructor.
    - transitivity (undup l'); auto.
  Qed.

  Lemma dupfree_perm (A B: list form): A ≡P B -> (dupfree A) <-> (dupfree B).
  Proof.
    intros.
    repeat rewrite dupfree_Nodup.
    split; apply Permutation_NoDup. auto. symmetry. auto.
  Qed.

  Lemma undup_double (a: form) A: undup (a::a::A) = undup (a::A).
  Proof.
    simpl undup.
    dec.
    reflexivity.
    reflexivity.
    exfalso. auto. exfalso. apply n. auto.
  Qed.

  Lemma dupfree_rem A (x: form): dupfree A -> In x A -> ((x::(rem A x)) ≡P A).
  Proof.
    intros.
    induction H.
    - inversion H0.
    -  destruct H0.
       + rewrite H0. simpl rem. dec. congruence. simpl.
         rewrite rem_id. reflexivity. rewrite<- H0. auto.
       + assert (x <> x0). { intro. apply H.  rewrite<- H2. auto.  } specialize (IHdupfree H0).
         simpl rem. dec. simpl.
         transitivity (x0::x::(rem A x)). psolve.
         rewrite IHdupfree.  reflexivity.
         exfalso. apply n. firstorder eauto.
  Qed.

  Lemma dupfree_app_reml A (B: list form): dupfree (A++B) -> dupfree A .
  Proof.
    intros H.
    dependent induction A.
    - constructor.
    - norm_list_in H.   constructor.
      apply dupfree_cons in H. destruct H. auto.
      apply dupfree_cons in H. apply IHA with B. tauto.
  Qed.

  Lemma dupfree_app_remr A (B: list form): dupfree (A++B) -> dupfree B .
  Proof.
    intros H.
    dependent induction B.
    - constructor.
    - norm_list_in H.   constructor. intro.
      apply dupfree_perm with (A := (a :: (A++B))) in H.
      apply dupfree_cons in H. destruct H. apply H. firstorder eauto. psolve.
      apply IHB.  apply dupfree_perm with (A := (a :: (A++B))) in H. apply dupfree_cons in H.
      tauto. psolve.
  Qed.

  Lemma undupIncl (A B : list form) : incl A B -> dupfree A -> dupfree B  -> exists B', B ≡P (A++B').
  Proof.
    intros.
    induction A.
    - exists B. rewrite app_nil_l. reflexivity.
    - destruct IHA as (B' & HB').
      firstorder eauto.
      apply dupfree_cons in H0.
      tauto.
      assert (a el B').
      enough (a el (A ++ B') /\ ~(a el A)).  destruct H2. apply in_app_iff in H2. destruct H2; tauto.
      split. rewrite<- HB'. apply H. left. auto.
      apply dupfree_cons in H0; tauto.

      exists (rem B' a). rewrite HB'.
      transitivity (A ++ (a:: rem B' a)).
      rewrite dupfree_rem. reflexivity.

      apply dupfree_app_remr with A.  apply dupfree_perm with (A := ((B))).    auto. auto. auto.    psolve.
  Qed.
End UndupFacts.

Section ClassicalProperties.

  Variable ent : nat -> list form -> list form -> Prop.

  (** We define properties of entailment relations. **)
  Definition structLeftWeakening : Prop := forall h Γ Ω F, ent h Γ Ω -> ent h (F::Γ) Ω.

  Definition structRightWeakening : Prop := forall h Γ Ω F, ent h Γ Ω -> ent h Γ (F::Ω).

  Definition structLeftContraction : Prop := forall h Γ Ω F, ent h (F::F::Γ) Ω -> ent h (F::Γ) Ω.

  Definition structRightContraction : Prop := forall h Γ Ω F, ent h Γ (F::F::Ω) -> ent h Γ (F::Ω).

  Definition PermutationExchange : Prop := forall h Γ Γ' Ω Ω', ent h Γ Ω -> Γ ≡P Γ' -> Ω ≡P Ω' -> ent h Γ' Ω'.

  (* These are the properties we will shwo admissible *)
  Definition Weak : Prop := forall h Γ Ω Γ' Ω', Γ <<= Γ' -> Ω <<= Ω' -> ent h Γ Ω -> ent h Γ' Ω'.

  Definition Contraction : Prop := forall Γ Γ' Δ Δ' h, ent h Γ Δ ->  Γ === Γ' -> Δ === Δ' -> ent h Γ' Δ'.

End ClassicalProperties.

Section UsableContraction.
  Variable ent : nat -> list form -> list form -> Prop.
  Variables (srW : structRightWeakening ent) (slW: structLeftWeakening ent) (slC:structLeftContraction ent) (srC: structRightContraction ent) (pe: PermutationExchange ent) .

  Lemma provToUndupRight h Γ Ω: ent h Γ Ω -> ent h Γ (undup Ω).
  Proof.
    intros. induction Ω using list_length_ind. destruct (dupfree_dec Ω).
    - rewrite (undup_id d). auto.
    - apply not_dupfree in n. destruct n as (a & A1 & A2 & A3 & Hl').
      rewrite Hl' in H.
      assert ((A1++(a :: A2) ++ (a::A3)) ≡P (a::(a::(A1++A2++A3)))) by psolve.
      unfold PermutationExchange in pe. unfold structRightWeakening in srC.
      apply pe with (Γ' := Γ) (Ω' := (a::a::A1++A2++A3)) in H; try psolve.  apply srC in H.
      rewrite Hl'.
      specialize (undup_perm H1). intro H2.
      apply pe with (Γ := Γ) (Ω := undup (a :: a :: A1 ++ A2 ++ A3)); try psolve.
      rewrite undup_double.
      apply H0.  rewrite Hl'; firstorder eauto. repeat (rewrite app_length; simpl).  lia. auto.
  Qed.

  Lemma ProvToUndupL  h Γ Ω: ent h Γ Ω -> ent h (undup Γ) Ω.
  Proof.
    intros. induction Γ using list_length_ind. destruct (dupfree_dec Γ).
    - rewrite (undup_id d). auto.
    - apply not_dupfree in n. destruct n as (a & A1 & A2 & A3 & Hl').
      rewrite Hl' in H.
      assert ((A1++(a :: A2) ++ (a::A3)) ≡P (a::(a::(A1++A2++A3)))) by psolve.
      unfold PermutationExchange in pe. unfold structLeftWeakening in slC.
      apply pe with (Ω' := Ω) (Γ' := (a::a::A1++A2++A3)) in H; try psolve.  apply slC in H.
      rewrite Hl'.
      specialize (undup_perm H1). intro H2.
      apply pe with (Ω := Ω) (Γ := undup (a :: a :: A1 ++ A2 ++ A3)); try psolve.
      rewrite undup_double.
      apply H0.  rewrite Hl'; firstorder eauto. repeat (rewrite app_length; simpl).  lia. auto.
  Qed.

  Lemma UndupToProvL h Γ Ω: ent h (undup Γ) Ω -> ent h Γ Ω.
  Proof.
    intros. induction Γ using list_length_ind.   destruct (dupfree_dec Γ).
    - rewrite<- (undup_id d); auto.
    - apply not_dupfree in n. destruct n as (a & A1 & A2 & A3 & Hl').
      rewrite Hl' in H.
      assert ((A1++(a :: A2) ++ (a::A3)) ≡P (a::(a::(A1++A2++A3)))) by psolve.
      unfold PermutationExchange in pe. unfold structLeftContraction in slC.
      apply pe with (Ω' := Ω) (Γ' := undup (a::a::A1++A2++A3)) in H; try psolve.
      rewrite undup_double in H. apply H0 in H.
      apply pe with (Ω := Ω) (Γ :=  (a :: a :: A1 ++ A2 ++ A3)); try psolve.
      apply slC.  auto. rewrite Hl'.  repeat (rewrite app_length; simpl).  lia.
      eauto using undup_perm.
  Qed.

  Lemma UndupToProvR h Γ Ω: ent h  Γ (undup Ω) -> ent h Γ Ω.
  Proof.
    intros. induction Ω using list_length_ind.   destruct (dupfree_dec Ω).
    - rewrite<- (undup_id d); auto.
    - apply not_dupfree in n. destruct n as (a & A1 & A2 & A3 & Hl').
      rewrite Hl' in H.
      assert ((A1++(a :: A2) ++ (a::A3)) ≡P (a::(a::(A1++A2++A3)))) by psolve.
      unfold PermutationExchange in pe. unfold structRightContraction in srC.
      apply pe with (Γ' := Γ) (Ω' := undup (a::a::A1++A2++A3)) in H; try psolve.
      rewrite undup_double in H. apply H0 in H.
      apply pe with (Γ := Γ) (Ω :=  (a :: a :: A1 ++ A2 ++ A3)); try psolve.
      apply srC.  auto. rewrite Hl'.  repeat (rewrite app_length; simpl).  lia.
      eauto using undup_perm.
  Qed.

  (* Combine above lemmas to get undup equivalence for the calculus *)
  Lemma undup_prove Γ Δ h :  ent h Γ Δ  <-> ent h (undup Γ) (undup Δ).
  Proof.
    split; intro;  eauto using ProvToUndupL, provToUndupRight, UndupToProvR, UndupToProvL.
  Qed.

  Lemma appendWeakeningLeft n Γ1 Γ2 Δ: ent n Γ1 Δ -> ent n (Γ1++Γ2) (Δ).
  Proof.
    induction Γ2.
    - intro. repeat rewrite app_nil_r. auto.
    - intros.  repeat rewrite app_nil_r.
      unfold PermutationExchange in pe. unfold structLeftWeakening in slW.
      apply pe with (a::(Γ1++Γ2)) Δ; try psolve. apply slW.   eauto.
  Qed.

  Lemma appendWeakeningRight n Γ Δ1 Δ2: ent n Γ Δ1 -> ent n (Γ) (Δ1++Δ2).
    induction Δ2.
    - intro. repeat rewrite app_nil_r. auto.
    - intros.  repeat rewrite app_nil_r.
      unfold PermutationExchange in pe. unfold structRightWeakening in srW.
      apply pe with Γ (a::(Δ1++Δ2)); try psolve. eauto.
  Qed.
  Lemma Weakening:  Weak ent.
  Proof.
    unfold Weak. intros.   rewrite undup_incl in H0, H. apply undup_prove.
    apply undup_prove in H1.   apply undupIncl in H0. apply undupIncl in H.
    destruct H as [Γ'' H], H0 as [Ω'' H0].
    unfold PermutationExchange in pe.  apply pe with (undup Γ ++ Γ'') (undup Ω ++ Ω''); try psolve.
    apply appendWeakeningLeft, appendWeakeningRight. auto.
    all: apply dupfree_undup.
  Qed.

  Lemma contraction: Contraction ent.
  Proof.
    unfold Contraction.  intros Γ Γ' Δ Δ' h H H0 H1.
    assert (Weak ent) by apply Weakening.
    unfold Weak in H2. apply H2 with Γ Δ.  destruct H1, H0. all: firstorder eauto.
  Qed.
End UsableContraction.


(* http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt3.html *)
Require Import List.
Theorem app_nil_r : forall (A : Type)(l : list A), l ++ nil = l.
  intros.induction l.reflexivity.simpl.apply (f_equal (cons a)).apply IHl.Qed.

Theorem app_assoc : forall (A : Type)(l1 l2 l3 : list A), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
  intros.induction l1.reflexivity.simpl.apply (f_equal (cons a)).apply IHl1.Qed.

Theorem rev_app_distr : forall (A : Type)(l1 l2 : list A), rev (l1 ++ l2) = rev l2 ++ rev l1.
  intros.induction l1.simpl.rewrite app_nil_r.reflexivity.simpl.rewrite app_assoc.f_equal.apply IHl1.Qed.

Theorem rev_involutive : forall (A : Type)(l : list A), rev (rev l) = l.
  intros.induction l.simpl.reflexivity.simpl.rewrite rev_app_distr.simpl.f_equal.apply IHl.Qed.

Theorem fold_right_app : forall (A B : Type)(f : B -> A -> A)(l l' : list B)(i : A),
    fold_right f i (l ++ l') = fold_right f (fold_right f i l') l.
  intros.induction l.simpl.f_equal.simpl.f_equal.apply IHl.Qed.


(**
BinCoproducts from Coproduct on bool.
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.

Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Open Scope cat.

(** the inverse of
 CoproductsBool: ∏ C : precategory, has_homsets C → BinCoproducts C → Coproducts bool C
*)
Definition BinCoproducts_from_CoproductsBool {C : category} (bc : Coproducts bool C) : BinCoproducts C.
  intros a b.
  set (CC := bc (fun x => if x then b else a)).
  use make_BinCoproduct.
  - exact (CoproductObject _ _ CC).
  - apply (CoproductIn _ _ CC false) .
  - apply (CoproductIn _ _ CC true) .
  - use make_isBinCoproduct;[apply homset_property|].
    intros c f g.
    use unique_exists; simpl.
    + apply CoproductArrow.
      induction i; assumption.
    + split.
      * use (CoproductInCommutes _ _ _ CC _ _ false).
      * use (CoproductInCommutes _ _ _ CC _ _ true).
    + intros h; apply isapropdirprod; apply homset_property.
    + (intros h [H1 H2]; apply CoproductArrowUnique; intro x; induction x); assumption.
Defined.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e165m25_3limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


(* Sequence manipulation. *)

From set_theory Require Import lib set.

Section Preliminaries.

Lemma lt_S m n : m < S n -> m < n \/ m = n.
Proof. lia. Qed.

End Preliminaries.

Section Sequences.

Variable T : Type.
Variable dec : ∀x y : T, {x = y} + {x ≠ y}.

Definition Eqn m (α β : nat -> T) := ∀i, i < m -> α i = β i.
Definition const (x : T) (i : nat) := x.
Definition del m (α : nat -> T) i := α (m + i).
Definition shift m x (α : nat -> T) i := if i <? m then x else α (i - m).
Definition pre m (α β : nat -> T) i := if i <? m then α i else β i.
Definition set n v (α : nat -> T) i := if i =? n then v else α i.

Lemma eqn_refl m α : Eqn m α α.
Proof. easy. Qed.

Lemma eqn_sym m α β : Eqn m α β -> Eqn m β α.
Proof. intros H i Hi. symmetry. auto. Qed.

Lemma eqn_trans m α β γ : Eqn m α β -> Eqn m β γ -> Eqn m α γ.
Proof. intros H1 H2 i Hi. etransitivity. all: auto. Qed.

Lemma eqn_pre m α β : Eqn m α (pre m α β).
Proof. intros i Hi. unfold pre. now apply ltb_lt in Hi; rewrite Hi. Qed.

Lemma eqn_incl m n α : m <= n -> Eqn n α ⊆ Eqn m α.
Proof. intros Hle β H i Hi. apply H. lia. Qed.

Lemma eqn_del m n α β : Eqn (m + n) α β -> Eqn n (del m α) (del m β).
Proof. intros H i Hi; unfold del. apply H; lia. Qed.

Lemma eqn_eq m α β :
  Eqn m α β -> Eqn m α = Eqn m β.
Proof.
intros; apply incl_eq; intros γ Hγ; eapply eqn_trans.
apply eqn_sym, H. easy. apply H. easy.
Qed.

Lemma eqn_S m α β :
  Eqn m α β -> α m = β m -> Eqn (S m) α β.
Proof.
intros Hm HS i Hi. apply lt_S in Hi as [Hi|Hi].
now apply Hm. now subst.
Qed.

Lemma pre_0 α β : pre 0 α β = β.
Proof. extensionality i. now replace (i <? 0) with false by b_lia. Qed.

Lemma pre_m_mth m α β : pre m α β m = β m.
Proof. unfold pre; now rewrite ltb_irrefl. Qed.

Lemma pre_pre1 m α β γ : pre m (pre m α β) γ = pre m α γ.
Proof. extensionality i; unfold pre. now destruct (i <? m). Qed.

Lemma pre_pre2 m n α β γ :
  m < n -> pre n α (pre m β γ) = pre n α γ.
Proof.
intros; extensionality i; unfold pre.
destruct (i <? n) eqn:E. easy. now replace (i <? m) with false by b_lia.
Qed.

Lemma shift_m_mth m x α : (shift m x α) m = α 0.
Proof. unfold shift; now rewrite ltb_irrefl, sub_diag. Qed.

Lemma del_const b m : del m (const b) = const b.
Proof. now extensionality i. Qed.

Lemma del_add m n α : del (m + n) α = del m (del n α).
Proof. extensionality i; unfold del. now rewrite (add_comm m), add_assoc. Qed.

Lemma del_shift m x α :
  del m (shift m x α) = α.
Proof.
extensionality i; unfold del, shift.
replace (m + i <? m) with false by b_lia.
now replace (m + i - m) with i by b_lia.
Qed.

Lemma set_get1 n x α : set n x α n = x.
Proof. unfold set; now rewrite eqb_refl. Qed.

Lemma set_get2 n x α i : i ≠ n -> set n x α i = α i.
Proof. intros; unfold set; now replace (i =? n) with false by b_lia. Qed.

Lemma set_override n x y α : set n x (set n y α) = set n x α.
Proof. extensionality i; unfold set. now destruct (i =? n). Qed.

Lemma set_eqn m x n α : m <= n -> Eqn m α (set n x α).
Proof. intros H i Hi; unfold set. now replace (i =? n) with false by b_lia. Qed.

Lemma set_comm m n x y α :
  m ≠ n -> set m x (set n y α) = set n y (set m x α).
Proof.
intros; extensionality i; unfold set.
destruct (i =? m) eqn:H1, (i =? n) eqn:H2; try easy. b_lia.
Qed.

Lemma set_eq_pre_pre_const n x α :
  set n x α = pre (S n) (pre n α (const x)) α.
Proof.
extensionality i; unfold set, pre, shift.
destruct (i =? n) eqn:E; b_Prop.
subst; rewrite ltb_irrefl. now replace (n <? S n) with true by b_lia.
apply not_eq in E as [E|E]. replace (i <? S n) with true by b_lia.
now replace (i <? n) with true by b_lia.
now replace (i <? S n) with false by b_lia.
Qed.

(* Find the least shared eqn of two different sequences. *)
Lemma find_first_split α β i :
  α i ≠ β i -> ∃m, m <= i /\ Eqn m α β /\ α m ≠ β m.
Proof.
revert α β; induction i; intros. now exists 0.
destruct (IHi (del 1 α) (del 1 β)) as [m [H1m [H2m H3m]]]. easy.
destruct (dec (α 0) (β 0)).
- exists (S m); repeat split. lia. intros j Hj; destruct j. easy.
  apply succ_lt_mono in Hj; now apply H2m in Hj. easy.
- exists 0; repeat split. lia. all: easy.
Qed.

(*
Properties that rely on classical logic. We could avoid using classical logic
for these properties by defining a strong apartness relation.
*)
Section Intensional_equality.

Lemma seq_neq (α β : nat -> T) :
  (∃i, α i ≠ β i) <-> α ≠ β.
Proof.
split. intros [i Hi]. intros H. now subst.
intros H1. apply not_all_ex_not. intros H2; apply H1.
now extensionality i.
Qed.

Lemma del_pre_neq m α β γ :
  del m β ≠ del m γ -> pre m α β ≠ γ.
Proof.
intros H. apply seq_neq in H as [i Hi]. unfold del in Hi.
apply seq_neq. exists (m + i). unfold pre. replace (m + i <? m) with false.
easy. symmetry. b_lia.
Qed.

End Intensional_equality.

End Sequences.

Arguments Eqn {_}.
Arguments const  {_}.
Arguments del {_}.
Arguments shift {_}.
Arguments pre {_}.
Arguments set {_}.

Notation "n << α" := (del n α) (at level 20, format "n << α").
Notation "α ; n := x" := (set n x α)
  (at level 25, left associativity, format "α ; n := x").


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Generalizable All Variables.
Require Import Notations.
Require Import Categories.
Require Import Functors.
Require Import Isomorphisms.

(******************************************************************************)
(* Chapter 1.6.4: Slice Categories                                            *)
(******************************************************************************)
Locate "{ _ : _ & _ }".                     (* "{ x : A  & P }" := sigT (fun x : A => P) *)
(* X が 圏Cの対象であるとき、 *)
(* cod(f) = X である圏Cの射fの集まり *)
Definition MorphismInTo  `{C : Category} (X : C) := {Y : C & Y ~~{C}~~> X}.
(* dom(f) = X である圏Cの射fの集まり *)
Definition MorphismOutOf `{C : Category} (X : C) := {Y : C & X ~~{C}~~> Y}.
Check @MorphismInTo : ∀ (Obj : Type) (Hom : Obj → Obj → Setoid) (C : Category Hom),
    C → Type.
Check MorphismInTo _ : Type.                (* 引数は対象 *)

Check projT1 : ∀ (A : Type) (P : A → Type), sigT P → A.
Check projT2 : ∀ (A : Type) (P : A → Type) (x : sigT P), P (projT1 x).

Section SliceExample.
  Check Sets.                               (* 圏Sets *)
  Variable X : Sets.                        (* 圏Setsの対象 *)
  Variable M : MorphismInTo X.              (* 圏Setsの対象Xをcodとする射、cod(M)=X *)
  Check projT1 M : Sets.                    (* 圏Setsの対象 *)
  Check projT2 M : (λ Y : Sets, Y ~~{ Sets }~~> X) (projT1 M).
  Check projT2 M : (fun (Y : Sets) => (Y ~~{ Sets }~~> X)) (projT1 M).
  Check projT2 M : ((projT1 M) ~~{ Sets }~~> X).
  Check projT2 M : ((projT1 M) ~> X).       (* cod(f)=Xなる射 *)

  Check @id (projT1 M).
End SliceExample.

Definition TriangleAbove `{C : Category} {X : C} (M1 M2 : MorphismInTo X) :=
   {f : (projT1 M1) ~~{C}~~> (projT1 M2) & (projT2 M2) \\o f === (projT2 M1)}.
Definition TriangleBelow `{C : Category} {X : C} (M1 M2 : MorphismOutOf X) :=
   {f : (projT1 M1) ~~{C}~~> (projT1 M2) & f \\o (projT2 M1) === (projT2 M2)}.
(*
(projT1 M1) ~~{C}~~> (projT1 M2) は Setoid
(projT2 M2) \\o f === (projT2 M1) は Prop
 *)
Check TriangleAbove _ _ : Type.
(*
TriangleAbove M1 M2 は、
(projT1 M1) ~~{C}~~> (projT1 M2) のサブタイプ で、
それを f しとたときに、
(projT2 M2) \\o f === (projT2 M1) を満たすもの。

すなわち、次の可換図を満たす f :

                f
   projT1(M1) -----> projT1(M2)
            \       /
             \     /
       M1     \   /     M2
               V V
                X
*)

Check @eqv.

Program Instance EquivSlice : forall `{C : Category} {X : C} (M1 M2 : MorphismInTo X),
    Equivalence (@eq C).
Print EquivSlice.
(*
Equivalence_Reflexive := eq_Reflexive;
Equivalence_Symmetric := eq_Symmetric;
Equivalence_Transitive := eq_Transitive |}
     : ∀Obj Hom C X _ _, Equivalence eq
 *)

Check eqv_equivalence.
Check EquivSlice.

(* ***** *)
(* ABOVE *)
(* ***** *)

Program Instance SliceTAbove' `{C : Category} {X : C} (M1 M2 : MorphismInTo X) : Setoid :=
  {|
    carrier := TriangleAbove M1 M2;
    eqv := fun f g => (projT1 f = projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - by case.
  - by case.
  - move=> f g h /= Hfg Hgh.
      by rewrite Hfg Hgh.
Defined.

Program Instance SliceTAbove `{C : Category} {X : C} (M1 M2 : MorphismInTo X) : Setoid :=
  {|
    carrier := TriangleAbove M1 M2;
    eqv := fun f g => (projT1 f === projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - case=> f Hf.
    reflexivity.
  - move=> f g /= Hfg.
    rewrite Hfg.
    reflexivity.
  - move=> f g h /= Hfg Hgh.
    rewrite Hfg Hgh.
    reflexivity.
Defined.

Check @comp : ∀Obj Hom Category a b c _ _, a ~~{ Category }~~> c.
Check comp _ _ : _ ~~{ _ }~~> _.

Program Instance SliceOver `(C : Category) (X : C) : @Category (MorphismInTo X) SliceTAbove :=
  {|
    id  := fun y1 => existT _ (@id _ _ (projT1 y1)) _;
    comp := fun _ _ _ f g => existT _ ((projT1 f) \\o (projT1 g)) _
  |}.
Obligation 1.                               (* projT1 y1 ~~{ C }~~> projT1 y1 *)
Proof.
  by apply id.
Defined.
Obligation 2.                               (* projT2 y1 \\o id === projT2 y1 *)
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 3.                               (* projT2 c \\o (projT1 f \\o projT1 g) === projT2 a *)
Proof.
  move: H H0 H1 f g => a b c f g.
  case: f => MORbc Hcbc_b.
  case: g => MORab Hbab_a.
  simpl.
  rewrite -associativity.
  rewrite Hcbc_b Hbab_a.
  reflexivity.
Defined.
Obligation 4.
Proof.
  move=> fbc fbc' Hbc fab fab' Hab /=.
  rewrite Hbc Hab.
  reflexivity.
Defined.
Obligation 5.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 6.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 7.
Proof.
  rewrite associativity.
  reflexivity.
Defined.

Check @Functor.
Check Functor (fun x => projT1 x).

(* スライスからもとの圏をとりだす関手 *)
Program Instance SliceOverInclusion `{C : Category} (X : C) :
  @Functor _ _ (SliceOver C X) _ _ C (fun x => projT1 x) :=
  {|
    fmor := fun a b f => projT1 f
  |}.
Obligation 2.
Proof.
  rewrite /SliceOver_obligation_1.
  reflexivity.
Defined.
Obligation 3.
Proof.
  reflexivity.
Defined.

(* ***** *)
(* UNDER *)
(* ***** *)

Program Instance SliceTUnder `{C : Category} {X : C} (M1 M2 : MorphismOutOf X) : Setoid :=
  {|
    carrier := TriangleBelow M1 M2;
    eqv := fun f g => (projT1 f === projT1 g)
  |}.
Obligation 1.
Proof.
  split.
  - case=> f Hf.
    reflexivity.
  - move=> f g /= Hfg.
    rewrite Hfg.
    reflexivity.
  - move=> f g h /= Hfg Hgh.
    rewrite Hfg Hgh.
    reflexivity.
Defined.

Check @comp : ∀Obj Hom Category a b c _ _, a ~~{ Category }~~> c.
Check comp _ _ : _ ~~{ _ }~~> _.

Program Instance SliceUnder `(C : Category) (X : C) :
  @Category (MorphismOutOf X) SliceTUnder :=
  {|
    id  := fun y1 => existT _ (@id _ _ (projT1 y1)) _;
    comp := fun _ _ _ f g => existT _ ((projT1 f) \\o (projT1 g)) _
  |}.
Obligation 1.                               (* projT1 y1 ~~{ C }~~> projT1 y1 *)
Proof.
  by apply id.
Defined.
Obligation 2.                               (* projT2 y1 \\o id === projT2 y1 *)
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 3.                               (* projT2 c \\o (projT1 f \\o projT1 g) === projT2 a *)
Proof.
  move: H H0 H1 f g => a b c f g.
  case: f => MORbc Hcbc_b.
  case: g => MORab Hbab_a.
  simpl.
  rewrite associativity.
  rewrite Hbab_a Hcbc_b.
  reflexivity.
Defined.
Obligation 4.
Proof.
  move=> fbc fbc' Hbc fab fab' Hab /=.
  rewrite Hbc Hab.
  reflexivity.
Defined.
Obligation 5.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite left_identity.
  reflexivity.
Defined.
Obligation 6.
Proof.
  rewrite /SliceOver_obligation_1.
  rewrite right_identity.
  reflexivity.
Defined.
Obligation 7.
Proof.
  rewrite associativity.
  reflexivity.
Defined.

Check @Functor.
Check Functor (fun x => projT1 x).

(* スライスからもとの圏をとりだす関手 *)
Program Instance SliceUnderInclusion `{C : Category} (X : C) :
  @Functor _ _ (SliceUnder C X) _ _ C (fun x => projT1 x) :=
  {|
    fmor := fun a b f => projT1 f
  |}.
Obligation 2.
Proof.
  rewrite /SliceOver_obligation_1.
  reflexivity.
Defined.
Obligation 3.
Proof.
  reflexivity.
Defined.

(* END *)


From Coq Require Import
     Morphisms
     Setoid
     Relation_Definitions
     RelationClasses
.

From ITree Require Import Tacs Indexed.Sum.

Set Warnings "-future-coercion-class-field".

(* Heterogeneous relation definition, modified from
   https://coq.inria.fr/stdlib/Coq.Relations.Relation_Definitions.html. *)
(* A categorical account of this file is given in [CategoryRelation.v] *)

#[global] Tactic Notation "intros !" := repeat intro.

Definition relationH (A B : Type) := A -> B -> Prop.

Section RelationH_Operations.

  Definition rel_compose {A B C} (S : relationH B C) (R : relationH A B): relationH A C :=
    fun x y => exists b, R x b /\ S b y.

  (** ** Relations for morphisms/parametricity *)

  (* Heterogeneous notion of [subrelation] *)
  Definition subrelationH {A B} (R S : relationH A B) : Prop :=
    forall (x : A) (y : B), R x y -> S x y.

  Definition eq_rel {A B} (R S : relationH A B) :=
      subrelationH R S /\ subrelationH S R.

  Definition transpose {A B: Type} (R: relationH A B): relationH B A :=
    fun x y => R y x.

  (* The graph of a function forms a relation *)
  Definition fun_rel {A B: Type} (f: A -> B): relationH A B :=
    fun x y => y = f x.

  (** ** Relations for morphisms/parametricity *)

  (** Logical relation for the [sum] type. *)
  Variant sum_rel {A1 A2 B1 B2 : Type}
      (RA : relationH A1 A2) (RB : relationH B1 B2)
  : relationH (A1 + B1) (A2 + B2) :=
  | inl_morphism a1 a2 : RA a1 a2 -> sum_rel RA RB (inl a1) (inl a2)
  | inr_morphism b1 b2 : RB b1 b2 -> sum_rel RA RB (inr b1) (inr b2).

  (** Logical relation for the [prod] type. *)
  Record prod_rel {A1 A2 B1 B2 : Type}
      (RA : relationH A1 A2) (RB : relationH B1 B2)
      (p1 : A1 * B1) (p2 : A2 * B2) : Prop := prod_morphism
  { fst_rel : RA (fst p1) (fst p2)
  ; snd_rel : RB (snd p1) (snd p2) }.

End RelationH_Operations.

#[global] Hint Constructors prod_rel: core.
#[global] Hint Constructors sum_rel: core.

Arguments inl_morphism {A1 A2 B1 B2 RA RB}.
Arguments inr_morphism {A1 A2 B1 B2 RA RB}.
Arguments fst_rel {A1 A2 B1 B2 RA RB}.
Arguments snd_rel {A1 A2 B1 B2 RA RB}.

Arguments rel_compose [A B C] S R.
Arguments subrelationH [A B] R S.
Arguments transpose [A B] R.
Arguments sum_rel [A1 A2 B1 B2] RA RB.
Arguments prod_rel [A1 A2 B1 B2] RA RB.

Declare Scope relationH_scope.
Delimit Scope relationH_scope with relationH.

Module RelNotations.

  (* Notice the levels: (R ⊕ S ⊗ T ∘ U) is parsed as ((R ⊕ (S ⊗ T)) ∘ U) *)
  Infix "∘" := rel_compose (at level 40, left associativity) : relationH_scope.
  Infix "⊕" := sum_rel (at level 39, left associativity) : relationH_scope.
  Infix "⊗" := prod_rel (at level 38, left associativity) : relationH_scope.

  Infix "⊑" := subrelationH (at level 70, no associativity) : relationH_scope.
  Notation "† R" := (transpose R) (at level 5, right associativity) : relationH_scope.

  Infix "≡" := eq_rel (at level 70, no associativity) : relationH_scope.

End RelNotations.

Import RelNotations.
#[local] Open Scope relationH_scope.

Definition relationH_of_Type (A : Type) : relationH A A :=
  fun x y => x = y.

#[global]
Instance Proper_relation {A: Type} (R : relationH A A) :
  Proper (@eq A ==> @eq A ==> iff) R.
Proof.
  repeat intro.
  repeat red.
  split; intros.
  - rewrite <- H,<- H0. auto.
  - rewrite H, H0. auto.
Qed.

(* Properties of Heterogeneous Relations ************************************ *)

Class ReflexiveH {A: Type} (R : relationH A A) : Prop :=
  reflexive : forall (a:A), R a a.

Class SymmetricH {A: Type} (R : relationH A A) : Prop :=
  symmetric : forall x y, R x y -> R y x.

Class TransitiveH {A: Type} (R : relationH A A) : Prop :=
  transitive : forall x y z, R x y -> R y z -> R x z.

Class PER {A : Type} (R : relationH A A) : Type :=
  {
    per_symm :> SymmetricH R;
    per_trans :> TransitiveH R
  }.

Class Preorder {A : Type} (R : relationH A A) : Type :=
  {
    pre_refl :> ReflexiveH R;
    pre_trans :> TransitiveH R
  }.

Class EquivalenceH {A : Type} (R : relationH A A) : Type :=
  {
    equiv_refl :> ReflexiveH R;
    equiv_symm :> SymmetricH R;
    equiv_trans :> TransitiveH R
  }.

#[global]
Instance relationH_reflexive : forall (A:Type), ReflexiveH (@eq A).
Proof.
  repeat intro.
  reflexivity.
Defined.

#[global]
Instance relationH_symmetric : forall (A:Type), SymmetricH (@eq A).
Proof.
  repeat intro. cbn; auto.
Defined.

#[global]
Instance relationH_transitive : forall (A:Type), TransitiveH (@eq A).
Proof.
  repeat intro. cbn in *. etransitivity.
  apply H. apply H0.
Defined.

#[global]
Instance relationH_PER {A : Type} : PER (@eq A).
Proof.
  constructor; typeclasses eauto.
Defined.

#[global]
Instance relationH_Preorder {A : Type} : Preorder (@eq A).
Proof.
  constructor; typeclasses eauto.
Defined.

#[global]
Instance relationH_Equiv {A : Type} : EquivalenceH (@eq A).
Proof.
  constructor; typeclasses eauto.
Defined.

Lemma ReflexiveH_Reflexive {A: Type} (R : relationH A A) :
  ReflexiveH R <-> Reflexive R.
Proof.
  split; intros.
  - red. apply H.
  - apply H.
Qed.

Lemma SymmetricH_Symmetric {A: Type} (R : relationH A A) :
  SymmetricH R <-> Symmetric R.
Proof.
  split; intros.
  - red. unfold SymmetricH in H. intros. specialize (H x y). cbn in H.
    apply H. assumption.
  - red. intros p HP. cbn in *. apply H.
Qed.

Lemma TransitiveH_Transitive {A: Type} (R : relationH A A) :
  TransitiveH R <-> Transitive R.
Proof.
  split; intros.
  - red. intros x y z H0 H1. unfold TransitiveH in H. eapply H; eauto.
  - red. intros p q HP HQ EQ.
    unfold Transitive in H. cbn in EQ.
    eapply H; eauto.
Qed.

(** ** subrelationH *)
Section SubRelationH.

  (* YZ TODO: Study how [subrelation] is manipulated. Notably:
     * Relevance of using [flip] exactly, and how it relates to us using [transpose]
     * Definition of [relation_equivalence] in terms of [predicate_equivalence]
   *)
  Lemma subrelationH_Reflexive {A B: Type} (R: relationH A B): R ⊑ R.
  Proof.
    intros!; auto.
  Qed.

  Lemma subrelationH_antisym {A B: Type} (R S: relationH A B) `{R ⊑ S} `{S ⊑ R}: R ≡ S.
  Proof.
    split; auto.
  Qed.

  Lemma subrelationH_trans {A B: Type} (R S T: relationH A B)
         `{R ⊑ S} `{S ⊑ T} : R ⊑ T.
  Proof.
    intros!; auto.
  Qed.

  Lemma subrelationH_refl_eq {A: Type} (R: relationH A A) (H : Reflexive R) : @eq A ⊑ R.
  Proof.
    intros!.
    rewrite H0. cbn. apply H.
  Qed.

End SubRelationH.

Section RelationEqRel.

  (* [eq_rel] is an equivalence relation *)
  #[global]
  Instance eq_rel_Reflexive {A B} : Reflexive (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. tauto.
  Qed.

  #[global]
  Instance eq_rel_Symmetric {A B} : Symmetric (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. tauto.
  Qed.

  #[global]
  Instance eq_rel_Transitive {A B} : Transitive (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. intros.
    destruct H, H0. split; eauto.
  Qed.

  #[global]
  Instance eq_rel_Equiv {A B} : Equivalence (@eq_rel A B).
  Proof.
    split; typeclasses eauto.
  Qed.

  (* YZ: I believe that this instance is redundant with the [Transitive] instance, as illustrated by its proof *)
  #[global]
  Instance eq_rel_Proper {A B} : Proper (eq_rel ==> eq_rel ==> iff) (@eq_rel A B).
  Proof.
    intros ? ? EQ1 ? ? EQ2.
    rewrite EQ1,EQ2; reflexivity.
  Qed.

  (* This instance should allow to rewrite [H: R ≡ S] in a goal of the form [R x y] *)
  (* It works in simple contxets, however, it fails weirdly quickly. See:
     https://github.com/coq/coq/issues/12141
   *)

  (* Global Instance eq_rel_rewrite {A B}: subrelationH eq_rel (pointwise_relation A (pointwise_relation B iff)). *)
  (* Proof. *)
  (*   intros!; destructn eq_rel; split; intro; appn subrelationH; auto. *)
  (* Qed. *)
End RelationEqRel.

Section RelationCompose.

  (* [eq] define identities *)
  Lemma eq_id_r: forall {A B : Type} (R : relationH A B),
    ((@eq B) ∘ R) ≡ R.
  Proof.
    split; intros!.
    - cbn in *. destruct H as (b & HR & EQ).
      rewrite <- EQ. assumption.
    - cbn. exists y. split; auto.
  Qed.

  Lemma eq_id_l: forall {A B} (R : relationH A B),
      R ∘ (@eq A) ≡ R.
  Proof.
    split; intros!.
    - cbn in *. destruct H as (b & EQ & HR).
      rewrite EQ. assumption.
    - cbn. exists x. split; auto.
  Qed.

  (* Composition is associative *)

  Lemma compose_assoc: forall {A B C D} (R : relationH A B) (S : relationH B C) (T : relationH C D),
      T ∘ S ∘ R ≡ (T ∘ S) ∘ R.
  Proof.
    split; intros!; cbn in *.
    - repeat destruct H. repeat destruct H0.
      repeat (eexists; split; eauto).
    - repeat destruct H. repeat destruct H0.
      repeat (eexists; split; eauto).
  Qed.

  #[global]
  Instance Proper_compose: forall A B C,
      Proper
        (* (relationH B C -> relationH A B -> relationH A C) *)
        (eq_rel ==> eq_rel ==> eq_rel) (@rel_compose A B C).
  Proof.
    intros ? ? ? S S' EQS R R' EQR.
    split; intros ? ? EQ; destruct EQ as (? & ? & ?); econstructor; split; (apply EQR || apply EQS); eauto.
  Qed.

End RelationCompose.

Section TransposeFacts.

  (* SAZ: Unfortunately adding these typeclass instances can cause typeclass resolution
   to loop when looking for a reflexive instance.
   e.t. in InterpFacts we get a loop.

     YZ: If it's indeed too much of a problem, one solution is to not declare them [Global] and use
     [Existing Instance] locally in section where we them.
   *)

  (* begin
     [transpose] is closed on equivalence relations
   *)
  (* YZ: Would it be worth to Typeeclass this property? *)
  Instance transpose_Reflexive {A} (R : relationH A A) {RR: Reflexive R} : Reflexive † R | 100.
  Proof.
    red. intros x. apply RR.
  Qed.

  Instance transpose_Symmetric {A} (R : relationH A A) {RS: Symmetric R} : Symmetric † R | 100.
  Proof.
    red; intros x; unfold transpose; intros. apply SymmetricH_Symmetric in RS.
    apply RS. assumption.
  Qed.

  Instance transpose_Transitive {A} (R : relationH A A) {RT : Transitive R} : Transitive † R | 100.
  Proof.
    red; intros x; unfold transpose; intros.
    apply TransitiveH_Transitive in RT.
    unfold TransitiveH in RT.
    (* destruct A. cbn in *. destruct R. cbn in *. *)
    specialize (RT z y x). apply RT; eauto.
  Qed.

  (* [transpose] is closed on equivalence relations *)

  (* [transpose] is a functor (from the opposite category into itself) *)

  Lemma transpose_eq {A: Type}
    : † (@eq A) ≡ (@eq A).
  Proof.
    split; unfold transpose; intros!; subst; auto.
  Qed.

  Lemma transpose_sym {A : Type} (R : relationH A A) {RS: Symmetric R}
    : † R ≡ R.
  Proof.
    unfold transpose; split; intros!; cbn in *.
    apply SymmetricH_Symmetric in RS. red in RS.
    apply (RS y x). assumption.
    apply SymmetricH_Symmetric in RS. red in RS.
    apply (RS x y). assumption.
  Qed.

  Lemma transpose_compose {A B C : Type}
        (R : relationH A B) (S : relationH B C)
    : † (S ∘ R) ≡ (†R ∘ †S).
  Proof.
    split; unfold transpose; cbn; intros!; cbn in *.
    - destruct H as (b & HR & HS). exists b. tauto.
    - destruct H as (b & HR & HS). exists b. tauto.
  Qed.

  #[global]
  Instance Proper_transpose {A B : Type}
    : Proper (eq_rel ==> eq_rel) (@transpose A B).
  Proof.
    intros ? ? EQ; split; unfold transpose; intros!; apply EQ; auto.
  Qed.

  (*    [transpose] is a functor *)

  (* [transpose] is an involution *)
  Lemma transpose_involution : forall {A B} (R : relationH A B),
      † † R ≡ R.
  Proof.
    intros A B R.
    split.
    - unfold subrelationH. unfold transpose. tauto.
    - unfold subrelationH, transpose. tauto.
  Qed.

  Lemma transpose_inclusion : forall {A B} (R1 : relationH A B) (R2 : relationH A B),
      R1 ⊑ R2 <-> († R1 ⊑ † R2).
  Proof.
    intros A B R1 R2.
    split.
    - intros HS.
      unfold subrelationH, transpose in *. eauto.
    - intros HS.
      unfold subrelationH, transpose in *. eauto.
  Qed.

  #[global]
  Instance transpose_Proper :forall A B, Proper (@eq_rel A B ==> eq_rel) (@transpose A B).
  Proof.
    intros A B R1 R2 (Hab & Hba).
    split.
    - apply transpose_inclusion in Hab. assumption.
    - apply transpose_inclusion in Hba. assumption.
  Qed.

  (* [transpose] is the identity over symmetric relations *)
  Lemma transpose_sym_eq_rel {A} (R : relationH A A) {RS: Symmetric R}
    : † R ≡ R.
  Proof.
    unfold transpose; split; intros!; cbn in *.
    - apply SymmetricH_Symmetric in RS. unfold SymmetricH in RS. apply (RS y x). assumption.
    - apply SymmetricH_Symmetric in RS. unfold SymmetricH in RS. apply (RS x y). assumption.
  Qed.

  (* [transpose] is monotone *)
  Lemma transpose_monotone
         {A B} (R S: relationH A B) `{R ⊑ S}
    : †R ⊑ †S.
  Proof.
    unfold transpose; intros!.
    apply H. auto.
  Qed.

End TransposeFacts.

Section ProdRelFacts.

  (* [prod_rel] preserves the structure of equivalence relations (what does one call it for a [bifunctor]?) *)
  Section Equivalence.
    Context {R S : Type}.
    Context (RR : relationH R R).
    Context (SS : relationH S S).

    #[global]
    Instance prod_rel_refl `{Reflexive _ RR} `{Reflexive _ SS} : Reflexive (RR ⊗ SS).
    Proof.
      intros []. apply ReflexiveH_Reflexive in H. apply ReflexiveH_Reflexive in H0.
      cbn. split. apply H. apply H0.
    Qed.

    #[global]
    Instance prod_rel_sym `{Symmetric _ RR} `{Symmetric _ SS}  : Symmetric (RR ⊗ SS).
    Proof.
      intros ? ? ?. apply SymmetricH_Symmetric in H. apply SymmetricH_Symmetric in H0.
      destruct x; destruct y; cbn in *. destruct H1. split.
      - unfold SymmetricH in H. apply H. auto.
      - unfold SymmetricH in H0. apply H0. auto.
    Qed.

    #[global]
    Instance prod_rel_trans `{Transitive _ RR} `{Transitive _ SS}  : Transitive (RR ⊗ SS).
    Proof.
      intros!.
      apply TransitiveH_Transitive in H. apply TransitiveH_Transitive in H0.
      unfold TransitiveH in *.
      inversion H1; inversion H2; subst; eauto; inversion H9; subst.
    Qed.

    #[global]
    Instance prod_rel_eqv `{Equivalence _ RR} `{Equivalence _ SS} : Equivalence (RR ⊗ SS).
    Proof.
      constructor; typeclasses eauto.
    Qed.

    #[global]
    Instance prod_rel_PER `{PER _ RR} `{PER _ SS} : @PER _ (RR ⊗ SS).
    Proof.
      constructor.
      - destruct H, H0.
        eapply SymmetricH_Symmetric.
        eapply @prod_rel_sym; [ eapply SymmetricH_Symmetric; eauto .. | ].
        eapply SymmetricH_Symmetric; eauto.
      - eapply TransitiveH_Transitive.
        eapply @prod_rel_trans.
        + destruct H, H0.
          eapply TransitiveH_Transitive; eauto.
        + destruct H, H0.
          eapply TransitiveH_Transitive; eauto.
    Qed.

  End Equivalence.

  (* [prod_rel] is monotone in both parameters *)
  Lemma prod_rel_monotone
         {A B C D: Type} (R R': relationH A B) (S S': relationH C D)
         `{R ⊑ R'} `{S ⊑ S'}
  : R ⊗ S ⊑ R' ⊗ S'.
  Proof.
    intros!. destruct x, y. repeat red. repeat red in H1. destruct H1.
    split.
    - apply H. assumption.
    - apply H0. assumption.
  Qed.

  (* begin *)
(*    [prod_rel] is a bifunctor *)
(*    *)

  Lemma prod_rel_eq : forall (A B:Type),  (@eq A) ⊗ (@eq B) ≡ @eq (A * B).
  Proof.
    intros.
    unfold eq_rel; split; unfold subrelationH; intros.
    - destruct x, y. repeat red in H. destruct H. cbn in *; subst; reflexivity.
    - destruct x; destruct y. cbn in H. repeat red. inversion H. split; reflexivity.
  Qed.

  Definition prod_fst_rel {A B : Type} (R : relationH (A * B) (A * B)) :
    relationH A A :=
    fun x y => forall (b1 b2 : B), R  (x, b1) (y, b2).

  Definition prod_snd_rel {A B : Type} (R : relationH (A * B) (A * B)) :
    relationH B B :=
    fun x y => forall (a1 a2 : A), R  (a1, x) (a2, y).

  Lemma prod_inv (A B : Type) :
    forall (R : relationH (A * B) (A * B)) (x1 x2 : A) (y1 y2 : B),
        prod_fst_rel R x1 x2 /\ prod_snd_rel R y1 y2 ->
        R (x1, y1) (x2, y2).
  Proof.
    intros.
    destruct H. unfold prod_fst_rel, prod_snd_rel in *. cbn in *.
    apply H0.
  Qed.

  Lemma prod_compose {A B C D E F: Type}
        (R: relationH A B) (S: relationH B C)
        (T: relationH D E) (U: relationH E F)
    : (S ∘ R) ⊗ (U ∘ T) ≡ (S ⊗ U) ∘ (R ⊗ T).
  Proof.
    split; intros!.
    - destruct x, y. repeat red. repeat red in H. destruct H as [H1 H2].
      unfold fst, snd. cbn in H1, H2.
      edestruct H1 as (b & HR & HS).
      edestruct H2 as (e & HT & HU).
      exists (b, e). split; cbn; split; eauto.
    - destruct x, y. repeat red. repeat red in H. destruct H as [x [H1 H2]].
      split.
      + exists (fst x). cbn; split; [apply H1|apply H2].
      + exists (snd x). cbn; split; [apply H1|apply H2].
  Qed.

  #[global]
  Instance Proper_prod_rel {A B C D}: Proper (eq_rel ==> eq_rel ==> eq_rel) (@prod_rel A B C D).
  Proof.
    intros!. split; intros!; destruct x1, y1; cbn in *; destruct H1; split;
    try apply H; try apply H0; eauto.
  Qed.

  (* end *)
(*    [prod_rel] is a bifunctor *)

(* Note: we also have associators and unitors, forming a monoidal category. *)
(*      See [CategoryRelation.v] if needed. *)

  (* Distributivity of [transpose] over [prod_rel] *)
  Lemma transpose_prod {A B C D: Type}
        (R: relationH A B) (S: relationH C D)
    : † (S ⊗ R) ≡ (†S ⊗ †R).
  Proof.
    split; unfold transpose; cbn; intros!; destruct x, y; cbn in *;
    destruct H; split; eauto.
  Qed.
End ProdRelFacts.

Section SumRelFacts.

  (* [sum_rel] preserves the structure of equivalence relations (what does one call it for a [bifunctor]?) *)
  Section Equivalence.
    Context {A B : Type}.
    Context (R : relationH A A).
    Context (S : relationH B B).

    #[global]
    Instance sum_rel_refl {RR: Reflexive R} {SR: Reflexive S} : Reflexive (R ⊕ S).
    Proof.
      intros []. apply ReflexiveH_Reflexive in RR.
      apply ReflexiveH_Reflexive in SR.
      cbn.
      constructor. apply RR.
      constructor. apply SR.
    Qed.

    #[global]
    Instance sum_rel_sym {RS: Symmetric R} {SS: Symmetric S} : Symmetric (R ⊕ S).
    Proof.
      intros ? ? ?. apply SymmetricH_Symmetric in RS.
      apply SymmetricH_Symmetric in SS.
      destruct x, y.
      - constructor. inversion H. subst. apply RS. auto.
      - inversion H.
      - inversion H.
      - constructor. inversion H. subst. apply SS. auto.
    Qed.

    #[global]
    Instance sum_rel_trans {RT: Transitive R} {ST: Transitive S}  : Transitive (R ⊕ S).
    Proof.
      intros!.
      apply TransitiveH_Transitive in RT. apply TransitiveH_Transitive in ST.
      unfold TransitiveH in *.
      destruct x, y, z; try contradiction; inversion H; inversion H0; subst.
      cbn in *.
      constructor. eauto. constructor. eauto.
    Qed.

    #[global]
    Instance sum_rel_eqv {RE: Equivalence R} {SE: Equivalence S} : Equivalence (R ⊕ S).
    Proof.
      constructor; typeclasses eauto.
    Qed.

  End Equivalence.

  (* [sum_rel] is monotone in both parameters *)
  Lemma sum_rel_monotone
         {A B C D: Type} (R R': relationH A B) (S S': relationH C D)
         `{R ⊑ R'} `{S ⊑ S'}
    : R ⊕ S ⊑ R' ⊕ S'.
  Proof.
    intros!; destruct x, y; repeat red; repeat red in H1;
    inversion H1; subst; constructor; eauto.
  Qed.

(*    [sum_rel] is a bifunctor *)

  Lemma sum_rel_eq : forall (A B: Type),  @eq A ⊕ @eq B ≡ @eq (A + B).
  Proof.
    intros. red.
    split; repeat intro; eauto.
    inversion H; subst; auto; try reflexivity.
    subst. destruct y; constructor; eauto.
  Qed.

  Lemma sum_compose {A B C D E F: Type}
        (R: relationH A B) (S: relationH B C)
        (T: relationH D E) (U: relationH E F)
  : (S ∘ R) ⊕ (U ∘ T) ≡ (S ⊕ U) ∘ (R ⊕ T).
  Proof.
    split; intros!.
    - destruct x, y; inv H.
      destruct H2 as (? & ? & ?); eexists; eauto.
      destruct H2 as (? & ? & ?); eexists; eauto.
    - destruct H as (? & H1 & H2); inv H1; inv H2.
      econstructor; eexists; eauto.
      econstructor; eexists; eauto.
  Qed.

  #[global]
  Instance Proper_sum_rel {A B C D}: Proper (eq_rel ==> eq_rel ==> eq_rel) (@sum_rel A B C D).
  Proof.
    intros!.
    split; intros!; destruct x1, y1; cbn in *; try inversion H1;
      try apply H; try apply H0; eauto; subst; inversion H1; subst;
        try econstructor; try apply H; try apply H0; eauto.
  Qed.

(*    [sum_rel] is a bifunctor *)

(* Note: we also have associators and unitors, forming a monoidal category. *)
(*      See [CategoryRelation.v] if needed. *)
(*  *)

  (* Distributivity of [transpose] over [sum_rel] *)
  Lemma transpose_sum {A B C D: Type}
        (R: relationH A B) (S: relationH C D)
    : † (S ⊕ R) ≡ (†S ⊕ †R).
  Proof.
    split; unfold transpose; cbn; intros!; destruct x, y; cbn in *;
      try inversion H; eauto; subst; inversion H; subst; try econstructor; eauto.
  Qed.

End SumRelFacts.

Lemma PER_reflexivityH1 : forall {A:Type} (R : relationH A A) (RS: SymmetricH R) (RT: TransitiveH R)
                            (a b : A), R  a b -> R a a.
Proof.
  intros.
  assert (R  b a). { specialize (RS a b). apply RS. assumption. }
  specialize (RT a b a). apply RT; auto.
Qed.

Lemma PER_reflexivityH2 : forall {A:Type} (R : relationH A A) (RS: SymmetricH R) (RT: TransitiveH R)
                            (a b : A), R  b a -> R a a.
Proof.
  intros.
  assert (R a b). { specialize (RS b a). apply RS. assumption. }
  specialize (RT a b a). apply RT; auto.
Qed.

Ltac PER_reflexivityH :=
  match goal with
  | [ H : ?R  ?X ?Y |- ?R  ?X ?X ] =>  eapply PER_reflexivityH1; eauto
  | [ H : ?R  ?Y ?X |- ?R  ?X ?X ] =>  eapply PER_reflexivityH2; eauto
  end; try apply per_symm ; try apply per_trans.

Definition diagonal_prop {A : Type} (P : A -> Prop) : relationH A A :=
  fun x y => (P  x /\ P y).

Lemma diagonal_prop_SymmetricH {A : Type} (P : A -> Prop) : SymmetricH (diagonal_prop P).
Proof.
  red. intros a1 a2 H.
  cbn in *. unfold diagonal_prop in *. tauto.
Qed.

Lemma diagonal_prop_TransitiveH {A : Type} (P : A -> Prop) : TransitiveH (diagonal_prop P).
Proof.
  red. intros.
  cbn in *. unfold diagonal_prop in *.
  tauto.
Qed.

Lemma diagonal_prop_PER {A : Type} (P : A -> Prop) : PER (diagonal_prop P).
Proof.
  constructor.
  red. intros.
  cbn in *. unfold diagonal_prop in *; tauto.
  red. intros.
  cbn in *. unfold diagonal_prop in *; tauto.
Qed.

(* With the current state of the monad theory, we cannot prove the laws generically.
   We specialize things to [failT (itree E)] until we generalize [Eq1] to be parameterized
   by the underlying relation on returned values.
 *)
Definition option_rel {X : Type} (R : relation X) : relation (option X) :=
  fun mx my => match mx,my with
            | Some x, Some y => R x y
            | None, None => True
            | _, _ => False
            end.
#[export] Hint Unfold option_rel : core.

Lemma option_rel_eq : forall {A : Type},
    eq_rel (@eq (option A)) (option_rel eq).
Proof.
  intros ?; split; intros [] [] EQ; subst; try inv EQ; cbn; auto.
Qed.

#[export] Hint Unfold option_rel : core.

Notation prerel E D := (forall (A B : Type), E A -> D B -> Prop ).
Notation postrel E D := (forall (A B : Type), E A -> A -> D B -> B -> Prop).

Variant sum_prerel {E1 E2 D1 D2 : Type -> Type} (PR1 : prerel E1 D1 ) (PR2 : prerel E2 D2)
  : prerel (E1 +' E2) (D1 +' D2) :=
  | sum_prerel_inl (A B : Type) e1 d1 : PR1 A B e1 d1 -> sum_prerel PR1 PR2 A B (inl1 e1) (inl1 d1)
  | sum_prerel_inr (A B : Type) e2 d2 : PR2 A B e2 d2 -> sum_prerel PR1 PR2 A B (inr1 e2) (inr1 d2)
.

Variant sum_postrel  {E1 E2 D1 D2 : Type -> Type} (PR1 : postrel E1 D1 ) (PR2 : postrel E2 D2)
  : postrel (E1 +' E2) (D1 +' D2) :=
  | sum_postrel_inl A B e1 d1 a b : PR1 A B e1 a d1 b -> sum_postrel PR1 PR2 A B (inl1 e1) a (inl1 d1) b
  | sum_postrel_inr A B e2 d2 a b : PR2 A B e2 a d2 b -> sum_postrel PR1 PR2 A B (inr1 e2) a (inr1 d2) b
.


From Undecidability.L Require Export Datatypes.LNat Datatypes.LBool Tactics.LTactics Computability.Computability Tactics.Lbeta.

Set Default Proof Using "Type".
Section MuRecursor.

Variable P : term.
Hypothesis P_proc : proc P.
Hint Resolve P_proc : LProc.

Hypothesis dec'_P : forall (n:nat), (exists (b:bool), app P (ext n) == ext b ).

Lemma dec_P : forall n:nat, {b:bool | app P (ext n) == ext b}.
Proof using dec'_P.
  intros. eapply lcomp_comp.
  -apply bool_enc_inv_correct.
  -apply dec'_P.
Qed.

Section hoas.
  Import HOAS_Notations.
  Definition mu' := Eval cbn -[enc] in rho (convert (λ mu P n, (P n) (!!K n) (λ Sn, mu P Sn) (!!(ext S) n))).
End hoas.

Import L_Notations.

Lemma mu'_proc : proc mu'.
Proof.
  unfold mu'; Lproc.
Qed.

Hint Resolve mu'_proc : LProc.

Lemma mu'_n_false n: P (ext n)  == ext false -> mu' P (ext n) >* mu' P (ext (S n)).
Proof using P_proc.
  intros R. apply equiv_lambda in R;[|Lproc]. recStep mu'. unfold K. now Lsimpl.
Qed.

Lemma mu'_0_false n: (forall n', n' < n -> P (ext n')  == ext false) -> mu' P (ext 0) >* mu' P (ext n).
Proof using P_proc.
  intros H. induction n.
  -reflexivity.
  -rewrite IHn.
   +apply mu'_n_false. apply H. lia.
   +intros. apply H. lia.
Qed.

Lemma mu'_n_true (n:nat): P (ext n)  == ext true -> mu' P (ext n) == ext n.
Proof using P_proc.
  intros R. recStep mu'. Lsimpl. rewrite R. unfold K. now Lsimpl.
Qed.

(* TODO: mu' sound*)
Lemma mu'_sound v n: proc v -> mu' P (ext (n:nat)) == v ->
                     (forall n', n' < n -> P (ext n') == ext false) ->
                     exists n0, n0 >= n /\ P (ext n0) == ext true /\ v == ext n0
                                /\ forall n', n' < n0 -> P (ext (n':nat)) == ext false.
Proof using P_proc dec'_P.
  intros pv. intros R. apply equiv_lambda in R;try Lproc. apply star_pow in R. destruct R as [k R]. revert n R. apply complete_induction with (x:=k);clear k;intros k. intros IH n R H.
  specialize (dec_P n).
  destruct (dec_P n) as [[] eq].
  -exists n;intuition. apply pow_star in R. apply star_equiv in R. rewrite <- R. now rewrite mu'_n_true.
  -assert (R':=mu'_n_false eq). apply star_pow in R'. destruct R' as [k' R'].
   destruct (parametrized_confluence uniform_confluence R R') as [x [l [u [le1 [le2 [R1 [R2 eq']]]]]]]. destruct x.
   +inv R1. apply IH in R2 as [n0 [ge1 [Rn0 [eq0 H0]]]].
    *exists n0. repeat split;try assumption;lia.
    *decide (l=k);[|lia]. subst l. assert (k'=0) by lia. subst k'. inv R'. apply inj_enc in H1. lia.
    *intros. decide (n'=n). subst. tauto.  apply H. lia.
   +destruct R1 as [? [C _]]. destruct pv as [_ [v']]. subst v. inv C.
Qed.

Lemma mu'_complete n0 : P (ext n0) == ext true
                        -> (forall n', n' < n0 -> P (ext n') == ext false)
                        -> mu' P (ext 0) == ext n0.
Proof using P_proc.
  intros. rewrite mu'_0_false with (n:=n0);try tauto.
  -recStep mu'. Lsimpl. rewrite H. unfold K. now Lsimpl.
Qed.

(* the mu combinator:*)

Definition mu :term := lam (mu' #0 (ext 0)).

Lemma mu_proc : proc mu.
Proof.
  unfold mu. Lproc.
Qed.

Hint Resolve mu_proc : LProc.

Lemma mu_sound v : lambda v -> mu P == v -> exists n, v = ext n /\ P (ext n) == ext true /\ (forall n', n' < n -> P (ext n') == ext false).
Proof using P_proc dec'_P.
  unfold mu. intros lv R. standardizeHypo 100. apply mu'_sound in R.
  -destruct R as [n ?]. exists n. intuition. apply unique_normal_forms;try Lproc. assumption.
  -split;[|Lproc]. apply equiv_lambda in R;auto. apply closed_star in R;Lproc.
  -intros. lia.
Qed.

Lemma mu_complete (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0.
Proof using P_proc dec'_P.
  remember 0 as n0.
  assert (forall n':nat, n'< n-(n-n0) -> P (ext n') == ext false) by (intros;lia).
  assert ((n-n0)+n0=n) by lia. remember (n-n0) as k. clear Heqk Heqn0 H0 n0. induction k.
  -simpl in *. subst. intros. eexists. unfold mu. Lsimpl. apply mu'_complete;eauto. intros. apply H. lia.
  -intros. destruct (dec_P (n-S k)) as [y P'].
   destruct y.
   +eexists. unfold mu. Lsimpl. apply mu'_complete. exact P'. exact H.
   +apply IHk. intros. decide (n' = n - (S k)).
     *subst. exact P'.
     *apply H. lia.
     *assumption.
Qed.

Lemma mu_spec : converges (mu P) <-> exists n : nat, P (ext n) == ext true.
Proof using P_proc dec'_P.
  split.
  - intros (? & ? & ?). eapply mu_sound in H as (? & ? & ? & ?); eauto.
  - intros []. eapply mu_complete in H as []. exists (ext x0). split. eauto. eapply proc_ext.
Qed.

End MuRecursor.

Hint Resolve mu'_proc : LProc.
Hint Resolve mu_proc : LProc.


(* unordered pairs  *)

Require Import DecidableType.
Require Import DecidableTypeEx.

Module Upair (M: DecidableType)  <: DecidableType
with  Definition t := (M.t* M.t)%type.

Definition t := (M.t * M.t)%type.

Definition eq(p p':t) : Prop :=
       M.eq (fst p) (fst p') /\ M.eq (snd p) (snd p')
    \/ M.eq (fst p) (snd p') /\ M.eq (snd p) (fst p').

Lemma  eq_refl : forall x : t, eq x x.
Proof.
  destruct x ;left;simpl;auto.
Qed.

Lemma  eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
 intros (x0,x1) (y0,y1) [(H1,H2)|(H1,H2)]; simpl in H1,H2;
 [left|right];split;auto.
Qed.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
 intros (x0,x1) (y0,y1) (z0,z1) [(H1,H2)|(H1,H2)] [(H3,H4)|(H3,H4)];
 simpl in * ;
 [left|right|right|left];eauto.
Qed.

Definition eq_dec :forall x y : t, { eq x y } + { ~ eq x y }.
destruct x as (t0, t1);destruct y as (t2,t3).
case (M.eq_dec t0 t2).
intro e; case (M.eq_dec t1 t3).
 left;red. left; simpl;auto.
 intro n; right;red.
 intros [(H1,H2)|(H1,H2)];simpl in *.
 firstorder.
 case n.
 apply M.eq_trans with t2;auto.
 apply M.eq_trans with t0;auto.
 intro n.
  case (M.eq_dec t0 t3);intro H.
 case (M.eq_dec t1 t2);intro H1.
 left.
 right;simpl; auto.
 right; intros [(H2,H3)|(H2,H3)]; simpl in *; firstorder.
 right;
 intros [(H2,H3)|(H2,H3)]; simpl in *; firstorder.

Defined.

End Upair.

Locate eq_dec.

(* exemple *)
Require Import ZArith.
Module Zpair := Upair Z_as_DT.

Recursive Extraction Zpair.eq_dec.

Open Scope Z_scope.

Check (5,6).

Eval compute in (if Zpair.eq_dec  (5,6) (4+2,5) then true else false).


Definition pierce := forall (p q : Prop),
  ((p -> q) -> p) -> p.

Definition lem := forall p, p \/ ~ p.

Theorem pierce_equiv_lem: pierce <-> lem.
Proof.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~ (p \/ ~p )).
  firstorder.
  destruct (H p).
  assumption.
  tauto.

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

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

(* 用 Compute 指令来计算包含 next_weekday 的复合表达式 *)
Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

(* 我们可以将期望的结果写成 Coq 的示例 *)
Example test_next_weekday:
  (next_weekday(next_weekday saturday)) = tuesday.

(* 经过一番化简后，若等式两边的求值结果相同，该断言即可得证 *)
Proof. simpl. reflexivity. Qed.

Inductive bool: Type :=
  | true
  | false.

Definition negb(b: bool): bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb(b1: bool)(b2: bool): bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb(b1: bool)(b2: bool): bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

(*  Notation 指令能为既有的定义赋予新的中缀记法 *)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

(* 特殊的指令 Admitted 被用作不完整证明的占位符 *)

Definition nandb (b1:bool) (b2:bool) : bool :=
  match (b1, b2) with
  | (false, _) => true
  | (_, false) => true
  | _ => false
  end.
Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match (b1, b2, b3) with
  | (true, true, true) => true
  | _ => false
  end.
Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

(* Check 指令会让 Coq 显示一个表达式的类型 *)
Check true.
Check (negb true).
Check negb.

Inductive rgb: Type :=
  | red
  | green
  | blue.

Inductive color: Type :=
  | black
  | white
  | primary (p: rgb).

Definition monochrome(c: color): bool :=
  match c with
    | black => true
    | white => true
    | primary q => false
  end.

Definition isread(c: color): bool :=
  match c with
    | black => false
    | white => false
    | primary red => true
    | primary _ => false
  end.

(* Tuple *)
Inductive bit: Type :=
  | B0
  | B1.

Inductive nybble: Type :=
  | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0).

Definition all_zero(nb: nybble): bool :=
  match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).
(* ===> false : bool *)
Compute (all_zero (bits B0 B0 B0 B0)).
(* ===> true : bool *)

(* Module NatPlayground. *)

(* Inductive nat: Type :=
  | O
  | S (n: nat)
  . *)

Definition pred(n: nat): nat :=
  match n with
    | O => 0
    | S n' => n'
  end.

Check (S (S (S (S 0)))).
(* 4 : nat  *)

Definition minustwo(n: nat): nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Check S.
Check pred.
Check minustwo.

(* End NatPlayground. *)

Fixpoint evenb(n: nat): bool :=
  match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
  end.

Definition oddb(n: nat): bool := negb(evenb n).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

(* Module Nat2. *)
  Fixpoint plus (n: nat) (m: nat): nat :=
    match n with
      | O => m
      | S n' => S (plus n' m)
    end.

  Compute (plus 3 2).

  Fixpoint mult(n m: nat): nat :=
    match n with
      | O => O
      | S n' => plus m (mult n' m)
    end.

  Example test_mult1: (mult 3 3) = 9.
  Proof. simpl. reflexivity. Qed.

  Fixpoint minus (n m: nat) : nat :=
    match n, m with
      | O , _ => O
      | S _ , O => n
      | S n', S m' => minus n' m'
    end.
(* End Nat2. *)

Fixpoint exp(base power: nat): nat :=
    match power with
      | O => S O
      | S p => mult base (exp base p)
    end.

Fixpoint factorial (n: nat) : nat :=
  match n with
    | O => S O
    | S n' => mult (S n') (factorial n')
  end.
Example test_factorial1: (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. reflexivity. Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Naturality.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section SymmetricMonoidal.

Context `{@Monoidal C}.

Class SymmetricMonoidal := {
twist {x y} : x ⨂ y ≅ y ⨂ x;
twist_natural : natural (@twist);

twist_invol {x y} : twist ∘ twist ≈ id[x ⨂ y];

hexagon_identity {x y z} :
tensor_assoc ∘ twist ∘ tensor_assoc
<< (x ⨂ y) ⨂ z ~~> y ⨂ (z ⨂ x) >>
id ⨂ twist ∘ tensor_assoc ∘ twist ⨂ id
}.

Corollary hexagon_rotated `{SymmetricMonoidal} {x y z} :
tensor_assoc ∘ twist ⨂ id ∘ tensor_assoc ⁻¹
<< x ⨂ (y ⨂ z) ~~> y ⨂ (x ⨂ z) >>
id ⨂ twist ∘ tensor_assoc ∘ twist.
Proof. hammer_hook "Symmetric" "Symmetric.hexagon_rotated".
rewrite <- (id_right (id ⨂ twist ∘ tensor_assoc ∘ twist)).
rewrite <- (iso_to_from tensor_assoc).
rewrite comp_assoc; rewrite <- (comp_assoc _ tensor_assoc twist); rewrite <- (comp_assoc _ (tensor_assoc ∘ twist) _).
rewrite hexagon_identity.
rewrite !comp_assoc.
rewrite <- bimap_comp; rewrite id_left.
rewrite twist_invol.
cat.
Qed.

Corollary bimap_twist `{SymmetricMonoidal} {x y z w} (f : x ~> z) (g : y ~> w) :
g ⨂ f ∘ twist ≈ twist ∘ f ⨂ g.
Proof. hammer_hook "Symmetric" "Symmetric.bimap_twist".
spose (fst twist_natural _ _ f _ _ g) as X.
normal.
apply X.
Qed.

Corollary twist_bimap_twist `{SymmetricMonoidal} {x y z w} (f : x ~> z) (g : y ~> w) :
twist ∘ g ⨂ f ∘ twist ≈ f ⨂ g.
Proof. hammer_hook "Symmetric" "Symmetric.twist_bimap_twist".
rewrite <- comp_assoc.
rewrite bimap_twist.
rewrite comp_assoc.
rewrite twist_invol.
cat.
Qed.

End SymmetricMonoidal.


(************************************************************************)
(*  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: Rgeom.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import R_sqrt.
Open Local Scope R_scope.

(** * Distance *)

Definition dist_euc (x0 y0 x1 y1:R) : R :=
  sqrt (Rsqr (x0 - x1) + Rsqr (y0 - y1)).

Lemma distance_refl : forall x0 y0:R, dist_euc x0 y0 x0 y0 = 0.
Proof.
  intros x0 y0; unfold dist_euc in |- *; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
      [ apply Rle_0_sqr | apply Rle_0_sqr ]
      | right; reflexivity
      | rewrite Rsqr_0; rewrite Rsqr_sqrt;
        [ unfold Rsqr in |- *; ring
          | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
Qed.

Lemma distance_symm :
  forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0.
Proof.
  intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
      | apply sqrt_positivity; apply Rplus_le_le_0_compat
      | repeat rewrite Rsqr_sqrt;
        [ unfold Rsqr in |- *; ring
          | apply Rplus_le_le_0_compat
          | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
Qed.

Lemma law_cosines :
  forall x0 y0 x1 y1 x2 y2 ac:R,
    let a := dist_euc x1 y1 x0 y0 in
      let b := dist_euc x2 y2 x0 y0 in
        let c := dist_euc x2 y2 x1 y1 in
          a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
          Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac).
Proof.
  unfold dist_euc in |- *; intros; repeat rewrite Rsqr_sqrt;
    [ rewrite H; unfold Rsqr in |- *; ring
      | apply Rplus_le_le_0_compat
      | apply Rplus_le_le_0_compat
      | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr.
Qed.

Lemma triangle :
  forall x0 y0 x1 y1 x2 y2:R,
    dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
Proof.
  intros; unfold dist_euc in |- *; apply Rsqr_incr_0;
    [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
      [ replace (Rsqr (x0 - x1)) with
        (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1));
        [ replace (Rsqr (y0 - y1)) with
          (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1));
          [ apply Rplus_le_reg_l with
            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
              Rsqr (y2 - y1));
            replace
            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
              Rsqr (y2 - y1) +
              (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1) +
                (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1))))
            with (2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1)));
              [ replace
                (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
                  Rsqr (y2 - y1) +
                  (Rsqr (x0 - x2) + Rsqr (y0 - y2) +
                    (Rsqr (x2 - x1) + Rsqr (y2 - y1)) +
                    2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with
                (2 *
                  (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1))));
                [ apply Rmult_le_compat_l;
                  [ left; cut (0%nat <> 2%nat);
                    [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
                      intro H0; assumption
                      | discriminate ]
                    | apply sqrt_cauchy ]
                  | ring ]
                | ring ]
            | ring_Rsqr ]
          | ring_Rsqr ]
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr ]
      | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr
      | apply Rplus_le_le_0_compat; apply sqrt_positivity;
        apply Rplus_le_le_0_compat; apply Rle_0_sqr ].
Qed.

(******************************************************************)
(** *                       Translation                           *)
(******************************************************************)

Definition xt (x tx:R) : R := x + tx.
Definition yt (y ty:R) : R := y + ty.

Lemma translation_0 : forall x y:R, xt x 0 = x /\ yt y 0 = y.
Proof.
  intros x y; split; [ unfold xt in |- * | unfold yt in |- * ]; ring.
Qed.

Lemma isometric_translation :
  forall x1 x2 y1 y2 tx ty:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
Proof.
  intros; unfold Rsqr, xt, yt in |- *; ring.
Qed.

(******************************************************************)
(** *                         Rotation                            *)
(******************************************************************)

Definition xr (x y theta:R) : R := x * cos theta + y * sin theta.
Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta.

Lemma rotation_0 : forall x y:R, xr x y 0 = x /\ yr x y 0 = y.
Proof.
  intros x y; unfold xr, yr in |- *; split; rewrite cos_0; rewrite sin_0; ring.
Qed.

Lemma rotation_PI2 :
  forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x.
Proof.
  intros x y; unfold xr, yr in |- *; split; rewrite cos_PI2; rewrite sin_PI2;
    ring.
Qed.

Lemma isometric_rotation_0 :
  forall x1 y1 x2 y2 theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
    Rsqr (yr x1 y1 theta - yr x2 y2 theta).
Proof.
  intros; unfold xr, yr in |- *;
    replace
    (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
    (cos theta * (x1 - x2) + sin theta * (y1 - y2));
    [ replace
      (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta))
      with (cos theta * (y1 - y2) + sin theta * (x2 - x1));
        [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2;
          ring_simplify; replace (x2 - x1) with (- (x1 - x2));
          [ rewrite <- Rsqr_neg; ring | ring ]
          | ring ]
      | ring ].
Qed.

Lemma isometric_rotation :
  forall x1 y1 x2 y2 theta:R,
    dist_euc x1 y1 x2 y2 =
    dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
    (yr x2 y2 theta).
Proof.
  unfold dist_euc in |- *; intros; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
      | apply sqrt_positivity; apply Rplus_le_le_0_compat
      | repeat rewrite Rsqr_sqrt;
        [ apply isometric_rotation_0
          | apply Rplus_le_le_0_compat
          | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
Qed.

(******************************************************************)
(** *                       Similarity                            *)
(******************************************************************)

Lemma isometric_rot_trans :
  forall x1 y1 x2 y2 tx ty theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
    Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta).
Proof.
  intros; rewrite <- isometric_rotation_0; apply isometric_translation.
Qed.

Lemma isometric_trans_rot :
  forall x1 y1 x2 y2 tx ty theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
    Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty).
Proof.
  intros; rewrite <- isometric_translation; apply isometric_rotation_0.
Qed.


(** An Ssreflect Tutorial *)

(** http://hal.archives-ouvertes.fr/docs/00/40/77/78/PDF/RT-367.pdf  *)

Require Import ssreflect ssrbool eqtype ssrnat.

(** 2.3 Two so-called paradoxes *)

(**
その1. 対称律と遷移律だけでは、反射律は証明できない、ということ。
*)
Section R_sym_trans.
Variables (D : Type) (R : D -> D -> Prop).

Hypothesis R_sym : forall x y, R x y -> R y x.
Hypothesis R_trans : forall x y z, R x y -> R y z -> R x z.

Lemma refl_if : forall x : D, (exists y, R x y) -> R x x.
Proof.
  move=> x [y Rxy].
    by apply: R_trans _ (R_sym _ y _).
Qed.

Lemma refl_if' : forall x : D, (exists y, R x y) -> R x x.
Proof.
  move=> x.
  (* (exists y : D, R x y) -> R x x *)
  case.
  (* forall y : D, (R x y -> R x x) *)
  move=> y Rxy.
  (* R x x *)
  move: (R_sym x y Rxy).                    (* R y x *)
  move: Rxy.                                (* R x y *)
  move: (R_trans x y x).                    (* R x y -> R y x -> R x x *)
  apply.
Qed.
End R_sym_trans.

(**
その2. スマリヤン・ドリンカー
 *)
Section Smullyan_drinker.
Variables (D : Type) (P : D -> Prop).

Hypothesis (d : D) (EM : forall A, A \/ ~A). (* 排中律 *)

Lemma drinker : exists x, P x -> forall y, P y.
Proof.
  case: (EM (exists y, ~P y)) => [[y notPy] | nonotPy];
  first by exists y.
    exists d => _ y;
      case: (EM (P y)) => // notPy.
      by case: nonotPy; exists y.
Qed.

(* 分解した書き方 *)
Lemma drinker' : exists x, (P x -> forall y, P y).
Proof.
  Check (EM (exists y, ~P y)).
  (* (exists y : D, ~ P y) \/ ~ (exists y : D, ~ P y) *)
  move: (EM (exists y, ~P y)).
  case.
  (* (exists y : D, ~ P y) -> exists x : D, (P x -> forall y : D, P y) *)
    move=> [y notPy].
    exists y.
    done.
  (* (**) ~ (exists y : D, ~ P y) -> exists x : D, P x -> forall y : D, P y *)
  move=> nonotPy.
  exists d => HPd y.
  (* P y *)

  Check (EM (P y)).
  (* 排中律 (P y \/ ~ P y) *)
  move: (EM (P y)).
  (* P y \/ ~ P y -> P y *)
  case.
  (*P y -> P y *)
    move=> //.
  (* ~ P y -> P y *)
  move=> notPy.
  move: nonotPy.
  (* ~ (exists z : D, ~ P z) -> P y *)
  case.
  (* exists z : D, ~ P z *)
  exists y.
  (* ~ P y *)
  done.
Qed.

(**
最初の排中律を左側の場合を使ったゴールが、パラドックスの本質なのだが、簡単に解けてしまう。
排中律の右側の場合を使ったゴール (**) は、
~ (exists y : D, ~ P y) -> exists x : D, P x -> forall y : D, P y

スタックの先頭をドモルガンの定理で書き換えられるなら簡単にとけてしまう。
(forall y : D, P y) -> exists x : D, P x -> forall y : D, P y

そこで、ドモルガンの定理だけを証明する部分を取り出してみる。
ここにも、排中律が必要である。
*)

Lemma deMorgan : ~ (exists y : D, ~ P y) -> forall y : D, P y.
Proof.
  move=> nonotPy y.
  move: (EM (P y)).
  case.
    by [].
  move=> notPy.
  move: nonotPy.
  case.
  exists y.
  by [].
Qed.

Lemma drinker'' : exists x, (P x -> forall y, P y).
Proof.
  Check (EM (exists y, ~P y)).
  (* (exists y : D, ~ P y) \/ ~ (exists y : D, ~ P y) *)
  move: (EM (exists y, ~P y)).
  case.
  (* (exists y : D, ~ P y) -> exists x : D, (P x -> forall y : D, P y) *)
  (* 誰も飲んでいないなら、（誰かが飲んでいれば）、皆が飲んでいる、は成立する。 *)
    move=> [y notPy].
    exists y.
    done.
  (* ~ (exists y : D, ~ P y) -> exists x : D, (P x -> forall y : D, P y) *)
  (* (forall y : D, P y) -> exists x : D, P x -> forall y : D, P y *)
  (* 皆が飲んでいるなら、（誰かが飲んでいれば）、皆が飲んでいる、は成立する。 *)
  move=> nonotPy.
  exists d => HPd y.
  apply: deMorgan.
  apply: nonotPy.
Qed.

End Smullyan_drinker.

(* END *)


Require Import Lia.
Load Preamble.

Definition Spec {X Y} (f : option X -> option Y) x r_x :=
  match f None, f(Some x) with
  | None    , _       => f(Some x) = Some r_x
  | Some y0 , None    => r_x = y0
  | Some y0 , Some y  => r_x <> y0 /\ r_x = y
  end.

Definition R {X Y} (f : option X -> option Y) :
  (forall x, f(Some x) <> f None) -> forall x, { r_x & Spec f x r_x}.
Proof.
  unfold Spec; intros H x.
  destruct  (f None) as [y0|] eqn:?,
            (f (Some x)) as [y|] eqn:?.
  - exists y. split; congruence.
  - exists y0. reflexivity.
  - exists y. reflexivity.
  - exfalso. now apply (H x).
Defined.

Definition r {X Y} (f : option X -> option Y) H x := projT1 (R f H x).
Definition r_spec {X Y} (f : option X -> option Y) H x := projT2 (R f H x).

Lemma r_agree {X Y} (f : option X -> option Y) H x x' :
let r := r f H in
  r x = r x' -> f(Some x) = f(Some x').
Proof.
  unfold r; intros e.
  generalize (r_spec f H x), (r_spec f H x').
  rewrite <-e.
  generalize (projT1 (R f H x)) as z.
  intros ?. clear e; unfold Spec.
  destruct (f None) as [y0|]. 2: congruence.
  destruct  (f (Some x)) as [y|],
            (f (Some x')) as [y'|].
  * intros [][]; subst; congruence.
  * intros [] ?; subst; congruence.
  * intros ? []; subst; congruence.
  * intros [][]; reflexivity.
Qed.

Lemma pred_LEM_ {X} (p : X -> Prop) :
  ~~((forall x : X, ~~p x) \/ (exists x, ~p x)).
Proof.
  DN.lem_ (exists x, ~p x). apply DN.ret.
  intros [| H]; auto.
  left. intros x.
  DN.lem_ (p x). apply DN.ret.
  intros []; auto.
  exfalso. apply H.
  now exists x.
Qed.

Lemma Pigeonhole X Y (f : option X -> option Y) :
  (forall g : option Y -> option X, exists x, forall y, g y <> x) ->
  ~~ exists a b, a <> b /\ f a = f b.
Proof.
  intros nonSurj.
  destruct (nonSurj (fun _ => None)).
  specialize (H None).
  destruct (dec_exists (fun x => f(Some x) = f None)) as [H|H].
  { intros ?; apply EQ_fin. }
  - destruct H as [x ]. exists (Some x), None.
    split; congruence.
  - destruct (IHN _ (r f H) ltac:(lia)) as (x & x' &[]).
    exists (Some x), (Some x').
    split; try congruence.
    eapply r_agree; eauto.
Qed.