(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Cut Cases

In this file we prove the cases for cut-elimination. Each lemma contains a case for the respective connective (and its dual).
*)

(* Require Export Tactics.
Set Implicit Arguments. *)

Require Import myTactics.

Ltac simpl_duals H :=
  try rewrite one_bot in H;
  try rewrite bot_one in H;
  try rewrite top_zero in H;
  try rewrite zero_top in H;
  try rewrite atom_perp in H;
  try rewrite perp_atom in H;
  try rewrite tensor_par in H;
  try rewrite par_tensor in H;
  try rewrite with_plus in H;
  try rewrite plus_with in H;
  try rewrite bang_quest in H;
  try rewrite quest_bang in H.

Lemma aux_CUT_ap n1 n2 h B L M1 M2 v:
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
    S h = n1 + n2 -> 0%nat = Lexp_weight (v ⁺) -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; v ⁺ :: M1 ->
    n2 |~> 0; B; v ⁻ :: M2 ->
    exists m, m |~> 0 ; B; L.
  Proof.
   intros H Hh Hw P Hn1 Hn2.
   inversion Hn1; subst; inversion Hh; try cut_free.
  * {
   inversion Hn2; subst; inversion Hh; try cut_free.
     - simpl_cases2.
       organizer.
       refine (tab_bot H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_par H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_tensor _ _ _ P H2 H3 H4 H6 Hn2 Hn1); eauto.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_with _ _ _ P H2 H3 H4 H6 Hn2 Hn1); eauto.
     - simpl_cases2.
       organizer.
       refine (tab_copy H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_quest H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - apply resolvers2 in H2; firstorder; lexp_contr H2.
     - simpl_cases2.
       organizer.
       refine (tab_ex H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_fx H _ Hw P H2 H4 H3 Hn2 Hn1). omega.
   }
  * apply resolvers2 in H0; firstorder; lexp_contr H0.
  * simpl_cases2.
    top_commutes.
  * simpl_cases2.
    refine (tab_bot _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2.
    refine (tab_par _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2.
    refine (tab_tensor _ _ _ P H0 H1 H2 H4 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus1 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus2 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2.
    refine (tab_with _ _ _ P H0 H1 H2 H4 Hn1 Hn2); eauto.
  * refine (tab_copy _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
   refine (tab_quest _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; lexp_contr H0.
  * simpl_cases2.
    refine (tab_ex H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
  * simpl_cases2.
    refine (tab_fx H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
Qed.
Arguments aux_CUT_ap [n1 n2 h B L M1 M2 v].

Lemma aux_CUT_tz n1 n2 h B L M1 M2:
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; 0; m; B; L ->
    exists m, m |~> 0; B; L) ->
    S h = n1 + n2 -> 0%nat = Lexp_weight (⊤) -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; ⊤ :: M1 ->
    n2 |~> 0; B; 0 :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
  intros H Hh Hw P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder;  lexp_contr H0.
  * apply resolvers2 in H0; firstorder;  lexp_contr H0.
  * {
   simpl_cases4.
   inversion Hn2; subst; inversion Hh; try cut_free.
     - simpl_cases2. organizer.
       refine (tab_bot H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_par H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2; organizer.
       refine (tab_tensor _ _ _ P H2 H3 H4 H6 Hn2 Hn1); eauto.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2;
       organizer.
       refine (tab_with _ _ _ P H2 H3 H4 H6 Hn2 Hn1); eauto.
     - simpl_cases2.
       organizer.
       refine (tab_copy H _ Hw P H2 H3 H4 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_quest H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - apply resolvers2 in H2; firstorder; lexp_contr H2.
     - simpl_cases2.
       organizer.
       refine (tab_ex H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_fx H _ Hw P H2 H4 H3 Hn2 Hn1).
       omega.
   }

  * simpl_cases2;
    refine (tab_bot _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_par _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_tensor _ _ _ P H0 H1 H2 H4 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus1 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus2 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_with _ _ _ P H0 H1 H2 H4 Hn1 Hn2); eauto.
  * refine (tab_copy _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
   refine (tab_quest _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; lexp_contr H0.
  * simpl_cases2.
    refine (tab_ex H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
  * simpl_cases2.
    refine (tab_fx H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
Qed.
Arguments aux_CUT_tz [n1 n2 h B L M1 M2].

Lemma aux_CUT_bo n1 n2 h B L M1 M2:
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
    S h = n1 + n2 -> 0%nat = Lexp_weight (⊥) -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; ⊥ :: M1 ->
    n2 |~> 0; B; 1 :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
  intros H Hh Hw P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder;  lexp_contr H0.
  * apply resolvers2 in H0; firstorder;  lexp_contr H0.
  * simpl_cases2; top_commutes.
  * {
   simpl_cases4.
   inversion Hn2; subst; inversion Hh; try cut_free.
     - apply resolvers in H2; firstorder;  lexp_contr H2.
     - apply resolvers2 in H2; firstorder.
       rewrite H3 in P. rewrite union_empty in P.
       rewrite <- P in H0.
       rewrite <- H0 in H1.
       eexists; eauto.
     - simpl_cases2; top_commutes.
     - simpl_cases2. organizer.
       refine (tab_bot H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2. organizer.
       refine (tab_par H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2; organizer.
       refine (tab_tensor _ _ _ P H2 H3 H5 H7 Hn2 Hn1) ; eauto. omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2;
       organizer.
       refine (tab_with _ _ _ P H2 H3 H5 H7 Hn2 Hn1); eauto. omega.
     - simpl_cases2.
       organizer.
       refine (tab_copy H _ Hw P H2 H4 H5 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_quest H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - apply resolvers2 in H2; firstorder; lexp_contr H2.
     - simpl_cases2.
       organizer.
       refine (tab_ex H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_fx H _ Hw P H2 H3 H4 Hn2 Hn1). omega.
   }

  * simpl_cases2;
    refine (tab_par _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_tensor _ _ _ P H0 H1 H2 H4 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus1 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_plus2 _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
    refine (tab_with _ _ _ P H0 H1 H2 H4 Hn1 Hn2); eauto.
  * refine (tab_copy _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
   refine (tab_quest _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; lexp_contr H0.
  * simpl_cases2.
    refine (tab_ex H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
  * simpl_cases2.
    refine (tab_fx H _ Hw P H0 H2 H1 Hn1 Hn2). omega.
Qed.
Arguments aux_CUT_bo [n1 n2 h B L M1 M2].

Lemma tensor_par_principal n m n0 B L F G N M M1 M2:
(forall m : nat,
    m <= Lexp_weight F + Lexp_weight G ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  L =mul= M1 ++ M2 ->
  S (max n m) |~> 0; B; F ** G :: M1 ->
  S n0 |~> 0; B; F° $ G° :: M2 ->
  M1 =mul= M ++ N ->
  m |~> 0; B; F :: M ->
  n |~> 0; B; G :: N ->
  n0 |~> 0; B; F° :: G° :: M2 -> exists m0 : nat, m0 |~> 0 + 0; B; L.
Proof.
  intros.
  rewrite meq_swap_cons in H6.
  assert (exists m, m |~> 0 ; B; F° :: (N ++ M2)) as Hyp.
  refine (H _ _ _ _ _ _ _);
  [|change (0%nat) with (0+0);
    refine (sig3_cut _ _ _ H5 H6); auto]; resolve_max.
  destruct Hyp as [p Hp].

  refine (H _ _ _ _ _ _ _);
  [|change (0%nat) with (0+0);
    refine (sig3_cut _ _ _ H4 Hp); auto]; resolve_max.
  rewrite H0, H3.
  solve_permutation.
Qed.

Arguments tensor_par_principal [n m n0 B L F G N M M1 M2].

Lemma with_plus1_principal n m n0 B L F G M1 M2:
(forall m : nat,
    m <= Lexp_weight F + Lexp_weight G ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  L =mul= M1 ++ M2 ->
  S (max n m) |~> 0; B; F & G :: M1 ->
  S n0 |~> 0; B; F° ⊕ G° :: M2 ->
  m |~> 0; B; F :: M1 ->
  n |~> 0; B; G :: M1 ->
  n0 |~> 0; B; F° :: M2 -> exists m0 : nat, m0 |~> 0 + 0; B; L.
Proof.
  intros.
  refine (H _ _ _ _ _ _ _);
  [|change (0%nat) with (0+0);
    refine (sig3_cut _ _ _ H3 H5); auto]; resolve_max.
Qed.

Arguments with_plus1_principal [n m n0 B L F G M1 M2].

Lemma with_plus2_principal n m n0 B L F G M1 M2:
(forall m : nat,
    m <= Lexp_weight F + Lexp_weight G ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  L =mul= M1 ++ M2 ->
  S (max n m) |~> 0; B; F & G :: M1 ->
  S n0 |~> 0; B; F° ⊕ G° :: M2 ->
  m |~> 0; B; F :: M1 ->
  n |~> 0; B; G :: M1 ->
  n0 |~> 0; B; G° :: M2 -> exists m0 : nat, m0 |~> 0 + 0; B; L.
Proof.
  intros.
  refine (H _ _ _ _ _ _ _);
  [|change (0%nat) with (0+0);
    refine (sig3_cut _ _ _ H4 H5); auto]; resolve_max.
Qed.

Arguments with_plus2_principal [n m n0 B L F G M1 M2].

Lemma bang_quest_principal n n0 B L F:
(forall m : nat,
     m <= n + S n0 ->
     forall (n : nat) (L B : Multiset),
     n ~> 0; S (Lexp_weight F); m; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  S n |~> 0; B; [! F] ->
  S n0 |~> 0; B; ? F° :: L ->
  n |~> 0; B; [F] ->
  n0 |~> 0; F° :: B; L -> exists m0 : nat, m0 |~> 0; B; L.
Proof.
  intros.
  refine (H _ _ _ _ _ _);
  [|change (0%nat) with (0+0);
    refine (sig3_ccut _ _ _ H0 H3); auto]; resolve_max.
Qed.

Arguments bang_quest_principal [n n0 B L F].

Lemma aux_CUT_tp n1 n2 w h B L F G M1 M2:
  (forall m : nat,
    m <= w ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
    w = Lexp_weight F + Lexp_weight G ->
    S h = n1 + n2 -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; (F ** G) :: M1 ->
    n2 |~> 0; B; (F° $ G°) :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; lexp_contr H1.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2.
    refine (tab_bot H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_par H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  *
     destruct (FEqDec (F ** G) (F0 ** G0)) as [Te|notTe].
     rewrite <- Te in *.
     assert (F0 = F) by solve [eapply TensorEq1; eauto].
     assert (G0 = G) by solve [eapply TensorEq2; eauto].
     subst.
     clear Te.
     + {
        simpl_cases4. (* Tensor é principal em Hn1 *)
        inversion Hn2; subst; inversion Hh; try cut_free.
     - apply resolvers in H1; firstorder; lexp_contr H1.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2; top_commutes.
     - simpl_cases2.
       organizer.

   refine (tab_bot H0 _ _ P H1 H6 H4 Hn2 Hn1); auto.
   omega.
   rewrite lweight_dual_plus; auto.
    -
        destruct (FEqDec (F0 $ G0) (F° $ G°)) as [Te|notTe].
        rewrite Te in *.

     assert (F° = F0) by solve [eapply ParEq1; eauto].
     assert (G° = G0) by solve [eapply ParEq2; eauto].
     subst.
     clear Te.
        *
          simpl_cases4. (* Par é principal em Hn2 *)
          rewrite <- H1 in *.
          refine (tensor_par_principal H P Hn1 Hn2 H2 H3 H5 H4).
        *
          simpl_cases2.
          organizer.
          refine (tab_par H0 _ _ P H6 H1 H4 Hn2 Hn1).
          omega.
          rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_tensor H0 _ _ P H1 H4 H6 H8 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_with H0 _ _ P H1 H4 H6 H8 Hn2 Hn1).
       omega.
      rewrite lweight_dual_plus; auto.
     - organizer.
       refine (tab_copy H0 _ _ P H1 H4 H6 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_quest H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2.
       organizer.
       refine (tab_ex H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_fx H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
    }
      +
     simpl_cases2.
     refine (tab_tensor H0 _ _ P H1 H2 H3 H5 Hn1 Hn2); auto.

  * simpl_cases2.
    refine (tab_plus1 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus2 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_with H0 _ _ P _ _ H3 H5 Hn1 Hn2); auto.
  * refine (tab_copy H0 _ _ P H1 H2 H3 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_quest H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2.
    refine (tab_ex H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_fx H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
Qed.
Arguments aux_CUT_tp [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_pw n1 n2 w h B L F G M1 M2:
  (forall m : nat,
    m <= w ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
    w = Lexp_weight F + Lexp_weight G ->
    S h = n1 + n2 -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; (F & G) :: M1 ->
    n2 |~> 0; B; (F° ⊕ G°) :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; lexp_contr H1.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2.
    refine (tab_bot H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_par H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_tensor H0 _ _ P H1 H2 H3 H5 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus1 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus2 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * {
     destruct (FEqDec (F & G) (F0 & G0)) as [Te|notTe].
     rewrite <- Te in *.
     assert (F = F0) by solve [eapply WithEq1; eauto].
     assert (G = G0) by solve [eapply WithEq2; eauto].
     rewrite <- H1, <- H4 in *.
     clear H1; clear H4; clear Te.
     + {
        simpl_cases4. (* With é principal em Hn1 *)
        inversion Hn2; subst; inversion Hh; try cut_free.
     - apply resolvers in H1; firstorder; lexp_contr H1.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2; top_commutes.
     - simpl_cases2.
       organizer.
       refine (tab_bot H0 _ _ P H1 H6 H4 Hn2 Hn1); auto.
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_par H0 _ _ P H1 H6 H4 Hn2 Hn1); auto.
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_tensor H0 _ _ P H1 H4 H6 H8 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - destruct (FEqDec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
        rewrite <- Te in *.
             assert (F° = F1) by solve [eapply PlusEq1; eauto].
     assert (G° = G1) by solve [eapply PlusEq2; eauto].
     rewrite <- H6, <- H7 in *.
     clear H6; clear H7; clear Te.
      *
          simpl_cases4. (* Plus1 é principal em Hn2 *)
          rewrite <- H2 in *.
          rewrite <- H1 in *.
          refine (with_plus1_principal H P Hn1 Hn2 H3 H5 H4).
        * simpl_cases2.

       simpl_cases2.
       organizer.
       refine (tab_plus1 H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
    - destruct (FEqDec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
        rewrite <- Te in *.
             assert (F° = F1) by solve [eapply PlusEq1; eauto].
     assert (G° = G1) by solve [eapply PlusEq2; eauto].
     rewrite <- H6, <- H7 in *.
     clear H6; clear H7; clear Te.
        *
          simpl_cases4. (* Plus2 é principal em Hn2 *)
                    rewrite <- H2 in *.
          rewrite <- H1 in *.
          refine (with_plus2_principal H P Hn1 Hn2 H3 H5 H4).
        * simpl_cases2.
                 simpl_cases2.
       organizer.
       refine (tab_plus2 H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_with H0 _ _ P H1 H4 H6 H8 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - organizer.
       refine (tab_copy H0 _ _ P H1 H4 H6 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_quest H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2.
       organizer.
       refine (tab_ex H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
     - simpl_cases2.
       organizer.
       refine (tab_fx H0 _ _ P H1 H6 H4 Hn2 Hn1).
       omega.
       rewrite lweight_dual_plus; auto.
   }
   +   simpl_cases2.
refine (tab_with H0 _ _ P _ _ H3 H5 Hn1 Hn2); auto.
}

  * refine (tab_copy H0 _ _ P H1 H2 H3 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_quest H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2.
    refine (tab_ex H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_fx H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
Qed.

Arguments aux_CUT_pw [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_bq n1 n2 w h B L F M1 M2:
  (forall m : nat,
    m <= w ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
    w = Lexp_weight F ->
    S h = n1 + n2 -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; (! F) :: M1 ->
    n2 |~> 0; B; (? F°) :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
   intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; lexp_contr H1.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2.
    refine (tab_bot H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_par H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_tensor H0 _ _ P H1 H2 H3 H5 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus1 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus2 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_with H0 _ _ P _ _ H3 H5 Hn1 Hn2); auto.
  * refine (tab_copy H0 _ _ P H1 H2 H3 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_quest H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * {
    apply resolvers2 in H1; firstorder.
     assert (F = F0) by solve [eapply BangEq; eauto].
    rewrite H3 in Hn1.
    rewrite <- H5 in *.
    clear H1; clear H5.
    inversion Hn2; subst; inversion Hh; try cut_free.
     - apply resolvers in H1; firstorder; lexp_contr H1.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2; top_commutes.
     - simpl_cases2.
       organizer.
       refine (tab_bot H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_par H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_tensor H0 _ _ P H1 H3 H6 H8 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_plus1 H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_plus2 H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_with H0 _ _ P H1 H3 H6 H8 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - organizer.
       refine (tab_copy H0 _ _ P H1 H5 H6 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
 - destruct (FEqDec (? F°) (? F1)) as [Te|notTe].
       rewrite <- Te in *.
            assert (F° = F1) by solve [eapply QuestEq; eauto].
    rewrite <- H3 in *.
    clear Te; clear H3.
       + simpl_cases4. (* Quest é principal em Hn2 *)
         simpl in P.
         rewrite <- H1 in *.
         rewrite <- P in *.
         refine (bang_quest_principal H0 Hn1 Hn2 H2 H5).
       +
         simpl_cases2.
       organizer.
       refine (tab_quest H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_ex H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
     - simpl_cases2.
       rewrite (Ng_involutive (! F)) in Hn1;
       rewrite union_comm in P.
       refine (tab_fx H0 _ _ P H1 H3 H5 Hn2 Hn1).
       omega.
       rewrite lweight_dual; auto.
    }
  * simpl_cases2.
    refine (tab_ex H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_fx H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
Qed.

Arguments aux_CUT_bq [n1 n2 w h B L F M1 M2].

Lemma aux_CUT_ef n1 n2 w h B L FX M1 M2:
  (forall m : nat,
    m <= w ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
    S w = Lexp_weight (E{ FX}) ->
    S h = n1 + n2 -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; E{ FX} :: M1 ->
    n2 |~> 0; B; (E{ FX})° :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
   intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; lexp_contr H1.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2.
    refine (tab_bot H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_par H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_tensor H0 _ _ P H1 H2 H3 H5 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus1 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus2 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_with H0 _ _ P _ _ H3 H5 Hn1 Hn2); auto.
  * refine (tab_copy H0 _ _ P H1 H2 H3 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_quest H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * {
    destruct (FEqDec (E{ FX}) (E{ FX0})).
    assert (FX = FX0) by solve [eapply ExEq; eauto].
    subst. simpl_cases4.
    rewrite <- H1 in *.
    clear e; clear H1. (* Ex é principal em Hn1 *)
    inversion Hn2; subst; inversion Hh; try cut_free.
     - apply resolvers in H1; firstorder; lexp_contr H1.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2; top_commutes.
     - simpl_cases2.
       organizer.
       refine (tab_bot H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_par H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_tensor H0 _ Hw P H1 H3 H4 H6 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_with H0 _ Hw P H1 H3 H4 H6 Hn2 Hn1).
       omega.
     - organizer.
       refine (tab_copy H0 _ Hw P H1 H3 H4 Hn2 Hn1).
       omega.
     - simpl_cases2.
       organizer.
       refine (tab_quest H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - apply resolvers2 in H1; firstorder; lexp_contr H1.
     - simpl_cases2.
       organizer.
       refine (tab_ex H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - destruct (FEqDec ((E{ FX0})°) (F{ FX})).
       +
       rewrite e in *.
       simpl_cases4.
       assert (n0 |~> 0; B; (Subst FX t) :: M0) by auto.
       assert (Subst FX0 t = (Subst FX t)°) by solve [apply SubsDual; auto].
       rewrite H5 in H2.
       rewrite H1 in *.
       rewrite union_comm in P.
       eapply H.

       Focus 2.
       change (0%nat) with (0+0).
       refine (sig3_cut _ _ P H4 H2); auto.
       eapply WeightEF; eauto.

       + simpl_cases2.
       organizer.
       refine (tab_fx H0 _ Hw P H1 H4 H3 Hn2 Hn1).
       omega.
     - simpl_cases2.
       refine (tab_ex H0 _ Hw P H1 H3 H2 Hn1 Hn2).
       omega.
  }
  * simpl_cases2.
    refine (tab_fx H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
Qed.

Arguments aux_CUT_ef [n1 n2 w h B L FX M1 M2].

Lemma aux_CUT_fe n1 n2 w h B L FX M1 M2:
  (forall m : nat,
    m <= w ->
    forall (h n : nat) (L B : Multiset),
    n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
    m <= h ->
    forall (n : nat) (L B : Multiset),
    n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
    S w = Lexp_weight (F{ FX}) ->
    S h = n1 + n2 -> L =mul= M1 ++ M2 ->
    n1 |~> 0; B; F{ FX} :: M1 ->
    n2 |~> 0; B; (F{ FX})° :: M2 ->
    exists m, m |~> 0 ; B; L.
 Proof.
 intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; lexp_contr H1.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2.
    refine (tab_bot H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_par H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_tensor H0 _ _ P H1 H2 H3 H5 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus1 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_plus2 H0 _ _ P H1 H3 H2 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_with H0 _ _ P _ _ H3 H5 Hn1 Hn2); auto.
  * refine (tab_copy H0 _ _ P H1 H2 H3 Hn1 Hn2); auto.
  * simpl_cases2.
    refine (tab_quest H0 _ _ P _ H3 H2 Hn1 Hn2); auto.
  * apply resolvers2 in H1; firstorder; lexp_contr H1.
  * simpl_cases2.
    refine (tab_ex H0 _ Hw P H1 H3 H2 Hn1 Hn2).
    omega.
  * {
  destruct (FEqDec (F{ FX}) (F{ FX0}) ).
  rewrite e in *. clear e.
  simpl_cases4. (*  rewrite dEx in Hn2. *)
  inversion Hn2; subst; inversion Hh; try cut_free.
  - apply resolvers in H3; firstorder; lexp_contr H3.
  - apply resolvers2 in H3; firstorder; lexp_contr H3.
     - simpl_cases2; top_commutes.
     - simpl_cases2. organizer.
       refine (tab_bot _ _ Hw P H3 H4 H5 Hn2 _); eauto.
       omega.
     - simpl_cases2. organizer.
       refine (tab_par _ _ Hw P H3 H4 H5 Hn2 _); eauto. omega.
     - simpl_cases2. organizer.
       refine (tab_tensor H0 _ Hw P H3 H4 H6 H8 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus1 _ _ Hw P H3 H4 H5 Hn2 _); eauto. omega.
     - simpl_cases2.
       organizer.
       refine (tab_plus2 _ _ Hw P H3 H4 H5 Hn2 _); eauto. omega.
     - simpl_cases2. organizer.
       refine (tab_with H0 _ Hw P H3 H4 H6 H8 Hn2 Hn1). omega.
     - simpl_cases2.
       organizer.
       refine (tab_copy _ _ Hw P H3 H5 H6 Hn2 _); eauto. omega.
     - simpl_cases2.
       organizer.
       refine (tab_quest _ _ Hw P H3 H4 H5 Hn2 _); eauto. omega.
     - apply resolvers2 in H3; firstorder.
       lexp_contr H3.
     -
       destruct (FEqDec (F{ FX0})° (E{ FX1})).
       -- rewrite e in H3.
       simpl_cases4.
       assert (n |~> 0; B; Subst FX0 t :: M) by auto.
       assert (Subst FX0 t = (Subst FX1 t)°) by solve [apply SubsDual'; auto].
       rewrite H6 in H4.
       rewrite H1, H3 in *.
       rewrite union_comm in P.
       eapply H.

       Focus 2.
       change (0%nat) with (0+0).
       refine (sig3_cut _ _ P H5 H4); auto.
       eapply WeightFE; eauto.
       -- simpl_cases2. organizer.
          refine (tab_ex H0 _ Hw P H3 H4 H5 Hn2 Hn1 ). omega.
     - simpl_cases2.
       organizer.
       refine (tab_fx H0 _ Hw P H3 H4 _ Hn2 Hn1); auto. omega.
     - simpl_cases2.
       refine (tab_fx H0 _ Hw P H1 H3 _ Hn1 Hn2); auto.
  }
Qed.

Arguments aux_CUT_fe [n1 n2 w h B L FX M1 M2].


From Mtac2 Require Import Mtac2.

Goal forall x, True /\ x = 0.
MProof.
  intros x.
  match_goal with
  | [[? y |- context C [y = 0] ]] => T.change (C (y = 0 + 0))
  end.
Abort.

Goal forall x, x = 0.
MProof.
  intros x.
  match_goal with
  | [[? y |- context C [y = 0] ]] => T.change (C (y = 0 + 0))
  end.
Abort.

Goal forall x y, True /\ (x = x + (y + 0)) /\ True.
MProof.
  intros x y.
  match_goal with
  | [[ y |- context C [y + 0] ]] => T.change (C (y + (0 * 0 * 0 * 0)))
  end.
Abort.

Goal True /\ True.
MProof.
  match_goal with
  | [[ |- context C [ True ] ]] => T.change (C (id True))
  end. (* works on Prop goals *)
Abort.

Goal nat * nat.
MProof.
  Fail match_goal with
  | [[ |- context C [ nat : Set ] ]] => idtac
  end. (* It fails on non Prop goals... *)
Abort.

Goal nat * nat.
MProof.
  match_goal with
  | [[ |- context C [ nat : Type ] ]] => T.idtac
  end. (* It works on Type *)
Abort.


(** * Additive categories. *)
(** * Contents
- Definition of additive categories
- Quotient of an additive category is additive
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.Algebra.Monoids.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.PreAdditive.
Require Import UniMath.CategoryTheory.opp_precat.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.Opp.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.BinDirectSums.

Local Open Scope cat.

(** * Definition of additive categories *)
Section def_additive.

  (** A preadditive category has an additive structure if it is given a zero object and a binary direct sum operation. *)
  Definition AdditiveStructure (PA : PreAdditive) : UU := (Zero PA) × (BinDirectSums PA).

  Definition make_AdditiveStructure (PA : PreAdditive) (H1 : Zero PA) (H2 : BinDirectSums PA) :
    AdditiveStructure PA.
  Proof.
    exact (H1,,H2).
  Defined.

  (** Definition of categories with an additive structure *)
  Definition CategoryWithAdditiveStructure : UU := ∑ PA : PreAdditive, AdditiveStructure PA.

  Definition Additive_PreAdditive (A : CategoryWithAdditiveStructure) : PreAdditive := pr1 A.
  Coercion Additive_PreAdditive : CategoryWithAdditiveStructure >-> PreAdditive.

  Definition make_Additive (PA : PreAdditive) (H : AdditiveStructure PA) : CategoryWithAdditiveStructure.
  Proof.
    exact (tpair _ PA H).
  Defined.

  (** A preadditive category is additive if it has a zero object and binary direct sums. *)
  Definition isAdditive (PA : PreAdditive) : hProp := hasZero PA ∧ hasBinDirectSums PA.

  Definition make_isAdditive (PA : PreAdditive) (H1 : hasZero PA) (H2 : hasBinDirectSums PA) : isAdditive PA := H1,,H2.

  (** Definition of additive categories *)

  Definition AdditiveCategory : UU := ∑ PA : PreAdditive, isAdditive PA.

  Coercion Additive_to_PreAdditive (A : AdditiveCategory) : PreAdditive := pr1 A.

  (** Accessor functions. *)
  Definition to_AdditiveStructure (A : CategoryWithAdditiveStructure) : AdditiveStructure A := pr2 A.

  Definition to_Zero (A : CategoryWithAdditiveStructure) : Zero A := dirprod_pr1 (to_AdditiveStructure A).

  Definition to_BinDirectSums (A : CategoryWithAdditiveStructure) : BinDirectSums A := dirprod_pr2 (to_AdditiveStructure A).

  Definition to_BinCoproducts (A : CategoryWithAdditiveStructure) : BinCoproducts A.
  Proof.
    intros X Y.
    exact (BinDirectSum_BinCoproduct A (to_BinDirectSums A X Y)).
  Defined.

  Definition to_BinProducts (A : CategoryWithAdditiveStructure) : BinProducts A.
  Proof.
    intros X Y.
    exact (BinDirectSum_BinProduct A (to_BinDirectSums A X Y)).
  Defined.

  Lemma to_Unel1' {A : CategoryWithAdditiveStructure} {a b : A} (BS : BinDirectSum a b) :
    to_In1 BS · to_Pr2 BS = ZeroArrow (to_Zero A) _ _.
  Proof.
    rewrite (to_Unel1 BS). apply PreAdditive_unel_zero.
  Qed.

  Lemma to_Unel2' {A : CategoryWithAdditiveStructure} {a b : A} (BS : BinDirectSum a b) :
    to_In2 BS · to_Pr1 BS = ZeroArrow (to_Zero A) _ _.
  Proof.
    rewrite (to_Unel2 BS). apply PreAdditive_unel_zero.
  Qed.

  Definition to_hasZero (A : AdditiveCategory) : hasZero A := pr1 (pr2 A).

  Definition to_hasBinDirectSums {A : AdditiveCategory} : hasBinDirectSums A := pr2 (pr2 A).

  Definition AdditiveZeroArrow {A : CategoryWithAdditiveStructure} (x y : ob A) : A⟦x, y⟧ :=
    ZeroArrow (to_Zero A) x y.

  Definition oppositeAdditiveCategory : AdditiveCategory -> AdditiveCategory.
  Proof.
    intros M.
    exists (oppositePreAdditive M). split.
    - use (hinhfun _ (to_hasZero M)). exact (λ Z, pr1 Z,, pr2 (pr2 Z),, pr1 (pr2 Z)).
    - intros A B. exact (hinhfun oppositeBinDirectSum (to_hasBinDirectSums A B)).
  Defined.

  Definition sums_lift (M:AdditiveCategory) {X:Type} (j : X -> ob M) : hProp :=
    zero_lifts M j ∧
    ∀ a b (S : BinDirectSum (j a) (j b)), ∃ x, z_iso (j x) (BinDirectSumOb S).

  Definition opp_sums_lift (M:AdditiveCategory) {X:Type} (j : X -> ob M) :
    sums_lift M j -> sums_lift (oppositeAdditiveCategory M) j.
  Proof.
    intros [hz su]. exists (opp_zero_lifts j hz).
    intros a b S. generalize (su a b (oppositeBinDirectSum S)). apply hinhfun.
    intros [s t]. exists s. exact (z_iso_inv (opp_z_iso t)).
  Defined.

  Definition induced_Additive (M : AdditiveCategory)
             {X:Type} (j : X -> ob M) (sum : sums_lift M j) : AdditiveCategory.
  Proof.
    exists (induced_PreAdditive M j). induction sum as [hz sum]. split.
    - use (hinhfun _ hz). intros [z iz]. exists z. split.
      + intros a. apply iz.
      + intros b. apply iz.
    - clear hz. intros a b. apply (squash_to_hProp (to_hasBinDirectSums (j a) (j b))); intros S.
      use (hinhfun _ (sum a b S)); intros [c t]; clear sum. set (S' := replaceSum S t).
      use tpair.
      + exists c. exact (pr21 S').
      + cbn. exact (pr2 S').
  Defined.

  Lemma induced_opposite_Additive {M:AdditiveCategory}
        {X:Type} (j : X -> ob M) (su : sums_lift M j) :
    oppositeAdditiveCategory (induced_Additive M j su) =
    induced_Additive (oppositeAdditiveCategory M) j (opp_sums_lift M j su).
  Proof.
    intros.
    apply (total2_paths2_f (induced_opposite_PreAdditive j)).
    apply propproperty.
  Defined.

End def_additive.

(** * Quotient is additive
    We show that quotient of an additive category by certain subgroups is additive. In particular,
    this is used to show that the naive homotopy category of the category of chain complexes is an
    CategoryWithAdditiveStructure precategory. *)
Section additive_quot_additive.

  Variable A : CategoryWithAdditiveStructure.
  Hypothesis PAS : PreAdditiveSubabgrs A.
  Hypothesis PAC : PreAdditiveComps A PAS.

  Definition Quotcategory_Additive : CategoryWithAdditiveStructure.
  Proof.
    use make_Additive.
    - exact (Quotcategory_PreAdditive A PAS PAC).
    - use make_AdditiveStructure.
      + exact (Quotcategory_Zero A PAS PAC (to_Zero A)).
      + exact (Quotcategory_BinDirectSums A (to_BinDirectSums A) PAS PAC).
  Defined.

End additive_quot_additive.

(** * Kernels, Equalizers, Cokernels, and Coequalizers in CategoryWithAdditiveStructure categories *)
(** ** Introduction
Let f g : X --> Y be morphisms in an additive category. In this section we show that a
Cokernel of f - g is the Coequalizer of f and g, and vice versa. Similarly for Kernels
and equalizers.
 *)
Section additive_kernel_equalizers.

  Variable A : CategoryWithAdditiveStructure.

  Lemma AdditiveKernelToEqualizer_eq1 {x y : ob A} (f g : x --> y)
        (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) :
    KernelArrow K · f = KernelArrow K · g.
  Proof.
    use (to_rcan A (KernelArrow K · (to_inv g))).
    rewrite <- to_premor_linear'. rewrite <- to_premor_linear'.
    rewrite KernelCompZero.
    rewrite (@to_rinvax' A (to_Zero A)). rewrite ZeroArrow_comp_right.
    apply idpath.
  Qed.

  Lemma AdditiveKernelToEqualizer_isEqualizer {x y : ob A} (f g : x --> y)
             (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) :
    isEqualizer (*C:= categoryWithAbgrops_category _ *)f g (KernelArrow K) (AdditiveKernelToEqualizer_eq1 f g K).
  Proof.
    use make_isEqualizer.
    intros w h H'.
    use unique_exists.
    - use KernelIn.
      + exact h.
      + set (X := @to_premor_linear' A).
        rewrite X.
        etrans.
        { apply maponpaths_2.
          apply H'. }

        rewrite <- to_premor_linear'.
        rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_right.
    - cbn. use KernelCommutes.
    - intros y0. apply to_has_homsets.
    - intros y0 X. cbn in X.
      use (KernelArrowisMonic _ K).
      etrans.
        2 : { apply pathsinv0. apply KernelCommutes.
        }
        exact X.
  Qed.

  Definition AdditiveKernelToEqualizer {x y : ob A} (f g : x --> y)
             (K : Kernel (to_Zero A) (to_binop _ _ f (to_inv g))) : Equalizer f g.
  Proof.
    use make_Equalizer.
    - exact K.
    - use (KernelArrow K).
    - exact (AdditiveKernelToEqualizer_eq1 f g K).
    - exact (AdditiveKernelToEqualizer_isEqualizer f g K).
  Defined.

  Lemma AdditiveEqualizerToKernel_eq1 {x y : ob A} (f g : x --> y) (E : Equalizer f g) :
    EqualizerArrow E · to_binop x y f (to_inv g) = ZeroArrow (to_Zero A) E y.
  Proof.
    set (X:= @to_premor_linear' A).
    rewrite X.
    use (to_rcan A (EqualizerArrow E · g)). rewrite to_assoc.
    rewrite to_lunax''. rewrite <- to_premor_linear'. rewrite (@to_linvax' A (to_Zero A)).
    rewrite ZeroArrow_comp_right. rewrite to_runax''. apply (EqualizerEqAr E).
  Qed.

  Lemma AdditiveEqualizerToKernel_isKernel {x y : ob A} (f g : x --> y) (E : Equalizer f g) :
    isKernel (to_Zero A) (EqualizerArrow E) (to_binop x y f (to_inv g))
             (AdditiveEqualizerToKernel_eq1 f g E).
  Proof.
    use make_isKernel.
    - intros w h H'.
      use unique_exists.
      + use (EqualizerIn E).
        * exact h.
        * use (to_rcan A (h · to_inv g)). rewrite <- to_premor_linear'.
          rewrite <- to_premor_linear'. rewrite (@to_rinvax' A (to_Zero A)).
          rewrite ZeroArrow_comp_right. exact H'.
      + cbn. use EqualizerCommutes.
      + intros y0. apply to_has_homsets.
      + intros y0 X. cbn in X.
        use (EqualizerArrowisMonic E).
        rewrite EqualizerCommutes.
        exact X.
  Qed.

  Definition AdditiveEqualizerToKernel {x y : ob A} (f g : x --> y) (E : Equalizer f g) :
    Kernel (to_Zero A) (to_binop _ _ f (to_inv g)).
  Proof.
    use make_Kernel.
    - exact E.
    - use (EqualizerArrow E).
    - exact (AdditiveEqualizerToKernel_eq1 f g E).
    - exact (AdditiveEqualizerToKernel_isKernel f g E).
  Defined.

  (** ** Correspondence between Cokernels and Coeqalizers *)

  Lemma AdditiveCokernelToCoequalizer_eq1 {x y : ob A} (f g : x --> y)
             (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) :
    f · CokernelArrow CK = g · CokernelArrow CK.
  Proof.
    use to_rcan.
    - exact (to_inv g · CokernelArrow CK).
    - rewrite <- to_postmor_linear'. rewrite <- to_postmor_linear'.
      rewrite (CokernelCompZero (to_Zero A) CK). apply pathsinv0.
      rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_left.
  Qed.

  Lemma AdditiveCokernelToCoequalizer_isCoequalizer {x y : ob A} (f g : x --> y)
             (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) :
    isCoequalizer f g (CokernelArrow CK) (AdditiveCokernelToCoequalizer_eq1 f g CK).
  Proof.
    use make_isCoequalizer.
    intros w0 h H'.
    use unique_exists.
    - use CokernelOut.
      + exact h.
      + use to_rcan.
        * exact (g · h).
        * rewrite to_lunax''. rewrite <- to_postmor_linear'. rewrite to_assoc.
          rewrite (@to_linvax' A (to_Zero A)). rewrite to_runax''. apply H'.
    - cbn. use CokernelCommutes.
    - intros y0. apply to_has_homsets.
    - intros y0 X. cbn in X. cbn.
      use (CokernelArrowisEpi _ CK).
      rewrite CokernelCommutes.
      exact X.
  Qed.

  Definition AdditiveCokernelToCoequalizer {x y : ob A} (f g : x --> y)
             (CK : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g))) : Coequalizer f g.
  Proof.
    use make_Coequalizer.
    - exact CK.
    - use (CokernelArrow CK).
    - exact (AdditiveCokernelToCoequalizer_eq1 f g CK).
    - exact (AdditiveCokernelToCoequalizer_isCoequalizer f g CK).
  Defined.

  Lemma AdditiveCoequalizerToCokernel_eq1 {x y : ob A} (f g : x --> y)
             (CE : Coequalizer f g) :
    to_binop x y f (to_inv g) · CoequalizerArrow CE = ZeroArrow (to_Zero A) x CE.
  Proof.
    rewrite to_postmor_linear'. rewrite CoequalizerEqAr. rewrite <- to_postmor_linear'.
    rewrite (@to_rinvax' A (to_Zero A)). apply ZeroArrow_comp_left.
  Qed.

  Lemma AdditiveCoequalizerToCokernel_isCokernel {x y : ob A} (f g : x --> y)
        (CE : Coequalizer f g) :
    isCokernel (to_Zero A) (to_binop x y f (to_inv g)) (CoequalizerArrow CE)
               (AdditiveCoequalizerToCokernel_eq1 f g CE).
  Proof.
    use make_isCokernel.
    - intros w h H'.
      use unique_exists.
      + use CoequalizerOut.
        * exact h.
        * use (to_rcan A (to_inv g · h)). rewrite <- to_postmor_linear'.
          rewrite <- to_postmor_linear'. rewrite (@to_rinvax' A (to_Zero A)).
          rewrite ZeroArrow_comp_left. exact H'.
      + cbn. use CoequalizerCommutes.
      + intros y0. apply to_has_homsets.
      + intros y0 X. cbn in X.
        use (CoequalizerArrowisEpi CE).
        rewrite CoequalizerCommutes.
        exact X.
  Qed.

  Definition AdditiveCoequalizerToCokernel {x y : ob A} (f g : x --> y)
             (CE : Coequalizer f g) : Cokernel (to_Zero A) (to_binop _ _ f (to_inv g)).
  Proof.
    use make_Cokernel.
    - exact CE.
    - use CoequalizerArrow.
    - exact (AdditiveCoequalizerToCokernel_eq1 f g CE).
    - exact (AdditiveCoequalizerToCokernel_isCokernel f g CE).
  Defined.

End additive_kernel_equalizers.

(** * Sum and in to BinDirectSum is Monic *)
Section additive_minus_monic.

  Variable A : CategoryWithAdditiveStructure.

  Lemma isMonic_to_binop_BinDirectSum1 {x y z : A} (f : Monic A x y) (g : x --> z)
        (DS : BinDirectSum y z) :
    isMonic (to_binop _ _ (f · to_In1 DS) (g · to_In2 DS)).
  Proof.
    use make_isMonic.
    intros x0 g0 h X.
    assert (e : g0 · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr1 DS =
                h · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr1 DS).
    {
      etrans. apply maponpaths_2.
      apply X.
      apply idpath.
    }
    rewrite <- assoc in e. rewrite <- assoc in e.
    rewrite (@to_postmor_linear' A) in e.
    rewrite <- assoc in e. rewrite <- assoc in e.
    rewrite (to_IdIn1 DS) in e.
    rewrite (to_Unel2' DS) in e. rewrite ZeroArrow_comp_right in e.
    rewrite id_right in e. use (MonicisMonic A f).
    rewrite to_runax'' in e. exact e.
  Qed.

  (** This version is used in AbelianPushoutPullback *)
  Lemma isMonic_to_binop_BinDirectSum1' {x y z : A} (f : Monic A x y) (g : x --> z)
        (DS : BinDirectSum y z) :
    isMonic (to_binop _ _ (f · to_In1 DS) (to_inv (g · to_In2 DS))).
  Proof.
    rewrite PreAdditive_invlcomp. use isMonic_to_binop_BinDirectSum1.
  Qed.

  Lemma isMonic_to_binop_BinDirectSum2 {x y z : A} (f : x --> y) (g : Monic A x z)
        (DS : BinDirectSum y z) :
    isMonic (to_binop _ _ (f · to_In1 DS) (g · to_In2 DS)).
  Proof.
    use make_isMonic.
    intros x0 g0 h X.
    assert (e : g0 · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr2 DS =
                h · to_binop x DS (f · to_In1 DS) (g · to_In2 DS) · to_Pr2 DS).
    {
      rewrite X. apply idpath.
    }
    rewrite <- assoc in e. rewrite <- assoc in e.
    rewrite (@to_postmor_linear' A) in e.
    rewrite <- assoc in e. rewrite <- assoc in e. rewrite (@to_IdIn2 A _ _ _ _ _ _ _ DS) in e.
    rewrite (to_Unel1' DS) in e. rewrite ZeroArrow_comp_right in e.
    rewrite id_right in e. use (MonicisMonic A g).
    rewrite to_lunax'' in e. exact e.
  Qed.

  Lemma isEpi_to_binop_BinDirectSum1 {x y z : A} (f : Epi A y x) (g : z --> x)
        (DS : BinDirectSum y z) :
    isEpi (to_binop _ _ (to_Pr1 DS · f) (to_Pr2 DS · g)).
  Proof.
    use make_isEpi.
    intros z0 g0 h X.
    use (EpiisEpi A f).
    assert (e : to_In1 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · g0 =
                to_In1 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · h).
    {
      rewrite <- assoc. rewrite <- assoc. rewrite X. apply idpath.
    }
    rewrite to_premor_linear' in e. rewrite assoc in e. rewrite assoc in e.
    rewrite to_Unel1' in e. rewrite ZeroArrow_comp_left in e. rewrite to_runax'' in e.
    rewrite (to_IdIn1 DS) in e. rewrite id_left in e. apply e.
  Qed.

  (** This version is used in AbelianPushoutPullback *)
  Lemma isEpi_to_binop_BinDirectSum1' {x y z : A} (f : Epi A x z) (g : y --> z)
        (DS : BinDirectSum x y) :
    isEpi (to_binop _ _ (to_Pr1 DS · f) (to_inv (to_Pr2 DS · g))).
  Proof.
    rewrite PreAdditive_invrcomp. use isEpi_to_binop_BinDirectSum1.
  Qed.

  Lemma isEpi_to_binop_BinDirectSum2 {x y z : A} (f : y --> x) (g : Epi A z x)
        (DS : BinDirectSum y z) :
    isEpi (to_binop _ _ (to_Pr1 DS · f) (to_Pr2 DS · g)).
  Proof.
    use make_isEpi.
    intros z0 g0 h X.
    use (EpiisEpi A g).
    assert (e : to_In2 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · g0 =
                to_In2 DS · to_binop DS x (to_Pr1 DS · f) (to_Pr2 DS · g) · h).
    {
      rewrite <- assoc. rewrite <- assoc. rewrite X. apply idpath.
    }
    rewrite to_premor_linear' in e. rewrite assoc in e. rewrite assoc in e.
    rewrite to_Unel2' in e. rewrite ZeroArrow_comp_left in e. rewrite to_lunax'' in e.
    rewrite (to_IdIn2 DS) in e. rewrite id_left in e. apply e.
  Qed.

End additive_minus_monic.

(** Kernels and cokernels in PreAdditive *)
Section monics_and_epis_in_additive.

  Variable A : CategoryWithAdditiveStructure.

  Lemma to_isMonic {x y : ob A} (f : x --> y)
        (H : ∏ (z : ob A) (g : z --> x) (H : g · f = ZeroArrow (to_Zero A) _ _),
             g = ZeroArrow (to_Zero A) _ _ ) : isMonic f.
  Proof.
    use make_isMonic.
    intros x0 g h X.
    set (tmp := H x0 (to_binop _ _ g (to_inv h))).
    use (to_rcan A (to_inv h)). rewrite (@to_rinvax' A (to_Zero A)). apply tmp. clear tmp.
    rewrite to_postmor_linear'.
    use (to_rcan A (h · f)). rewrite to_assoc. rewrite <- to_postmor_linear'.
    rewrite (@to_linvax' A (to_Zero A)). rewrite ZeroArrow_comp_left.
    rewrite to_runax''. rewrite to_lunax''. exact X.
  Qed.

  Lemma to_isEpi {x y : ob A} (f : x --> y)
        (H : ∏ (z : ob A) (g : y --> z) (H : f · g = ZeroArrow (to_Zero A) _ _),
             g = ZeroArrow (to_Zero A) _ _ ) : isEpi f.
  Proof.
    use make_isEpi.
    intros x0 g h X.
    set (tmp := H x0 (to_binop _ _ g (to_inv h))).
    use (to_rcan A (to_inv h)). rewrite (@to_rinvax' A (to_Zero A)). apply tmp. clear tmp.
    rewrite to_premor_linear'.
    use (to_rcan A (f · h)). rewrite to_assoc. rewrite <- to_premor_linear'.
    rewrite (@to_linvax' A (to_Zero A)). rewrite ZeroArrow_comp_right.
    rewrite to_runax''. rewrite to_lunax''. exact X.
  Qed.

End monics_and_epis_in_additive.


(** * Parallelization of the Bracket Matching Application *)
Require Import NArith Lia.
From SyDPaCC.Core Require Import Bmf Diffusion Parallelization.
Require Import SyDPaCC.Support.NList.
From SyDPaCC.Bsml Require  Model.Core Model.Pid
     DataStructures.DistributedList
     Skeletons.StdLib Skeletons.Accumulate.
Require Import SyDPaCC.Applications.BracketMatching.

Open Scope sydpacc_scope.
Open Scope N_scope.

Module Make (Import Bsml: Core.BSML)(Char: CHAR).

  Module Pid       := Pid.Make Bsml.Bsp.
  Module StdLib    := StdLib.Make Bsml Pid.
  Module Import ParList   := DistributedList.C Bsml Pid.
  Module Import ParVect   := DistributedVector.C Bsml Pid.
  Module Import Accumulate := Accumulate.Make Bsml Pid StdLib ParList ParVect.
  Module BM := SyDPaCC.Applications.BracketMatching.Make Char. Include BM.

  Definition par_bm (s:list Char.t) : par(list Char.t) -> bool :=
    Eval sydpacc in
      parallel (bm_spec s).

End Make.

Close Scope sydpacc_scope.
Close Scope N_scope.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Expr.
Require Import Crypto.Language.API.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

(* for [eauto with lia] *)
Require Import Crypto.BoundsPipeline.

Import API.Compilers.
Import Types.Notations.

Section Cmd.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Existing Instance Types.rep.Z.
  Existing Instance Types.rep.listZ_local. (* local list representation *)

  Fixpoint assign_list (nextn : nat) (xs : base_rtype base_listZ)
    : nat * base_ltype base_listZ * Syntax.cmd.cmd :=
    match xs with
      | [] => (0%nat, [], Syntax.cmd.skip)
      | x :: xs' =>
        let rec := assign_list (S nextn) xs' in
        (S (fst (fst rec)), varname_gen nextn :: snd (fst rec),
         Syntax.cmd.seq (Syntax.cmd.set (varname_gen nextn) x) (snd rec))
    end.

  Fixpoint assign_base {t : base.type} (nextn : nat)
    : base_rtype t -> (nat * base_ltype t * Syntax.cmd.cmd) :=
    match t with
    | base.type.prod a b =>
      fun rhs =>
        let assign1 := assign_base nextn (fst rhs) in
        let assign2 := assign_base (nextn + fst (fst assign1)) (snd rhs) in
        ((fst (fst assign1) + fst (fst assign2))%nat,
         (snd (fst assign1), snd (fst assign2)),
         Syntax.cmd.seq (snd assign1) (snd assign2))
    | base.type.list (base.type.type_base base.type.Z) =>
      assign_list nextn
    | base.type.list _ | base.type.option _ | base.type.unit
    | base.type.type_base _ =>
      fun rhs =>
        let v := varname_gen nextn in
        (1%nat, v, Syntax.cmd.set v rhs)
    end.

  Definition assign {t} (nextn : nat)
    : rtype t -> (nat * ltype t * Syntax.cmd.cmd) :=
    match t as t0 return
          rtype t0 -> nat * ltype t0 * _ with
    | type.base b => assign_base (t:=b) nextn
    | _ =>
      fun _ =>
        (0%nat, dummy_ltype _, Syntax.cmd.skip)
    end.

  Definition translate_ident2_for_cmd {a b c} (i : ident (a -> b -> c))
    : ltype a -> ltype b -> option (ltype c)
    := match i in ident t return ltype (type.domain t) -> ltype (type.domain (type.codomain t)) -> option (ltype (type.codomain (type.codomain t))) with
       | ident.cons base_Z => fun x xs => Some (x :: xs)
       | ident.pair _ _ => fun x y => Some (x, y)
       | _ => fun _ _ => None
       end.

  Fixpoint translate_cmd
           {t} (e : @API.expr ltype t) (nextn : nat)
    : nat (* number of variable names used *)
      * ltype t (* variables in which return values are stored *)
      * Syntax.cmd.cmd (* actual program *) :=
    match e in expr.expr t0
          return (nat * ltype t0 * Syntax.cmd.cmd) with
    | expr.LetIn (type.base t1) (type.base t2) x f =>
      let trx := assign nextn (translate_expr true x) in
      let trf := translate_cmd (f (snd (fst trx))) (nextn + fst (fst trx)) in
      ((fst (fst trx) + fst (fst trf))%nat,
       snd (fst trf),
       Syntax.cmd.seq (snd trx) (snd trf))
    | expr.App _ _ _ _ as e
      => let result_if_ident2
             := (ixy <- invert_expr.invert_AppIdent2_cps e (@translate_cmd) (@translate_cmd);
                let '(existT _ (i, translate_cmd_x, translate_cmd_y)) := ixy in
                let trx := translate_cmd_x nextn in
                let try := translate_cmd_y (fst (fst trx) + nextn)%nat in
                vars <- translate_ident2_for_cmd i (snd (fst trx)) (snd (fst try));
                Some ((fst (fst trx) + fst (fst try))%nat,
                      vars,
                      Syntax.cmd.seq (snd trx) (snd try)))%option in
         match result_if_ident2 with
         | Some res => res
         | None =>
           let v := translate_expr true e in
           assign nextn v
         end
    | expr.Ident type_listZ (ident.nil _) =>
      (0%nat, [], Syntax.cmd.skip)
    | expr.Ident _ i =>
      let v := translate_expr true (expr.Ident i) in
      assign nextn v
    | expr.Var _ v =>
      let v := translate_expr true (expr.Var v) in
      assign nextn v
    | _ => (0%nat, dummy_ltype _, Syntax.cmd.skip)
    end.
End Cmd.


Require Import VST.floyd.proofauto.
Require Import wand_demo.wand_frame.

Ltac pull_left_wand :=
   match goal with
   | |- ?A |-- _ =>
       match A with
       | context [?P -* ?Q] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((P -* Q) * fold_right_sepcon frame);
           [ solve [cancel] | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp]
       end
   end.

Ltac right_ver :=
   match goal with
   | |- (?P -* ?Q) * ?A |-- _ =>
       match A with
       | context [?Q -* ?R] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((P -* Q) * ((Q -* R) * fold_right_sepcon frame));
           [ apply sepcon_derives; [apply derives_refl | solve [cancel]]
           | rewrite <- sepcon_assoc;
             eapply derives_trans;
             [ apply sepcon_derives; [apply wand_frame_ver | apply derives_refl]
             | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
       end
   end.

Ltac left_ver :=
   match goal with
   | |- (?Q -* ?R) * ?A |-- _ =>
       match A with
       | context [?P -* ?Q] =>
           let frame := fresh "frame" in evar (frame: list mpred);
           apply derives_trans with ((Q -* R) * ((P -* Q) * fold_right_sepcon frame));
           [ apply sepcon_derives; [apply derives_refl | solve [cancel]]
           | rewrite <- sepcon_assoc;
             eapply derives_trans;
             [ apply sepcon_derives; [rewrite sepcon_comm; apply wand_frame_ver | apply derives_refl]
             | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
       end
   end.

Ltac apply_wand_frame_ver :=
  try (
    pull_left_wand;
    repeat right_ver;
    repeat left_ver;
    match goal with
    | |- (?P -* ?Q) * ?A |-- _ =>
           let PQ := fresh "PQ" in
           set (PQ := P -* Q);
           apply_wand_frame_ver;
           subst PQ
    end).

Ltac apply_one_wand_frame_elim :=
  match goal with
  | |- (?P -* ?Q) * ?A |-- _ =>
       let frame := fresh "frame" in evar (frame: list mpred);
       apply derives_trans with (P * (P -* Q) * fold_right_sepcon frame);
       [ solve [cancel]
       | eapply derives_trans;
         [ apply sepcon_derives; [apply wand_frame_elim | apply derives_refl]
         | subst frame; unfold fold_right_sepcon; rewrite ?sepcon_emp ]]
   end.

Ltac apply_wand_frame_elim :=
  repeat (
    pull_left_wand;
    apply_one_wand_frame_elim
  ).

Goal forall A B C D E F G H: mpred, (B -* C) * E * (A -* B) * (F -* G) * (C -* D) * (G -* H) |-- A * F -* D * E * H.
  intros.
  apply_wand_frame_ver.
  apply -> wand_sepcon_adjoint.
  apply_wand_frame_elim.
  cancel.
Qed.


Module Type Sub.
  Axiom Refl1 : forall x : nat, x = x.
  Axiom Refl2 : forall x : nat, x = x.
  Axiom Refl3 : forall x : nat, x = x.
  Inductive T : Set :=
      A : T.
End Sub.

Module Type Main.
  Declare Module M: Sub.
End Main.

Module A <: Main.
  Module M <: Sub.
    Lemma Refl1 : forall x : nat, x = x.
      intros; reflexivity.
    Qed.
    Axiom Refl2 : forall x : nat, x = x.
    Lemma Refl3 : forall x : nat, x = x.
      intros; reflexivity.
    Defined.
    Inductive T : Set :=
        A : T.
  End M.
End A.

(* first test *)

Module F (S: Sub).
  Module M := S.
End F.

Module B <: Main with Module M:=A.M := F A.M.

(* second test *)

Lemma r1 : (A.M.Refl1 = B.M.Refl1).
Proof.
  reflexivity.
Qed.

Lemma r2 : (A.M.Refl2 = B.M.Refl2).
Proof.
  reflexivity.
Qed.

Lemma r3 : (A.M.Refl3 = B.M.Refl3).
Proof.
  reflexivity.
Qed.

Lemma t : (A.M.T = B.M.T).
Proof.
  reflexivity.
Qed.

Lemma a : (A.M.A = B.M.A).
Proof.
  reflexivity.
Qed.


From iris.algebra Require Import auth dfrac.
From iris.algebra.lib Require Import mono_list.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang Require Import lang resources inject tactics proofmode.
From aneris.aneris_lang.lib Require Import
     list_proof monitor_proof lock_proof.

(* ------------------------------------------------------------------------ *)
 Section Logical_Log_Resources.
  Context `{!anerisG Mdl Σ}.
  Context {Aty : Type}.
  Notation A := (leibnizO Aty).
  Context `{inG Σ (mono_listUR A)}.

  (** Log resources. *)

  (** ** Owned by global invariant of the system. *)
  Definition own_log_auth (γ : gname) (q : Qp) (l : list A) : iProp Σ :=
    own γ (●ML{ DfracOwn q } l).

  (** ** Duplicable observation describing the prefix of a log. *)
  Definition own_log_obs (γ : gname) (l : list A) : iProp Σ :=
    own γ (◯ML l).

  Lemma get_obs (γ : gname) (q : Qp) (l : list A) :
    own_log_auth γ q l ⊢ own_log_obs γ l.
  Proof.
   iIntros "Hown".
   rewrite /own_log_obs.
   iApply (own_mono with "Hown").
   apply mono_list_included.
  Qed.

  Lemma get_obs_prefix (γ : gname) (l1 l2 l3 : list A) :
    l3 = l1 ++ l2 →
    own_log_obs γ l3 ⊢ own_log_obs γ l1.
  Proof.
   rewrite /own_log_obs.
   iIntros (Hl3) "Hauth".
   iApply (own_mono with "Hauth").
   apply mono_list_lb_mono.
   list_simplifier.
   by eexists.
  Qed.

  Lemma get_auth_obs_prefix (γ : gname) (q : Qp) (l1 l2 l3 : list A) :
    l3 = l1 ++ l2 →
    own_log_auth γ q l3 ⊢ own_log_obs γ l1.
  Proof.
   rewrite /own_log_obs /own_log_auth.
   iIntros (Hl3) "Hauth".
   iDestruct (get_obs with "Hauth") as "Hobs".
   by iApply get_obs_prefix.
  Qed.

  Lemma own_obs_prefix (γ : gname) (q : Qp) (L l : list A) :
    own_log_auth γ q L ⊢ own_log_obs γ l -∗ ⌜l `prefix_of` L⌝.
  Proof.
   iIntros "Hown Hobs".
   rewrite /own_log_obs.
   iDestruct (own_valid_2 with "[$Hown][$Hobs]") as "%Hvalid".
   apply mono_list_both_dfrac_valid_L in Hvalid.
   naive_solver.
  Qed.

  Lemma own_log_auth_combine γ q1 q2 l1 l2 :
    own_log_auth γ q1 l1 -∗
    own_log_auth γ q2 l2 -∗
    own_log_auth γ (q1 + q2) l1 ∗ ⌜l1 = l2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "[$H1][$H2]") as "%Hvalid".
    rewrite mono_list_auth_dfrac_op_valid_L dfrac_op_own in Hvalid.
    destruct Hvalid as (Hvalid & ->).
    iCombine "H1 H2" as "H3".
    rewrite /own_log_auth. rewrite -dfrac_op_own.
    rewrite mono_list_auth_dfrac_op. by iFrame.
  Qed.

  Lemma own_log_auth_split γ q1 q2 l1 :
    own_log_auth γ (q1 + q2) l1 ⊢
    own_log_auth γ q1 l1 ∗ own_log_auth γ q2 l1.
  Proof.
    iIntros "H1".
    rewrite /own_log_auth.
    rewrite -dfrac_op_own  mono_list_auth_dfrac_op.
    iDestruct "H1" as "(H11 & H12)". iFrame.
  Qed.

  Lemma obs_obs_prefix γ l1 l2 :
    own_log_obs γ l1 ∗ own_log_obs γ l2 -∗
    ⌜l1 `prefix_of` l2 ∨ l2 `prefix_of` l1⌝.
  Proof.
    iIntros "[Hown1 Hown2]".
    by iDestruct (own_valid_2 with "Hown1 Hown2") as
      %Hvalid%mono_list_lb_op_valid_L.
  Qed.

  Lemma obs_length_agree (γ : gname) (l1 l2 : list A) :
    length l1 = length l2 →
    own_log_obs γ l1 ⊢ own_log_obs γ l2 -∗ ⌜l1 = l2⌝.
  Proof.
    iIntros (Hlen) "Hown1 Hown2".
    iDestruct (obs_obs_prefix with "[$Hown1 $Hown2]")
      as %[[k Hprefix]|[k Hprefix]].
    - iPureIntro. simplify_eq.
      destruct k; [by rewrite right_id|].
      rewrite app_length in Hlen. simpl in Hlen. lia.
    - iPureIntro. simplify_eq.
      destruct k; [by rewrite right_id|].
      rewrite app_length in Hlen. simpl in Hlen. lia.
  Qed.

  Lemma own_log_auth_update γ l1 l2 :
    l1 `prefix_of` l2 →
    own_log_auth γ 1 l1 ==∗ own_log_auth γ 1 l2.
  Proof.
    iIntros (Hprefix) "Hown".
    iMod (own_update with "Hown"); [|done].
    by apply mono_list_update.
  Qed.

End Logical_Log_Resources.

Section Physical_Log_Spec.
  Context `{!anerisG Mdl Σ, !lockG Σ}.
  Context {Aty : Type}.
  Notation A := (leibnizO Aty).
  Context `{inG Σ (mono_listUR A)}.
  Context `{!Inject A val}.

  Definition inject_log (xs : list A) :=
    ($xs, #(List.length xs))%V.

  Global Program Instance Inject_log `{!Inject A val}
    : Inject (list A) val := {| inject := inject_log |}.
  Next Obligation.
    intros ? [] xs ys.
    - inversion ys as [[Hinj Hinj2]].
      symmetry. apply nil_length_inv. naive_solver.
    - inversion ys as [[Hinj Hinj2]].
      destruct xs as [| x xs]; first done.
      simplify_eq.
      inversion Hinj as [[Hinj3]]. apply Inject_list in Hinj3.
      naive_solver.
  Qed.

  Definition is_log (logM : list A) (logV : val) :=
    ∃ (lV : val), logV = (lV, #(List.length logM))%V ∧ is_list logM lV.

  Definition log_monitor_inv_def
    (ip : ip_address) (γlog : gname) (q: Qp)
    (logL : loc) (Res : list A → iProp Σ) : iProp Σ :=
    ∃ logV logM,
      ⌜is_log logM logV⌝ ∗
      logL ↦[ip] logV ∗
      own_log_auth γlog q logM ∗
      Res logM.

  Definition log_monitor_inv monN ip monγ monV γlog q logL monR :=
    is_monitor monN ip monγ monV (log_monitor_inv_def ip γlog q logL monR).

End Physical_Log_Spec.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A copy to try and get inversion working on getD as it breaks
 K induction.

*)

(*
  Typographic conventions

   Upper case for inductive types.
   Using only Dan's greek names.
   Context is C.
   P for path (p).
   Phi went from lower case delta/ampersand to human readable witnesschange/aliases.
   s for the judgement, St for statements and State for states.

   YE for elements that go in lists of type Y.
*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export CpdtTactics.
Require Export Case.
(* The abstract syntax of kinds. *)

Inductive Kappa : Type :=
 | B                         (* 'boxed' kind. *)
 | A.                        (* 'any'   kind. *)

Function beq_kappa (k k' : Kappa) : bool :=
   match k, k' with
     |  A, A => true
     |  B, B => true
     |  _, _ => false
  end.

(* The abstract syntax of types. *)

(* A type variable, numbered. *)
Inductive TVar : Type :=
 | tvar   : nat -> TVar.

Function beq_tvar (x y : TVar) : bool :=
   match x, y with
     | (tvar x'), (tvar y') => beq_nat x' y'
  end.

(* A type limiting the opening of existential types. *)

Inductive Phi : Type :=
 | witnesschanges  : Phi                            (* Allowing witness changes. \delta *)
 | aliases        : Phi.                             (* Allowing aliases as the opened type. \amp *)

(* The types. *)

Inductive Tau : Type :=
 | tv_t   : TVar -> Tau                              (* A type variable is a type. *)
 | cint   : Tau                                      (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau                        (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau                        (* Function    type. *)
 | ptype  : Tau -> Tau                               (* Pointer     type. *)
 | utype  : TVar -> Kappa -> Tau -> Tau              (* Universal   type. *)
 | etype  : Phi -> TVar -> Kappa -> Tau -> Tau.      (* Existential type. *)

Function removeTVar (alpha : TVar) (tvars : list TVar) : list TVar :=
  match alpha, tvars with
   | _, [] => []
   | tvar n, (tvar n') :: tvars' =>
     if beq_nat n n'
     then removeTVar alpha tvars'
     else (tvar n) :: (removeTVar alpha tvars')
  end.

Function FreeVariablesTau (tau : Tau) : list TVar :=
  match tau with
   | tv_t alpha   => [alpha]
   | cint         => []
   | cross t0 t1  => (FreeVariablesTau t0) ++ (FreeVariablesTau t1)
   | arrow t0 t1  => (FreeVariablesTau t0) ++ (FreeVariablesTau t1)
   | ptype t      => (FreeVariablesTau t)
   | utype alpha _ t    => removeTVar alpha (FreeVariablesTau t)
   | etype _ alpha _ t  => removeTVar alpha (FreeVariablesTau t)
  end.

(* The abstract syntax of expression variables. *)

Inductive EVar : Type :=
 | evar : nat -> EVar.                                          (* variables appearing in the source language. *)

Function beq_evar (x y : EVar) : bool :=
   match x, y with
     | (evar x'), (evar y') => beq_nat x' y'
  end.

(* The abstract syntax of terms, split into statements and expressions. *)
(* Got rid of a bunch of _e but still have four to simplify.  *)

Inductive I  : Type :=
 | i_i       : Z -> I.                         (* An integer value in an expression or statement. *)

(* Bug 45, should have made this just zero/one not an i to make the inductions
   work. *)
Inductive IPE: Type :=
 | zero_pe                                 (* Access first of pair. *)
 | one_pe                                  (* Access second of pair. *)
with PE : Type :=                          (* Path Element, the empty path is nil. *)
 | i_pe      : IPE -> PE                   (* An access into a pair. *)
 | u_pe      : PE.                         (* An access into an existential type. *)

Definition P : Type := list PE.              (* Paths are lists of path elements. *)

Inductive St : Type :=                        (* Terms for statements. *)
 | e_s       : E   -> St                      (* An expression in a statement. *)
 | retn      : E   -> St                      (* Returns are required in this syntax. *)
 | seq       : St  -> St -> St                (* Statement sequencing. *)
 | if_s      : E   -> St -> St   -> St        (* if expression in a statement. *)
 | while     : E   -> St -> St                (* A while statement. *)
 | letx      : EVar -> E -> St   -> St        (* A let expression. *)
 | open      : E -> TVar -> EVar -> St -> St  (* open an existential package (elimination) to a value. *)
 | openstar  : E -> TVar -> EVar -> St -> St  (* open an existential package (elimination) with a pointer to the value. *)
with E : Type :=                              (* Terms for expressions. *)
 | i_e       : I -> E                         (* An integer value in an expression. *)
 | p_e       : EVar -> list PE -> E           (* This is a term that derefences a path into the value of the variable. *)
 | f_e       : F -> E                         (* A function identifier in an expression or statement. *)
 | amp       : E -> E                         (* Take the address of an expression. *)
 | star      : E -> E                         (* Derefence an expression of a pointer type. *)
 | cpair     : E -> E -> E                    (* A pair in an expression. *)
 | dot       : E -> IPE -> E                  (* A deference of a pair. *)
 | assign    : E -> E -> E                    (* Equality expression. *)
 | appl      : E -> E -> E                    (* Application expression. app is append. *)
 | call      : St -> E                        (* A call expression for the semantics use. *)
 | inst      : E -> Tau -> E                  (* Type instantiation, e[\tau]. *)
 | pack      : Tau -> E -> Tau -> E           (* Existential type introduction. *)
with F : Type :=
 | dfun      : Tau -> EVar -> Tau -> St -> F  (* Function definition. *)
 | ufun      : TVar -> Kappa -> F -> F        (* Univerally quantified polymorphic function definition.  *)
.

Scheme St_ind_mutual := Induction for St Sort Prop
with    E_ind_mutual := Induction for E Sort Prop
with    F_ind_mutual := Induction for F Sort Prop.
Combined Scheme Term_ind_mutual from St_ind_mutual, E_ind_mutual, F_ind_mutual.

(* jrw why can't coqie invert? *)
Function beq_path (p q : P) : bool :=
  match p, q with
    | [], [] => true
    | (i_pe zero_pe) :: p', (i_pe zero_pe) :: q' => beq_path p' q'
    | (i_pe one_pe)  :: p', (i_pe one_pe ) :: q' => beq_path p' q'
    | u_pe :: p', u_pe :: q'  => beq_path p' q' (* Bug 39, failed to recurse. *)
    | _  , _ => false
  end.
(* TODO on inversion write the last clause to explicitly match the other cases. *)

(* Make a value type judgement. The thesis does this syntactically
but that's not representable in Coq. *)

Inductive Value : E -> Prop :=
 | IIsAValue    : forall (i : I),              Value (i_e i)

 | AmpIsAValue  : forall (x : EVar) (p : P),   Value (amp (p_e x p))

 | DfunIsAValue : forall (t1 t2 : Tau) (x : EVar) (s : St),
                        Value (f_e (dfun t1 x t2 s))
 | UfunIsAValue :
     forall (t : TVar) (k : Kappa) (f : F),
       Value (f_e (ufun t k f))

 | PairIsAValue :
     forall (v0 v1 : E),
       Value v0 ->
       Value v1 ->
       Value (cpair v0 v1)

(* Bug 40, forget a subvalue here. *)
 | PackIsAValue :
     forall (tau tau': Tau) (v : E),
       Value v ->
       Value (pack tau v tau').

(* The abstract syntax of H values. *)

Definition HE : Type := prod EVar E.
Definition H  : Type := list HE.

(* Bug 2, 3 *)

Function getH (h : H) (x : EVar) : option E :=
    match x, h with
    | x, (y,v) :: h' =>
      if beq_evar x y
      then Some v
      else getH h' x
    | _ , nil => None
  end.

(* TODO move to beq_evar. *)

Function setH (h : H) (x : EVar) (e : E) : H :=
  match x, h with
    | evar x', (evar y',v) :: h' =>
      if beq_nat x' y'
      then [(x,e)] ++ h'
      else (evar y',v) :: (setH h' x e)
    | (evar x'), _ => [(x,e)]
 end.

Function deleteH (h : H) (x : EVar) : H :=
    match x, h with
    | evar x', (evar y',v) :: h' =>
      if beq_nat x' y'
      then h'
      else (evar y',v) :: (deleteH h' x)
    | _, [] => []
 end.

(* The context is three part: kind assignment, type assignments and path assignments. *)

Definition DE : Type := prod TVar Kappa.
Definition Delta     := list DE.

(* Inversion on getD may be the bug in K induction as d0 keeps appearing. *)

Function getD (d : Delta) (alpha : TVar) : option Kappa :=
  match alpha, d with
    | a, (b, k) :: d' =>
      if beq_tvar a b
      then Some k
      else getD d' alpha
    | _ , nil => None
  end.

Print getD_equation.
Print getD_ind.
Print getD_rec.
Print getD_rect.
Print R_getD_correct.
Print R_getD_complete.


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 conj14eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus Zero (plus lv1 lv0))).
Admitted.
QuickChick conj14eqsynthconj2.


Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Strings.String.
Require Import Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.EqdepFacts.
Require Import Coq.Logic.ProofIrrelevance.

Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import DetermA.
Require Import AbbrevA.

Module Hoare (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module Abbrev := Abbrev IdT.
Export Abbrev.

Open Scope string_scope.
Import ListNotations.

Definition HoareTriple_Step
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EStep fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_ExtendedStep
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_Eval
           (P : W -> Prop) (Q : Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)) ->
    P s -> Q v s'.

Definition HoarePrmsTriple_Eval
           (P : W -> Prop) (Q : list Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (es: list Exp) : Prop :=
  forall (s s': W) (vs: list Value),
    PrmsClosure fenv env (Conf Prms s (PS es)) (Conf Prms s'
                                                     (PS (map Val vs))) ->
    P s -> Q vs s'.

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

Lemma write_T_1 {T: Type} (VT: ValTyp T) (f: T -> W)
      (P0: W -> Prop)
      (fenv: funEnv) (env: valEnv) (x: T):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (Write VT f x))
                   (Conf Exp s' e) ->
  P0 (f x) -> P0 s'.
  intros.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  unfold b_exec.
  unfold b_mod.
  unfold xf_write.
  simpl.
  eapply inj_pair2 in H8.
  rewrite H8.
  exact H.
  inversion X0.
Qed.

Definition WriteT1SHT {T: Type} (VT: ValTyp T) (f: T -> W)
           (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: T) :=
  HoareTriple_Step (fun _ => P0 (f x)) (fun _ s => P0 s)
                   fenv env (Write VT f x).

Lemma write_T_1_sht {T: Type} (VT: ValTyp T) (f: T -> W)
      (P0: W -> Prop)
      (fenv: funEnv) (env: valEnv) (x: T):
  forall (s s': W) (e: Exp),
    WriteT1SHT VT f P0 fenv env x.
  unfold WriteT1SHT.
  unfold HoareTriple_Step.
  intros.
  eapply write_T_1.
  eauto.
  auto.
Qed.

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

Lemma bindn_congruence0 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    (forall s, P s -> P1 s) ->
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros E H e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  eapply E.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

Lemma bindn_congruence1 (P: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P) fenv env e ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros H e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

Lemma bindn_congruence2 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    (forall (e1: Exp) (v: Value),
       HoareTriple_Step P (fun _ => P1) fenv env (BindN (Val v) e1)) ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros H K e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  eapply K.
  eauto.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

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

Lemma BindN_VHT1 (P0 P1: W -> Prop) (P2: Value -> W -> Prop)
      (fenv: funEnv) (env: valEnv) (e1 e2: Exp)
      (k1: forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))
      (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :
  HoareTriple_Eval P0 (fun _ => P1) fenv env e1 ->
  HoareTriple_Eval P1 P2 fenv env e2 ->
  HoareTriple_Eval P0 P2 fenv env (BindN e1 e2).
  unfold HoareTriple_Eval.
  intros.
  eapply BindN_BStep1 in X.
  destruct X as [s1 X].
  destruct X as [v1 X].
  eapply H0.
  eauto.
  eapply H.
  eauto.
  auto.
  auto.
  auto.
Qed.

Lemma BindS_VHT1 (P0: W -> Prop) (P1 P2: Value -> W -> Prop)

(fenv: funEnv) (env: valEnv) (e1 e2: Exp) (x: Id)

(k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))

      (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :

  HoareTriple_Eval P0 P1 fenv env e1 ->
  (forall v, HoareTriple_Eval (P1 v) P2 fenv ((x,v)::env) e2) ->
  HoareTriple_Eval P0 P2 fenv env (BindS x e1 e2).
Proof.
  unfold HoareTriple_Eval.
  intros.
  eapply BindS_BStep1 in X.
  destruct X as [s1 X].
  destruct X as [v1 X].
  eapply H0.
  eauto.
  eapply H.
  eauto.
  auto.
  auto.
  auto.
Qed.

Lemma Apply_VHT1 (P0: W -> Prop) (P1: list Value -> W -> Prop)
                 (P2: Value -> W -> Prop)
   (fenv: funEnv) (env: valEnv) (f: Fun) (es: list Exp)
     (k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))

     (k2: forall (fenv: funEnv) (env: valEnv) (es:list Exp) (s: W),
      sigT (fun vs: list Value =>
                 sigT (fun s': W =>
      PrmsClosure fenv env (Conf Prms s (PS es))
                           (Conf Prms s' (PS (map Val vs))))))

     (k3: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
          (s1 = s2) /\ (v1 = v2)) :

  HoarePrmsTriple_Eval P0 P1 fenv env es ->
  match f with
  | FC fenv' tenv' e0 e1 x n =>
    length tenv' = length es /\
    match n with
    | 0 => (forall vs: list Value,
          HoareTriple_Eval (P1 vs) P2 fenv' (mkVEnv tenv' vs) e0)
    | S n' => (forall vs: list Value,
          HoareTriple_Eval (P1 vs) P2 ((x,FC fenv' tenv' e0 e1 x n')::fenv')
                           (mkVEnv tenv' vs) e1)
    end
  end ->
  HoareTriple_Eval P0 P2 fenv env (Apply (QF f) (PS es)).
Proof.
  unfold HoareTriple_Eval, HoarePrmsTriple_Eval.
  intros.
  generalize (Apply_BStep1 fenv env f es v s s' k1 k2 k3).
  intro P.
  destruct f.
  destruct H0.
  specialize (P H0 X).
  destruct P as [s1 P].
  destruct P as [vs P].
  specialize (H s s1 vs P H1).
  destruct n.
  specialize (H2 vs s1 s' v y H).
  exact H2.
  specialize (H2 vs s1 s' v y H).
  exact H2.
Qed.

End Hoare.


Require Import Behavior.
Require Import Expr.

Require Import Arith.
Require Import Omega.
Require Import FunctionalExtensionality.

Local Open Scope behavior.
Local Open Scope tla.
(*
Lemma skip_predicate_inner :
  forall (A : Type) (P : Predicate A) (s : Behavior A),
    eval `P s ->
    eval SKIP s ->
    eval `P s@1.
Proof.
  unfold shift. simpl.
  intros A P s HP HSkip.
  rewrite <- HSkip.
  assumption.
Qed.
 *)

Theorem tla_inv :
  forall (A : Type) (Init P : Predicate A) (Next : Action A),
    (forall x, Init x -> P x) ->
    (forall x y, P x -> Next x y -> P y) ->
    valid (`Init `/\ [][Next] `=> [] `P).
Proof.
  unfold valid. simpl. unfold shift. simpl.
  intros A Init P Next Hinv1 Hinv2 s (Hini,Hnxt) n.
  induction n; auto.
  specialize (Hnxt n).
  destruct Hnxt as [H | H].
  apply Hinv2 with (s n); auto.
  rewrite <- H; auto.
Qed.

Theorem tla_inv_gen :
  forall (A : Type) (Init : Predicate A) (Next : Action A) (F P : Expr A),
    (valid (`Init `/\ [][Next] `/\ F `=> P)) ->
    (forall s, eval P s -> Next (s 0) (s 1) -> eval P (s @ 1)) ->
    valid (`Init `/\ [][Next] `/\ F `=> [] P).
Proof.
  intros A Init Next F P H H0 s.
  intros H1 n.
  destruct H1 as (H1,(H2,H3)).
  generalize dependent s.
  induction n.
  intros s H1 H2 H3.
  apply H. simpl. rewrite shift_0. repeat split; auto.
  intros s H1 H2 H3.
  assert (R : s @ (S n) = (s @ n) @ 1). extensionality x. unfold shift.
  assert (R' : x + S n = x + 1 + n). omega.
  rewrite R'. trivial.
  rewrite R. clear R.
  assert (H4 : Next (s @ n 0) (s @ n 1) \/ s @ n 0 = s @ n 1). apply H2.
  destruct H4 as [H4|H4].
  apply H0; trivial.
  apply IHn; trivial.
  apply stutter_equiv_shift_1 in H4.
  rewrite contraction in *. simpl in H4.
  assert (H5 : eval P (s @ (S n)) <-> eval P (s @ n)).  apply stutter_equiv_eval; auto.
  simpl. apply H5. apply IHn; auto.
Qed.