(** * Some useful tools to manipulate lists of lists instead of multisets of multisets (and so to deal with the exchange rules) *)
Require Import Rpos.
Require Import RL.hmr.term.
Require Import RL.hmr.hseq.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Definition Allperm := (Forall2_inf (Permutation_Type (A:=Rpos * term))).

Lemma decomp_Permutation_Type_2 A : forall l l' (x y : A),
    Permutation_Type (x :: y :: l) l' ->
    {' (l1,l2,l3) : _ & {l' = l1 ++ x :: l2 ++ y :: l3} +
                        {l' = l1 ++ y :: l2 ++ x :: l3}}.
Proof.
  intros l l' x y Hperm.
  destruct (in_inf_split x l') as [[la lb] Heq].
  { apply Permutation_Type_in_inf with (x :: y :: l); [ apply Hperm | ].
    left; reflexivity. }
  case (in_inf_app_or la lb y).
  { apply Permutation_Type_in_inf with (y :: l) ; [ | left; reflexivity].
    apply Permutation_Type_cons_inv with x.
    rewrite Heq in Hperm; Permutation_Type_solve. }
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (l1 , l2 , lb).
    right; subst.
    rewrite <- ? app_assoc; reflexivity.
  - intros Hin.
    apply in_inf_split in Hin as [[l1 l2] Heq' ].
    split with (la , l1 , l2).
    left; subst; reflexivity.
Qed.

Lemma decomp_M_case : forall T1 T2 r D A,
    Permutation_Type (T1 ++ T2) (vec r A ++ D) ->
    {' (D1, D2, r1, r2) : _ &
                          prod (Permutation_Type r (r1 ++ r2))
                               ((Permutation_Type D (D1 ++ D2)) *
                                (Permutation_Type T1 (vec r1 A ++ D1)) *
                                (Permutation_Type T2 (vec r2 A ++ D2)))}.
Proof.
  intros T1 T2 r D A Hperm.
  revert T1 T2 D Hperm; induction r; intros T1 T2 D Hperm.
  - simpl in Hperm.
    split with (T1 , T2, nil, nil).
    simpl; repeat split; try Permutation_Type_solve.
  - simpl in Hperm.
    case (in_inf_app_or T1 T2 (a , A)).
    + apply Permutation_Type_in_inf with ((a, A) :: vec r A ++ D); try Permutation_Type_solve.
      left; reflexivity.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr (l1 ++ l2) T2 D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, (a :: r1'), r2).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
    + intros Hin.
      apply in_inf_split in Hin as [[l1 l2] Heq].
      destruct (IHr T1 (l1 ++ l2) D) as [[[[D1 D2] r1'] r2] [H1' [[H2 H3] H4]]].
      * apply Permutation_Type_cons_inv with (a, A).
        rewrite Heq in Hperm; Permutation_Type_solve.
      * split with (D1, D2, r1', (a :: r2)).
        rewrite Heq; simpl; repeat split; try Permutation_Type_solve.
Qed.

Lemma decomp_M_case_2 : forall T1 T2 r s D A B,
    Permutation_Type (T1 ++ T2) (vec r A ++ vec s B ++ D) ->
    {' (D1, D2, r1, r2, s1, s2) : _ &
                          prod (Permutation_Type r (r1 ++ r2))
                               ((Permutation_Type s (s1 ++ s2)) *
                                (Permutation_Type D (D1 ++ D2)) *
                                (Permutation_Type T1 (vec r1 A ++ vec s1 B ++ D1)) *
                                (Permutation_Type T2 (vec r2 A ++ vec s2 B ++ D2)))}.
Proof.
  intros T1 T2 r s D A B Hperm.
  apply decomp_M_case in Hperm as [[[[D1 D2] r1] r2] [H1 [[H2 H3] H4]]].
  symmetry in H2.
  apply decomp_M_case in H2 as [[[[D1' D2'] s1] s2] [H1' [[H2' H3'] H4']]].
  split with (D1', D2', r1,r2,s1,s2).
  repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq_2 : forall T D r s t A B C,
    A <> B ->
    A <> C ->
    Permutation_Type (vec s B ++ vec t C ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s B ++ vec t C) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D r s t A B C Hnc Hnv Hperm.
  revert D r Hperm; induction s; [ induction t | ]; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, C) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , C)).
      + apply Permutation_Type_in_inf with ((a, C) :: vec t C ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnv.
        induction r; inversion i.
        * inversion H.
          apply Hnv; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHt D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, C).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, C):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
  - simpl in *.
    assert (In_inf (a, B) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , B)).
      + apply Permutation_Type_in_inf with ((a, B) :: vec s (B) ++ vec t C ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hnc.
        induction r; inversion i.
        * inversion H.
          apply Hnc; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, B).
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, B):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq : forall T D r s A B,
    A <> B ->
    Permutation_Type (vec s B ++ T) (vec r A ++ D) ->
    {' (Ta, Tb, Da, Db) : _ &
                          prod (Permutation_Type T (Ta ++ Tb))
                               ((Permutation_Type D (Da ++ Db)) *
                                (Permutation_Type (vec s B) Da) *
                                (Permutation_Type (vec r A) Ta) *
                                (Permutation_Type Tb Db)) }.
