(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Binary modified Post correspondence problem (MPCPb)
  to:
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)
*)

Require Import List Lia.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Require Import Undecidability.HilbertCalculi.HSC.
Require Import Undecidability.HilbertCalculi.Util.HSCFacts.

Require Import Undecidability.PCP.PCP.

Set Default Goal Selector "!".

Module Argument.

Local Arguments incl_cons_inv {A a l m}.
Local Arguments incl_cons {A a l m}.

Definition bullet := var 0.
(* encodes symbol true *)
Definition b2 := (arr bullet bullet).
(* encodes symbol false *)
Definition b3 := arr bullet (arr bullet bullet).

Fixpoint append_word (s: formula) (v: list bool) :=
  match v with
  | [] => s
  | a :: v =>
    if a then append_word (arr b2 s) v
    else append_word (arr b3 s) v
  end.

Definition encode_word (v: list bool) := append_word bullet v.
Definition encode_pair (s t: formula) := arr b3 (arr s (arr t b3)).

Local Notation "⟨ s , t ⟩" := (encode_pair s t).
Local Notation "⟦ v ⟧" := (encode_word v).
Local Notation "s → t" := (arr s t) (at level 50).

(* environment encoding the instance ((v, w), P) of BMPCP *)
Definition Γ v w P :=
  (encode_pair (var 1) (var 1)) ::
  (arr (encode_pair (encode_word v) (encode_word w)) a_b_a) ::
  map (fun '(v, w) => arr (encode_pair (append_word (var 2) v) (append_word (var 3) w)) (encode_pair (var 2) (var 3))) ((v, w) :: P).

(* if t is derivable from a → b → a, then so is s → t *)
Lemma arr_allowed {s t} : hsc [a_b_a] t -> hsc [a_b_a] (arr s t).
Proof.
  move=> H. apply: hsc_arr; last by eassumption.
  pose ζ i := if i is 0 then t else if i is 1 then s else var i.
  have -> : arr t (arr s t) = substitute ζ a_b_a by done.
  apply: hsc_var. by left.
Qed.

(* • → • → • is derivable from a → b → a *)
Lemma b3_allowed : hsc [a_b_a] b3.
Proof.
  pose ζ i := if i is 0 then bullet else if i is 1 then bullet else var i.
  have -> : b3 = substitute ζ a_b_a by done.
  apply: hsc_var. by left.
Qed.

(* Γ v w P is derivable from a → b → a *)
Lemma Γ_allowed {v w P} : forall r, In r (Γ v w P) -> hsc [a_b_a] r.
Proof.
  apply /Forall_forall. constructor; [|constructor; [|constructor]].
  - do 3 (apply: arr_allowed). by apply: b3_allowed.
  - apply: arr_allowed.
    have -> : a_b_a = substitute var a_b_a by done.
    apply: hsc_var. by left.
  - do 4 (apply: arr_allowed). by apply: b3_allowed.
  - apply /Forall_forall => ? /in_map_iff [[x y]] [<- _].
    do 4 (apply: arr_allowed). by apply: b3_allowed.
Qed.

Lemma encode_word_last {a v} : encode_word (v ++ [a]) = arr (if a then b2 else b3) (encode_word v).
Proof.
  rewrite /encode_word. move: (bullet) => r. elim: v r.
  { move=> r. by case: a. }
  move=> b A IH r. case: b; by apply: IH.
Qed.

Lemma encode_word_app {v x} : encode_word (v ++ x) = append_word (encode_word v) x.
Proof.
  elim: x v.
  { move=> v. by rewrite app_nil_r. }
  move=> a x IH v.
  rewrite -/(app [a] _) ? app_assoc IH encode_word_last.
  by case: a.
Qed.

(* unifiable words are equal *)
Lemma unify_words {v w ζ} : substitute ζ (encode_word v) = substitute ζ (encode_word w) -> v = w.
Proof.
  move: v w. elim /rev_ind.
  { elim /rev_ind; first done.
    move=> b w _. rewrite encode_word_last.
    move: b => [] /(f_equal size) /=; by lia. }
  move=> a v IH. elim /rev_ind.
  { rewrite encode_word_last.
    move: a => [] /(f_equal size) /=; by lia. }
  move=> b w _. rewrite ? encode_word_last.
  case: a; case: b; move=> /=; case.
  - by move /IH => ->.
  - move /(f_equal size) => /=. by lia.
  - move /(f_equal size) => /=. by lia.
  - by move /IH => ->.
Qed.

Lemma substitute_combine {ζ ξ r v x} :
  ζ 0 = ξ 0 ->
  substitute ζ r = substitute ξ (encode_word v) ->
  substitute ζ (append_word r x) = substitute ξ (encode_word (v ++ x)).
Proof.
  move=> ?. elim: x v r.
  { move=> ?. by rewrite app_nil_r. }
  move=> a x IH v r /=.
  have -> : v ++ a :: x = v ++ [a] ++ x by done.
  rewrite app_assoc. move=> ?.
  case: a; apply: IH; rewrite encode_word_last /=; by congruence.
Qed.

Lemma tau1_lastP {x y: list bool} {A} : tau1 (A ++ [(x, y)]) = tau1 A ++ x.
Proof.
  elim: A; first by rewrite /= app_nil_r.
  move=> [a b] A /= ->. by rewrite app_assoc.
Qed.

Lemma tau2_lastP {x y: list bool} {A} : tau2 (A ++ [(x, y)]) = tau2 A ++ y.
Proof.
  elim: A; first by rewrite /= app_nil_r.
  move=> [a b] A /= ->. by rewrite app_assoc.
Qed.

(* derivability of an instance of a → b → a *)
Definition adequate v w P n :=
  exists p q, der (Γ v w P) n (arr p (arr q p)).

(* derivability of (v ++ v₁ ++...++ vₙ, w ++ w₁ ++...++ wₙ) *)
Definition solving (v w: list bool) P n :=
  exists A,
    (incl A ((v, w) :: P)) /\
    exists ζ, der (Γ v w P) n
      (substitute ζ (encode_pair
        (encode_word (v ++ tau1 A))
        (encode_word (w ++ tau2 A)))).

Lemma adequate_step {v w P n} : adequate v w P (S n) -> adequate v w P n \/ solving v w P n.
Proof.
  move=> [p [q /derE]] => [[ζ [s [k]]]].
  rewrite {1}/Γ /In -/(In _ _). case. case; last case.
  (* case ⟨ a, a ⟩ *)
  {
    move=> ?. subst s. case: k.
    { move=> [_] /=. case=> -> ->.
      move=> /(f_equal size) /=. by lia. }
    move=> k /= [/Forall_cons_iff] [? _] _. left.
    eexists. eexists. by eassumption.
  }
  (* case ⟨ v, w ⟩ → a → b → a *)
  {
    move=> ?. subst s. case: k.
    { move=> [_] /=. case=> <- _.
      case=> _ /(f_equal size) /=. by lia. }
    move=> k /= [/Forall_cons_iff] [? _] _. right.
    exists []. constructor; first done.
    eexists. rewrite ? app_nil_r /=. by eassumption.
  }
  (* case ⟨ va, wb ⟩ → ⟨ a, b ⟩ *)
  {
    move /in_map_iff => [[x y] [<- _]] /=. case: k; last case.
    - move=> [_] /=.
      case=> <- _. case=> _ _ _ /(f_equal size) /=. by lia.
    - move=> [_] /=. case=> <- _. move=> /(f_equal size) /=. by lia.
    - move=> k /= [/Forall_cons_iff] [_] /Forall_cons_iff [? _] _.
      left. eexists. eexists. by eassumption.
  }
Qed.

Lemma solving_step {v w P n} : solving v w P (S n) -> adequate v w P n \/ solving v w P n \/ MPCPb ((v, w), P).
Proof.
  move=> [A [HA [ξ /derE]]]. move=> [ζ [s [k]]].
  rewrite {1}/Γ /In -/(In _ _). case. case; last case.
  (* case ⟨ a, a ⟩ *)
  {
    move=> ?. subst s. case: k.
    { move=> /= [_]. case=> _ _ _ -> /unify_words HA2 _ _ _.
      right. right. eexists. by constructor; eassumption. }
    move=> k /= [/Forall_cons_iff] [? _] *.
    left. eexists. eexists. by eassumption.
  }
  (* case ⟨ v, w ⟩ → a → b → a *)
  {
    move=> ?. subst s. case: k.
    { move=> /= [_]. case=> <- _ /(f_equal size) /=. by lia. }
    move=> k /= [/Forall_cons_iff] [? _] *.
    right. left. exists []. constructor; first done.
    eexists. move=> /=. rewrite ? app_nil_r. by eassumption.
  }
  (* case ⟨ va, wb ⟩ → ⟨ a, b ⟩ *)
  {
    move /in_map_iff => [[x y]]. move=> [<- ?] /=. case: k; last case.
    (* k = 0 *)
    - move=> [_] /=. case=> -> _ /(f_equal size) /=. by lia.
    (* k = 1 *)
    - move=> /= [/Forall_cons_iff] [H1 _] [] H2. move: H1. rewrite H2.
      rewrite - ? /(substitute ζ (var _)).
      move=> + _ _ /(substitute_combine H2 (x := x)) Hx.
      move=> + /(substitute_combine H2 (x := y)) Hy _ _ _.
      rewrite Hx Hy => HD. right. left.
      exists (A ++ [(x, y)]). constructor.
      { apply: incl_app; first done.
        by apply /incl_cons. }
      exists ξ => /=. by rewrite tau1_lastP tau2_lastP ? app_assoc.
    (* k = 2 *)
    - move=> k /= [/Forall_cons_iff] [_ /Forall_cons_iff] [? _] *.
      left. eexists. eexists. by eassumption.
  }
Qed.

Lemma adequate0E {v w P} : not (adequate v w P 0).
Proof. by move=> [? [?]] /derE. Qed.

Lemma solving0E {v w P} : not (solving v w P 0).
Proof. by move=> [? [? [?]]] /derE. Qed.

(* if ((v, w), P) is adequate, then MPCPb is solvable *)
Lemma complete_adequacy {v w P n}: adequate v w P n -> MPCPb ((v, w), P).
Proof.
  apply: (@proj1 _ (solving v w P n -> MPCPb ((v, w), P))).
  elim: n.
  { constructor; [by move /adequate0E | by move /solving0E]. }
  move=> n [IH1 IH2]. constructor.
  { by case /adequate_step. }
  by case /solving_step; last case.
Qed.

(* if a → b → a is derivable, then MPCPb is solvable *)
Lemma completeness {v w P} : hsc (Γ v w P) a_b_a -> MPCPb ((v, w), P).
Proof.
  move /hsc_der => [n ?]. apply: complete_adequacy.
  eexists. eexists. by eassumption.
Qed.

Lemma transparent_encode_pair {ζ s t} : ζ 0 = var 0 ->
  substitute ζ (encode_pair s t) = encode_pair (substitute ζ s) (substitute ζ t).
Proof. by move=> /= ->. Qed.

Lemma transparent_append_word {ζ s v} : ζ 0 = var 0 ->
  substitute ζ (append_word s v) = append_word (substitute ζ s) v.
Proof.
  move=> Hζ. elim: v s; first done.
  move=> a v IH s.
  case: a; by rewrite /b3 /b2 /bullet IH /= Hζ.
Qed.

Lemma substitute_arrP {ζ s t} : substitute ζ (arr s t) = arr (substitute ζ s) (substitute ζ t).
Proof. done. Qed.

(* key inductive argument for the soundness lemma *)
Lemma soundness_ind {v w P x y A} :
  incl A ((v, w) :: P) ->
  x ++ tau1 A = y ++ tau2 A ->
  hsc (Γ v w P) (encode_pair (encode_word x) (encode_word y)).
Proof.
  elim: A x y.
  { move=> x y _ /=. rewrite ? app_nil_r => <-.
    pose ζ i := if i is 1 then encode_word x else var i.
    have -> : encode_pair (encode_word x) (encode_word x) =
      substitute ζ (encode_pair (var 1) (var 1)) by done.
    apply: hsc_var.
    rewrite /Γ /In. by left. }
  move=> [a b] A IH x y /incl_cons_inv [? HA].
  rewrite /tau1 -/tau1 /tau2 -/tau2 ? app_assoc.
  move /IH => /(_ HA) ?.
  apply: hsc_arr; last eassumption.
  rewrite ? encode_word_app.
  pose ζ i := if i is 2 then encode_word x else if i is 3 then encode_word y else var i.
  have -> : encode_word x = substitute ζ (var 2) by done.
  have -> : encode_word y = substitute ζ (var 3) by done.
  rewrite - ? transparent_append_word; try done.
  rewrite - ? transparent_encode_pair; try done.
  rewrite - substitute_arrP.
  apply: hsc_var. rewrite /Γ.
  right. right. rewrite in_map_iff.
  exists (a, b). by constructor.
Qed.

Lemma soundness {v w P} : MPCPb ((v, w), P) -> hsc (Γ v w P) a_b_a.
Proof.
  move=> [A [/soundness_ind + H]] => /(_ _ _ H){H} ?.
  apply: hsc_arr; last eassumption.
  pose ζ i := var i.
  have Hζ: forall s, s = substitute ζ s.
  { elim; first done.
    by move=> ? + ? /= => <- <-. }
  rewrite (Hζ (arr _ _)).
  apply: hsc_var. rewrite /Γ. right. by left.
Qed.

End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* Reduction from MPCPb to HSC_AX *)
Theorem reduction : MPCPb ⪯ HSC_AX.
Proof.
  exists (fun '((v, w), P) => exist _ (Argument.Γ v w P) Argument.Γ_allowed).
  intros [[v w] P]. constructor.
  - exact Argument.soundness.
  - exact Argument.completeness.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Coq.Lists.List Coq.Sorting.Permutation.

From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts Eq.Rutt Props.Finite.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts Logic.Classical.
Require Import Lia.
Require Export Refinement Combinators ConvergentRefinement ConcreteRefinement Automation Merge.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Open Scope list_scope.

Lemma and_or_spec E R (t1 t2 : itree_spec E R) :
  padded_refines_eq eq (and_spec t1 t2) (or_spec t1 t2).
Proof.
  unfold and_spec, or_spec, padded_refines_eq, padded_refines.
  setoid_rewrite pad_vis. pstep. red. cbn. econstructor. constructor.
  Unshelve. all : try apply true. econstructor. cbn. constructor.
  Unshelve. all : try apply true. pstep_reverse.
  enough (padded_refines_eq eq t1 t1). auto. reflexivity.
Qed.

Definition halve_spec_fix {E} : list nat -> itree_spec E (list nat * list nat) :=
  rec_fix_spec (fun halve_spec_rec l =>
                  n <- exists_spec nat;;
                  trepeat n ( l' <- exists_spec (list nat);; halve_spec_rec l' );;
                  halve_spec l
               ).

Variant halve_call : forall A, callE (list nat) (list nat * list nat) A -> A -> Prop :=
  | halve_call_i (l l1 l2: list nat) :
    Permutation l (l1 ++ l2) ->
    (length l1 >= length l2 /\ (length l > length l1 \/ length l <= 1)) ->
    halve_call _ (Call l) (l1,l2).

Lemma halve_correct' E l : padded_refines_eq eq (@halve E l) (halve_spec_fix l).
Proof.
  eapply padded_refines_monot with (RPre1 := eqPreRel)
                                   (RPost1 := eqPostRel)
                                   (RR1 := subEqPostRel halve_call _ _ (Call l) (Call l)); eauto.
  { intros [l1 l2] [l3 l4]. intros. inv PR. inj_existT. subst. auto. }
  eapply padded_refines_mrec with (RPreInv := eqPreRel)
                                  (* in this post condition need to include *)
                                  (RPostInv := subEqPostRel halve_call).
  2 : constructor. intros.
  eqPreRel_inv H. clear l. destruct d2 as [l]. cbn.
  destruct l as [ | a [ | b l] ].
  - existssr 0. rewrite trepeat_0. rewrite bind_ret_l.
    existssr (@nil nat). existssr (@nil nat). assertsr. reflexivity.
    assertsr. cbn. lia.
    apply padded_refines_ret. do 2 constructor. reflexivity.
    cbn. lia. (*note reflexivity is not enough this is a subreflexive rel*)
  - existssr 0. rewrite trepeat_0. rewrite bind_ret_l.
    existssr (a :: nil). existssr (@nil nat). assertsr. reflexivity.
    assertsr. cbn. lia. apply padded_refines_ret. do 2 constructor.
    reflexivity. cbn. lia.
  - cbn. existssr 1. rewrite trepeat_Sn. setoid_rewrite trepeat_0.
    cbn. repeat rewrite bind_bind. existssr l.
    eapply padded_refines_bind with (RR :=
                                    subEqPostRel halve_call (list nat * list nat) (list nat * list nat) (Call (l)) (Call (l))).
    + unfold call_spec. apply padded_refines_vis. repeat constructor.
      intros [l1 l2] r Hl12. inv Hl12. inj_existT. subst.
      inv H5. inj_existT. subst. apply padded_refines_ret.
      constructor. auto.
    + intros [l1 l2] r2 Heq. inv Heq. inj_existT. subst.
      inv H4. inj_existT. injection H5. intros. subst.
      rewrite bind_ret_l.
      existssr (a :: l1). existssr (b :: l2). assertsr.
      { cbn. rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity. }
      assertsr.
      { cbn. rewrite H0. repeat rewrite app_length. lia. }
      apply padded_refines_ret. do 2 constructor.
      { cbn. rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity. }
      cbn. repeat rewrite H0. repeat rewrite app_length. lia.
Qed.

Lemma auto_halve_correct' E l :
  padded_refines_eq eq (@halve E l) (@halve_spec_fix E l).
Proof.
  unfold halve, halve_spec_fix, halve_spec.
  prove_refinement.
  - exact (a = a0).
  - exact ((Permutation a (fst r ++ snd r)) /\
           (length (fst r) >= length (snd r) /\ (length a > length (fst r) \/ length a <= 1))).
  - prove_refinement_continue.
    all: cbn; cbn in *.
    all: try split; try easy; try lia.
    + rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity.
    + rewrite H0. repeat rewrite app_length. lia.
    + rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity.
    + repeat rewrite H0. repeat rewrite app_length. lia.
Qed.

Opaque assume_spec.
Opaque assert_spec.
Opaque forall_spec.
Opaque exists_spec.

Lemma halve_spec_fix_correct' E l :
  padded_refines_eq eq (@halve E l) (partial_spec_fix (fun _ => True)
                                                   (fun l '(l1,l2) => Permutation l (l1 ++ l2) /\
                               (length l1 >= length l2 /\ (length l > length l1 \/ length l <= 1))) l).
Proof.
  eapply padded_refines_monot with (RPre1 := eqPreRel)
                                   (RPost1 := eqPostRel)
                                   (RR1 := subEqPostRel halve_call _ _ (Call l) (Call l)); eauto.
  { intros [l1 l2] [l3 l4]. intros. inv PR. inj_existT. subst. auto. }
    eapply padded_refines_mrec with (RPreInv := eqPreRel)
                                  (* in this post condition need to include *)
                                  (RPostInv := subEqPostRel halve_call).
  2 : constructor. intros.
  eqPreRel_inv H. clear l. destruct d2 as [l]. cbn.
  destruct l as [ | a [ | b l] ].
  - assumesr. intros _. rewrite bind_bind. existssr 0.
    cbn. rewrite bind_ret_l. existssr (@nil nat,@nil nat).
    assertsr. split. reflexivity. lia.
    apply padded_refines_ret. do 2 constructor. reflexivity. cbn. lia.
  - assumesr. intros _. rewrite bind_bind. existssr 0.
    cbn. rewrite bind_ret_l. existssr (a :: nil, @nil nat).
    assertsr. split. reflexivity. cbn. lia.
    apply padded_refines_ret. do 2 constructor. reflexivity. cbn. lia.
  - assumesr. intros _. rewrite bind_bind. existssr 1.
    cbn. repeat rewrite bind_bind. existssr l.
    repeat rewrite bind_bind.
    assertsr. auto. setoid_rewrite bind_ret_l.
    eapply padded_refines_bind with  (RR :=
                                    subEqPostRel halve_call (list nat * list nat) (list nat * list nat) (Call (l)) (Call (l))).
    { apply padded_refines_vis. constructor. constructor. intros [l1 l2] b0 Hl12.
      inv Hl12. inj_existT. subst. inv H5. inj_existT. subst.
      apply padded_refines_ret. constructor. auto. }
    intros [l1 l2] r Hl12. inv Hl12. inj_existT. subst. inv H4. inj_existT.
    injection H5; intros; subst. existssr (a :: l1,b :: l2). assertsr.
    split.
    { cbn. rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity. }
    { cbn. repeat rewrite H0. repeat rewrite app_length. lia. }
    apply padded_refines_ret. constructor. constructor.
    { cbn. rewrite Permutation_app_comm. cbn.
      rewrite H0. rewrite Permutation_app_comm. reflexivity. }
    { cbn. repeat rewrite H0. repeat rewrite app_length. lia. }
 Qed.

  (* this is maybe a tad more subtle then I realized, does it require transitivity?,
     that would not be problematic for these relations because there seem to be PER's

   *)

(*
Theorem merge
*)


(* Software Foundations *)
(* Exercice 3 stars, excluded_middle_irrefutable *)

Axiom excluded_middle: forall  P:Prop, P \/ ~P.

Theorem excluded_middle_irrefutable: forall (P:Prop), ~~(P \/ ~ P).
Proof.
    compute. intros. apply H. destruct H. apply excluded_middle.
Qed.


(**************************************************************************)
(*  This is part of EXCEPTIONS, it is distributed under the terms of the  *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Prerequistes Terms Decorations Axioms.
Set Implicit Arguments.

Module Make(Import M: Prerequistes.T).
  Module Export Derived_CoProjectionsExp := Axioms.Make(M).

 Definition permut {X Y} : term (X+Y) (Y+X) := copair in2 in1.
 Definition rcopair {X Y Z} (f: term X Y) (g: term X Z): term X (Y+Z) := copair g f o (@permut Z Y).

 Lemma is_permut X Y: EPURE (@permut X Y).
 Proof. edecorate. Qed.

Lemma is_rcopair: forall k X Y Z (f1: term Z X) (f2: term Z Y), PPG f2 -> is k f1 -> is k f2 -> is k (rcopair f1 f2). (* FIXED *)
Proof. intros k X Y Z f1 f2 H1 H2 H3. induction k; edecorate. Qed.

Lemma s_rcopair_eq: forall X Z Y (f1: term X Y) (f2: term X Z), PPG f2 -> rcopair f1 f2 o in1 == f1.
Proof.
    intros X Y' Y f1 f2 H0. unfold rcopair, permut. rewrite <- assoc.
    cut (copair in2 in1 o in1 == (@in2 Y' Y)).
      intro H1. rewrite H1.
      apply s_lcopair_eq; exact H0.
      (*1st cut*)
      apply wtos; [edecorate| edecorate| ]. apply w_lcopair_eq; edecorate.
Qed.

Lemma w_rcopair_eq: forall X Z Y (f1: term X Y) (f2: term X Z), PPG f2 -> rcopair f1 f2 o in2 ~ f2.
Proof.
    intros X Y' Y f1 f2 H. unfold rcopair, permut. rewrite <- assoc.
    rewrite s_lcopair_eq;[| edecorate]. rewrite w_lcopair_eq;[reflexivity| edecorate].
Qed.

Lemma lcopair_u: forall X Y Y' (f1 f2: term X (Y' + Y)),
  (f1 o in1 ~ f2 o in1) /\ (f1 o in2 == f2 o in2) -> f1 == f2.
Proof.
    intros X Y Y' f1 f2 (H0&H1). apply eeffect.
    (* f 1 ◦ [ ] ≡ f 2 ◦ [ ] *)
    cut((@in2 Y' Y) o (@empty Y) == (@empty (Y' + Y))).
      intro H2. rewrite <- H2.
      setoid_rewrite assoc. rewrite H1. reflexivity.
      (* 1st cut *)
      setoid_rewrite s_empty; [reflexivity| edecorate].
    (* f 1 ∼ f 2 *)
    apply lcopair_ueq. exact H0. apply stow. exact H1.
Qed.

Lemma rcopair_u: forall X Y Y' (f1 f2: term X (Y' + Y)),
   (f1 o in1 == f2 o in1) /\ (f1 o in2 ~ f2 o in2) -> f1 == f2.
Proof.
     intros X Y Y' f1 f2 (H0&H1). apply eeffect.
     (* f 1 ◦ [ ] ≡ f 2 ◦ [ ] *)
     cut((@in1 Y' Y) o (@empty Y') == (@empty (Y' + Y))).
       intro H2. rewrite <- H2.
       setoid_rewrite assoc. rewrite H0. reflexivity.
       (* 1st cut *)
       setoid_rewrite s_empty; [reflexivity| edecorate].
     (* f 1 ∼ f 2 *)
     apply lcopair_ueq. apply stow. exact H0. exact H1.
Qed.

(* -------------------- End of Derived Pair Projections -------------------- *)

End Make.