From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import ordinals.

From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import proof_trees.
From Cyclic_PA.Logic Require Import substitute.
From Cyclic_PA.Logic Require Import PA_cyclic.

Require Import List.
Import ListNotations.

Definition dub_neg_sub_formula (A E : formula) (S : subst_ind) : formula :=
  formula_sub_ind A (neg (neg E)) E S.

Lemma dub_neg_formula_free :
  forall (A E : formula) (S : subst_ind),
      free_list (dub_neg_sub_formula A E S) = free_list A.
Proof.
intros A E S.
unfold dub_neg_sub_formula, formula_sub_ind.
case (subst_ind_fit A S) eqn:FIT.
- apply formula_sub_ind_free_list.
  reflexivity.
- reflexivity.
Qed.

Lemma dub_neg_sub_formula_closed :
    forall (A : formula),
        forall (E : formula) (S : subst_ind),
            closed A = closed (dub_neg_sub_formula A E S).
Proof.
intros A E S.
case (closed A) eqn:CA.
- unfold dub_neg_sub_formula.
  symmetry.
  apply (formula_sub_ind_closed _ _ _ CA).
  unfold closed; fold closed.
  intros CE.
  apply CE.
- case (closed (dub_neg_sub_formula A E S)) eqn:CnA.
  + apply closed_free_list in CnA.
    rewrite dub_neg_formula_free in CnA.
    apply free_list_closed in CnA.
    rewrite CnA in CA.
    inversion CA.
  + reflexivity.
Qed.

Fixpoint dub_neg_sub_ptree_fit
  (P : ptree) (E : formula) (S : subst_ind) : ptree :=
match P, S with
| deg_up d P', _ => deg_up d (dub_neg_sub_ptree_fit P' E S)

| ord_up alpha P', _ => ord_up alpha (dub_neg_sub_ptree_fit P' E S)

| node A, _ => node (dub_neg_sub_formula A E S)

| exchange_ab A B d alpha P', lor_ind S_B S_A =>
    exchange_ab
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula B E S_B)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind S_A S_B))

| exchange_cab C A B d alpha P', lor_ind (lor_ind S_C S_B) S_A =>
    exchange_cab
      (dub_neg_sub_formula C E S_C)
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula B E S_B)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind (lor_ind S_C S_A) S_B))

| exchange_abd A B D d alpha P', lor_ind (lor_ind S_B S_A) S_D =>
    exchange_abd
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula B E S_B)
      (dub_neg_sub_formula D E S_D)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind (lor_ind S_A S_B) S_D))

| exchange_cabd C A B D d alpha P', lor_ind (lor_ind (lor_ind S_C S_B) S_A) S_D =>
    exchange_cabd
      (dub_neg_sub_formula C E S_C)
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula B E S_B)
      (dub_neg_sub_formula D E S_D)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D))

| contraction_a A d alpha P', _ =>
    contraction_a
      (dub_neg_sub_formula A E S)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind S S))

| contraction_ad A D d alpha P', lor_ind S_A S_D =>
    contraction_ad
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula D E S_D)
      d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind (lor_ind S_A S_A) S_D))