Proof.
  intros T D r s A B Hneq Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  - split with (vec r A , D, nil, D).
    repeat split; try assumption; try reflexivity.
  - simpl in *.
    assert (In_inf (a, B) D) as HinD.
    { destruct (in_inf_app_or (vec r A) D (a , B)).
      + apply Permutation_Type_in_inf with ((a, B) :: vec s B ++ T); try assumption.
        left; reflexivity.
      + exfalso.
        clear - i Hneq.
        induction r; inversion i.
        * inversion H.
          apply Hneq; apply H2.
        * apply IHr; apply X.
      + assumption. }
    destruct (Add_inf_inv _ _ HinD) as [D' Hadd].
    apply Permutation_Type_Add_inf in Hadd.
    destruct (IHs D' r) as [ [[[Ta Tb] Da ] Db] [H1 [[[H2 H3] H4] H5]]].
    { apply Permutation_Type_cons_inv with (a, B).
      etransitivity; [ apply Hperm | ].
      Permutation_Type_solve. }
    split with (Ta, Tb, ((a, B):: Da), Db).
    repeat split; try assumption; try reflexivity; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_eq : forall T D r s A,
    Permutation_Type (vec s A ++ T) (vec r A ++ D) ->
    {' (a , b , c , T', D') : _ &
                     prod (Permutation_Type r  (a ++ b))
                          ((Permutation_Type s  (b ++ c)) *
                           (Permutation_Type T (vec a A ++ T')) *
                           (Permutation_Type D (vec c A ++ D')) *
                           (Permutation_Type T' D')) }.
Proof.
  intros T D r s A Hperm.
  revert D r Hperm; induction s; intros D r Hperm.
  + split with (r, nil, nil, D , D).
    repeat split; try Permutation_Type_solve.
  + simpl in Hperm.
    case (in_inf_app_or (vec r A) D (a , A)).
    * apply Permutation_Type_in_inf with ((a, A) :: vec s A ++ T); [apply Hperm | ].
      left; reflexivity.
    * intro Hin.
      assert { r' & Permutation_Type r (a :: r')}.
      { clear - Hin.
        induction r.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with r; simpl; reflexivity.
          + specialize (IHr Hin) as [r' Hperm].
            split with (a0 :: r').
            Permutation_Type_solve. }
      destruct X as [r' Hperm'].
      destruct (IHs D r') as [ [[[[a1 b1] c1] T'] D'] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        transitivity (vec r A ++ D); try Permutation_Type_solve.
        change ((a, A) :: vec r' A ++ D) with (vec (a :: r') A ++ D).
        apply Permutation_Type_app; try reflexivity.
        apply vec_perm; apply Hperm'. }
      split with (a1 , a :: b1, c1, T' , D').
      repeat split; try Permutation_Type_solve.
    * intro Hin.
      destruct (Add_inf_inv _ _ Hin) as [D' Hadd].
      apply Permutation_Type_Add_inf in Hadd.
      destruct (IHs D' r) as [ [[[[a1 b1] c1] T'] D''] [H1 [[[H2 H3] H4] H5]]].
      { apply Permutation_Type_cons_inv with (a, A).
        Permutation_Type_solve. }
      split with (a1, b1, a :: c1 , T', D'').
      repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_eq_2 : forall T D r s r' s' A B,
    A <> B ->
    Permutation_Type (vec s' B ++ vec r' A ++ T) (vec s B ++ vec r A ++ D) ->
    {' (a1 , b1 , c1, a2 , b2, c2, T', D') : _ &
                     prod (Permutation_Type r  (a1 ++ b1))
                          ((Permutation_Type r'  (b1 ++ c1)) *
                           (Permutation_Type s  (a2 ++ b2)) *
                           (Permutation_Type s'  (b2 ++ c2)) *
                           (Permutation_Type T (vec a2 B ++ vec a1 A ++ T')) *
                           (Permutation_Type D (vec c2 B ++ vec c1 A ++ D')) *
                           (Permutation_Type T' D')) }.
Proof.
  intros T D r s r' s' A B Hneq Hperm.
  revert s r' r T D A B Hneq Hperm.
  induction s'; [ intros s ; induction s ; [ intros r'; induction r'; [ intros r; induction r | ] | ] | ].
  - intros T D A B Hneq Hperm.
    split with (nil, nil,nil,nil,nil,nil , T , D).
    repeat split; try Permutation_Type_solve.
  - intros T D A B Hneq Hperm.
    simpl in *.
    destruct (in_inf_split (a , A) T) as [[T1 T2] HeqT].
    { apply Permutation_Type_in_inf with ((a , A) :: vec r A ++ D); try Permutation_Type_solve.
      left; reflexivity. }
    subst.
    destruct (IHr (T1 ++ T2) D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
    { apply Permutation_Type_cons_inv with (a , A).
      Permutation_Type_solve. }
    split with ((a :: a1), b1,c1,a2,b2,c2, T' , D').
    repeat split; try Permutation_Type_solve.
  - intros r T D A B Hneq Hperm; simpl in *.
    case (in_inf_app_or (vec r A) D (a , A)).
    { apply Permutation_Type_in_inf with ((a , A) :: vec r' A ++ T); try Permutation_Type_solve.
      left; reflexivity. }
    + intros Hin.
      assert { r' & Permutation_Type r (a :: r')}.
      { clear - Hin.
        induction r.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with r; simpl; reflexivity.
          + specialize (IHr Hin) as [r' Hperm].
            split with (a0 :: r').
            Permutation_Type_solve. }
      destruct X as [vr Hperm'].
      destruct (IHr' vr T D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a , A).
        change ((a , A) :: vec vr A ++ D) with (vec (a :: vr) A ++ D).
        etransitivity ; [ apply Hperm | ].
        apply Permutation_Type_app; [ apply vec_perm | ]; Permutation_Type_solve. }
      split with (a1, a :: b1, c1, a2, b2, c2, T', D').
      repeat split; simpl; try Permutation_Type_solve.
    + intros Hin.
      apply in_inf_split in Hin as [[D1 D2] HeqD]; subst.
      destruct (IHr' r T (D1 ++ D2) A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a,  A).
        Permutation_Type_solve. }
      split with (a1, b1, a :: c1 , a2, b2, c2, T', D').
      simpl; repeat split; try Permutation_Type_solve.
  - intros r' r T D A B Hneq Hperm; simpl in *.
    assert (In_inf (a , B) T).
    { case (in_inf_app_or (vec r' A) T (a , B)); try (intro H; assumption).
      { apply Permutation_Type_in_inf with ((a, B) :: vec s B ++ vec r A ++ D); try Permutation_Type_solve.
        left; reflexivity. }
      intro H; exfalso; clear - H Hneq.
      induction r'; simpl in H; inversion H.
      + inversion H0; subst; now apply Hneq.
      + apply IHr'; try assumption. }
    apply in_inf_split in X as [[T1 T2] Heq]; subst.
    destruct (IHs r' r (T1 ++ T2) D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
    { apply Permutation_Type_cons_inv with (a , B).
      Permutation_Type_solve. }
    split with (a1, b1,c1,a :: a2,b2,c2, T' , D').
    repeat split; try Permutation_Type_solve.
  - intros s r' r T D A B Hneq Hperm; simpl in *.
    case (in_inf_app_or (vec s B) (vec r A ++ D) (a , B)).
    { apply Permutation_Type_in_inf with ((a, B) :: vec s' B ++ vec r' A ++ T); try Permutation_Type_solve.
      left; reflexivity. }
    + intros Hin.
      assert { s' & Permutation_Type s (a :: s')}.
      { clear - Hin.
        induction s.
        - inversion Hin.
        - simpl in Hin.
          destruct Hin as [Heq | Hin].
          + inversion Heq; split with s; simpl; reflexivity.
          + specialize (IHs Hin) as [s' Hperm].
            split with (a0 :: s').
            Permutation_Type_solve. }
      destruct X as [vs Hperm'].
      destruct (IHs' vs r' r T D A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a , B).
        change ((a , B) :: vec vs B ++ vec r A ++  D) with (vec (a :: vs) B ++ vec r A ++ D).
        etransitivity ; [ apply Hperm | ].
        apply Permutation_Type_app; [ apply vec_perm | ]; Permutation_Type_solve. }
      split with (a1, b1, c1, a2, a::b2, c2, T', D').
      repeat split; simpl; try Permutation_Type_solve.
    + intros H.
      assert (In_inf (a , B) D) as Hin; [ | clear H].
      { case (in_inf_app_or (vec r A) D (a , B)); [ apply H | | ]; try (intros H0; assumption).
        intro H0; exfalso; clear - H0 Hneq.
        induction r; simpl in H0; inversion H0.
        - inversion H; subst; now apply Hneq.
        - apply IHr; try assumption. }
      apply in_inf_split in Hin as [[D1 D2] HeqD]; subst.
      destruct (IHs' s r' r T (D1 ++ D2) A B Hneq) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]].
      { apply Permutation_Type_cons_inv with (a,  B).
        Permutation_Type_solve. }
      split with (a1, b1, c1 , a2, b2, a :: c2, T', D').
      simpl; repeat split; try Permutation_Type_solve.
Qed.

Lemma perm_decomp_vec_neq_2_2 : forall T1 T2 r s r' s' A B C D,
    A <> C ->
    A <> D ->
    B <> C ->
    B <> D ->
    Permutation_Type (vec s A ++ vec r B ++ T1) (vec s' C ++ vec r' D ++ T2) ->
    {' (T', D') : _ &
                          prod (Permutation_Type T1 (vec s' C ++ vec r' D ++ T'))
                               ((Permutation_Type T2 (vec s A ++ vec r B ++ D')) *
                                (Permutation_Type T' D'))}.
Proof.
  intros T1 T2 r s r' s'.
  revert s r' r T1 T2.
  induction s'; [ intros s ; induction s ; [ intros r' ; induction r' ; [ intros r; induction r | ] | ] | ].
  - intros T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    split with (T1, T2).
    simpl in *; repeat split; Permutation_Type_solve.
  - intros T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , B) T2) as [[D1 D2] Heq].
    { apply Permutation_Type_in_inf with ((a, B) :: vec r B ++ T1); try Permutation_Type_solve.
      left; reflexivity. }
    subst.
    destruct (IHr T1 (D1 ++ D2) A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , B).
      Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , D) T1) as [[T1' T2'] Heq].
    { case (in_inf_app_or (vec r B) T1 (a , D)) ; [ apply Permutation_Type_in_inf with ((a, D) :: vec r' D ++ T2); [ Permutation_Type_solve | left; reflexivity ] | | auto ].
      intros H; clear - H Hneq4.
      exfalso.
      induction r; simpl in H; inversion H.
      - inversion H0.
        apply Hneq4; apply H3.
      - apply IHr; apply X. }
    subst.
    destruct (IHr' r (T1' ++ T2') T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , D); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros r' r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , A) T2) as [[D1 D2] Heq].
    { case (in_inf_app_or (vec r' D) T2 (a , A)) ; [ apply Permutation_Type_in_inf with ((a, A) :: vec s A ++ vec r B ++ T1); [ Permutation_Type_solve | left; reflexivity ] | | auto ].
      intros H; clear - H Hneq2.
      exfalso.
      induction r'; simpl in H; inversion H.
      - inversion H0.
        apply Hneq2; symmetry; apply H3.
      - apply IHr'; apply X. }
    subst.
    destruct (IHs r' r T1 (D1 ++ D2) A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , A); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
  - intros s r' r T1 T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4 Hperm.
    simpl in *.
    destruct (in_inf_split (a , C) T1) as [[T1' T2'] Heq].
    { case (in_inf_app_or (vec s A) (vec r B ++ T1) (a , C)) ; [ apply Permutation_Type_in_inf with ((a, C) :: vec s' C ++ vec r' D ++ T2); [ Permutation_Type_solve | left; reflexivity ] | | ].
      - intros H; clear - H Hneq1.
        exfalso.
        induction s; simpl in H; inversion H.
        + inversion H0.
          apply Hneq1; apply H3.
        + apply IHs; apply X.
      - intro H0 ;case (in_inf_app_or (vec r B) T1 (a , C)) ; [ apply H0 | | auto ].
        intros H; clear - H Hneq3.
        exfalso.
        induction r; simpl in H; inversion H.
        + inversion H0; subst; apply Hneq3; reflexivity.
        + apply IHr; apply X. }
    subst.
    destruct (IHs' s r' r (T1' ++ T2') T2 A B C D Hneq1 Hneq2 Hneq3 Hneq4) as [[T' D'] [H1' [H2' H3']]].
    { apply Permutation_Type_cons_inv with (a , C); Permutation_Type_solve. }
    split with (T', D').
    repeat split; try Permutation_Type_solve.
Qed.


Lemma negation_winning_strategy {g} {p} {s : strategy g p}
  : winning_strategy s <-> winning_strategy (~s).
Proof.
  unfold winning_strategy.
  unfold winning_strategy.
  apply forall_iff_compat; intro w.
  rewrite <- negation_player_follows_strategy.
  apply imp_iff_compat_l.
  apply negation_play_won_by.
Qed.


Require Import FunctionalExtensionality JMeq.
Require Export SpecializedCategory Functor.
Require Import Common Notations FunctorAttributes FEqualDep.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Local Ltac faithful_t :=
  repeat (unfold Object in *; simpl in *; subst;
          match goal with
            | _ => intro
            | _ => progress trivial
            | [ |- _ = _ ] => (apply functional_extensionality_dep; intro)
            | _ => progress simpl_eq
            | [ H : _ = _ |- _ ] => fg_equal_in H
            (*| [ |- projT2 ?a == projT2 ?b ] =>
              (cut (projT1 a = projT1 b); [ (*generalize a b*) | faithful_t ](*;
               intros [] [] ?*))*)
            | _ => progress JMeq_eq
          end).

Section sigT_obj_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Type.
  Variable Pmor : forall s d : sigT Pobj, A.(Morphism) (projT1 s) (projT1 d) -> Type.

  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Hypothesis P_Associativity : forall o1 o2 o3 o4 m1 m2 m3 m1' m2' m3',
    @Pcompose o1 o2 o4 _ m1 (@Pcompose o2 o3 o4 m3 m2 m3' m2') m1' ==
    @Pcompose o1 o3 o4 m3 _ m3' (@Pcompose o1 o2 o3 m2 m1 m2' m1').

  Hypothesis P_LeftIdentity : forall a b f f',
    @Pcompose a b b _ f (@Pidentity b) f' ==
    f'.

  Hypothesis P_RightIdentity : forall a b f f',
    @Pcompose a a b f _ f' (@Pidentity a) ==
    f'.

  Definition SpecializedCategory_sigT : @SpecializedCategory (sigT Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sigT (@Pmor s d))
          (fun x => existT _ (Identity (C := A) (projT1 x)) (Pidentity x))
          (fun s d d' m1 m2 => existT _ (Compose (C := A) (projT1 m1) (projT1 m2)) (Pcompose (projT2 m1) (projT2 m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition projT1_functor : SpecializedFunctor SpecializedCategory_sigT A
    := Build_SpecializedFunctor SpecializedCategory_sigT A
                                (@projT1 _ _)
                                (fun _ _ => @projT1 _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).
End sigT_obj_mor.

Arguments projT1_functor {objA A Pobj Pmor Pidentity Pcompose P_Associativity P_LeftIdentity P_RightIdentity}.

Section sigT_obj.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Type.

  Definition SpecializedCategory_sigT_obj : @SpecializedCategory (sigT Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => A.(Morphism) (projT1 s) (projT1 d))
          (fun x => Identity (C := A) (projT1 x))
          (fun s d d' m1 m2 => Compose (C := A) m1 m2)
          _
          _
          _
        )
    end;
    abstract (intros; destruct_sig; simpl; auto with category).
  Defined.

  Definition projT1_obj_functor : SpecializedFunctor SpecializedCategory_sigT_obj A
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj A
                                (@projT1 _ _)
                                (fun s d m => m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition SpecializedCategory_sigT_obj_as_sigT : @SpecializedCategory (sigT Pobj).
    refine (@SpecializedCategory_sigT _ A Pobj (fun _ _ _ => unit) (fun _ => tt) (fun _ _ _ _ _ _ _ => tt) _ _ _);
    abstract (simpl; intros; trivial).
  Defined.

  Definition sigT_functor_obj : SpecializedFunctor SpecializedCategory_sigT_obj_as_sigT SpecializedCategory_sigT_obj
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj_as_sigT SpecializedCategory_sigT_obj
                                (fun x => x)
                                (fun _ _ => @projT1 _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition sigT_functor_obj_inv : SpecializedFunctor SpecializedCategory_sigT_obj SpecializedCategory_sigT_obj_as_sigT
    := Build_SpecializedFunctor SpecializedCategory_sigT_obj SpecializedCategory_sigT_obj_as_sigT
                                (fun x => x)
                                (fun _ _ m => existT _ m tt)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Lemma sigT_obj_eq : ComposeFunctors sigT_functor_obj sigT_functor_obj_inv = IdentityFunctor _ /\ ComposeFunctors sigT_functor_obj_inv sigT_functor_obj = IdentityFunctor _.
    split; functor_eq; hnf in *; destruct_type @sigT; f_equal; trivial.
  Qed.

  Lemma sigT_obj_compat : ComposeFunctors projT1_obj_functor sigT_functor_obj = projT1_functor.
    functor_eq.
  Qed.
End sigT_obj.

Arguments projT1_obj_functor {objA A Pobj}.

Section sigT_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pmor : forall s d, A.(Morphism) s d -> Type.

  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Hypothesis P_Associativity : forall o1 o2 o3 o4 m1 m2 m3 m1' m2' m3',
    @Pcompose o1 o2 o4 _ m1 (@Pcompose o2 o3 o4 m3 m2 m3' m2') m1' ==
    @Pcompose o1 o3 o4 m3 _ m3' (@Pcompose o1 o2 o3 m2 m1 m2' m1').

  Hypothesis P_LeftIdentity : forall a b f f',
    @Pcompose a b b _ f (@Pidentity b) f' ==
    f'.

  Hypothesis P_RightIdentity : forall a b f f',
    @Pcompose a a b f _ f' (@Pidentity a) ==
    f'.

  Definition SpecializedCategory_sigT_mor : @SpecializedCategory objA.
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sigT (@Pmor s d))
          (fun x => existT _ (Identity (C := A) x) (Pidentity x))
          (fun s d d' m1 m2 => existT _ (Compose (C := A) (projT1 m1) (projT1 m2)) (Pcompose (projT2 m1) (projT2 m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition projT1_mor_functor : SpecializedFunctor SpecializedCategory_sigT_mor A.
    refine (Build_SpecializedFunctor SpecializedCategory_sigT_mor A
      (fun x => x)
      (fun s d m => projT1 m)
      _
      _
    );
    intros; reflexivity.
  Defined.

  Definition SpecializedCategory_sigT_mor_as_sigT : @SpecializedCategory (sigT (fun _ : objA => unit)).
    apply (@SpecializedCategory_sigT _ A _ (fun s d => @Pmor (projT1 s) (projT1 d)) (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2));
      abstract (intros; trivial).
  Defined.

  Definition sigT_functor_mor : SpecializedFunctor SpecializedCategory_sigT_mor_as_sigT SpecializedCategory_sigT_mor.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (@projT1 _ _)
          (fun _ _ => @id _)
          _
          _
        )
    end;
    simpl; intros; reflexivity.
  Defined.

  Definition sigT_functor_mor_inv : SpecializedFunctor SpecializedCategory_sigT_mor SpecializedCategory_sigT_mor_as_sigT.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (fun x => existT _ x tt)
          (fun _ _  => @id _)
          _
          _
        )
    end;
    abstract (simpl; intros; f_equal; trivial).
  Defined.

  Lemma sigT_mor_eq : ComposeFunctors sigT_functor_mor sigT_functor_mor_inv = IdentityFunctor _ /\ ComposeFunctors sigT_functor_mor_inv sigT_functor_mor = IdentityFunctor _.
    split; functor_eq; simpl_eq; trivial.
  Qed.

  Lemma sigT_mor_compat : ComposeFunctors projT1_mor_functor sigT_functor_mor = projT1_functor.
    functor_eq.
  Qed.
End sigT_mor.

Arguments projT1_mor_functor {objA A Pmor Pidentity Pcompose P_Associativity P_LeftIdentity P_RightIdentity}.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^291 - 19
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 64;
    bitwidth := 64;
    s := 2^291;
    c := [(1, 19)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Arith.Peano_dec.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Ascii.
Require Import Coq.ZArith.Znat.
Require Import Coq.Program.Equality.
Require Import Tactics.
Require Import Keys.
Require Import Definitions2.
Require Import Nameless2.
Require Import CorrectnessLemmas.
Require Import Environment.
Require Import Heap.

Module TypeSoundness.

  Import Heap.
  Import Environment.

Lemma subst_rho_natural :
  forall rho, subst_rho rho Ty2_Natural = Ty2_Natural.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e Ty2_Natural) with Ty2_Natural.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_boolean :
  forall rho, subst_rho rho Ty2_Boolean = Ty2_Boolean.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e Ty2_Boolean) with Ty2_Boolean.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_unit :
  forall rho, subst_rho rho Ty2_Unit = Ty2_Unit.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e  Ty2_Unit) with  Ty2_Unit.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_effect :
  forall rho, subst_rho rho Ty2_Effect = Ty2_Effect.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e  Ty2_Effect) with  Ty2_Effect.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_rgn_const :
  forall rho c, fold_subst_rgn rho (Rgn2_Const true true c) = (Rgn2_Const true true c).
Proof.
  intros rho c.
  unfold  fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_Const true true c)) with (Rgn2_Const true true c).
    rewrite IHthis2 by assumption.
    reflexivity.
    simpl. reflexivity.
Qed.

Lemma subst_rho_index :
  forall rho n, fold_subst_rgn rho (Rgn2_BVar true true n) = (Rgn2_BVar true true n).
Proof.
  intros rho n.
  unfold  fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_BVar true true n)) with (Rgn2_BVar true true n).
    rewrite IHthis2 by assumption.
    reflexivity.
    simpl. reflexivity.
Qed.

Lemma fold_eps_leaf :
forall eff is_bst,
  eff = (fun sa : StaticAction2 =>
           exists sa' : StaticAction2, eff sa' /\
                                       fold_subst_sa {| R.this := R.Raw.Leaf Region; R.is_bst := is_bst |} sa' = sa).
Proof.
 intros eff is_bst.
 apply Extensionality_Ensembles;
      unfold Same_set, Included; split; intros x H.
      * unfold In in *.
        exists x. intuition. unfold fold_subst_sa. destruct x; unfold fold_subst_rgn, subst_rgn; f_equal.
      * unfold In in *.  destruct H as [sa [? ?]].
        assert ( fold_subst_sa {| R.this := R.Raw.Leaf Region; R.is_bst := is_bst |} sa = sa)
          by (unfold fold_subst_sa, fold_subst_rgn, subst_rgn; simpl; destruct sa; subst; f_equal).
        rewrite H1 in H0. now subst.
Qed.

Lemma fold_eps_node :
  forall eff k t e this1 this2
         (Hl : R.Raw.bst this1)
         (Hr : R.Raw.bst this2)
         (is_bst : R.Raw.bst (R.Raw.Node this1 k e this2 t)),
    fold_subst_eps {| R.this := this2; R.is_bst := Hr |}
     (subst_eps k (Rgn2_Const true false e)
        (fold_subst_eps {| R.this := this1; R.is_bst := Hl |} eff)) =
   fold_subst_eps
     {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} eff.
Proof.
  intros eff k t e this1 this2 Hl Hr is_bst.
  apply Extensionality_Ensembles;
  unfold Same_set, Included; split; intros x H; unfold In in *.
  - unfold fold_subst_eps in *.
    destruct H as [sa [[sa' [[sa'' [H1 H2]] H3]] H4]].
    exists sa''. intuition. subst.
    unfold fold_subst_sa, subst_sa; destruct sa''; f_equal.
  - unfold fold_subst_eps in *.
    destruct H as [sa [H1 H2]].
    exists (subst_sa k (Rgn2_Const true false e) (fold_subst_sa {| R.this := this1; R.is_bst := Hl |} sa)).
    split.
    + unfold subst_eps.
      exists (fold_subst_sa {| R.this := this1; R.is_bst := Hl |} sa).
      intuition. exists sa. intuition.
    + destruct sa; rewrite <- H2; simpl; f_equal.
Qed.

Lemma subst_rho_arrow :
  forall rho tyr1 eff1 tyr2 eff2 tyr3,
    subst_rho rho (Ty2_Arrow tyr1 eff1 tyr2 eff2 tyr3) = Ty2_Arrow (subst_rho rho tyr1) (fold_subst_eps rho eff1) (subst_rho rho tyr2)
                                                                   (fold_subst_eps rho eff2) (subst_rho rho tyr3) .
Proof.
  unfold subst_rho.
  unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros tyr1 eff1 tyr2 eff2 tyr3.
  - f_equal; unfold fold_subst_eps; apply fold_eps_leaf.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    rewrite IHthis1 with (is_bst:=Hl) by assumption. f_equal.
    unfold subst_in_type; simpl.
    rewrite IHthis2 with (is_bst:=Hr) by assumption. f_equal.
    + apply fold_eps_node.
    + apply fold_eps_node.
Qed.

Lemma subst_rho_tyref : forall rho r ty,subst_rho rho (Ty2_Ref r ty) =  Ty2_Ref (fold_subst_rgn rho r) (subst_rho rho ty).
Proof.
  unfold subst_rho, fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros r ty.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    unfold subst_in_type, open_var, close_var; simpl.
    rewrite IHthis2 by assumption.
    unfold subst_in_type, open_var, close_var. simpl.
    reflexivity.
Qed.

Lemma subst_rho_forallrgn  :
  forall rho eff rty,
    subst_rho rho (Ty2_ForallRgn eff rty) = Ty2_ForallRgn (fold_subst_eps rho eff) (subst_rho rho rty).
Proof.
  unfold subst_rho, fold_subst_eps. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros eff rty.
  - f_equal; unfold fold_subst_eps; apply fold_eps_leaf.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    rewrite IHthis1 with (is_bst:=Hl) by assumption. f_equal.
    unfold subst_in_type; simpl.
    rewrite IHthis2 with (is_bst:=Hr) by assumption. f_equal.
    apply fold_eps_node.
Qed.

Lemma subst_rho_fvar_1:
  forall rho x,
    (exists v, fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_Const true true v) \/ fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_FVar true true x.
Proof.
  intro rho. destruct rho. induction this; intros x.
  - unfold fold_subst_rgn, R.fold, R.Raw.fold; simpl. right. reflexivity.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    replace (fold_subst_rgn {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} (Rgn2_FVar true true x))
    with
    (fold_subst_rgn {| R.this := this2; R.is_bst := Hr |}
                    (subst_rgn k (Rgn2_Const true false e)
                               (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x)))
    ) by (unfold fold_subst_rgn, R.fold, R.Raw.fold in *; reflexivity).
    destruct (IHthis1 Hl x).
    + destruct H as [v ?].
      left. exists v.
      rewrite H.
      replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_Const true true v)) with (Rgn2_Const true true v) by (simpl; reflexivity).
      apply subst_rho_rgn_const.
    + rewrite H.
      unfold subst_rgn.
      destruct (RMapP.eq_dec k x); subst; simpl.
      * left. exists e.
        apply subst_rho_rgn_const.
      * apply IHthis2.
Qed.

Module RMapOrdProp := FMapFacts.OrdProperties R.

Lemma subst_rho_fvar_2:
  forall rho x v,
   find_R (Rgn2_FVar true false x) rho = Some v ->
   fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_Const true true v.
Proof.
  intro rho.
  destruct rho.
  induction this; intros x v H.
  - unfold fold_subst_rgn, R.fold, R.Raw.fold; simpl.
    inversion H.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    replace (fold_subst_rgn {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} (Rgn2_FVar true true x))
    with
    (fold_subst_rgn {| R.this := this2; R.is_bst := Hr |}
                    (subst_rgn k (Rgn2_Const true false e)
                               (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x)))
    ) by (unfold fold_subst_rgn, R.fold, R.Raw.fold in *; reflexivity).
    apply  RMapP.find_mapsto_iff in H.

    inversion H; subst.
    + (* x = k *)
      apply RMapP.find_mapsto_iff in H.

      unfold R.find, R.Raw.find in H. simpl in H.
      destruct (AsciiVars.compare k k).
      * unfold AsciiVars.lt in l. omega.
      *  unfold AsciiVars.eq in e0.
         apply R.Raw.InRoot with (l:= R.Raw.empty nat) (r:=R.Raw.empty nat) (e:=e) (h:=t) in e0.
         inversion e0; subst.
         {  admit. }
         {  inversion H1. }
         {  inversion H1. }
      *  unfold AsciiVars.lt in l. omega.

      (*replace (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true k) )
      with (Rgn2_FVar true true k) by admit.
      simpl. destruct (RMapP.eq_dec k k).
      * rewrite subst_rho_rgn_const. reflexivity.
      * contradict n. reflexivity. *)
    + apply R.Raw.Proofs.find_1 in H1; auto.
      apply IHthis1 with (is_bst := Hl) in H1. rewrite H1. simpl.
      rewrite subst_rho_rgn_const. reflexivity.
    + apply R.Raw.Proofs.find_1 in H1; auto.
      assert (R.Raw.In x this2) by (apply R.Raw.Proofs.find_iff in H1; [ eapply R.Raw.Proofs.MapsTo_In; eassumption | assumption]).
      apply IHthis2 with (is_bst := Hr) in H1.

      (* apply R.Raw.InRight with (l:= R.Raw.empty nat) (r:=this2) (h:=t) (e':=e) (y:=k) in H0.
      inversion H0; subst.
      {  admit. }
      { inversion H3. }
      { admit. } *)

      assert (Hthis1 : (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x) =
                        Rgn2_FVar true true x)) by admit.
      rewrite Hthis1. simpl.
      assert (AsciiVars.lt k x) by admit.
      apply AsciiVars.lt_not_eq in H2.
      destruct (RMapP.eq_dec k x); subst; [contradict H0; auto | assumption].
Qed.

Lemma subst_rho_open_close_rgn :
  forall rho n w v' rho' r r0 x,
    lc_type_rgn r0 ->
    find_R w rho = Some v' ->
    fold_subst_rgn rho r = fold_subst_rgn rho' (closing_rgn_in_rgn2 n x r0) ->
    fold_subst_rgn rho' (opening_rgn_in_rgn2 n (Rgn2_Const true true v') (closing_rgn_in_rgn2 n x r0)) =
    fold_subst_rgn rho (opening_rgn_in_rgn2 n (mk_rgn_type w) r).
Proof.
  intros rho n w v' rho' r r0 x Hlc1 HF H.
  unfold rgn2_in_typ in r.
  unfold rgn2_in_typ in r0.
  unfold rgn2_in_exp in w.
  dependent induction r; dependent induction Hlc1; simpl in *.
  - repeat rewrite subst_rho_rgn_const in *. auto.
  - destruct (RMapP.eq_dec r0 x); subst; simpl in *.
    + rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
    + auto.
  - auto.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho n0) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
    + auto.
  - rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + repeat rewrite subst_rho_index in H. inversion H; subst.
      rewrite NPeano.Nat.eqb_refl.
      rewrite subst_rho_rgn_const.
      dependent induction w; simpl.
      * inversion HF; subst.
        rewrite subst_rho_rgn_const.
        reflexivity.
      * inversion HF. symmetry.
        apply subst_rho_fvar_2. now simpl.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho' r) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
Qed.

Lemma subst_rho_open_close_sa:
  forall rho n w v' rho' sa sa1 x,
    lc_type_sa sa ->
    find_R w rho = Some v' ->
    fold_subst_sa rho sa1 = fold_subst_sa rho' (closing_rgn_in_sa2 n x sa) ->
    fold_subst_sa rho' (opening_rgn_in_sa2 n (Rgn2_Const true true v') (closing_rgn_in_sa2 n x sa)) =
    fold_subst_sa rho (opening_rgn_in_sa2 n (mk_rgn_type w) sa1).
Proof.
  intros rho n w v' rho' sa sa1 x Hlc HF H.
  unfold fold_subst_sa.
  inversion Hlc; subst; induction sa1;
  unfold fold_subst_sa in H; inversion H; simpl in *;
  erewrite subst_rho_open_close_rgn; eauto.
Qed.

Lemma subst_rho_open_close_eps:
  forall rho n w v' rho' e e1 x,
    lc_type_eps e ->
    find_R w rho = Some v' ->
    fold_subst_eps rho e1 = fold_subst_eps rho' (closing_rgn_in_eps2 n x e) ->
    fold_subst_eps rho' (opening_rgn_in_eps2 n (Rgn2_Const true true v') (closing_rgn_in_eps2 n x e)) =
    fold_subst_eps rho (opening_rgn_in_eps2 n (mk_rgn_type w) e1).
Proof.
  intros rho n w v' rho' e e1 x  Hcl1 HF H.
  apply Extensionality_Ensembles.
  unfold Same_set, Included.
  split. intros; unfold In in *.
  - unfold fold_subst_eps.  unfold fold_subst_eps in H0.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2. unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
    destruct H0 as [sa [[sa' [[sa'' [H2 H3]] H4]] H5]].
    subst.
    exists (opening_rgn_in_sa2 n (mk_rgn_type w) sa'').
    split.
    exists sa''. intuition. admit.
    symmetry.
    eapply subst_rho_open_close_sa.
    inversion Hcl1; subst. destruct (H0 sa''). assumption.
    assumption.
    unfold fold_subst_eps in H.
    apply equal_f with sa'' in H.
    assert ((exists sa' : StaticAction2,
         closing_rgn_in_eps2 n x e sa' /\ fold_subst_sa rho' sa' = sa'') -> (exists sa' : StaticAction2, e1 sa' /\ fold_subst_sa rho sa' = sa'')).
    intro. rewrite H. assumption.
Admitted.

Lemma subst_rho_open_close :
  forall rho w v' rho' x tyr0 tyr,
    lc_type tyr0 ->
    find_R w rho = Some v' ->
    subst_rho rho' (close_var x tyr0) = subst_rho rho tyr ->
    subst_rho rho' (open (mk_rgn_type (Rgn2_Const true false v')) (close_var x tyr0)) =
    subst_rho rho (open (mk_rgn_type w) tyr).
Proof.
  unfold open, close_var.
  intros rho w v' rho' x tyr0 tyr Hcl1 HF.
  generalize dependent 0.
  generalize dependent tyr. generalize dependent tyr0.
  induction tyr0; induction tyr; intros n;
  simpl;
  repeat (rewrite subst_rho_natural ||
                  rewrite subst_rho_boolean ||
                  rewrite subst_rho_unit ||
                  rewrite subst_rho_forallrgn ||
                  rewrite subst_rho_effect
         );
  try (solve [intro Z; inversion Z | intro Y; reflexivity | intro X; assumption |
              intros; rewrite subst_rho_tyref in H; inversion H |
              intros; rewrite subst_rho_arrow in H; inversion H ]).
  - intro. symmetry in H. rewrite  subst_rho_tyref in H.
    rewrite  subst_rho_tyref in H. inversion H as [ [HR1 HR2] ].
    repeat rewrite subst_rho_tyref. f_equal.
    + erewrite subst_rho_open_close_rgn; eauto. now inversion Hcl1.
    + erewrite IHtyr0; eauto. now inversion Hcl1.
  - intro. symmetry in H. rewrite  subst_rho_arrow in H.
    rewrite  subst_rho_tyref in H. now inversion H.
  - intro.  rewrite  subst_rho_tyref in H. rewrite  subst_rho_arrow in H. now inversion H.
  - repeat rewrite subst_rho_arrow. intro Z. inversion Z.
    f_equal.
    + rewrite <- IHtyr0_1; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_2; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_3; auto. now inversion Hcl1.
  - repeat rewrite subst_rho_forallrgn.
    intro Z; inversion Z.
     f_equal.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0; auto. now inversion Hcl1.
Qed.

Lemma ty_sound_var :
  forall x v stty rho env ctxt t,
  TcEnv (stty, rho, env, ctxt) ->
  find_E x env = Some v -> find_T x ctxt = Some t ->
  TcVal (stty, v, subst_rho rho t).
Proof.
  intros x v stty rho env ctxt t HTcEnv FindEnv FindCtxt. (* Hclosed. *)
  inversion_clear HTcEnv as [? ? ? ? HBst HFwd HBack HTc].
  destruct (HFwd x v FindEnv) as [y FindEnv'].
  rewrite FindEnv' in FindCtxt. inversion FindCtxt; subst.
  eapply HTc; [eexact FindEnv | eexact FindEnv' ]. (*| assumption]. *)
Qed.

Lemma ty_sound_closure:
  forall stty rgns env rho ctxt f x ec ee tyx tyc effc effe,
    TcRho (rho, rgns) ->
    TcEnv (stty, rho, env, ctxt) ->
    TcExp (stty, ctxt, rgns,  Mu f x ec ee, Ty2_Arrow tyx effc tyc effe Ty2_Effect, Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho,  Mu f x ec ee),  subst_rho rho (Ty2_Arrow tyx effc tyc effe Ty2_Effect)).
Proof.
  intros; econstructor; eassumption.
Qed.

Lemma ty_sound_region_closure:
  forall stty rgns env rho ctxt x er tyr effr,
    TcRho (rho, rgns) ->
    TcEnv (stty, rho, env,ctxt) ->
    TcExp (stty, ctxt, rgns, Lambda x er, Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr),  Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho, Lambda x er), subst_rho rho (Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr))).
Proof.
  intros. econstructor; eassumption.
Qed.

Lemma weakening_trans :
   forall stty stty' stty'',
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty' = Some t -> ST.find (elt:=tau) l stty'' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty'' = Some t).
Proof.
  intros stty stty' stty'' Weak Weak'.
  intros l t ?. apply Weak'. now apply Weak.
Qed.

Lemma bound_var_is_fresh :
  forall rho rgns x,
    TcRho (rho, rgns) -> not_set_elem rgns x -> ~ R.In (elt:=Region) x rho.
Proof.
  intros rho rgns x H1 H2.
  inversion H1; subst.
  unfold not_set_elem in H2. unfold Ensembles.Complement in H2.
  unfold not. intro.
  apply RMapP.in_find_iff in H.
  apply H2. (* double negation *)
  eapply H3; eassumption.
Qed.

Lemma ty_sound:
  forall e env rho hp hp' v dynamic_eff,
    (hp, env, rho, e) ⇓ (hp', v, dynamic_eff) ->
    forall stty ctxt rgns t static_eff,
      TcHeap (hp, stty) ->
      TcRho (rho, rgns) ->
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (stty, ctxt, rgns, e, t, static_eff) ->
      exists stty',
        (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
         /\ TcHeap (hp', stty')
         /\ TcVal (stty', v, subst_rho rho t).
Proof.
  intros e env rho hp hp'  v dynamic_eff D.
  dynamic_cases (dependent induction D) Case;
  intros stty ctxt rgns t static_eff Hhp Hrho Henv Hexp;
  inversion Hexp; subst.
  Case "cnt n".
    exists stty; (split; [| split]; auto). rewrite subst_rho_natural.
    econstructor; eassumption.
  Case "bool b".
    exists stty;  (split; [| split]; auto). rewrite subst_rho_boolean.
    econstructor; eassumption.
  Case "var x".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_var; eassumption.
  Case "mu_abs".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_closure; try (solve [eassumption]).
  Case "rgn_abs".
    exists stty;  (split; [| split]; auto).
    eapply ty_sound_region_closure; try (solve [eassumption]).
  Case "mu_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto.
    eapply ext_stores__env; eauto. eapply ext_stores__exp. eassumption. eassumption.
    inversion TcVal_mu as [ | | | ? ? ? ? ? ? ?   TcRho_rho' TcEnv_env' TcExp_abs | | ] ; subst.
    inversion TcExp_abs as [ | |  | ? ? ? ? ? ? ? ? ? ? ? ? TcExp_ec TcExp_ee | |  | | | | | | | | | | | | | | | | | | ]; subst.
    rewrite <- H5 in TcVal_mu.
    do 2 rewrite subst_rho_arrow in H5. inversion H5.
    assert (SubstEq1: subst_rho rho' tyx = subst_rho rho tya) by assumption.
    assert (SubstEq2: subst_rho rho' tyc = subst_rho rho t) by assumption.
    rewrite <- SubstEq1 in TcVal_arg.
    unfold update_rec_E, update_rec_T in *.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    apply update_env. apply update_env. eapply ext_stores__env; eauto.
    eapply ext_stores__val; eauto. eassumption.
    eapply ext_stores__exp; eauto.
    exists sttyb; intuition.
  Case "rgn_app".
    edestruct IHD1 as [sttyl [Weak1 [TcHeap1 TcVal_lam]]]; eauto.
    inversion TcVal_lam as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_lam | | ]; subst.
    inversion TcExp_lam as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
    edestruct IHD2 as [sttyr [Weak2 [TcHeap2 TcVal_res]]]; eauto using update_env, ext_stores__env, ext_stores__exp.
    apply update_rho. assumption. assumption. eapply extended_rho; eauto.
    exists sttyr; intuition.
    rewrite subst_rho_forallrgn in H6.
    rewrite subst_rho_forallrgn in H6.
    inversion H6.
    unfold update_R in TcVal_res.
    simpl in TcVal_res. rewrite subst_add_comm in TcVal_res.
    SCase "abstraction body is well typed".
    unfold subst_in_type in TcVal_res.
    rewrite SUBST_AS_CLOSE_OPEN in TcVal_res; auto.
    erewrite subst_rho_open_close in TcVal_res; eauto.
    SCase "bound variable is free".
    eapply bound_var_is_fresh; eauto.
  Case "eff_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto using ext_stores__env, ext_stores__exp.
    inversion TcVal_mu as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_abs | | ]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    SCase "Extended Env".
      apply update_env.
      SSCase "TcEnv". apply update_env.
        SSSCase "Extended". eapply ext_stores__env; eauto.
        SSSCase "Extended TcVal". rewrite <- H5 in TcVal_mu.  eapply ext_stores__val; eauto.
      SSCase "TcVal". do 2 rewrite subst_rho_arrow in H5.
          inversion H5.
          assert (SubstEq: subst_rho rho' tyx = subst_rho rho tya) by assumption.
          rewrite <- SubstEq in TcVal_arg.  eassumption.
    eapply ext_stores__exp; eauto.
    exists sttyb. intuition.
    rewrite subst_rho_effect. rewrite subst_rho_effect in TcVal_res.
    assumption.
  Case "cond_true".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty1 [Weak1 [TcHeapv1 TcVal_e1]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists stty1. intuition.
  Case "cond_false".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty2 [Weak2 [TcHeapv2 TcVal_e2]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists stty2. intuition.
  Case "new_ref e".
    destruct IHD with (stty := stty)
                      (ctxt := ctxt)
                      (rgns := rgns)
                      (t := t0)
                      (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    exists (update_ST ((r, l), subst_rho rho t0) sttyv); split; [ | split].
    SCase "Extended stores".
      intros k' t' STfind. destruct k' as [r' l'].
      destruct (eq_nat_dec r r'); destruct (eq_nat_dec l l'); subst.
      SSCase "New address must be fresh, prove by contradiction".
        apply Weakv in STfind.
        inversion_clear TcHeapv as [? ? ?  STfind_Hfind ?].
        destruct (STfind_Hfind (r', l') t' STfind) as [x F].
        assert (C : None = Some x) by (rewrite <- F; rewrite <- H0; reflexivity).
        discriminate.
      SSCase "Existing addresses are well-typed 1".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 2".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 3".
        apply ST_diff_key_2; [simpl; intuition; apply n; congruence | now apply Weakv ].
    SCase "Heap typeness".
      apply update_heap_fresh; eauto.
      remember (find_ST (r, l) sttyv) as to; symmetry in Heqto.
      destruct to as [ t | ].
      SSCase "New address must be fresh, prove by contradiction".
        inversion_clear TcHeapv as [? ? ? STfind_Hfind ?].
        destruct (STfind_Hfind (r, l) t Heqto) as [? ex].
        rewrite H0 in ex. discriminate.
      SSCase "Heap typeness is preserved".
         reflexivity.
    SCase "Loc is well-typed".
       simpl in H; inversion H; subst.
       rewrite subst_rho_tyref. unfold mk_rgn_type. rewrite subst_rho_rgn_const.
       econstructor. apply ST_same_key_1.
  Case "get_ref e".
    destruct IHD with (hp'0 := hp')
                      (v := Loc (Rgn2_Const true false s) l)
                      (stty := stty)
                      (rgns := rgns)
                      (ctxt := ctxt)
                      (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t)
                      (static_eff := aeff)
                      (dynamic_eff := aacts)
    as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      apply Weakv.
    SCase "Heap is well typed".
      apply TcHeapv.
    SCase "Value is well-typed".
      inversion_clear TcHeapv as [? ? ? ? HeapTcVal]. eapply HeapTcVal; eauto.
      inversion TcVal_v; subst; simpl in H; inversion H; subst.
      rewrite subst_rho_tyref in H7. inversion H7. subst.
      assumption.
  Case "set_ref e1 e2".
    destruct IHD1 with (hp' := heap')
                       (v := Loc (Rgn2_Const true false s) l)
                       (stty := stty)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t0)
                       (static_eff := aeff)
                       (dynamic_eff := aacts)
       as [sttya [Weaka [TcHeapa TcVal_a]]]; eauto.
    destruct IHD2 with (stty := sttya)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := t0)
                       (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      eapply weakening_trans; eauto.
    SCase "New heap is well typed".
      apply update_heap_exists with (t:= subst_rho rho t0).
      { assumption. }
      { apply Weakv. inversion TcVal_a; subst.
        simpl in H; inversion H; subst.
        rewrite subst_rho_tyref in H4. inversion H4. subst.
        assumption. }
      { assumption. }
    SCase "Result value is well-typed".
      rewrite subst_rho_unit. constructor.
  Case "nat_plus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_minus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_times x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "bool_eq x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_boolean. constructor.
  Case "alloc_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "write_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "write_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "eff_concat". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_top". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_empty". exists stty. intuition. rewrite subst_rho_effect. constructor.
Qed.

End TypeSoundness.


Require Import list_examples.

Definition head_code := Load::Ret::nil.

Inductive head_spec : Spec cfg :=
  head_claim : forall H x l, fun_claim head_spec
  "head" head_code
    1 (fun p => asP H (rep_list (x::l) p))
    1 (fun p => constraint (p = x) :* litP H).

Lemma head_proof : sound stack_step head_spec.
Proof. list_solver. Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_o_c.RPCF_rep_hom.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section id_rep.

Variable P : PCFPO_rep.

Definition id_rep_car c:
(forall t : type_type P,
  (retype_ipo (fun u : type_type P => u) (P c)) t ->
  (P (retype (fun u : type_type P => u) c)) t) :=
fun  t y =>
   match y with ctype _ z =>
     rlift P (@id_retype _ c) _ z end.

Obligation Tactic := idtac.

Program Instance id_rep_pos c:
ipo_mor_struct (a:=retype_ipo (fun u : type_type P => u) (P c))
  (b:=P (retype (fun u : type_type P => u) c)) (@id_rep_car c).
Next Obligation.
Proof.
  intros c t.
  unfold Proper;
  red.
  intros y z H;
  simpl in *.
  induction H.
  simpl.
  apply (rlift P (id_retype (V:=c))).
  auto.
Qed.

Definition id_rep_po c := Build_ipo_mor (id_rep_pos c).

Definition id_rep_c :
(forall c : ITYPE (type_type P),
  (RETYPE_PO (fun u : type_type P => u)) (P c) --->
  P ((RETYPE (fun u : type_type P => u)) c)) :=
      id_rep_po.

Program Instance RMon_id_s :
  gen_RMonad_Hom_struct (P:=P) (Q:=P)
   (G1:=RETYPE (fun u : type_type P => u))
   (G2:=RETYPE_PO (fun u : type_type P => u))
   (NNNT1 (fun u : type_type P => u)) id_rep_c.
Next Obligation.
Proof.
  simpl.
  intros V t y.
  destruct y as [t y];
  simpl.
  rew (rlift_rweta P).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V W f t z.
  destruct z as [t z];
  simpl.
  rew (rlift_rkleisli (M:=P)).
  rew (rkleisli_rlift (M:=P)).
  apply (rkl_eq P).
  simpl.
  auto.
Qed.

Definition RMon_id := Build_gen_RMonad_Hom RMon_id_s.

Lemma id_arrow_dist:
forall u v : type_type P,
  (fun u0 : type_type P => u0) (u ~~> v) =
  (fun u0 : type_type P => u0) u ~~> (fun u0 : type_type P => u0) v.
Proof.
  simpl.
  reflexivity.
Qed.

Program Instance PCFPO_id_struct : PCFPO_rep_Hom_struct
   (P:=P) (R:=P)
   (f:=fun u => u) (fun u => eq_refl) id_arrow_dist RMon_id.
Next Obligation.
Proof.
  simpl.
  intros c y.
  intros.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (CondB (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (
  (arrow_dist_ct4 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
               (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Bool Bool Bool Bool))).
     simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (CondN (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
  (arrow_dist_ct4 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
           (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Bool Nat Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Pred (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
   (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
        (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Zero (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
    (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
        (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Bool)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Succ (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
    (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
      (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (ffff (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (tttt (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros t c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (bottom t (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros m c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (nats m (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (app r s (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist r s)).
  simpl.
  auto.
Qed.
(*
Next Obligation.
Proof.
  simpl.
  intros r s c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (abs r s (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist r s)).
  simpl.
  apply f_equal.
  rew (rklkl P).
  apply (rkl_eq P).
  simpl.
  intros t z.
  rew (retakl P).
  destruct z as [t z | ];
  simpl.
  rew (rlift_rweta P).
  auto.
Qed.
*)
Next Obligation.
Proof.
  simpl.
  intros t c y.
  unfold rlift.
  simpl.
  rewrite (UIP_refl _ _ (id_arrow_dist t t)).
  simpl.
  rew (rmod_hom_rmkl  (rec t (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros u v c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (abs u v (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist u v)).
  simpl.
  apply f_equal.
  rew (rklkl P).
  apply (rkl_eq P).
  simpl.
  intros t z.
  rew (retakl P).
  destruct z as [t z | ];
  simpl.
  rew (rlift_rweta P).
  auto.
Qed.

Definition PCFPO_id := Build_PCFPO_rep_Hom PCFPO_id_struct.

End id_rep.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) (plus lv0 lv1))) (plus lv2 (plus lv1 (Succ Zero)))).
Admitted.
QuickChick conj28synthconj3.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^511 - 481
Base: 22 + 5/23
***)

Definition curve : CurveParameters :=
  {|
    sz := 23%nat;
    base := 22 + 5/23;
    bitwidth := 32;
    s := 2^511;
    c := [(1, 481)];
    carry_chains := Some [seq 0 (pred 23); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Aprime Bprime : Universe, ((wd_ O Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ Aprime O /\ (wd_ Bprime O /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ A Aprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Aprime /\ (col_ O Eprime Bprime /\ col_ O Eprime C)))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Check pattern-unification on evars in apply unification *)

Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'.

Axiom copy : forall tau:Type, tau -> tau -> Prop.
Axiom copyr : forall tau:Type, tau -> tau -> Prop.
Axiom copyf : forall tau:Type, tau -> tau -> Prop.
Axiom eq : forall tau:Type, tau -> tau -> Prop.
Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop.

Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'.
Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'),
(forall x:tau, copyr tau x x->copy tau' (t x) (t' x))
->copy (tau->tau') t t'.

Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'.
Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'),
copyr (tau->tau') t t'
->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)).

Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'.
Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'),
copyr (tau->tau') t t'
->(forall x y:tau, forall z1 z2:tau',
(copy tau x y)->
(subst tau tau' t x z1)->
(subst tau tau' t' y z2)->
copyf tau' z1 z2).

Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau',
( ((subst tau tau' t q t') /\ (eq tau' t' r))
->eq tau' (app tau tau' t q) r).

Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t'))
->eq tau' r (app tau tau' t q).

Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
(forall x:tau, (copyf tau x q) -> (copy tau' (t x) r))
->subst tau tau' t q r.

Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom.
Ltac Subst := apply substcopy;intros;EtaLong.
Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A).
Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A.

Theorem church0: forall i:Type, exists X:(i->i)->i->i,
copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)).
intros.
esplit.
EtaLong.
eapply eqappd;split.
Subst.
apply copyf_atom.
Show Existentials.
apply H1.


Declare ML Module "coq-paramcoq.plugin".

Ltac destruct_reflexivity :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail
  end.

Ltac destruct_construct x :=
    (destruct x; [ constructor 1 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail).

Ltac unfold_cofix := intros; match goal with
 [ |- _ = ?folded ] =>
    let x := fresh "x" in
    let typ := type of folded in
    (match folded with _ _ => pattern folded | _ => pattern folded at 2 end);
    match goal with [ |- ?P ?x ] =>
    refine (let rebuild : typ -> typ := _ in
            let path : rebuild folded = folded := _ in
            eq_rect _ P _ folded path) end;
    [ intro x ; destruct_construct x; fail
    | destruct folded; reflexivity
    | reflexivity]; fail
end.

Ltac destruct_with_nat_arg_pattern x :=
  pattern x;
  match type of x with
   | ?I 0 => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun p => _ p
     | S n => fun _  => unit end q) := _ in gen 0 x)
   | ?I (S ?n) => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun _  => unit
     | S n => fun p => _ p end q) := _ in gen (S n) x)
  end; intros m q; destruct q.

Ltac destruct_reflexivity_with_nat_arg_pattern :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail
  end.

Global Parametricity Tactic := ((destruct_reflexivity; fail)
                            || (unfold_cofix; fail)
                            || (destruct_reflexivity_with_nat_arg_pattern; fail)
                            ||  auto).

Require Import ProofIrrelevance. (* for opaque terms *)

Set Allow StrictProp.  (* TODO: use SProp instead of ProofIrrelevance *)

Parametricity Module Logic.
Parametricity Module Datatypes.
Parametricity Module Specif.

Parametricity Module Decimal.
Parametricity Module Hexadecimal.
Parametricity Module Number.
Parametricity Module Nat.

Parametricity Module Peano.

Parametricity Module Wf.
Parametricity Module Tactics.

Export Logic_R Datatypes_R Specif_R Nat_R Peano_R Wf_R Tactics_R.