| weakening_ad A D d alpha P', lor_ind S_A S_D =>
    (weakening_ad
      (dub_neg_sub_formula A E S_A)
      (dub_neg_sub_formula D E S_D)
      d alpha
      (dub_neg_sub_ptree_fit P' E S_D))

| demorgan_ab A B d1 d2 alpha1 alpha2 P1 P2, _ => P

| demorgan_abd A B D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_AB S_D =>
    demorgan_abd
      A B (dub_neg_sub_formula D E S_D) d1 d2 alpha1 alpha2
      (dub_neg_sub_ptree_fit P1 E (lor_ind (0) S_D))
      (dub_neg_sub_ptree_fit P2 E (lor_ind (0) S_D))

| negation_a A d alpha P', _ =>
    (match S, form_eqb A E with
    | (1), true => ord_up (ord_succ alpha) P'
    | _, _ => P
    end)

| negation_ad A D d alpha P', lor_ind S_A S_D =>
    (match S_A, form_eqb A E with
    | (1), true => ord_up (ord_succ alpha) (dub_neg_sub_ptree_fit P' E (lor_ind (non_target A) S_D))
    | _, _ =>
        negation_ad
          A
          (dub_neg_sub_formula D E S_D)
          d alpha
          (dub_neg_sub_ptree_fit P' E (lor_ind (non_target A) S_D))
    end)

| quantification_a A n t d alpha P', _ => P

| quantification_ad A D n t d alpha P', lor_ind S_A S_D =>
    quantification_ad
      A
      (dub_neg_sub_formula D E S_D)
      n t d alpha
      (dub_neg_sub_ptree_fit P' E (lor_ind (0) S_D))

| loop_a A n d1 d2 alpha1 alpha2 P1 P2, _ => P

| loop_ca C A n d1 d2 alpha1 alpha2 P1 P2, (lor_ind SC SA) =>
    loop_ca
      (dub_neg_sub_formula C E SC)
      A n d1 d2 alpha1 alpha2
      (dub_neg_sub_ptree_fit P1 E (lor_ind SC (non_target A)))
      P2

| loop_ad A D n d1 d2 alpha1 alpha2 P1 P2, (lor_ind SA SD) =>
    loop_ad
      A (dub_neg_sub_formula D E SD)
      n d1 d2 alpha1 alpha2
      P1 (dub_neg_sub_ptree_fit P2 E (lor_ind (non_target A) SD))

| loop_cad C A D n d1 d2 alpha1 alpha2 P1 P2, (lor_ind (lor_ind SC SA) SD) =>
    loop_cad
      (dub_neg_sub_formula C E SC)
      A
      (dub_neg_sub_formula D E SD)
      n d1 d2 alpha1 alpha2
      (dub_neg_sub_ptree_fit P1 E (lor_ind SC (non_target A)))
      (dub_neg_sub_ptree_fit P2 E (lor_ind (non_target A) SD))

| cut_ca C A d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ca
      (dub_neg_sub_formula C E S)
      A d1 d2 alpha1 alpha2
      (dub_neg_sub_ptree_fit P1 E (lor_ind S (non_target A)))
      P2

| cut_ad A D d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ad
      A (dub_neg_sub_formula D E S) d1 d2 alpha1 alpha2
      P1
      (dub_neg_sub_ptree_fit P2 E (lor_ind (0) S))

| cut_cad C A D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_C S_D =>
    cut_cad
      (dub_neg_sub_formula C E S_C)
      A (dub_neg_sub_formula D E S_D) d1 d2 alpha1 alpha2
      (dub_neg_sub_ptree_fit P1 E (lor_ind S_C (non_target A)))
      (dub_neg_sub_ptree_fit P2 E (lor_ind (0) S_D))

| _, _ => P
end.

Definition dub_neg_sub_ptree (P : ptree) (E : formula) (S : subst_ind) : ptree :=
match subst_ind_fit (ptree_formula P) S with
| false => P
| true => dub_neg_sub_ptree_fit P E S
end.

Lemma dub_neg_ptree_formula_true :
    forall (P : ptree) (E : formula) (S : subst_ind),
        subst_ind_fit (ptree_formula P) S = true ->
            dub_neg_sub_ptree_fit P E S = dub_neg_sub_ptree P E S.
Proof. intros. unfold dub_neg_sub_ptree. destruct P; rewrite H; auto. Qed.

Lemma dub_neg_ptree_formula' : forall (P : ptree) (E : formula),
  struct_valid P ->
      forall (S : subst_ind),
          subst_ind_fit (ptree_formula P) S = true ->
              ptree_formula (dub_neg_sub_ptree P E S) =
                  dub_neg_sub_formula (ptree_formula P) E S.
Proof.
intros P E PSV.
induction P; try intros S FS;
unfold dub_neg_sub_ptree;
rewrite FS;
unfold ptree_formula, node_extract in *; fold ptree_formula node_extract in *;
unfold dub_neg_sub_ptree_fit; fold dub_neg_sub_ptree_fit.

1 : destruct PSV as [ID PSV].
2 : destruct PSV as [[IO PSV] NO].
13-14 : destruct PSV as [[[PF PSV] PD] PO].

1-2 : rewrite (dub_neg_ptree_formula_true _ _ _ FS);
      unfold ptree_formula; fold ptree_formula;
      apply (IHP PSV _ FS).

1 : reflexivity.

5 : reflexivity.

all : destruct S;
      inversion FS as [FS'];
      try reflexivity;
      try apply and_bool_prop in FS' as [FS' FS1];
      unfold ptree_formula, dub_neg_sub_formula, formula_sub_ind, formula_sub_ind_fit, subst_ind_fit, form_eqb;
      fold form_eqb formula_sub_ind_fit ptree_formula subst_ind_fit.

8-10 :  case (form_eqb a E) eqn:FEQ;
        try reflexivity;
        try apply form_eqb_eq in FEQ;
        try destruct FEQ;
        try apply PF.

2-4,7-10,12,13 :  destruct S1;
                  inversion FS' as [FS''];
                  try apply and_bool_prop in FS' as [FS' FS2].

4 : destruct S1_1;
    inversion FS'' as [FS'''];
    apply and_bool_prop in FS' as [FS' FS3].

16 :  destruct S1_2;
      inversion FS2 as [FS'''];
      apply and_bool_prop in FS'' as [FS'' FS3].

all : unfold "&&";
      try rewrite FS;
      try rewrite FS';
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS2;
      try rewrite FS3;
      unfold ptree_formula;
      fold ptree_formula;
      try reflexivity.

1 : rewrite dub_neg_ptree_formula_true, (IHP PSV);
    try rewrite PF;
    unfold dub_neg_sub_formula, subst_ind_fit;
    fold subst_ind_fit.
    rewrite formula_sub_ind_lor, non_target_sub.

2-4 : rewrite non_target_fit, FS1;
      reflexivity.

1 : unfold formula_sub_ind.
    rewrite FS1.
    reflexivity.
Qed.

Lemma dub_neg_ptree_formula :
    forall (P : ptree) (E : formula),
        struct_valid P ->
            forall (S : subst_ind),
                ptree_formula (dub_neg_sub_ptree P E S) =
                    dub_neg_sub_formula (ptree_formula P) E S.
Proof.
intros P E PSV S.
destruct (subst_ind_fit (ptree_formula P) S) eqn:FS.
- apply (dub_neg_ptree_formula' _ _ PSV _ FS).
- unfold dub_neg_sub_ptree, dub_neg_sub_formula, formula_sub_ind.
  rewrite FS.
  reflexivity.
Qed.

Lemma dub_neg_ptree_deg :
    forall (P : ptree) (E : formula),
        struct_valid P ->
            forall (S : subst_ind),
                ptree_deg (dub_neg_sub_ptree P E S) = ptree_deg P.
Proof.
intros P E PSV.
unfold dub_neg_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold dub_neg_sub_ptree_fit; fold dub_neg_sub_ptree_fit;
unfold ptree_deg in *; fold ptree_deg in *;
try reflexivity.

1 : destruct PSV as [[IO PSV] NO].

9,10 : destruct PSV as [[[PF PSV] PD] PO].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PSV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb a E) eqn:EQ;
      unfold ptree_deg; fold ptree_deg;
      try rewrite PD;
      try reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_deg; fold ptree_deg;
      try reflexivity.

- assert (subst_ind_fit (ptree_formula P) (lor_ind (non_target a) S2) = true) as FSP.
  { rewrite PF.
    unfold subst_ind_fit; fold subst_ind_fit.
    rewrite non_target_fit.
    unfold "&&".
    apply FS''. }
  pose proof (IHP PSV (lor_ind (non_target a) S2)) as IHPS.
  rewrite FSP in IHPS.
  apply IHPS.
Qed.

Lemma dub_neg_ptree_ord :
    forall (P : ptree) (E : formula),
        struct_valid P ->
            forall (S : subst_ind),
                (ptree_ord (dub_neg_sub_ptree P E S)) = (ptree_ord P).
Proof.
intros P E PSV.
unfold dub_neg_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold dub_neg_sub_ptree_fit; fold dub_neg_sub_ptree_fit;
unfold ptree_ord in *; fold ptree_ord in *;
try reflexivity.

1 : destruct PSV as [ID PSV].

9,10 : destruct PSV as [[[PF PSV] PD] PO].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PSV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb a E) eqn:EQ;
      unfold ptree_deg; fold ptree_deg;
      try rewrite PD;
      try reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_deg; fold ptree_deg;
      try reflexivity.
Qed.

Lemma dub_neg_ptree_free_aux :
    forall (P : ptree) (E : formula),
        struct_valid P ->
            forall (S : subst_ind),
                (flat_map free_list (node_extract (dub_neg_sub_ptree_fit P E S)) = flat_map free_list (node_extract P)).
Proof.
intros P E PSV.
induction P;
intros S;
unfold dub_neg_sub_ptree_fit, node_extract, ptree_formula in *;
fold dub_neg_sub_ptree_fit node_extract ptree_formula in *;
try reflexivity.

1 : destruct PSV as [LT PSV]. (*deg up*)
2 : destruct PSV as [[LT PSV] NO]. (*ord up*)
3 : destruct PSV as []. (*node*)
4-9,12-14 :  destruct PSV as [[[PF PSV] PD] PO]. (*single hyp*)
13 : destruct PSV as [[[[PF CPF] PSV] PD] PO]. (*weakening*)
14-20 : destruct PSV as [[[[[[[P1F P1SV] P2F] P2SV] P1D] P2D] P1O] P2O]. (*double hyp*)

all : try rewrite PF in IHP;
      try rewrite P1F in IHP1;
      try rewrite P2F in IHP2.

3 : { unfold flat_map.
      rewrite dub_neg_formula_free.
      reflexivity. }

1,2 : try pose proof (IHP PSV S) as IHPS;
      try rewrite FS in IHPS;
      try apply IHPS.

16 :  { repeat rewrite flat_map_app.
        rewrite (IHP2 P2SV).
        reflexivity. }

15 :  { repeat rewrite flat_map_app.
        rewrite (IHP1 P1SV).
        reflexivity. }

5 : apply IHP, PSV.

all : destruct S;
      try rewrite IHP;
      try reflexivity.

2-4,7,13 :  destruct S1;
            try rewrite IHP;
            try reflexivity.

4 : destruct S1_1;
    try rewrite IHP;
    try reflexivity.

6,10 :  case (form_eqb a E) eqn:EQ;
        try rewrite IHP;
        try reflexivity.

all : unfold node_extract;
      fold node_extract;
      repeat rewrite flat_map_app;
      try rewrite (IHP PSV);
      try rewrite (IHP1 P1SV);
      try rewrite (IHP2 P2SV);
      try reflexivity.

all : repeat rewrite <- dub_neg_sub_formula_closed;
      try case (closed c) eqn:CC;
      try case (closed d) eqn:CD;
      unfold flat_map; fold (flat_map free_list);
      repeat rewrite flat_map_app;
      try rewrite (IHP PSV);
      try rewrite (IHP1 P1SV);
      try rewrite (IHP2 P2SV);
      try reflexivity.

7 : {  }
Qed.

Lemma dub_neg_struct_valid :
    forall (P : ptree) (E : formula),
        struct_valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    struct_valid (dub_neg_sub_ptree P E S).
Proof.
intros P E PSV.
induction P; try intros S FS;
unfold dub_neg_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold dub_neg_sub_ptree_fit; fold dub_neg_sub_ptree_fit.

all : try apply PSV.

1 : destruct PSV as [ID PSV].
2 : destruct PSV as [[IO PSV] NO].
3-8 : destruct PSV as [[[PF PSV] PD] PO].
9 : destruct PSV as [[[[PF FC] PSV] PD] PO].
11-13 : destruct PSV as [[[PF PSV] PD] PO].
10,14-19: destruct PSV as [[[[[[[P1F P1SV] P2F] P2SV] P1D] P2D] P1O] P2O].

3-6,8-19 :  destruct S; inversion FS as [FS'];
            try destruct (and_bool_prop _ _ FS') as [FS1 FS2].

4-6,12,22 : destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

6 : destruct S1_1; inversion FS'' as [FS'''];
    destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

10 :  assert (closed (neg (neg E)) = true -> closed E = true) as CIMP.
10 :  { unfold closed; fold closed;
        intros CE;
        apply CE. }

8,9,22,23 : case (form_eqb f E) eqn:EQ.

all : try apply form_eqb_eq in EQ;
      try destruct EQ;
      repeat rewrite dub_neg_ptree_formula_true;
      repeat split;
      try apply IHP;
      try apply IHP1;
      try apply IHP2;
      try rewrite dub_neg_ptree_deg;
      try rewrite dub_neg_ptree_ord;
      try rewrite dub_neg_ptree_formula;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold dub_neg_sub_formula, formula_sub_ind;
      try apply PSV;
      try rewrite PD;
      try rewrite PO;
      try apply P1SV;
      try rewrite P1D;
      try rewrite P1O;
      try apply P2SV;
      try rewrite P2D;
      try rewrite P2O;
      try apply ID;
      try apply IO;
      try apply NO;
      unfold subst_ind_fit; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite non_target_sub_fit;
      try rewrite FS;
      try rewrite FS';
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try rewrite FS2;
      unfold "&&";
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb; fold form_eqb;
      try rewrite non_target_sub_term';
      try rewrite non_target_sub';
      try rewrite <- (sub_fit_true _ _ _ _ FS1);
      try apply (formula_sub_ind_closed _ _ _ FC CIMP);
      try case (form_eqb f (neg E));
      try case (form_eqb f0 (neg E));
      try case (form_eqb (substitution f n (projT1 c)) (neg E));
      try reflexivity.

1,3 : apply ord_succ_monot.

all : try apply nf_nf_succ;
      try apply ptree_ord_nf_struct;
      try apply PSV.
Qed.

Lemma dub_neg_valid :
    forall (P : ptree) (E : formula),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    valid (dub_neg_sub_ptree P E S).
Proof.
intros P E [PSV PAX].
induction P; try intros S FS;
unfold dub_neg_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold dub_neg_sub_ptree_fit; fold dub_neg_sub_ptree_fit.

all : try apply (PSV,PAX).

1 : destruct PSV as [ID PSV].
2 : destruct PSV as [[IO PSV] NO].
3-8 : destruct PSV as [[[PF PSV] PD] PO].
9 : destruct PSV as [[[[PF FC] PSV] PD] PO].
11-13 : destruct PSV as [[[PF PSV] PD] PO].
10,14-19: destruct PSV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

3-6,8-19 :  destruct S; inversion FS as [FS'];
            try destruct (and_bool_prop _ _ FS') as [FS1 FS2].

4-6,12,22 : destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

6 : destruct S1_1; inversion FS'' as [FS'''];
    destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

10 :  assert (closed (neg (neg E)) = true -> closed E = true) as CIMP.
10 :  { unfold closed; fold closed;
        intros CE;
        apply CE. }

8,9,22,23 : case (form_eqb f E) eqn:EQ.

all : try apply form_eqb_eq in EQ;
      try destruct EQ;
      repeat rewrite dub_neg_ptree_formula_true;
      repeat split;
      try apply IHP;
      try apply IHP1;
      try apply IHP2;
      try rewrite dub_neg_ptree_deg;
      try rewrite dub_neg_ptree_ord;
      try rewrite dub_neg_ptree_formula;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold dub_neg_sub_formula, formula_sub_ind;
      try apply (PSV,PAX);
      try rewrite PD;
      try rewrite PO;
      try apply P1V;
      try rewrite P1D;
      try rewrite P1O;
      try apply P2V;
      try rewrite P2D;
      try rewrite P2O;
      try apply ID;
      try apply IO;
      try apply NO;
      unfold subst_ind_fit; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite FS;
      try rewrite FS';
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try rewrite FS2;
      unfold "&&";
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb; fold form_eqb;
      try rewrite non_target_sub';
      try rewrite <- (sub_fit_true _ _ _ _ FS1);
      try apply (formula_sub_ind_closed _ _ _ FC CIMP);
      try case (form_eqb f (neg E));
      try case (form_eqb f0 (neg E));
      try case (form_eqb (substitution f n (projT1 c)) (neg E));
      try reflexivity.

1,3 : apply ord_succ_monot.

all : apply nf_nf_succ;
      apply ptree_ord_nf;
      apply PSV.
Qed.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import finfun fintype tuple finset bigop.
From mathcomp Require Import ssralg fingroup morphism perm gproduct.
From mathcomp Require Import zmodp. (* Defines the coercion nat -> 'I_n.+1 *)
From mathcomp Require Import ssralg matrix vector mxalgebra falgebra ssrnum algC.
From mathcomp Require Import presentation classfun character mxrepresentation.

From Combi Require Import tools ordcast permuted symgroup partition Greene sorted.

Require Import ssrcomp slicedbij cycles cycletype.

Import LeqGeqOrder.

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

Import GroupScope GRing.Theory Num.Theory.

Local Notation algCF := [fieldType of algC].

Section classGroup.

Variables gT aT: finGroupType.
Variable G H : {group gT}.

Lemma class_disj x y :
  y \notin x ^: G -> x ^: G :&: y ^: G = set0.
Proof using.
move/class_eqP=> xy.
apply /setP=> a; rewrite !inE.
apply /andP => [][/class_eqP ax /class_eqP ay].
by apply xy; rewrite -ax -ay.
Qed.

Lemma prod_conjg (x y : gT * aT) :
  x ^ y = (x.1 ^ y.1, x.2 ^ y.2).
Proof using. by []. Qed.

End classGroup.

Section CFExtProdDefs.

Variables (gT aT : finGroupType).
Variables (G : {group gT}) (H : {group aT}).

Local Open Scope ring_scope.

Lemma cfextprod_subproof (g : 'CF(G)) (h : 'CF(H)) :
  is_class_fun <<setX G H>> [ffun x => (g x.1) * (h x.2)].
Proof using.
rewrite genGid; apply intro_class_fun => [x y|].
- rewrite !inE => /andP [x1 x2] /andP [y1 y2].
  by rewrite !cfunJgen ?genGid.
- move=> x; rewrite inE => /nandP [x1|x2].
  + by rewrite cfun0gen ?mul0r ?genGid.
  + by rewrite [h _]cfun0gen ?mulr0 ?genGid.
Qed.
Definition cfextprod g h := Cfun 0 (cfextprod_subproof g h).
Definition cfextprodr_head k g h := let: tt := k in cfextprod h g.

End CFExtProdDefs.

Notation "f \ox g" := (cfextprod f g) (at level 40, left associativity).
Notation cfextprodr := (cfextprodr_head tt).

Section CFExtProdTheory.

Variables (gT aT : finGroupType).
Variables (G : {group gT}) (H : {group aT}).
Implicit Type (g : 'CF(G)) (h : 'CF(H)).

Local Open Scope ring_scope.

Lemma cfextprodrE h g : cfextprodr h g = g \ox h.
Proof using. by []. Qed.

Lemma cfextprod_is_linear g : linear (cfextprod g : 'CF(H) -> 'CF(setX G H)).
Proof using.
move=> /= a h1 h2.
apply/cfunP=> /= x.
by rewrite !cfunE !mulrDr mulrA [g _ * _]mulrC mulrA.
Qed.
Canonical cfextprod_additive g := Additive (cfextprod_is_linear g).
Canonical cfextprod_linear g := Linear (cfextprod_is_linear g).

Lemma cfextprod0r g : g \ox (0 : 'CF(H)) = 0.
Proof using. by rewrite linear0. Qed.
Lemma cfextprodNr g h : g \ox - h = - (g \ox h).
Proof using. by rewrite linearN. Qed.
Lemma cfextprodDr g h1 h2 : g \ox (h1 + h2) = g \ox h1 + g \ox h2.
Proof using. by rewrite linearD. Qed.
Lemma cfextprodBr g h1 h2 : g \ox (h1 - h2) = g \ox h1 - g \ox h2.
Proof using. by rewrite linearB. Qed.
Lemma cfextprodMnr h g n : g \ox (h *+ n) = (g \ox h) *+ n.
Proof using. by rewrite linearMn. Qed.
Lemma cfextprod_sumr g I r (P : pred I) (phi : I -> 'CF(H)) :
  g \ox (\sum_(i <- r | P i) phi i) = \sum_(i <- r | P i) g \ox phi i.
Proof using. by rewrite linear_sum. Qed.
Lemma cfextprodZr g a h : g \ox (a *: h) = a *: (g \ox h).
Proof using. by rewrite linearZ. Qed.

Lemma cfextprodr_is_linear h : linear (cfextprodr h : 'CF(G) -> 'CF(setX G H)).
Proof using.
move=> /= a g1 g2; rewrite !cfextprodrE.
apply/cfunP=> /= x.
by rewrite !cfunE !mulrDl -mulrA.
Qed.
Canonical cfextprodr_additive h := Additive (cfextprodr_is_linear h).
Canonical cfextprodr_linear h := Linear (cfextprodr_is_linear h).

Lemma cfextprod0l h : (0 : 'CF(G)) \ox h = 0.
Proof using. by rewrite -cfextprodrE linear0. Qed.
Lemma cfextprodNl h g : - g \ox h = - g \ox h.
Proof using. by rewrite -!cfextprodrE linearN. Qed.
Lemma cfextprodDl h g1 g2 : (g1 + g2) \ox h = g1 \ox h + g2 \ox h.
Proof using. by rewrite -!cfextprodrE linearD. Qed.
Lemma cfextprodBl h g1 g2 : (g1 - g2) \ox h = g1 \ox h - g2 \ox h.
Proof using. by rewrite -!cfextprodrE linearB. Qed.
Lemma cfextprodMnl h g n : g *+ n \ox h = g \ox h *+ n.
Proof using. by rewrite -!cfextprodrE linearMn. Qed.
Lemma cfextprod_suml h I r (P : pred I) (phi : I -> 'CF(G)) :
  (\sum_(i <- r | P i) phi i) \ox h = \sum_(i <- r | P i) phi i \ox h.
Proof using. by rewrite -!cfextprodrE linear_sum. Qed.
Lemma cfextprodZl h a g : (a *: g) \ox h = a *: (g \ox h).
Proof using. by rewrite -!cfextprodrE linearZ. Qed.

Variables (n1 n2 : nat).
Variables (rG : mx_representation algCF G n1)
          (rH : mx_representation algCF H n2).

Lemma extprod_mx_repr : mx_repr (setX G H) (fun x => tprod (rG x.1) (rH x.2)).
Proof using.
split=>[|i j]; first by rewrite !repr_mx1 tprod1.
rewrite !inE => /andP [i1 i2] /andP [j1 j2].
by rewrite !repr_mxM // tprodE.
Qed.
Definition extprod_repr := MxRepresentation extprod_mx_repr.

Lemma cfRepr_extprod : cfRepr extprod_repr = cfRepr rG \ox cfRepr rH.
Proof using.
apply/cfun_inP=> x GXHx.
by have:= GXHx; rewrite !inE !cfunE GXHx mxtrace_prod => /andP [-> ->] /=.
Qed.

End CFExtProdTheory.

Section TowerMorphism.

Variables m n : nat.

Implicit Types (p : intpartn m) (q : intpartn n).

Local Notation ct := cycle_typeSN.
Local Notation Smn := (setX [set: 'S_m] [set: 'S_n]).

Definition tinjval (s : ('S_m * 'S_n)) :=
  fun (x : 'I_(m + n)) => let y := split x in
  match y with
  | inl a => unsplit (inl (s.1 a))
  | inr a => unsplit (inr (s.2 a))
  end.

Fact tinjval_inj s : injective (tinjval s).
Proof using.
rewrite /tinjval => x y.
case: {2 3}(split x) (erefl (split x)) => [] a Ha;
  case: {2 3} (split y) (erefl (split y)) => [] b Hb;
    move=> /(congr1 (@split _ _)); rewrite !unsplitK => [] // [];
    move=> /perm_inj Hab; subst a;
    by rewrite -(splitK x) Ha -Hb splitK.
Qed.
Definition tinj s : 'S_(m + n) := perm (@tinjval_inj s).

Fact tinj_morphM : {morph tinj : x y / x * y >-> x * y}.
Proof using.
rewrite /tinj => /= s1 s2; apply /permP => /= x.
rewrite permM -(splitK x) !permE.
by case: splitP => [] j _; rewrite /tinjval !unsplitK /= permM.
Qed.
Canonical morph_of_tinj := Morphism (D := Smn) (in2W tinj_morphM).

(* The image of 'S_m * 'S_n via tinj with a 'S_(m + n) group structure *)
Definition tinj_im := tinj @* ('dom tinj).

Lemma isom_tinj : isom Smn tinj_im tinj.
Proof using.
apply/isomP; split; last by [].
apply/subsetP => [] /= [s1 s2]; rewrite inE => /andP [_].
rewrite !inE /= => /eqP/permP H.
rewrite -[1]/(1,1) /xpair_eqE /=.
apply/andP; split; apply/eqP/permP => x; rewrite !perm1.
- have := H (unsplit (inl x)).
  rewrite /tinj permE /tinjval unsplitK perm1 /=.
  exact: linjP.
- have := H (unsplit (inr x)).
  rewrite /tinj permE /tinjval unsplitK perm1 /=.
  exact: rinjP.
Qed.

Lemma expg_tinj_lshift s a i :
 (tinj s ^+ i) (lshift n a) = lshift n ((s.1 ^+ i) a).
Proof using.
elim: i => [|i IHi].
  by rewrite !expg0 !perm1.
rewrite !expgSr !permM IHi permE /tinjval /=.
pose y := inl ((s.1 ^+ i) a) => /=.
rewrite (_: lshift _ _ = unsplit (y _)) //.
by rewrite unsplitK.
Qed.

Lemma expg_tinj_rshift s a i :
  (tinj s ^+ i) (rshift m a) = rshift m ((s.2 ^+ i) a).
Proof using.
elim: i => [|i IHi].
  by rewrite !expg0 !perm1.
rewrite !expgSr !permM IHi permE /tinjval /=.
pose y := inr ((s.2 ^+ i) a) => /=.
rewrite (_: rshift _ _ = unsplit (y _)) //.
by rewrite unsplitK.
Qed.

Lemma pcycle_tinj_lshift s a :
  pcycle (tinj s) (lshift n a) = imset (lshift n) (mem (pcycle s.1 a)).
Proof using.
apply/setP => /= Y.
apply/pcycleP/imsetP => /= [[i ->]|[y]].
- exists ((s.1 ^+ i) a); first by apply /pcycleP; exists i.
  exact: expg_tinj_lshift.
- move /pcycleP => [i ->] ->.
  by exists i; rewrite expg_tinj_lshift.
Qed.

Lemma pcycle_tinj_rshift s a :
  pcycle (tinj s) (rshift m a) = imset (@rshift m n) (mem (pcycle s.2 a)).
Proof using.
apply/setP => /= Y.
apply/pcycleP/imsetP => /= [[i ->]|[y]].
- exists ((s.2 ^+ i) a); first by apply /pcycleP; exists i.
  exact: expg_tinj_rshift.
- move /pcycleP => [i ->] ->.
  by exists i; rewrite expg_tinj_rshift.
Qed.

Lemma pcycles_tinj s :
  pcycles (tinj s) =
  [set (@lshift m n) @: (x : {set 'I_m}) | x in pcycles s.1]
    :|:
    [set (@rshift m n) @: (x : {set 'I_n}) | x in pcycles s.2 ].
Proof using.
apply/setP => S; rewrite /pcycles inE.
apply/imsetP/orP => [[x _ ->{S}] | [] /imsetP [T /imsetP [x _] ->{T}] ->{S}].
- rewrite -(splitK x); case: splitP => j _ {x}.
  + left; apply/imsetP; exists (pcycle s.1 j) => /=; first exact: mem_imset.
    exact: pcycle_tinj_lshift.
  + right; apply/imsetP; exists (pcycle s.2 j) => /=; first exact: mem_imset.
    exact: pcycle_tinj_rshift.
  - by exists (lshift n x); rewrite // pcycle_tinj_lshift.
  - by exists (rshift m x); rewrite // pcycle_tinj_rshift.
Qed.

Lemma cycle_type_tinj s : ct (tinj s) = union_intpartn (ct s.1) (ct s.2).
Proof using.
apply val_inj; rewrite union_intpartnE intpartn_castE /=.
rewrite pcycles_tinj parts_shape_union; first last.
  rewrite -setI_eq0; apply/eqP/setP => S.
  rewrite !inE; apply/negP => /andP [].
  move=> /imsetP [X /imsetP [x _ ->]] -> {X}.
  move=> /imsetP [X /imsetP [y _ ->]].
  move/setP => /(_ (lshift n x)).
  rewrite mem_imset; last exact: pcycle_id.
  move=> /esym/imsetP => [] [z _] /eqP.
  by rewrite lrinjF.
congr sort; rewrite /ct !intpartn_castE /=.
by congr (_ ++ _); apply parts_shape_inj; [exact: linjP | exact: rinjP].
Qed.

End TowerMorphism.

Arguments tinj {m n} s.
Arguments tinj_im {m n}.

Notation "f \o^ g" := (cfIsom (isom_tinj _ _) (cfextprod f g)) (at level 40).

Section Assoc.

Variables m n p : nat.

Lemma tinjA (s : 'S_m) (t : 'S_n) (u : 'S_p) :
  tinj (tinj(s, t), u) = cast_perm (addnA m n p) (tinj (s, tinj (t, u))).
Proof using.
apply/permP => /= itmp.
rewrite -(splitK itmp) !permE.
case: splitP => i _ {itmp}; rewrite /tinjval !unsplitK /= /cast_perm_val.
- rewrite -(splitK i) !permE.
  case: splitP => j _ {i}; rewrite /tinjval !unsplitK /=.
  + rewrite [cast_ord (esym _) _](_ : _ = unsplit (inl j));
      last exact: val_inj.
    by rewrite !unsplitK /=; apply val_inj.
  + rewrite [cast_ord (esym _) _](_ : _ = unsplit (inr (lshift _ j)));
      last exact: val_inj.
    rewrite !unsplitK /=; apply val_inj => /=.
    rewrite (_: lshift _ _ = unsplit (inl j)) //.
    by rewrite !permE /tinjval !unsplitK /=.
- rewrite [cast_ord (esym _) _](_ : _ = unsplit (inr (rshift _ i)));
    last by apply: val_inj => /=; rewrite addnA.
  rewrite !permE /tinjval !unsplitK /=.
  rewrite (_: rshift n _ = unsplit (inr i)) //.
  rewrite !permE /tinjval !unsplitK /=.
  by apply val_inj; rewrite /= addnA.
Qed.

End Assoc.

Local Open Scope ring_scope.

Section Restriction.

Variables m n : nat.

Implicit Types (p : intpartn m) (q : intpartn n).

Local Notation ct := cycle_typeSN.
Local Notation Smn := (setX [set: 'S_m] [set: 'S_n]).

Lemma cfuni_tinj s (l : intpartn (m + n)) :
  '1_[l] (tinj s) = (l == union_intpartn (ct s.1) (ct s.2))%:R.
Proof using. by rewrite cfuni_partnE cycle_type_tinj eq_sym. Qed.

Theorem cfuni_Res (l : intpartn (m + n)):
  'Res[tinj_im] ('1_[l]) =
  \sum_(x | l == union_intpartn x.1 x.2) ('1_[x.1] \o^ '1_[x.2]).
Proof using.
apply/cfunP => /= s.
case: (boolP (s \in tinj_im)) => Hs; last by rewrite !cfun0gen // genGid.
rewrite (cfResE _ _ Hs); last exact: subsetT.
move: Hs => /imsetP/= [[s1 s2]].
rewrite inE => /andP [H1 _] -> {s}.
rewrite cfuni_tinj /= -linear_sum (cfIsomE _ _ H1).
rewrite /cfextprod /= sum_cfunE.
rewrite (eq_bigr
           (fun x : intpartn m * intpartn n => ('1_[x.1] s1) * ('1_[x.2] s2)));
  last by move=> i _; rewrite cfunE.
case: (altP (l =P _ )) => [->| Hl] /=.
- rewrite (bigD1 (ct s1, ct s2)) //=.
  rewrite !cfuni_partnE !eqxx /= mulr1.
  rewrite big1 ?addr0 // => [[t1 t2]] /andP [_].
  rewrite !cfuni_partnE eq_sym xpair_eqE.
  by move=> /nandP [] /negbTE -> /=; rewrite ?mulr0 ?mul0r.
- rewrite big1 // => [[t1 t2]] /= /eqP Hll; subst l.
  have {Hl} : (t1, t2) != (ct s1, ct s2).
    by move: Hl; apply contra => /eqP [-> ->].
  rewrite !cfuni_partnE eq_sym xpair_eqE.
  by move=> /nandP [] /negbTE -> /=; rewrite ?mulr0 ?mul0r.
Qed.

End Restriction.

Section Induction.

Variables m n : nat.

Implicit Types (p : intpartn m) (q : intpartn n).

Local Notation ct := cycle_typeSN.
Local Notation S := [set: 'S_(m + n)].
Local Notation Smn := (setX [set: 'S_m] [set: 'S_n]).
Local Notation classX p q := ((perm_of_partCT p, perm_of_partCT q) ^: Smn).
Local Notation class p := (class_of_partCT p).

Import GroupScope GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Lemma classXE p q : classX p q = setX (class p) (class q).
Proof using.
apply /setP => /= x; rewrite inE.
apply /imsetP/andP => /= [[i _ ]|[/imsetP [i1 _ xi1] /imsetP[i2 _ xi2]]].
- rewrite prod_conjg /= => -> /=.
  by split; apply memJ_class; rewrite inE.
- exists (i1, i2); first by rewrite inE; apply /andP; split; rewrite inE.
  by rewrite prod_conjg -xi1{xi1} -xi2{xi2}; case: x => /=.
Qed.

Lemma cfextprod_cfuni p q :
  '1_[p] \ox '1_[q] = '1_(classX p q).
Proof using.
apply/cfunP => /= x.
rewrite cfunE !cfuni_partnE /= cfunElock genGid !inE /= -natrM mulnb.
congr ((nat_of_bool _)%:R).
rewrite classXE.
apply /andP/subsetP => [[ct1 ct2]|].
- move=> /= y /imsetP [/= x0 _ ] -> {y}.
  rewrite inE; apply/andP; split.
  + apply/classes_of_permP; rewrite perm_of_partCTP prod_conjg /=.
    rewrite cycle_type_conjg.
    by rewrite partn_of_partCTE partCT_of_partnK eq_sym ct1.
  + apply/classes_of_permP; rewrite perm_of_partCTP prod_conjg /=.
    rewrite cycle_type_conjg.
    by rewrite partn_of_partCTE partCT_of_partnK eq_sym ct2.
- move=> /(_ x); rewrite class_refl=> /(_ isT).
  rewrite inE=> /andP [/imsetP[y1 _ ->] /imsetP [y2 _ ->]].
  by rewrite /ct !cycle_type_conjg !perm_of_partCTP !partCT_of_partnK !eqxx.
Qed.

(*
Lemma cfdot_classfun_part p1 p2 :
  '[classfun_part p1, classfun_part p2] =
    (p1 == p2)%:R * (#|class_of_partCT p1|)%:R/(#|'S_n|)%:R.
Proof using.
  admit.
Admitted.
 *)

(*This lemma is of no use and a much more general case is stated below*)
Lemma decomp_cf_triv : \sum_(p : intpartn n) '1_[p] = 1.
Proof using.
apply/cfunP => /= x.
rewrite cfun1Egen genGid inE /=.
rewrite sum_cfunE (bigD1 (ct x)) //=.
rewrite big1 ?addr0 ?cfuni_partnE ?eqxx //=.
by move=> p /negbTE pct; rewrite cfuni_partnE eq_sym pct.
Qed.

Lemma classXI p1 p2 q1 q2 :
  (p2, q2) != (p1, q1) -> (classX p1 q1) :&: (classX p2 q2) = set0.
Proof using.
move=> /eqP qp; apply class_disj.
apply/imsetP => []/= [x _].
rewrite prod_conjg /= => [] [] qp1 qp2.
apply qp; congr (_, _);
  rewrite -[LHS]partCT_of_partnK -[RHS]partCT_of_partnK; congr partn_of_partCT;
  rewrite -[LHS]perm_of_partCTP -[RHS]perm_of_partCTP.
- by rewrite qp1 cycle_type_conjg.
- by rewrite qp2 cycle_type_conjg.
Qed.

(* Application of Frobenius duality : cfdot_Res_r *)
Lemma cfdot_Ind_cfuni_part p q (l : intpartn (m + n)):
  '['Ind[S] ('1_[p] \o^ '1_[q]), '1_[l]] =
  (union_intpartn p q == l)%:R * #|class p|%:R * #|class q|%:R / #|Smn|%:R.
Proof using.
rewrite -cfdot_Res_r cfuni_Res -linear_sum cfIsom_iso cfdot_sumr.
rewrite (eq_bigr
  (fun i : intpartn m * intpartn n =>
     #|(classX p q) :&: (classX i.1 i.2)|%:R / #|Smn|%:R)); first last.
- move => i _; rewrite !cfextprod_cfuni.
  by rewrite cfdot_cfuni //=; apply: class_normal; rewrite !inE.
- case: (boolP (_ == _)) => [|] /= unionp; [rewrite mul1r|rewrite !mul0r].
  + rewrite (bigD1 (p, q)) /=; last by rewrite eq_sym.
    rewrite setIid big1; first by rewrite addr0 classXE cardsX natrM //=.
    by move=> i /andP [] _ ip; rewrite classXI ?cards0 ?mul0r.
  + rewrite big1 //= => i /eqP unioni.
    have ip: i != (p, q).
      move: unionp; apply contraR; rewrite negbK {}unioni => /eqP.
      by case: i => [i1 i2] [-> ->].
    by rewrite classXI ?cards0 ?mul0r.
Qed.

Definition zcoeff (k : nat) (p : intpartn k) : algC :=
  #|'S_k|%:R / #|class_of_partCT p|%:R.

Local Notation "'z_ p " := (zcoeff p) (at level 2).

Lemma neq0zcoeff (k : nat) (p : intpartn k) : 'z_p != 0.
Proof using.
have := Cchar; rewrite charf0P => neq0.
rewrite /zcoeff /= card_Sn.
apply mulf_neq0.
- rewrite neq0 -lt0n; exact: fact_gt0.
- rewrite invr_eq0 neq0; exact: card_class_of_partCT_neq0.
Qed.

Definition pbasis (k : nat) (p : intpartn k) := 'z_p *: '1_[p].

Local Notation "''P_[' p ]" := (pbasis p).

Lemma cfdot_Ind_pbasis p q (l : intpartn (m + n)):
  '['Ind[S] ('P_[p] \o^ 'P_[q]), 'P_[l]] = (union_intpartn p q == l)%:R * 'z_l.
Proof using.
rewrite cfextprodZl cfextprodZr.
rewrite !linearZ /= !cfdotZl cfdotZr cfdot_Ind_cfuni_part /= cardsX.
rewrite !mulrA [_ * (_ == _)%:R]mulrC -!mulrA; congr (_ * _).
rewrite [(_)^* * _]mulrC !mulrA -[RHS]mul1r; congr (_ * _); first last.
  by rewrite fmorph_div !conjC_nat.
rewrite -!cardsT /= !natrM !invfM.
rewrite -!mulrA ![#|[set: 'S_n]|%:R * _]mulrC !mulrA mulfVK; last apply neq0CG.
rewrite -!mulrA ![#|[set: 'S_m]|%:R * _]mulrC !mulrA mulfVK; last apply neq0CG.
rewrite -invfM -mulrA mulrC; apply divff.
by rewrite -natrM pnatr_eq0 muln_eq0 negb_or !card_class_of_partCT_neq0.
Qed.

Lemma pbasis_gen k (f : 'CF([set: 'S_k])) :
  f = \sum_(p : intpartn k) f (perm_of_partCT p) / 'z_p *: 'P_[p].
Proof using.
apply/cfunP => /= x.
rewrite (bigD1 (ct x)) //= cfunE sum_cfunE big1.
- rewrite addr0 !cfunE cfuni_partnE eqxx /= mulr1.
  rewrite -mulrA [_^-1 *_]mulrC mulrA mulfK; last exact: neq0zcoeff.
  have: (perm_of_partCT (ct x)) \in x ^: [set: 'S_k].
    apply /classes_of_permP; rewrite perm_of_partCTP.
    by rewrite (partn_of_partCTK (cycle_type x)).
  by move/imsetP => [y _ ->]; rewrite cfunJgen ?genGid ?inE.
- by move=> p /negbTE pct; rewrite !cfunE cfuni_partnE eq_sym pct /= !mulr0.
Qed.

Lemma cfdotr_pbasis k (f : 'CF([set: 'S_k])) x : (f x) = '[f, 'P_[ct x]].
Proof using.
rewrite {2}(pbasis_gen f) cfdot_suml.
rewrite (bigD1 (ct x)) //= !cfdotZl cfdotZr.
rewrite cfdot_cfuni; try (by apply: class_normal; rewrite inE).
rewrite setIid big1 ?addr0.
- have: (perm_of_partCT (ct x)) \in x ^: [set: 'S_k].
    apply /classes_of_permP; rewrite perm_of_partCTP.
    by rewrite (partn_of_partCTK (cycle_type x)).
  move/imsetP => [y _ ->]; rewrite cfunJgen ?genGid ?inE //.
  rewrite /zcoeff invf_div -[LHS]mulr1 -!mulrA; congr (_ * _).
  rewrite -cardsT mulKf; last exact: neq0CG.
  rewrite [_^-1 * _]mulrC mulrA mulrC mulKf;
    last by rewrite pnatr_eq0 card_class_of_partCT_neq0.
  rewrite mulrC fmorph_div !conjC_nat -mulrA mulKf; last exact: neq0CG.
  by rewrite divff ?pnatr_eq0 ?card_class_of_partCT_neq0.
- move=> p /negbTE pct.
  rewrite !cfdotZl cfdotZr.
  rewrite cfdot_cfuni; try (by apply: class_normal; rewrite inE).
  rewrite class_disj; first by rewrite cards0 mul0r !mulr0.
  apply/negP=> /classes_of_permP; rewrite !perm_of_partCTP.
  by rewrite partn_of_partCTE !partCT_of_partnK pct.
Qed.

Theorem Ind_pbasis p q :
  'Ind[S] ('P_[p] \o^ 'P_[q]) = 'P_[union_intpartn p q].
Proof using.
apply/cfunP => /= x; rewrite cfunE.
rewrite cfdotr_pbasis cfdot_Ind_pbasis.
rewrite cfuni_partnE eq_sym mulrC.
by case: (boolP (_ == _)) => [/eqP ->|] //=; rewrite !mulr0.
Qed.

End Induction.


Require Export ExponentialLaws.Law2.Functors.
Require Import Common Functor.Pointwise Functor.Product Functor.Sum NaturalTransformation.Sum.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.

Section Law2.
  Context `{Funext}.
  Variable D : PreCategory.
  Variable C1 : PreCategory.
  Variable C2 : PreCategory.

  Lemma ExponentialLaw2_helper1 (c : Functor C1 D * Functor C2 D)
  : (1 ∘ (fst c + snd c) ∘ inl_Functor C1 C2,
     1 ∘ (fst c + snd c) ∘ inr_Functor C1 C2) = c.
  Proof.
    apply path_prod; simpl;
    functor_eq.
  Defined.

  Lemma ExponentialLaw2_helper2_helper (c : Functor (C1 + C2) D) x
  : (1 ∘ c ∘ inl_Functor C1 C2 + 1 ∘ c ∘ inr_Functor C1 C2) x = c x.
  Proof.
    destruct x; reflexivity.
  Defined.

  Lemma ExponentialLaw2_helper2 (c : Functor (C1 + C2) D)
  : 1 ∘ c ∘ inl_Functor C1 C2 + 1 ∘ c ∘ inr_Functor C1 C2 = c.
  Proof.
    functor_eq.
    exists (path_forall _ _ (@ExponentialLaw2_helper2_helper c)).
    repeat (apply (@path_forall _); intro).
    (*Set Printing Implicit.
    Set Printing Coercions.
    Unset Printing Notations.
    repeat match goal with
             | _ => reflexivity
             | _ => progress simpl
             | [ H : Object 1 |- _ ] => destruct (contr H)
             | [ H : Morphism 1 _ _ |- _ ] => destruct (contr H)
             | _ => rewrite !transport_forall_constant
             | [ |- appcontext[@MorphismOf ?C ?D (transport ?P ?p ?z)] ]
               => rewrite (@ap_transport _ P _ _ _ p (fun _ => @MorphismOf C D) z)
           end.
    Set Printing Implicit.
    rewrite !transport_forall_constant.
lazymatch goal with
    | [ |- appcontext[@MorphismOf ?C ?D (transport ?P ?p ?z)] ]
      => pose (@ap_transport _ P _ _ _ p (fun _ => @MorphismOf C D) z)
    end.
    apply path_forall.

    rewrite !transport_forall_constant.*)
    admit.
  Defined.

  Lemma ExponentialLaw2
  : ExponentialLaw2Functor D C1 C2 ∘ ExponentialLaw2Functor_Inverse D C1 C2 = 1
    /\ ExponentialLaw2Functor_Inverse D C1 C2 ∘ ExponentialLaw2Functor D C1 C2 = 1.
  Proof.
    split;
    functor_eq;
    [ (exists (path_forall _ _ ExponentialLaw2_helper1))
    | (exists (path_forall _ _ ExponentialLaw2_helper2)) ]. (*
    repeat (apply (@path_forall _) || apply path_prod || intro || functor_eq || nt_eq);
    repeat match goal with
             | _ => reflexivity
             | _ => progress simpl
             | [ H : Object 1 |- _ ] => destruct (contr H)
             | [ H : Morphism 1 _ _ |- _ ] => destruct (contr H)
             | _ => rewrite !transport_forall_constant
             | [ |- appcontext[ComponentsOf (transport ?P ?p ?z)] ]
               => rewrite (@ap_transport _ P _ _ _ p (fun _ => ComponentsOf) z)
           end;
    transport_path_forall_hammer.
    destruct_head_hnf @prod;
    unfold ExponentialLaw2_helper1, ExponentialLaw2_helper2;
    rewrite !transport_path_prod;
    rewrite !transport_prod.
    Opaque Functor_eq'_sig.
    repeat match goal with
             | _ => reflexivity
             | _ => progress simpl
             | [ H : Object 1 |- _ ] => destruct (contr H)
             | [ H : Morphism 1 _ _ |- _ ] => destruct (contr H)
             | _ => rewrite !transport_forall_constant
             | [ |- appcontext[ComponentsOf (transport ?P ?p ?z)] ]
               => rewrite (@ap_transport _ P _ _ _ p (fun _ => ComponentsOf) z)
           end.
    Set Printing Coercions.
    repeat match goal with
             | [ |- appcontext[transport (fun y => ?f (@ObjectOf ?C ?D y ?x))] ]
               => rewrite (fun a b => @transport_compose _ _ a b (fun y => f (y x)) (@ObjectOf C D))
             | [ |- appcontext[transport (fun y => ?f (@ObjectOf ?C ?D y ?x) ?z)] ]
               => rewrite (fun a b => @transport_compose _ _ a b (fun y => f (y x) z) (@ObjectOf C D))
           end.
    Set Printing Implicit.
    simpl.
    Check @Functor_eq'_sig_fst.
    match goal with
      | [ |- appcontext[ap (@ObjectOf ?C ?D) (@Functor_eq'_sig ?H ?C ?D ?F ?G (?HO; ?HM))] ]
        => pose (@Functor_eq'_sig_fst H C D F G HO HM)
    end.
    rewrite p.
    rewrite !Functor_eq'_sig_fst.
    transport_path_forall_hammer.
    assert (idpath = contr (center 1%category)) by exact (center _).
    path_induction.
    reflexivity.

 (* Lemma ExponentialLaw2
  : ExponentialLaw2Functor ∘ ExponentialLaw2Functor_Inverse = 1
    /\ ExponentialLaw2Functor_Inverse ∘ ExponentialLaw2Functor = 1.
  Proof.
    split.
    functor_eq.
    simpl.
    abstract (repeat
                match goal with
                  | _ => reflexivity
                  | _ => split
                  | _ => progress (simpl in *; intros; trivial)
                  | _ => progress repeat subst
                  | _ => progress destruct_head_hnf @Empty_set
                  | _ => progress simpl_eq
                  | _ => progress apply Functor_eq
                  | _ => progress nt_eq
                  | _ => progress rsimplify_morphisms
                  | _ => progress destruct_head_hnf @sum
                  | _ => progress rewrite FIdentityOf
                end).
  Qed.*)*)
  Admitted.
End Law2.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Export maps.
Require Export ZArith.
Require Export String.
Require Export List.

Open Scope string_scope.
Open Scope list_scope.
Open Scope Z.

Inductive Inst : Set :=
  | Dup : nat -> Inst
  | Roll : nat -> Inst
  | Drop
  | Push : Z -> Inst
  | Binop : (Z -> Z -> Z) -> Inst
  | While : list Inst -> list Inst -> Inst
  | If : list Inst -> list Inst -> Inst
  | Load
  | Store
  | Call : string -> Inst
  | Ret : Inst
  | Alloc : nat -> Inst
  | Dealloc : Inst.

Definition Swap := Roll 1.
Definition Over := Dup 1.
Definition Nip := Swap::Drop::nil.
Definition Rot := Roll 2::Roll 2::nil.
Definition Plus1 := Push 1::Binop Z.add::nil.

Structure cfg := Cfg {
  code : list Inst;
  stack : list Z;
  rstack : list (list Inst);
  heap : Map Z Z;
  functions : Map string (list Inst);
  alloc_next : Z
  }.

(* Compute a map for initial bindings in Alloc,
   with some extra work to make a pretty term *)
Definition offset (base :Z) (n : nat) : Z :=
  match n with
    | O => base
    | _ => (base + Z.of_nat n)%Z
  end.
Fixpoint init n ix base : Map Z Z :=
  match n with
    | O => mapEmpty
    | S O => offset base ix |-> 0%Z
    | S n' => offset base ix |-> 0%Z :* init n' (S ix) base
  end.

Local Notation basic_step step
    code  stk  heap  mark
    code2 stk2 heap2 mark2:=
  (forall rstk funs,
     step (Cfg code  stk  rstk heap  funs mark)
          (Cfg code2 stk2 rstk heap2 funs mark2)).
Local Notation inst_step step inst stk stk2 :=
  (forall rest heap mark, basic_step step
    (inst::rest) stk heap mark rest stk2 heap mark).

Generalizable Variables n x y stk.
Inductive stack_step : cfg -> cfg -> Prop :=
  | dup : `(inst_step stack_step (Dup n)
      stk (nth_default 0 stk n :: stk))
  | roll : `(inst_step stack_step (Roll n)
      (x::stk) (firstn n stk ++ x :: skipn n stk))
  | drop : `(inst_step stack_step Drop
      stk (tl stk))
  | push : `(inst_step stack_step (Push x)
      stk (x :: stk))
  | binop : forall f, `(inst_step stack_step (Binop f)
      (x :: y :: stk) (f y x :: stk))
  | while : forall test body rest stk h m, basic_step stack_step
      (While test body::rest) stk h m
      (test++If (body++While test body::nil) nil::rest) stk h m
  | ifz : forall x t f rest stk h m, basic_step stack_step
      (If t f::rest)                           (x::stk) h m
      ((if Zneq_bool x 0 then t else f)++rest)     stk  h m
  | load : forall x rest stk v heap heap' mark,
      heap ~= x |-> v :* heap' -> basic_step stack_step
        (Load::rest) (x::stk) heap              mark
               rest  (v::stk) (x|-> v :* heap') mark
  | store : forall p v rest stk v' heap heap' mark,
      heap ~= p |-> v' :* heap' -> basic_step stack_step
        (Store::rest) (p::v::stk) heap               mark
                rest         stk  (p |-> v :* heap') mark
  | alloc1 : forall n rest stk heap m, basic_step stack_step
      (Alloc n::rest) stk                 heap   m
       rest       (m::stk) (init n 0 m :* heap) (Z.of_nat n + m)%Z
  | dealloc : forall rest x v stk heap heap' mark,
      heap ~= x |-> v :* heap' -> basic_step stack_step
        (Dealloc::rest) (x::stk) heap  mark
                  rest      stk  heap' mark
  | call : forall f body rest stk rstk heap funs funs' mark,
      funs ~= f |-> body :* funs' -> stack_step
         (Cfg (Call f::rest) stk        rstk  heap funs mark)
         (Cfg body           stk (rest::rstk) heap funs mark)
  | ret : forall rest rbody stk rstk heap funs mark, stack_step
      (Cfg (Ret::rest) stk (rbody::rstk) heap funs mark)
      (Cfg rbody       stk         rstk  heap funs mark).
Arguments nth_default / : simpl nomatch.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                       *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence.    *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms

     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence.
                                                                          *)
(**************************************************************************)

Require Import Lia PeanoNat.
Require Import SetoidList.
Require Export Pactole.CaseStudies.Gathering.Definitions.
Require Export Pactole.Observations.MultisetObservation.
Close Scope R_scope.
Close Scope VectorSpace_scope.
Set Implicit Arguments.
Typeclasses eauto := (bfs) 5.
Require Even.

(** Gathering Definitions specific to a setting with multiplicities, i.e. a multiset observation. *)

Section MultisetGathering.

(** Here, we restrict the state to only contain the location. *)
Context `{Location}.
(* TODO: add the existence of a similarity here *)
Instance Info : State location := OnlyLocation (fun _ => True).
Context {VS : RealVectorSpace location}.
Context {RMS : RealMetricSpace location}.
Context `{Names}.
Context `{robot_choice}.
Context `{update_choice}.
Context `{inactive_choice}.
Context {UpdFun : update_function _ _ _}.
Context {InaFun : inactive_function _}.

Global Existing Instance multiset_observation.

Notation "!! config" :=
  (@obs_from_config location _ _ _ multiset_observation config origin : observation) (at level 10).

Lemma no_info : forall x y, get_location x == get_location y -> x == y.
Proof using . now intros. Qed.

(** When all robots are on two towers of the same height, there is no solution to the gathering problem.
    Therefore, we define these configurations as [invalid]. *)
Definition invalid (config : configuration) :=
     Nat.Even nG /\ nG >=2 /\ exists pt1 pt2 : location, pt1 =/= pt2
  /\ (!! config)[pt1] = Nat.div2 nG /\ (!! config)[pt2] = Nat.div2 nG.

Global Instance invalid_compat : Proper (equiv ==> iff) invalid.
Proof using .
intros ? ? Heq. split; intros [HnG [Hle [pt1 [pt2 [Hneq Hpt]]]]];
repeat split; trivial; exists pt1, pt2; split; trivial; now rewrite Heq in *.
Qed.

(** [ValidsolGathering r d] means that any possible (infinite)
    execution, generated by demon [d] and robogram [r] and any intial
    configuration not [invalid], will *eventually* be [Gather]ed.
    This is the statement used for the correctness proof of the algorithms. *)
Definition ValidSolGathering (r : robogram) (d : demon) :=
  forall config : configuration, ~invalid config -> WillGather (execute r d config).

(** **  Generic properties  **)

(* We need to unfold [obs_is_ok] for rewriting *)
Definition obs_from_config_spec : forall (config : configuration) (pt : location),
  (!! config)[pt] = countA_occ _ equiv_dec pt (List.map get_location (config_list config))
  := fun config => obs_from_config_spec config origin.

Lemma obs_non_nil : 2 <= nG -> forall config,
  !! config =/= MMultisetInterface.empty.
Proof using .
simpl obs_from_config. intros HnG config Heq.
assert (Hlgth:= config_list_length config).
assert (Hl : config_list config = nil).
{ apply List.map_eq_nil with _ get_location.
  rewrite <- make_multiset_empty.
  now intro; rewrite Heq. }
rewrite Hl in Hlgth.
simpl in *.
lia.
Qed.

Lemma invalid_size : nB = 0 ->
  forall config : configuration, invalid config -> size (!! config) = 2.
Proof using .
intros HnB config [Heven [HsizeG [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
rewrite <- (@cardinal_total_sub_eq _ _ _ _ _ (add pt2 (Nat.div2 nG) (singleton pt1 (Nat.div2 nG)))).
+ rewrite size_add.
  destruct (In_dec pt2 (singleton pt1 (Nat.div2 nG))) as [Hin | Hin].
  - exfalso. rewrite In_singleton in Hin.
    destruct Hin. now elim Hdiff.
  - rewrite size_singleton; trivial; [].
    apply Exp_prop.div2_not_R0. apply HsizeG.
  - apply Exp_prop.div2_not_R0. apply HsizeG.
+ intro pt. destruct (pt =?= pt2) as [Heq2 | Heq2], (pt =?= pt1) as [Heq1 | Heq1].
  - rewrite Heq1, Heq2 in *. now elim Hdiff.
  - rewrite add_spec, singleton_spec.
    do 2 destruct_match; try contradiction; [].
    simpl.
    rewrite Heq2.
    now apply Nat.eq_le_incl.
  - rewrite add_other, singleton_spec; auto; [].
    destruct_match; try contradiction; [].
    rewrite Heq1.
    now apply Nat.eq_le_incl.
  - rewrite add_other, singleton_spec; auto; [].
    destruct_match; try contradiction; [].
    auto with arith.
+ rewrite cardinal_add, cardinal_singleton, cardinal_obs_from_config.
  rewrite HnB, Nat.add_0_r. now apply even_div2.
Qed.

Lemma invalid_strengthen : nB = 0 -> forall config, invalid config ->
  { pt1 : location & { pt2 : location | pt1 =/= pt2 & !! config == add pt1 (Nat.div2 nG) (singleton pt2 (Nat.div2 nG)) } }.
Proof using .
intros HnB config Hconfig.
(* Because we want a computational goal and the hypothesis is not,
   we first destruct the support to get the elements and only then
   prove that they are the same as the one given in [invalid]. *)
assert (Hlen := invalid_size HnB Hconfig). rewrite size_spec in Hlen.
destruct (support (!! config)) as [| pt1 [| pt2 [| ? ?]]] eqn:Hsupp; try discriminate; [].
(* Transforming sig2 into sig to have only one goal after instanciating pt1 and pt2 *)
cut {pt1 : location & {pt2 : location
     | pt1 =/= pt2 /\ obs_from_config config origin == add pt1 (Nat.div2 nG) (singleton pt2 (Nat.div2 nG))}}.
{ intros [? [? [? ?]]]. eauto. }
exists pt1, pt2.
destruct Hconfig as [Heven [Hge2 [pt1' [pt2' [Hdiff [Hpt1' Hpt2']]]]]].
(* Both couples of points are the same *)
assert (Hcase : pt1' == pt1 /\ pt2' == pt2 \/ pt1' == pt2 /\ pt2' == pt1).
{ assert (Hin1 : InA equiv pt1' (pt1 :: pt2 :: nil)).
  { rewrite <- Hsupp, support_spec. unfold In. rewrite Hpt1'.
    destruct nG as [| [| nG]]; simpl; lia. }
  assert (Hin2 : InA equiv pt2' (pt1 :: pt2 :: nil)).
  { rewrite <- Hsupp, support_spec. unfold In. rewrite Hpt2'.
    destruct nG as [| [| nG]]; simpl; lia. }
  rewrite 2 InA_cons, InA_nil in Hin1, Hin2. clear -Hin1 Hin2 Hdiff.
  decompose [or] Hin1; decompose [or] Hin2; tauto || elim Hdiff; etransitivity; eauto. }
split.
+ intro. apply Hdiff.
  decompose [and or] Hcase; repeat (etransitivity; eauto; symmetry).
+ symmetry. apply cardinal_total_sub_eq.
  - intro pt. rewrite add_spec, singleton_spec.
    repeat destruct_match;
    destruct Hcase as [[Heq1 Heq2] | [Heq1 Heq2]];
    rewrite Heq1 in *; rewrite Heq2 in *;
    try match goal with H : pt == _ |- _ => rewrite H in *; clear H end;
    rewrite ?Hpt1', ?Hpt2'; lia || now elim Hdiff.
  - rewrite cardinal_add, cardinal_singleton, cardinal_obs_from_config, even_div2; auto; lia.
Qed.

Lemma invalid_same_location : nB = 0 -> forall config pt1 pt2 pt3, invalid config ->
  In pt1 (!! config) -> In pt2 (!! config) -> In pt3 (!! config) ->
  pt1 =/= pt3 -> pt2 =/= pt3 -> pt1 == pt2.
Proof using .
intros HnB config pt1 pt2 pt3 Hinvalid Hin1 Hin2 Hin3 Hdiff13 Hdiff23.
destruct (invalid_strengthen HnB Hinvalid) as [pta [ptb Hdiff Hobs]].
rewrite Hobs, add_In, In_singleton in Hin1, Hin2, Hin3.
destruct Hin1 as [[] | []], Hin2 as [[] | []], Hin3 as [[] | []];
solve [ etransitivity; eauto
      | elim Hdiff13; etransitivity; eauto
      | elim Hdiff23; etransitivity; eauto ].
Qed.
Arguments invalid_same_location _ config {pt1} {pt2} pt3 _ _ _ _ _.

Lemma invalid_dec : nB = 0 -> forall config, {invalid config} + {~invalid config}.
Proof using .
intros HnB config.
destruct (size (!! config)) as [| [| [| n]]] eqn:Hsize;
try (right; intro Habs; apply invalid_size in Habs; lia); [].
rewrite size_elements in Hsize.
destruct (elements (!! config)) as [| [pt1 n1] [| [pt2 n2] [| ? ?]]] eqn:Helem;
try discriminate; [].
destruct (n1 =?= n2) as [Hn | Hn].
* left.
  assert (2 * n1 = nG).
  { assert (Hcardinal := cardinal_obs_from_config config origin).
    rewrite cardinal_fold_elements, Helem in Hcardinal. simpl in Hcardinal.
    rewrite <- Hn, HnB in Hcardinal. lia. }
  assert (n1 = Nat.div2 nG). { rewrite <- (Exp_prop.div2_double n1). now f_equal. }
  split; [| split].
  + now exists n1.
  + cut (0 < n1); try lia; [].
    assert (Hin : InA eq_pair (pt1, n1) (elements (!! config))).
    { rewrite Helem. now left. }
    rewrite elements_spec in Hin. simpl in Hin. lia.
  + exists pt1, pt2.
    hnf in Hn. subst n1 n2.
    repeat split.
    - assert (Hnodup := elements_NoDupA (!! config)).
      rewrite Helem in Hnodup. inv Hnodup. rewrite InA_cons, InA_nil in *.
      unfold eq_elt in *. simpl in *. tauto.
    - change pt1 with (fst (pt1, Nat.div2 nG)). change (Nat.div2 nG) with (snd (pt1, Nat.div2 nG)) at 2.
      eapply proj1. rewrite <- elements_spec.
      rewrite Helem. now left.
    - change pt2 with (fst (pt2, Nat.div2 nG)). change (Nat.div2 nG) with (snd (pt2, Nat.div2 nG)) at 2.
      eapply proj1. rewrite <- elements_spec.
      rewrite Helem. now right; left.
* right.
  intro Hvalid. elim Hn.
  assert (Hhalf : 0 < Nat.div2 nG).
  { destruct Hvalid as [_ [Hle _]]. destruct nG as [| [| ?]]; simpl; lia. }
  destruct (invalid_strengthen HnB Hvalid) as [pt1' [pt2' Hdiff Hobs]].
  assert (Hperm : PermutationA eq_pair ((pt1, n1) :: (pt2, n2) :: nil)
                                       ((pt1', Nat.div2 nG) :: (pt2', Nat.div2 nG) :: nil)).
  { rewrite <- Helem, Hobs. rewrite elements_add, elements_singleton; auto; [].
    cbn [removeA]. rewrite singleton_other; trivial; [].
    constructor.
    + split; simpl; reflexivity || lia.
    + destruct_match.
      - elim Hdiff. hnf in * |-; simpl in *. auto.
      - reflexivity. }
  rewrite PermutationA_2 in Hperm; autoclass; [].
  clear -Hperm. destruct Hperm as [[[] []] | [[] []]]; compute in *; congruence.
Qed.

End MultisetGathering.


Require Import Coq.Program.Basics.
Require Import NArith.
Require Import monad state.

Require Import Extraction.
Extraction Language OCaml.
(* Extraction Language Haskell. *)

Definition TestM A := state nat A.
(* Hmm.. it doesn't resolve the instance properly when we use a type
   synonym like this. *)

Definition test : state nat bool :=
  ret tt >> put 123 >> get >>=
      fun s => if Nat.even s then ret true else ret false.

Definition test' : state nat bool :=
  put 123 >> get >>=
      fun s => if Nat.even s then ret true else ret false.

Definition test'' : state nat bool :=
  put 123;;
  s <-- get;
  if Nat.even s then ret true else ret false.

Lemma test_test'_eq : test = test'.
Proof.
  unfold test, test'.
  destruct (Monad_state nat).
  rewrite monad_left_id; auto.
Qed.

Lemma test_test''_eq : test = test''.
Proof. firstorder. Qed.

Definition test_result := fst (runState test 0).
Eval compute in test_result.

Definition add1 : state nat unit :=
  modify (fun n => n + 1).

Definition add1_test : state nat nat :=
  add1 >> get.

Definition add1_result := fst (runState add1_test 0).
Eval compute in add1_result.

Lemma add1_test_spec n :
  evalState add1_test n = S n.
Proof.
  unfold evalState, Basics.compose; simpl.
  rewrite PeanoNat.Nat.add_comm; auto.
Qed.

Definition addn : nat -> state nat unit :=
  modify ∘ Nat.add.

Lemma addn_spec n m :
  execState (addn m) n = n + m.
Proof. cbv delta; simpl; firstorder. Qed.

(* Extraction "extract/test_result" test_result. *)


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.TypeInversion.
Require Import Crypto.Reflection.Equality.
Require Import Crypto.Reflection.Z.Syntax.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.PartiallyReifiedProp.
Require Import Crypto.Util.HProp.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.FixedWordSizesEquality.
Require Import Crypto.Util.NatUtil.

Global Instance dec_eq_base_type : DecidableRel (@eq base_type)
  := base_type_eq_dec.
Global Instance dec_eq_flat_type : DecidableRel (@eq (flat_type base_type)) := _.
Global Instance dec_eq_type : DecidableRel (@eq (type base_type)) := _.

Definition base_type_eq_semidec_transparent (t1 t2 : base_type)
  : option (t1 = t2)
  := match base_type_eq_dec t1 t2 with
     | left pf => Some pf
     | right _ => None
     end.
Lemma base_type_eq_semidec_is_dec t1 t2 : base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2.
Proof.
  unfold base_type_eq_semidec_transparent; break_match; congruence.
Qed.

Definition op_beq_hetero {t1 tR t1' tR'} (f : op t1 tR) (g : op t1' tR') : bool
  := match f, g return bool with
     | OpConst T1 v, OpConst T2 v'
       => base_type_beq T1 T2 && Z.eqb v v'
     | Add T1 T2 Tout, Add T1' T2' Tout'
     | Sub T1 T2 Tout, Sub T1' T2' Tout'
     | Mul T1 T2 Tout, Mul T1' T2' Tout'
     | Shl T1 T2 Tout, Shl T1' T2' Tout'
     | Shr T1 T2 Tout, Shr T1' T2' Tout'
     | Land T1 T2 Tout, Land T1' T2' Tout'
     | Lor T1 T2 Tout, Lor T1' T2' Tout'
       => base_type_beq T1 T1' && base_type_beq T2 T2' && base_type_beq Tout Tout'
     | Cmovne T1 T2 T3 T4 Tout, Cmovne T1' T2' T3' T4' Tout'
     | Cmovle T1 T2 T3 T4 Tout, Cmovle T1' T2' T3' T4' Tout'
       => base_type_beq T1 T1' && base_type_beq T2 T2' &&  base_type_beq T3 T3' &&  base_type_beq T4 T4' &&  base_type_beq Tout Tout'
     | Neg Tin Tout n, Neg Tin' Tout' m
       => base_type_beq Tin Tin' && base_type_beq Tout Tout' && Z.eqb n m
     | OpConst _ _, _
     | Add _ _ _, _
     | Sub _ _ _, _
     | Mul _ _ _, _
     | Shl _ _ _, _
     | Shr _ _ _, _
     | Land _ _ _, _
     | Lor _ _ _, _
     | Neg _ _ _, _
     | Cmovne _ _ _ _ _, _
     | Cmovle _ _ _ _ _, _
       => false
     end%bool.

Definition op_beq t1 tR (f g : op t1 tR) : bool
  := Eval cbv [op_beq_hetero] in op_beq_hetero f g.

Definition op_beq_hetero_type_eq {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> t1 = t1' /\ tR = tR'.
Proof.
  destruct f, g;
    repeat match goal with
           | _ => progress unfold op_beq_hetero in *
           | _ => simpl; intro; exfalso; assumption
           | _ => solve [ repeat constructor ]
           | [ |- context[reified_Prop_of_bool ?b] ]
             => let H := fresh in destruct (Sumbool.sumbool_of_bool b) as [H|H]; rewrite H
           | [ H : nat_beq _ _ = true |- _ ] => apply internal_nat_dec_bl in H; subst
           | [ H : base_type_beq _ _ = true |- _ ] => apply internal_base_type_dec_bl in H; subst
           | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_bl in H; subst
           | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_hetero_bl in H; destruct H; subst
           | [ H : andb ?x ?y = true |- _ ]
             => assert (x = true /\ y = true) by (destruct x, y; simpl in *; repeat constructor; exfalso; clear -H; abstract congruence);
                  clear H
           | [ H : and _ _ |- _ ] => destruct H
           | [ H : false = true |- _ ] => exfalso; clear -H; abstract congruence
           | [ H : true = false |- _ ] => exfalso; clear -H; abstract congruence
           | _ => progress break_match_hyps
           end.
Defined.

Definition op_beq_hetero_type_eqs {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> t1 = t1'
  := fun H => let (p, q) := @op_beq_hetero_type_eq t1 tR t1' tR' f g H in p.
Definition op_beq_hetero_type_eqd {t1 tR t1' tR'} f g : to_prop (@op_beq_hetero t1 tR t1' tR' f g) -> tR = tR'
  := fun H => let (p, q) := @op_beq_hetero_type_eq t1 tR t1' tR' f g H in q.

Definition op_beq_hetero_eq {t1 tR t1' tR'} f g
  : forall pf : to_prop (@op_beq_hetero t1 tR t1' tR' f g),
    eq_rect
      _ (fun src => op src tR')
      (eq_rect _ (fun dst => op t1 dst) f _ (op_beq_hetero_type_eqd f g pf))
      _ (op_beq_hetero_type_eqs f g pf)
    = g.
Proof.
  destruct f, g;
    repeat match goal with
           | _ => solve [ intros [] ]
           | _ => reflexivity
           | [ H : False |- _ ] => exfalso; assumption
           | _ => intro
           | [ |- context[op_beq_hetero_type_eqd ?f ?g ?pf] ]
             => generalize (op_beq_hetero_type_eqd f g pf), (op_beq_hetero_type_eqs f g pf)
           | _ => intro
           | _ => progress eliminate_hprop_eq
           | _ => progress inversion_flat_type
           | _ => progress unfold op_beq_hetero in *
           | _ => progress simpl in *
           | [ H : context[andb ?x ?y] |- _ ]
             => destruct x eqn:?, y eqn:?; simpl in H
           | [ H : Z.eqb _ _ = true |- _ ] => apply Z.eqb_eq in H
           | [ H : to_prop (reified_Prop_of_bool ?b) |- _ ] => destruct b eqn:?; compute in H
           | _ => progress subst
           | _ => progress break_match_hyps
           | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_bl in H; subst
           | [ H : wordT_beq_hetero _ _ = true |- _ ] => apply wordT_beq_hetero_bl in H; destruct H; subst
           | _ => congruence
           end.
Qed.

Lemma op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y.
Proof.
  intros ?? f g H.
  pose proof (op_beq_hetero_eq f g H) as H'.
  generalize dependent (op_beq_hetero_type_eqd f g H).
  generalize dependent (op_beq_hetero_type_eqs f g H).
  intros; eliminate_hprop_eq; simpl in *; assumption.
Qed.

Section encode_decode.
  Definition base_type_code (t1 t2 : base_type) : Prop
    := match t1, t2 with
       | TZ, TZ => True
       | TWord s1, TWord s2 => s1 = s2
       | TZ, _
       | TWord _, _
         => False
       end.

    Definition base_type_encode (x y : base_type) : x = y -> base_type_code x y.
    Proof. intro p; destruct p, x; repeat constructor. Defined.

    Definition base_type_decode (x y : base_type) : base_type_code x y -> x = y.
    Proof.
      destruct x, y; simpl in *; intro H;
        try first [ apply f_equal; assumption
                  | exfalso; assumption
                  | reflexivity
                  | apply f_equal2; destruct H; assumption ].
    Defined.
    Definition path_base_type_rect {x y : base_type} (Q : x = y -> Type)
               (f : forall p, Q (base_type_decode x y p))
      : forall p, Q p.
    Proof. intro p; specialize (f (base_type_encode x y p)); destruct x, p; exact f. Defined.
End encode_decode.

Ltac induction_type_in_using H rect :=
  induction H as [H] using (rect _ _);
  cbv [base_type_code] in H;
  let H1 := fresh H in
  let H2 := fresh H in
  try lazymatch type of H with
      | False => exfalso; exact H
      | True => destruct H
      end.
Ltac inversion_base_type_step :=
  lazymatch goal with
  | [ H : _ = TWord _ |- _ ]
    => induction_type_in_using H @path_base_type_rect
  | [ H : TWord _ = _ |- _ ]
    => induction_type_in_using H @path_base_type_rect
  | [ H : _ = TZ |- _ ]
    => induction_type_in_using H @path_base_type_rect
  | [ H : TZ = _ |- _ ]
    => induction_type_in_using H @path_base_type_rect
  end.
Ltac inversion_base_type := repeat inversion_base_type_step.


(** ** Precategories with homsets abelian groups (abgrops). *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.

Require Import UniMath.CategoryTheory.Core.Categories.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Core.Functors.

Section def_precategory_with_abgrops.

  (** Definition of precategories such that homsets are abgrops. *)
  Definition categoryWithAbgropsData (PB : precategoryWithBinOps) : UU :=
    ∏ (x y : PB), @isabgrop (make_hSet (PB⟦x,y⟧) (homset_property PB x y)) (@to_binop _ x y).

  Definition make_categoryWithAbgropsData {PB : precategoryWithBinOps}
             (H : ∏ (x y : PB), @isabgrop (make_hSet (PB⟦x,y⟧) (homset_property _  x y)) (@to_binop _ x y)) :
    categoryWithAbgropsData PB := H.

  Definition categoryWithAbgrops : UU :=
    ∑ PA : precategoryWithBinOps,
           categoryWithAbgropsData PA.

  Definition categoryWithAbgrops_precategoryWithBinOps (PB : categoryWithAbgrops) :
    precategoryWithBinOps := (pr1 PB).

  Coercion categoryWithAbgrops_precategoryWithBinOps :
    categoryWithAbgrops >-> precategoryWithBinOps.

  Definition make_categoryWithAbgrops (PB : precategoryWithBinOps)
             (H : categoryWithAbgropsData PB) : categoryWithAbgrops.
  Proof.
    exact (tpair _ PB H).
  Defined.

  Variable PA : categoryWithAbgrops.

  (** Definitions to access the structure of a precategory with abelian groups. *)
  Definition to_has_homsets : has_homsets PA := (pr1 PA).

  Definition to_homset (x y : PA) : hSet := make_hSet (PA⟦x, y⟧) (to_has_homsets x y).

  Definition to_setwithbinop (x y : PA) := make_setwithbinop (to_homset x y) (to_binop x y).

  Definition to_isabgrop (x y : PA) := (pr2 PA) x y.

  Definition to_abgr (x y : PA) : abgr := make_abgr (to_setwithbinop x y) (to_isabgrop x y).

  Definition to_unel (x y : PA) := unel (to_abgr x y).

  Definition to_lunax (x y : PA) := lunax (to_abgr x y).

  Definition to_lunax' (x y : PA) (f : x --> y) : to_binop x y (to_unel x y) f = f.
  Proof.
    apply to_lunax.
  Qed.

  Definition to_runax (x y : PA) : isrunit op 1%multmonoid := runax (to_abgr x y).

  Definition to_runax' (x y : PA) (f : x --> y) : to_binop x y f (to_unel x y) = f.
  Proof.
    apply to_runax.
  Qed.

  Definition to_inv {x y : PA} : PA⟦x, y⟧ -> PA⟦x, y⟧ := grinv (to_abgr x y).

  Definition to_commax (x y : PA) := commax (to_abgr x y).

  Definition to_commax' {x y : ob PA} (f g : x --> y) : to_binop x y f g = to_binop x y g f.
  Proof.
    apply to_commax.
  Qed.

  (** The following definition gives maps between abgrops homsets by precomposing and postcomposing
      with a morphism. Note that we have not required these to be abelian group morphisms of abelian
      groups. *)
  Definition to_premor {x y : PA} (z : PA) (f : x --> y) : to_abgr y z -> to_abgr x z :=
    fun (g : (to_abgr y z)) => f · g.

  Definition to_postmor (x : PA) {y z : PA} (f : y --> z) : to_abgr x y -> to_abgr x z :=
    fun (g : (to_abgr x y)) => g · f.

  (** Some equations on inverses *)
  Lemma inv_inv_eq {x y : PA} (f : PA⟦x, y⟧) : to_inv (to_inv f) = f.
  Proof.
    unfold to_inv.
    apply (grinvinv (to_abgr x y) f).
  Qed.

  Lemma cancel_inv {x y : PA} (f g : PA⟦x, y⟧) (H : (to_inv f) = (to_inv g)) : f = g.
  Proof.
    apply (grinvmaponpathsinv (to_abgr x y) H).
  Qed.

  Lemma to_inv_unel {x y : PA} : to_inv (to_unel x y) = to_unel x y.
  Proof.
    unfold to_unel.
    set (tmp := grinvunel (to_abgr x y)). cbn in tmp. unfold to_inv.
    apply tmp.
  Qed.

  Lemma linvax {x y : PA} (f : PA⟦x, y⟧) : to_binop x y (to_inv f) f = to_unel x y.
  Proof.
    apply (grlinvax (to_abgr x y)).
  Qed.

  Lemma rinvax {x y : PA} (f : PA⟦x, y⟧) : to_binop x y f (to_inv f) = to_unel x y.
  Proof.
    apply (grrinvax (to_abgr x y)).
  Qed.

  Lemma to_lcan {x y : PA} {f g : PA⟦x, y⟧} (h : PA⟦x, y⟧) :
    to_binop x y h f = to_binop x y h g -> f = g.
  Proof.
    intros H.
    apply (grlcan (to_abgr x y) h H).
  Qed.

  Lemma to_rcan {x y : PA} {f g : PA⟦x, y⟧} (h : PA⟦x, y⟧) :
    to_binop x y f h = to_binop x y g h -> f = g.
  Proof.
    intros H.
    apply (grrcan (to_abgr x y) h H).
  Qed.

  Lemma to_lrw {x y : PA} (f g h : PA⟦x, y⟧) (e : f = g) : to_binop x y f h = to_binop x y g h.
  Proof.
    induction e. apply idpath.
  Qed.

  Lemma to_rrw {x y : PA} (f g h : PA⟦x, y⟧) (e : g = h) : to_binop x y f g = to_binop x y f h.
  Proof.
    apply maponpaths. exact e.
  Qed.

  Lemma to_assoc {x y : PA} (f g h : PA⟦x, y⟧) :
    to_binop _ _ (to_binop _ _ f g) h = to_binop _ _ f (to_binop _ _ g h).
  Proof.
    apply (assocax (to_abgr x y)).
  Qed.

  Lemma to_binop_inv_inv {x y : PA} (f g : PA⟦x, y⟧) :
    to_binop _ _ (to_inv f) (to_inv g) = to_inv (to_binop _ _ f g).
  Proof.
    apply (to_rcan g). rewrite to_assoc. rewrite linvax. rewrite to_runax'.
    apply (to_rcan f). rewrite to_assoc. rewrite linvax. cbn.
    rewrite <- (linvax (to_binop x y f g)). apply maponpaths. apply to_commax'.
  Qed.

  Lemma to_binop_inv_comm_1 {x y : PA} (f g : PA⟦x, y⟧) :
    to_binop _ _ (to_inv f) g = to_inv (to_binop _ _ f (to_inv g)).
  Proof.
    apply (to_rcan (to_binop x y f (to_inv g))). rewrite linvax.
    rewrite (to_commax' f). rewrite to_assoc. rewrite <- (to_assoc g).
    rewrite rinvax. rewrite to_lunax'. rewrite linvax. apply idpath.
  Qed.

  Lemma to_binop_inv_comm_2 {x y : PA} (f g : PA⟦x, y⟧) :
    to_binop _ _ f (to_inv g) = to_inv (to_binop _ _ (to_inv f) g).
  Proof.
    rewrite to_commax'. rewrite (to_commax' _ g). apply to_binop_inv_comm_1.
  Qed.

End def_precategory_with_abgrops.

Arguments to_has_homsets [PA] _ _ _ _ _ _.
Arguments to_homset [PA] _ _.
Arguments to_setwithbinop [PA] _ _.
Arguments to_isabgrop [PA] _ _.
Arguments to_abgr [PA] _ _.
Arguments to_unel [PA] _ _.
Arguments to_lunax [PA] _ _ _.
Arguments to_runax [PA] _ _ _.
Arguments to_premor [PA] [x] [y] _ _ _.
Arguments to_postmor [PA] _ [y] [z] _ _.
Arguments to_inv [PA] [x] [y] _.
Arguments inv_inv_eq [PA] [x] [y] _.
Arguments cancel_inv [PA] [x] [y] _ _ _.

Declare Scope abgrcat.
Delimit Scope abgrcat with abgrcat.
Notation "b <-- a" := (to_abgr a b) : abgrcat.
Notation "a --> b" := (to_abgr a b) : abgrcat.
Notation "1"     := (@identity (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _) : abgrcat.
Notation "0"     := (unel (grtomonoid (abgrtogr _))) : abgrcat.
Notation "0"     := (unel (grtomonoid (abgrtogr (to_abgr _ _)))) : abgrcat.
Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f g) : abgrcat.
Notation "f + g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f g) : abgrcat.
Notation "  - g" := (@grinv (abgrtogr _) g) : abgrcat.
Notation "  - g" := (@grinv (abgrtogr (to_abgr _ _)) g) : abgrcat.
Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr _))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat.
Notation "f - g" := (@op (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _)))) f (@grinv (abgrtogr (to_abgr _ _)) g)) : abgrcat.
Notation "g ∘ f" := (@compose (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _ _ _ f g) : abgrcat.
Notation "f · g" := (@compose (precategory_data_from_precategory (precategoryWithBinOps_precategory (categoryWithAbgrops_precategoryWithBinOps _))) _ _ _ f g) : abgrcat.
Notation "f = g" := (@eqset (pr1setwithbinop (pr1monoid (grtomonoid (abgrtogr (to_abgr _ _))))) f g) : abgrcat.

Section transport_morphisms.

  Variable PA : categoryWithAbgrops.

  Lemma transport_target_to_inv {x y z : ob PA} (f : x --> y) (e : y = z) :
    to_inv (transportf (precategory_morphisms x) e f) =
    transportf (precategory_morphisms x) e (to_inv f).
  Proof.
    induction e. apply idpath.
  Qed.

  Lemma transport_source_to_inv {x y z : ob PA} (f : y --> z) (e : y = x) :
    to_inv (transportf (λ x' : ob PA, precategory_morphisms x' z) e f) =
    transportf (λ x' : ob PA, precategory_morphisms x' z) e (to_inv f).
  Proof.
    induction e. apply idpath.
  Qed.

  Lemma transport_target_to_binop {x y z : ob PA} (f g : x --> y) (e : y = z) :
    to_binop _ _ (transportf (precategory_morphisms x) e f)
             (transportf (precategory_morphisms x) e g) =
    transportf (precategory_morphisms x) e (to_binop _ _ f g).
  Proof.
    induction e. apply idpath.
  Qed.

  Lemma transport_source_to_binop {x y z : ob PA} (f g : y --> z) (e : y = x) :
    to_binop _ _ (transportf (λ x' : ob PA, precategory_morphisms x' z) e f)
             (transportf (λ x' : ob PA, precategory_morphisms x' z) e g) =
    transportf (λ x' : ob PA, precategory_morphisms x' z) e (to_binop _ _ f g).
  Proof.
    induction e. apply idpath.
  Qed.

End transport_morphisms.

Definition oppositeCategoryWithAbgrops (M : categoryWithAbgrops) : categoryWithAbgrops.
Proof.
  use tpair.
  - exact (oppositePrecategoryWithBinOps M).
  - exact (λ a b, @to_isabgrop M (rm_opp_ob b) (rm_opp_ob a)).
Defined.

Definition induced_categoryWithAbgrops (M : categoryWithAbgrops) {X:Type} (j : X -> ob M)
  : categoryWithAbgrops.
Proof.
  use tpair.
  - exact (induced_precategoryWithBinOps M j).
  - exact (λ a b, @to_isabgrop M (j a) (j b)).
Defined.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Import Bool.
Require Import ZArith.
Require Import List.
Require Import setOrder.
Require Import Mapping.
Require Import graphInt.

Module Dgraph (M_Nodes: DecidableEquality) <: graphSig.

Module M_NNodes := genMapping myOrder M_Nodes.
Definition Nodes := M_NNodes.Mapping.
Definition Node := M_Nodes.A.
(*
Definition InternalState:Type :=
	Z -> Nodes -> Arcs -> Arcs -> Order.
*)
Inductive Graph : Set :=
    c_graph :
      forall (alloc : Z) (nodes : Nodes) (FwdArcs BwdArcs : Arcs)
        (order : Order), Graph.
Definition DGraph : Set := Graph.
Definition graph := c_graph.

Definition empty : DGraph :=
  graph 0 M_NNodes.empty M_Arcs.empty M_Arcs.empty M_Order.empty.

Definition g_in (g : DGraph) (id : NodeId) : bool :=
  match g with
  | c_graph alloc nodes fwd bwd order => M_NNodes.map_in id nodes
  end.

Definition get_node (g : DGraph) (id : NodeId) : option Node :=
  match g with
  | c_graph alloc nodes fwd bwd order => M_NNodes.map_get id nodes
  end.

Definition children (g : DGraph) (x : NodeId) : NodeSet :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      match M_Arcs.map_get x fwd with
      | None => emptyNS
      | Some s => s
      end
  end.

Fixpoint closure (ns : NodeSet) (g : DGraph)
 (f : DGraph -> NodeId -> NodeSet) {struct ns} : NodeSet :=
  match ns with
  | ZSet.empty => emptyNS
  | ZSet.item x ns2 => ZSet.add x (ZSet.union (f g x) (closure ns2 g f))
  end.

Definition descendants (g : DGraph) (x : NodeId) : NodeSet :=
  closure (single x) g children.

Definition parents (g : DGraph) (x : NodeId) : NodeSet :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      match M_Arcs.map_get x bwd with
      | None => emptyNS
      | Some s => s
      end
  end.

Definition ancestors (g : DGraph) (x : NodeId) : NodeSet :=
  closure (single x) g parents.

Definition roots (g : DGraph) (x : NodeId) : NodeSet :=
  ZSet.filter (ZSet.add x (ancestors g x))
    (fun y : NodeId =>
     match parents g y with
     | ZSet.empty => true
     | _ => false
     end).

Definition leaves (g : DGraph) (x : NodeId) : NodeSet :=
  ZSet.filter (ZSet.add x (descendants g x))
    (fun y : NodeId =>
     match children g y with
     | ZSet.empty => true
     | _ => false
     end).

Definition add_node (g : DGraph) (x : Node) : NodeId * DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      (alloc,
      graph (alloc + 1) (M_NNodes.map_add (alloc, x) nodes) fwd bwd order)
  end.

Definition add_arc (g : DGraph) (id1 id2 : NodeId) : DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      if andb (M_NNodes.map_in id1 nodes) (M_NNodes.map_in id2 nodes)
      then
       graph alloc nodes
         (M_Arcs.map_add
            (id1,
            match M_Arcs.map_get id1 fwd with
            | Some ns => ZSet.add id2 ns
            | None => single id2
            end) fwd)
         (M_Arcs.map_add
            (id2,
            match M_Arcs.map_get id2 bwd with
            | Some ns => ZSet.add id1 ns
            | None => single id1
            end) fwd) order
      (* specified arcs are inconsistent: not in known nodes *)
      else g
  end.

Definition sub_arc (g : DGraph) (id1 id2 : NodeId) : DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      if andb (M_NNodes.map_in id1 nodes) (M_NNodes.map_in id2 nodes)
      then
       graph alloc nodes
         match M_Arcs.map_get id1 fwd with
         | Some ns => M_Arcs.map_add (id1, ZSet.sub id2 ns) fwd
         | None => fwd
         end
         match M_Arcs.map_get id2 bwd with
         | Some ns => M_Arcs.map_add (id2, ZSet.sub id1 ns) bwd
         | None => bwd
         end order
      (* specified arcs are inconsistent: not in known nodes *)
      else g
  end.

Definition sub_node (g : DGraph) (id : NodeId) : DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      if M_NNodes.map_in id nodes
      then
       let f := fun (gg : DGraph) (x : NodeId) => sub_arc gg x id in
       let g1 := ZSet.reduce DGraph f g (parents g id) in
       let g2 := ZSet.reduce DGraph f g1 (children g id) in
       match g2 with
       | c_graph _ _ fwd2 bwd2 _ =>
           graph alloc (M_NNodes.map_sub id nodes) fwd2 bwd2
             (M_Order.map_sub id order)
       end
      else g
  end.

Definition set_order (g : DGraph) (id : NodeId) (ordvalue : Z) : DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      if M_NNodes.map_in id nodes
      then graph alloc nodes fwd bwd (M_Order.map_add (id, ordvalue) order)
      else g
  end.

Definition get_order (g : DGraph) (id : NodeId) : option Z :=
  match g with
  | c_graph alloc nodes fwd bwd order => M_Order.map_get id order
  end.

Definition project (g : DGraph) (ns : NodeSet) : DGraph :=
  match g with
  | c_graph alloc nodes fwd bwd order =>
      let anc := ZSet.product ns (ancestors g) in
      ZSet.reduce DGraph sub_node g anc
  end.

(*-------------------------------------------------------------------------------*)
Axiom
  g_in_sem :
    forall (g g' : DGraph) (id : NodeId) (N : Node),
    add_node g N = (id, g') -> g_in g' id = true.

Axiom
  g_in_sem2 :
    forall (g g' : DGraph) (id id' : NodeId) (N : Node),
    id <> id' -> add_node g N = (id', g') -> g_in g' id = g_in g id.
Axiom g_in_empty : forall id : NodeId, g_in empty id = false.

(*-------------------------------------------------------------------------------*)
Axiom
  get_node_sem1 :
    forall (g : DGraph) (id : NodeId),
    g_in g id = true -> exists N : Node, get_node g id = Some N.

Axiom
  get_node_sem2 :
    forall (g : DGraph) (id : NodeId),
    g_in g id = false -> get_node g id = None.

Axiom get_node_empty : forall id : NodeId, get_node empty id = None.

(*-------------------------------------------------------------------------------*)
Axiom
  roots_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (roots g id') = true ->
    parents g id = emptyNS /\
    (s_in id' (descendants g id) = true \/ id = id').
Axiom
  leaves_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (leaves g id') = true ->
    children g id = emptyNS /\ (s_in id' (ancestors g id) = true \/ id = id').

(*-------------------------------------------------------------------------------*)
Axiom
  add_sub_node :
    forall (g g' : DGraph) (N : Node) (id : NodeId),
    add_node g N = (id, g') -> sub_node g' id = g.
Axiom
  add_node_sem :
    forall (g g' : DGraph) (N : Node) (id : NodeId),
    add_node g N = (id, g') -> get_node g' id = Some N.

Axiom
  add_node_sem2 :
    forall (g g' : DGraph) (N : Node) (id id' : NodeId),
    id <> id' -> add_node g N = (id', g') -> get_node g' id = get_node g id.

Axiom
  sub_node_sem :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> get_node g' id = None.

Axiom
  sub_node_sem1 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> get_order g' id = None.

Axiom
  sub_node_sem2 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> descendants g' id = emptyNS.

Axiom
  sub_node_sem3 :
    forall (g g' : DGraph) (id : NodeId),
    sub_node g id = g' -> ancestors g' id = emptyNS.

(*-------------------------------------------------------------------------------*)
Axiom
  add_sub_arc :
    forall (g g' : DGraph) (id id' : NodeId),
    add_arc g id id' = g' -> sub_arc g' id id' = g.
Axiom
  add_arc_sem1 :
    forall (g g' : DGraph) (id id' : NodeId),
    add_arc g id id = g' -> s_in id' (children g' id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  children_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (children g id') = true -> g_in g id = true.
Axiom
  descendants_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (descendants g id') = true -> g_in g id = true.

Axiom descendants_sem2 :
        forall (g : DGraph) (x z: NodeId),
	s_in z (descendants g x) = true ->
        (s_in z (children g x)=true) \/
         (exists y:NodeId,
         s_in y (children g x)=true  /\ s_in z (descendants g y)=true)
	.

Axiom
  children_descendants :
    forall (g : DGraph) (id id' : NodeId),
    s_in id' (children g id) = true -> s_in id' (descendants g id) = true.

Axiom
  descendants_closure :
    forall (g : DGraph) (id id' id'' : NodeId),
    s_in id' (descendants g id) = true ->
    s_in id'' (descendants g id') = true ->
    s_in id'' (descendants g id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  parents_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (parents g id') = true -> g_in g id = true.
Axiom
  ancestors_sem :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (ancestors g id') = true -> g_in g id = true.

Axiom
  parents_ancestors :
    forall (g : DGraph) (id id' : NodeId),
    s_in id' (parents g id) = true -> s_in id' (ancestors g id) = true.

Axiom
  ancestors_closure :
    forall (g : DGraph) (id id' id'' : NodeId),
    s_in id' (ancestors g id) = true ->
    s_in id'' (ancestors g id') = true -> s_in id'' (ancestors g id) = true.

Axiom
  children_parents :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (children g id') = true -> s_in id' (parents g id) = true.

Axiom
  parents_children :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (parents g id') = true -> s_in id' (children g id) = true.

Axiom
  descendants_ancestors :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (descendants g id') = true -> s_in id' (ancestors g id) = true.

Axiom
  ancestors_descendants :
    forall (g : DGraph) (id id' : NodeId),
    s_in id (ancestors g id') = true -> s_in id' (descendants g id) = true.

(*-------------------------------------------------------------------------------*)
Axiom
  order_sem :
    forall (g : DGraph) (id : NodeId) (z : Z),
    g_in g id = true -> get_order (set_order g id z) id = Some z.

(*-------------------------------------------------------------------------------*)
Axiom
  project_sem :
    forall (g : DGraph) (ns : NodeSet) (e : NodeId),
    s_in e ns = true ->
    g_in g e = true ->
    g_in (project g ns) e = true /\
    (forall e' : NodeId,
     s_in e' (descendants g e) = true -> g_in (project g ns) e' = true).

End Dgraph.


From Tuto0 Require Export Loader.
Require Import Ltac_utils.

Lemma plane_of_2_lines : forall T U V X Y Z,
    rk(T::U::nil)=2 -> rk(T::V::nil)=2 -> rk(U::V::nil)=2 -> rk(T::U::V::nil)=2 ->
    rk(X::Y::nil)=2 -> rk(X::Z::nil)=2 -> rk(Y::Z::nil)=2 -> rk(X::Y::Z::nil)=2 ->
    rk(T::U::X::Y::nil)=3 ->
    exists R:Point, rk(T::U::V::R::nil)=2 /\ rk(X::Y::Z::R::nil)=2.
Proof.
    intros.
    assert (H1': rk (T :: U :: X :: Y :: nil) <=3) by lia.
    destruct (rk_inter _ _ _ _ H1') as [R [Hi1 Hi2]].
    exists R; split.
    pprove.
    Require Import pprove_plane_of_2_lines_197.
    solve_using LP1P2P3P7.
    pprove.
    Require Import pprove_plane_of_2_lines_198.
    solve_using LP4P5P6P7.
 Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.priority prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.basic.schedule.
Require Import prosa.classic.model.schedule.apa.affinity prosa.classic.model.schedule.apa.interference
               prosa.classic.model.schedule.apa.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module InterferenceEDF.

  Import Schedule Priority Platform Interference Priority Affinity.

  Section Lemmas.

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

    (* Assume any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* Consider any schedule. *)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.

    (* Assume that every job at any time has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Assume that the schedule satisfies the global scheduling invariant
       for EDF, i.e., if any job of tsk is backlogged, every processor
       must be busy with jobs with no larger absolute deadline. *)
    Hypothesis H_scheduler_uses_EDF:
      respects_JLFP_policy_under_weak_APA job_arrival job_cost job_task arr_seq sched
                                          alpha (EDF job_arrival job_deadline).

    (* Under EDF scheduling, a job only causes interference if its deadline
       is not larger than the deadline of the analyzed job. *)
    Lemma interference_under_edf_implies_shorter_deadlines :
      forall j j' t1 t2,
        arrives_in arr_seq j' ->
        job_interference job_arrival job_cost job_task sched alpha j' j t1 t2 != 0 ->
        job_arrival j + job_deadline j <= job_arrival j' + job_deadline j'.
    Proof.
      rename H_scheduler_uses_EDF into PRIO.
      unfold respects_JLDP_policy_under_weak_APA in *.
      intros j j' t1 t2 ARR' INTERF.
      unfold job_interference in INTERF.
      destruct ([exists t': 'I_t2,
                   [exists cpu: processor num_cpus,
                      (t' >= t1) &&
                      backlogged job_arrival job_cost sched j' t' &&
                      can_execute_on alpha (job_task j') cpu &&
                      scheduled_on sched j cpu t']]) eqn:EX.
      {
        move: EX => /existsP [t' /existsP [cpu /andP [/andP [/andP [LE BACK] CAN] SCHED]]].
        by specialize (PRIO j' j cpu t' ARR' BACK SCHED CAN).
      }
      {
        apply negbT in EX; rewrite negb_exists in EX; move: EX => /forallP ALL.
        rewrite big_nat_cond (eq_bigr (fun x => 0)) in INTERF;
          first by rewrite -big_nat_cond big_const_nat iter_addn mul0n  addn0 eq_refl in INTERF.
        move => i /andP [/andP [GEi LTi] _].
        specialize (ALL (Ordinal LTi)).
        rewrite negb_exists in ALL.
        move: ALL => /forallP ALL.
        rewrite (eq_bigr (fun x => 0));
          first by rewrite big_const_ord iter_addn mul0n addn0.
        intros cpu _; specialize (ALL cpu); simpl in ALL.
        destruct (backlogged job_arrival job_cost sched j' i); last by rewrite andFb.
        rewrite GEi 2!andTb in ALL; rewrite andTb.
        by apply negbTE in ALL; rewrite ALL.
      }
    Qed.

  End Lemmas.

End InterferenceEDF.


Require Import Arith.

Require Import matchingl.
Require Import matchinglreduction.
Require Import matchinglproofsystem.

Module MatchLPartialCorrectness(Base : ObjectLanguage).

Module MatchLProofSystemBase := MatchLProofSystem Base.
Export MatchLProofSystemBase.

Require Import Arith.

Proposition forall_in : forall T P l (e : T),
  List.In e l ->
  List.Forall P l ->
  P e.
Proof.
  induction 2; firstorder congruence.
Qed.

Hint Rewrite <- SatAnd : SatRewrite.
Hint Rewrite <- SatEquals : SatRewrite.
Hint Rewrite <- SatExists : SatRewrite.
Hint Rewrite <- SatImplies : SatRewrite.
Hint Rewrite <- SatOr : SatRewrite.

Ltac keep_first_conjunct H :=
  match type of H with
    ?P /\ ?Q => let name := fresh in assert (name: P) by (apply H); clear H; rename name into H
  end.

Definition gamma_entails parent strict s r :=
  forall gamma : M,
    clos s false parent gamma ->
    forall rho : Valuation,
      Satisfies gamma rho (fst r) ->
      exists gamma' : M, clos s strict gamma gamma' /\ Satisfies gamma' rho (snd r).

Lemma gamma_entails_fwd gamma gamma' strict s r :
  clos s false gamma gamma' ->
  gamma_entails gamma strict s r ->
  gamma_entails gamma' strict s r.
Proof.
  intros. intro gamma0;intros.
  destruct H0 with gamma0 rho.
  eauto using clos_trans.
  assumption.
  exists x. firstorder.
Qed.

Lemma entails_forall_gamma_entails : forall A strict phi phi',
  (forall gamma, terminates gamma A ->
    gamma_entails gamma strict A (phi,phi')) <->
  entails strict A (phi,phi').
Proof.
  split.
  firstorder using clos.
  intros; intro gamma0; intros.
  eauto using terminates_fwd.
Qed.

Lemma gamma_entails_unstrict : forall gamma A strict r,
  gamma_entails gamma true A r ->
  gamma_entails gamma strict A r.
Proof.
  unfold gamma_entails.
  firstorder.
  destruct (H gamma0 H0 rho H1).
  exists x.
  intuition.
  destruct strict; auto using clos_unstrict.
Qed.

Definition gamma_entails_system parent strict s (R : System) :=
  forall r, R r -> gamma_entails parent strict s r.

Lemma entails_system_forall_gamma_entails_system :
  forall A strict A',
  (forall gamma, terminates gamma A ->
    gamma_entails_system gamma strict A A') ->
  entails_system strict A A'.
Proof.
  unfold gamma_entails_system, entails_system.
  intros.
  destruct r.
  apply entails_forall_gamma_entails.
  auto.
Qed.

Lemma gamma_entails_system_fwd gamma gamma' strict s R :
  clos s false gamma gamma' ->
  gamma_entails_system gamma strict s R ->
  gamma_entails_system gamma' strict s R.
Proof.
  intro. unfold gamma_entails_system. intro.
  eauto using gamma_entails_fwd.
Qed.

Section FixSystem.

(* A is the new system, for some strange reason *)
Hypothesis SF : (M -> M -> Prop).

Definition gamma_rule (gamma : M) strict (phi phi' : Formula) :=
  gamma_entails gamma strict SF (phi,phi').

Definition gamma_system (gamma : M) strict (A' : System) : Prop :=
  gamma_entails_system gamma strict SF A'.

Theorem lemma1 : forall strict A phi phi',
  forall (proof : PS strict A phi phi'),
    forall gamma,
      terminates gamma SF ->
      gamma_system gamma true A ->
      gamma_rule gamma strict phi phi'.
  intros strict A phi phi' proof.
  induction proof; intros gamma Hterm Hproper.

  (* ps_refl *)
  subst strict. intro;intros.
  exists gamma0. solve[firstorder using clos_refl].

  (* ps_axiom *)
  apply gamma_entails_unstrict; solve [auto].

  (* ps_subst *)
  specialize (IHproof gamma Hterm Hproper).
  clear -IHproof.
  unfold gamma_rule, gamma_entails.
  simpl; setoid_rewrite SatApply.
  solve[firstorder].

  (* ps_trans *)
  specialize (IHproof1 gamma Hterm Hproper).
  specialize (IHproof2 gamma Hterm Hproper).
  clear -IHproof1 IHproof2.
  unfold gamma_rule, gamma_entails.
  intros.
  destruct (IHproof1 gamma0 H rho H0) as [x [xtranz xsat]].
  assert (clos SF false gamma x) by
    (clear -H xtranz; destruct strict;
      eauto using clos,clos_unstrict).
  destruct (IHproof2 x H1 rho xsat) as [gamma'' [Htranz Hsat'']].
  exists gamma''.
  split;[apply clos_trans_lt with x|];assumption.

  (* ps_case *)
  intros n Himpl.
  specialize (IHproof1 gamma Hterm Hproper).
  specialize (IHproof2 gamma Hterm Hproper).
  intro rho.
  simpl. rewrite <- SatOr.
  solve[firstorder].

  (* ps_lf *)
  specialize (IHproof gamma Hterm Hproper).
  unfold gamma_rule, gamma_entails.
  simpl.
  setoid_rewrite <- SatAnd.
  intros. destruct H1.
  destruct (IHproof gamma0 H0 rho H1) as [gamma'' [Htranz Hsat]].
  exists gamma''.
  firstorder.
  eapply patternless_sat; eassumption.

  (* ps_conseq *)
  unfold Valid in H, H0.
  setoid_rewrite <- SatImplies in H.
  setoid_rewrite <- SatImplies in H0.
  intro; intros.
  specialize (IHproof gamma Hterm Hproper gamma0).
  apply H in H2.
  solve[firstorder].

  (* ps_abstr *)
  intro; intros.
  simpl in H1.
  rewrite <- SatExists in H1.
  destruct H1.
  destruct (IHproof gamma Hterm Hproper gamma0 H0 _ H1).
  exists x0.
  rewrite <- notFree_sat in H2; assumption.

  (* ps_circ *)
  specialize (IHproof1 gamma Hterm Hproper).

  assert (forall gamma' : M, clos SF false gamma gamma' ->
    gamma_rule gamma' true phi phi' ->
    gamma_rule gamma' false phi'' phi') as IH2.
  intros; apply IHproof2; unfold gamma_system.
    eauto using terminates_fwd.
    intros r Hr.
    destruct Hr.
    subst r;assumption.

    eapply gamma_entails_system_fwd;eassumption.

  clear -IHproof1 IH2 Hterm.

  cut (gamma_rule gamma true phi phi').

  apply gamma_entails_unstrict.

  apply terminates_trans in Hterm.
  revert Hterm.
  remember (SF) as s.
  induction 1.
  clear H.
  subst s.

  assert (forall y : M,
    clos SF true x y ->
    gamma_rule y true phi phi').
  intros.
  specialize (H0 y H).
  apply H0.
  revert IHproof1; apply gamma_entails_fwd.
  apply clos_unstrict; assumption.
  intros.
  apply IH2.
  clear -H H1. apply clos_unstrict. exact (clos_cat H H1).
  assumption.

  assert (forall y : M,
    clos SF true x y ->
    gamma_rule y false phi'' phi').
  intros.
  apply IH2. apply clos_unstrict. assumption.
  apply H. assumption.

  clear -IHproof1 H1.
  intro gamma_phi; intros.
  specialize (IHproof1 gamma_phi H rho H0).
  destruct IHproof1 as [gamma_phi' [Hstep Hsat]].

  assert (clos SF true x gamma_phi').
    clear -Hstep H. exact (clos_cat H Hstep).
  destruct (H1 gamma_phi' H2) with gamma_phi' rho.
  apply clos_refl.
  assumption.

  exists x0.
  intuition.
  clear -Hstep H4. exact (clos_cat Hstep H4).
Qed.
End FixSystem.

Theorem partial_correctness : forall S A strict phi phi',
  entails_system true S A ->
  PS strict A phi phi' ->
  entails strict S (phi,phi').
Proof.
intros.
apply entails_forall_gamma_entails.
intros.
assert (gamma_system S gamma true A).
revert H; unfold entails_system, gamma_system, gamma_entails_system.
intros. specialize (H r H2).
unfold gamma_entails; intros.
apply H.
eauto using terminates_fwd.
assumption.

eapply lemma1;eassumption.
Qed.

Theorem system_correctness : forall S strict phi phi',
  wd_system S ->
  PS strict S phi phi' ->
  entails strict (ts S) (phi,phi').
Proof.
Abort.

End MatchLPartialCorrectness.