Require Import FunctionalExtensionality.
Require Export DiscreteCategory Functor SetCategory ComputableCategory SmallCat NaturalTransformation.
Require Import Common Adjoint.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section FunctorFromDiscrete.
  Variable O : Type.
  Context `(D : @SpecializedCategory objD).
  Variable objOf : O -> objD.

  Let FunctorFromDiscrete_MorphismOf s d (m : Morphism (DiscreteCategory O) s d) : Morphism D (objOf s) (objOf d)
    := match m with
         | eq_refl => Identity _
       end.

  Definition FunctorFromDiscrete : SpecializedFunctor (DiscreteCategory O) D.
  Proof.
    refine {| ObjectOf := objOf; MorphismOf := FunctorFromDiscrete_MorphismOf |};
      abstract (
        intros; hnf in *; subst; simpl;
          auto with category
      ).
  Defined.
End FunctorFromDiscrete.

Section Obj.
  Local Ltac build_ob_functor Index2Object :=
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (fun C' => Index2Object C')
          (fun _ _ F => ObjectOf F)
          _
          _
        )
    end;
    intros; simpl in *; reflexivity.

  Section type.
    Variable I : Type.
    Variable Index2Object : I -> Type.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctor : SpecializedFunctor (@ComputableCategory _ _ Index2Cat) TypeCat.
      build_ob_functor Index2Object.
    Defined.
  End type.

  Section set.
    Variable I : Type.
    Variable Index2Object : I -> Set.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctorToSet : SpecializedFunctor (@ComputableCategory _ _ Index2Cat) SetCat.
      build_ob_functor Index2Object.
    Defined.
  End set.

  Section prop.
    Variable I : Type.
    Variable Index2Object : I -> Prop.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition ObjectFunctorToProp : SpecializedFunctor (@ComputableCategory _ _ Index2Cat) PropCat.
      build_ob_functor Index2Object.
    Defined.
  End prop.
End Obj.

Arguments ObjectFunctor {I Index2Object Index2Cat}.
Arguments ObjectFunctorToSet {I Index2Object Index2Cat}.
Arguments ObjectFunctorToProp {I Index2Object Index2Cat}.

Section Mor.
  Local Ltac build_mor_functor Index2Object Index2Cat :=
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          (fun C' => { sd : Index2Object C' * Index2Object C' & (Index2Cat C').(Morphism) (fst sd) (snd sd) } )
          (fun _ _ F => (fun sdm =>
            existT (fun sd => Morphism _ (fst sd) (snd sd))
            (F (fst (projT1 sdm)), F (snd (projT1 sdm)))
            (MorphismOf F (s := fst (projT1 sdm)) (d := snd (projT1 sdm)) (projT2 sdm))
          ))
          _
          _
        )
    end;
    intros; simpl in *; try reflexivity;
      repeat (apply functional_extensionality_dep; intro);
        simpl_eq;
        reflexivity.

  Section type.
    Variable I : Type.
    Variable Index2Object : I -> Type.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition MorphismFunctor : SpecializedFunctor (@ComputableCategory _ _ Index2Cat) TypeCat.
      build_mor_functor Index2Object Index2Cat.
    Defined.
  End type.
End Mor.

Arguments MorphismFunctor {I Index2Object Index2Cat}.

Section dom_cod.
  Local Ltac build_dom_cod fst_snd :=
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
          (fun _ => (fun sdf => fst_snd _ _ (projT1 sdf)))
          _
        )
    end;
    reflexivity.

  Section type.
    Variable I : Type.
    Variable Index2Object : I -> Type.
    Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

    Definition DomainNaturalTransformation : SpecializedNaturalTransformation (@MorphismFunctor _ _ Index2Cat) ObjectFunctor.
      build_dom_cod @fst.
    Defined.

    Definition CodomainNaturalTransformation : SpecializedNaturalTransformation (@MorphismFunctor _ _ Index2Cat) ObjectFunctor.
      build_dom_cod @snd.
    Defined.
  End type.
End dom_cod.

Section InducedFunctor.
  Variable O : Type.
  Context `(O' : @SpecializedCategory obj).
  Variable f : O -> O'.

  Definition InducedDiscreteFunctor : SpecializedFunctor (DiscreteCategory O) O'.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          f
          (fun s d_ m => match m return _ with eq_refl => Identity (f s) end)
          _
          _
        )
    end;
    abstract (
      intros; simpl in *; repeat subst; trivial;
        repeat rewrite RightIdentity; repeat rewrite LeftIdentity;
          repeat rewrite Associativity;
            reflexivity
    ).
  Defined.
End InducedFunctor.

Section disc.
  Local Ltac t := simpl; intros; functor_eq;
    repeat (apply functional_extensionality_dep; intro);
      hnf in *; subst;
        auto.

  Definition DiscreteFunctor : SpecializedFunctor TypeCat LocallySmallCat.
    refine (Build_SpecializedFunctor TypeCat LocallySmallCat
      (fun O => DiscreteCategory O : LocallySmallSpecializedCategory _)
      (fun s d f => InducedDiscreteFunctor _ f)
      _
      _
    );
    abstract t.
  Defined.

  Definition DiscreteSetFunctor : SpecializedFunctor SetCat SmallCat.
    refine (Build_SpecializedFunctor SetCat SmallCat
      (fun O => DiscreteCategory O : SmallSpecializedCategory _)
      (fun s d f => InducedDiscreteFunctor _ f)
      _
      _
    );
    abstract t.
  Defined.
End disc.

Section Adjoints.
  Lemma DiscreteObjectIdentity : ComposeFunctors ObjectFunctor DiscreteFunctor = IdentityFunctor _.
    functor_eq.
  Qed.

  Definition DiscreteObjectAdjunction : HomAdjunction DiscreteFunctor ObjectFunctor.
    match goal with
      | [ |- HomAdjunction ?F ?G ] =>
        refine (Build_HomAdjunction F G
          (fun _ _ F => (fun x => F x))
          _
          _
        )
    end;
    try abstract trivial;
      simpl; intros.
    exists (fun f => (InducedDiscreteFunctor _ f));
      abstract (repeat match goal with
                         | _ => progress trivial
                         | _ => progress repeat (apply functional_extensionality_dep; intro)
                         | _ => hnf in *;
                           match goal with
                             | [ H : _ = _ |- _ ] => destruct H; simpl in *
                           end
                         | _ => rewrite FIdentityOf
                         | _ => progress functor_eq
                       end).
  Defined.
End Adjoints.


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 A B Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ O B /\ (wd_ O A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ col_ A B B))))))))))) -> col_ Bprime O Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 A B C I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ B I /\ (col_ B C H2 /\ (col_ B C I /\ (col_ H2 B H1 /\ col_ B H1 A))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(******************************************************************************************

 Fibrations of strict categories

 In this file, we classify the internal Street fibrations of strict categories. These are
 just the same Street fibrations.

 ******************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetOpFibration.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.StrictCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.

Local Open Scope cat.

Section IsOpCartesian.
  Context {C₁ C₂ : bicat_of_strict_cats}
          {F : C₁ --> C₂}
          (HF : street_opfib F)
          {C₀ : bicat_of_strict_cats}
          {G₁ G₂ : C₀ --> C₁}
          (α : G₁ ==> G₂)
          (Hα : ∏ (x : pr1 C₀), is_opcartesian_sopfib F (pr1 α x)).

  Section Factorization.
    Context {H : C₀ --> C₁}
      {β : G₁ ==> H}
      {δp : G₂ · F ==> H · F}
      (q : β ▹ F = (α ▹ F) • δp).

    Definition strict_pointwise_opcartesian_is_opcartesian_factor_data
      : nat_trans_data (pr1 G₂) (pr1 H)
      := λ x,
        opcartesian_factorization_sopfib
          _
          (Hα x)
          (pr1 β x)
          (pr1 δp x)
          (nat_trans_eq_pointwise q x).

    Definition strict_pointwise_opcartesian_is_opcartesian_factor_laws
      : is_nat_trans _ _ strict_pointwise_opcartesian_is_opcartesian_factor_data.
    Proof.
      intros x y f ; unfold strict_pointwise_opcartesian_is_opcartesian_factor_data ; cbn.
      pose (opcartesian_factorization_sopfib_commute
              F
              (Hα x) (pr1 β x) (pr1 δp x)
              (nat_trans_eq_pointwise q x))
        as p.
      pose (opcartesian_factorization_sopfib_commute
              F
              (Hα y) (pr1 β y) (pr1 δp y)
              (nat_trans_eq_pointwise q y))
        as p'.
      use (opcartesian_factorization_sopfib_unique
             _
             (Hα x)
             (pr1 β x · # (pr1 H) f)
             (pr1 δp x · # (pr1 F) (# (pr1 H) f))).
      - rewrite functor_comp.
        pose (r := nat_trans_eq_pointwise q x) ; cbn in r.
        etrans.
        {
          apply maponpaths_2.
          exact r.
        }
        clear r.
        rewrite !assoc'.
        apply idpath.
      - rewrite functor_comp.
        rewrite opcartesian_factorization_sopfib_over.
        exact (nat_trans_ax δp _ _ f).
      - rewrite !functor_comp.
        rewrite opcartesian_factorization_sopfib_over.
        apply idpath.
      - rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          exact (!(nat_trans_ax α _ _ f)).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          exact p'.
        }
        exact (nat_trans_ax β _ _ f).
      - rewrite !assoc.
        apply maponpaths_2.
        exact p.
    Qed.

    Definition strict_pointwise_opcartesian_is_opcartesian_factor
      : G₂ ==> H.
    Proof.
      use make_nat_trans.
      - exact strict_pointwise_opcartesian_is_opcartesian_factor_data.
      - exact strict_pointwise_opcartesian_is_opcartesian_factor_laws.
    Defined.

    Definition strict_pointwise_opcartesian_is_opcartesian_over
      : strict_pointwise_opcartesian_is_opcartesian_factor ▹ F = δp.
    Proof.
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x ; cbn.
      apply (opcartesian_factorization_sopfib_over F).
    Qed.

    Definition strict_pointwise_opcartesian_is_opcartesian_comm
      : α • strict_pointwise_opcartesian_is_opcartesian_factor = β.
    Proof.
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x ; cbn.
      apply (opcartesian_factorization_sopfib_commute F).
    Qed.

    Definition strict_pointwise_opcartesian_is_opcartesian_unique
      : isaprop (∑ (δ : G₂ ==> H), δ ▹ F = δp × α • δ = β).
    Proof.
      use invproofirrelevance.
      intros δ₁ δ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply cellset_property.
      }
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x.
      use (opcartesian_factorization_sopfib_unique
             _ (Hα x)
             (pr1 β x)
             (pr1 δp x)).
      - exact (nat_trans_eq_pointwise q x).
      - exact (nat_trans_eq_pointwise (pr12 δ₁) x).
      - exact (nat_trans_eq_pointwise (pr12 δ₂) x).
      - exact (nat_trans_eq_pointwise (pr22 δ₁) x).
      - exact (nat_trans_eq_pointwise (pr22 δ₂) x).
    Qed.
  End Factorization.

  Definition strict_pointwise_opcartesian_is_opcartesian
    : is_opcartesian_2cell_sopfib F α.
  Proof.
    intros H β δp q.
    use iscontraprop1.
    - exact (strict_pointwise_opcartesian_is_opcartesian_unique q).
    - simple refine (_ ,, _ ,, _).
      + exact (strict_pointwise_opcartesian_is_opcartesian_factor q).
      + exact (strict_pointwise_opcartesian_is_opcartesian_over q).
      + exact (strict_pointwise_opcartesian_is_opcartesian_comm q).
  Defined.
End IsOpCartesian.


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


Require Export List.
Export ListNotations.
Set Implicit Arguments.

From Coq Require Import ssreflect.

(* Add LoadPath "../modal".
Add LoadPath "../tense-lns". *)
Require Import gen genT ddT gen_tacs.
Require Import gstep.
Require Import List_lemmasT swappedT existsT.
Require Import Coq.Program.Basics.

Inductive rlsmap U W (f : U -> W) (rls : rlsT U) : rlsT W :=
  | rmI : forall ps c, rls ps c -> rlsmap f rls (map f ps) (f c).

Lemma rmI_eq U W (f : U -> W) (rls : rlsT U) ps c mps mc :
  rls ps c -> mps = map f ps -> mc = f c -> rlsmap f rls mps mc.
Proof. intros. subst. apply rmI ; assumption. Qed.

Inductive relmap U W (f : U -> W) (rel : relationT U) : relationT W :=
  | rlI : forall p c, rel p c -> relmap f rel (f p) (f c).

Lemma rlI_eq U W (f : U -> W) (rel : relationT U) p c mp mc :
  rel p c -> mp = f p -> mc = f c -> relmap f rel mp mc.
Proof. intros. subst. apply rlI ; assumption. Qed.

(** seqext, seqrule, extending sequent and rule with left- and right-contexts
  in antecedent and consequent **)
Definition seqext (W : Type) Gam1 Gam2 Delt1 Delt2 (seq : rel (list W)) :=
  match seq with | pair U V => pair (Gam1 ++ U ++ Gam2) (Delt1 ++ V ++ Delt2) end.

Lemma seqext_seqext: forall V (Gam1 Gam2 Delt1 Delt2 Phi1 Phi2 Psi1 Psi2 : list V) seq,
  seqext Gam1 Gam2 Delt1 Delt2 (seqext Phi1 Phi2 Psi1 Psi2 seq) =
  seqext (Gam1 ++ Phi1) (Phi2 ++ Gam2) (Delt1 ++ Psi1) (Psi2 ++ Delt2) seq.
Proof. intros. unfold seqext. destruct seq.
rewrite !app_assoc. reflexivity. Qed.

Lemma map_seqext_seqext: forall V (Gam1 Gam2 Delt1 Delt2 Phi1 Phi2 Psi1 Psi2 : list V) seqs,
  map (seqext Gam1 Gam2 Delt1 Delt2) (map (seqext Phi1 Phi2 Psi1 Psi2) seqs) =
  map (seqext (Gam1 ++ Phi1) (Phi2 ++ Gam2) (Delt1 ++ Psi1) (Psi2 ++ Delt2)) seqs.
Proof. induction seqs. tauto.
simpl. rewrite IHseqs. rewrite seqext_seqext. reflexivity. Qed.

Inductive seqrule (W : Type) (pr : rlsT (rel (list W))) :
    rlsT (rel (list W)) :=
  | Sctxt : forall ps c Phi1 Phi2 Psi1 Psi2, pr ps c ->
    seqrule pr (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (seqext Phi1 Phi2 Psi1 Psi2 c).

Lemma seqext_def : forall (W : Type) Phi1 Phi2 Psi1 Psi2 U V,
      @seqext W Phi1 Phi2 Psi1 Psi2 (U,V) = (Phi1 ++ U ++ Phi2, Psi1 ++ V ++ Psi2).
Proof. reflexivity. Qed.

Lemma Sctxt_e: forall (W : Type) (pr : rlsT (rel (list W))) ps U V Phi1 Phi2 Psi1 Psi2,
  pr ps (U, V) ->
  seqrule pr (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (Phi1 ++ U ++ Phi2, Psi1 ++ V ++ Psi2).
Proof.
  intros until 0. intros H. rewrite <- seqext_def.
  apply Sctxt. exact H.
Qed.

Lemma Sctxt_eq: forall (W : Type) pr ps mps (ca cs U V Phi1 Phi2 Psi1 Psi2 : list W),
  pr ps (U, V) -> ca = Phi1 ++ U ++ Phi2 -> cs = Psi1 ++ V ++ Psi2 ->
  mps = map (seqext Phi1 Phi2 Psi1 Psi2) ps -> seqrule pr mps (ca, cs).
Proof. intros.  subst. apply Sctxt_e. exact X. Qed.

Lemma seqrule_id (W : Type) (pr : rlsT (rel (list W))) :
  forall ps c, pr ps c -> seqrule pr ps c.
Proof. intros. destruct c as [ca cs].
apply (Sctxt_eq pr ps ca cs [] [] [] []). assumption.
simpl. rewrite app_nil_r.  reflexivity.
simpl. rewrite app_nil_r.  reflexivity.
clear X. induction ps.  simpl.  reflexivity.
simpl. rewrite <- IHps.
destruct a. unfold seqext. simpl.  rewrite !app_nil_r.
reflexivity. Qed.

Lemma seqrule_seqrule (W : Type) (pr : rlsT (rel (list W))) :
  rsub (seqrule (seqrule pr)) (seqrule pr).
Proof. unfold rsub. intros. inversion X. subst. clear X.
inversion X0.  subst. clear X0.
rewrite seqext_seqext.
destruct c0 as [ca cs].
eapply Sctxt_eq. exact X.
reflexivity.  reflexivity.
clear X. induction ps0.  simpl.  reflexivity.
simpl. rewrite IHps0.  rewrite seqext_seqext. reflexivity. Qed.

Definition seqrule_seqrule' (W : Type) pr :=
  rsubD (@seqrule_seqrule W pr).

Lemma derl_seqrule'' (W : Type) (rules : rlsT (rel (list W))) :
  forall Phi1 Phi2 Psi1 Psi2, (forall ps c, derl rules ps c ->
   derl (seqrule rules) (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (seqext Phi1 Phi2 Psi1 Psi2 c)) *
  (forall ps cs, dersl rules ps cs ->
    dersl (seqrule rules) (map (seqext Phi1 Phi2 Psi1 Psi2) ps)
    (map (seqext Phi1 Phi2 Psi1 Psi2)cs)).
Proof. intros Phi1 Phi2 Psi1 Psi2.
eapply (derl_dersl_rect_mut (rules := rules)
  (fun ps c => fun _ => derl (seqrule rules)
    (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (seqext Phi1 Phi2 Psi1 Psi2 c))
  (fun ps cs : list _ => fun _ => dersl (seqrule rules)
    (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (map (seqext Phi1 Phi2 Psi1 Psi2) cs))).
- simpl. intros. apply asmI.
- intros. eapply dtderI.  apply Sctxt. eassumption.  assumption.
- simpl. apply dtNil.
- intros. rewrite map_app. simpl. apply dtCons ; assumption. Qed.

Definition derl_seqrule' W rules Phi1 Phi2 Psi1 Psi2 :=
  fst (@derl_seqrule'' W rules Phi1 Phi2 Psi1 Psi2).
Definition dersl_seqrule' W rules Phi1 Phi2 Psi1 Psi2 :=
  snd (@derl_seqrule'' W rules Phi1 Phi2 Psi1 Psi2).

Lemma derl_seqrule (W : Type) (rules : rlsT (rel (list W))) :
  rsub (seqrule (derl rules)) (derl (seqrule rules)).
Proof.  unfold rsub.  intros.  destruct X.
apply derl_seqrule'. assumption. Qed.

Lemma seqrule_derl_seqrule (W : Type) (rules : rlsT (rel (list W))) :
  rsub (seqrule (derl (seqrule rules))) (derl (seqrule rules)).
Proof.  eapply rsub_trans. apply derl_seqrule.
 unfold rsub.  intros.  eapply derl_mono. 2: eassumption.
 apply seqrule_seqrule. Qed.

Definition seqrule_derl_seqrule' W rules :=
  rsubD (@seqrule_derl_seqrule W rules).

(* seqrule_s ps c qs d means that d is a sequent extension of c
  and that each q in qs is a corresponding sequent extension of the
  corresponding p in ps *)
Inductive seqrule_s (W : Type) (ps : list (rel (list W))) (c : rel (list W)) :
    rlsT (rel (list W)) :=
  | Sctxt_s : forall Phi1 Phi2 Psi1 Psi2,
    seqrule_s ps c (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (seqext Phi1 Phi2 Psi1 Psi2 c).

Inductive seqrule' (W : Type) (pr : rlsT (rel (list W))) :
    rlsT (rel (list W)) :=
  | Sctxt' : forall ps c pse ce,
    pr ps c -> seqrule_s ps c pse ce -> seqrule' pr pse ce.

Check (Sctxt' _ _ (Sctxt_s _ _ _ _ _ _)).

(* Check, get same as Sctxt but for seqrule' *)
Lemma Sctxt_alt : forall (W : Type) (pr : rlsT (rel (list W))) ps c Phi1 Phi2 Psi1 Psi2,
    pr ps c -> seqrule' pr (map (seqext Phi1 Phi2 Psi1 Psi2) ps) (seqext Phi1 Phi2 Psi1 Psi2 c).
Proof.
  intros until 0. intros H.
  eapply Sctxt'. exact H. apply Sctxt_s.
Qed.

Lemma Sctxt_e': forall (W : Type) (pr : rlsT (rel (list W))) ps U V Phi1 Phi2 Psi1 Psi2,
  pr ps (U, V) ->
  seqrule pr (map (seqext Phi1 Phi2 Psi1 Psi2) ps) ((Phi1 ++ U) ++ Phi2, Psi1 ++ V ++ Psi2).
Proof.
  intros until 0. intros H.
  rewrite <- app_assoc. apply Sctxt_e. exact H.
Qed.

Lemma seqext_defp : forall (W : Type) Phi1 Phi2 Psi1 Psi2 seq,
      @seqext W Phi1 Phi2 Psi1 Psi2 seq =
        let (U, V) := seq in (Phi1 ++ U ++ Phi2, Psi1 ++ V ++ Psi2).
Proof. reflexivity. Qed.

Lemma seqrule_same: forall (W : Type) pr ps (c c' : rel (list W)),
  seqrule pr ps c -> c = c' -> seqrule pr ps c'.
Proof. intros. subst. assumption. Qed.

Lemma seqrule_mono X (rulesa rulesb : rlsT (rel (list X))) :
  rsub rulesa rulesb -> rsub (seqrule rulesa) (seqrule rulesb).
Proof. unfold rsub. intros. destruct X1. apply Sctxt. firstorder. Qed.

Definition seqrule_mono' X rulesa rulesb rs :=
  rsubD (@seqrule_mono X rulesa rulesb rs).

Lemma Sctxt_nil: forall (W : Type) pr c Gam1 Gam2 Delt1 Delt2, (pr [] c : Type) ->
  @seqrule W pr [] (seqext Gam1 Gam2 Delt1 Delt2 c).
Proof.
  intros until 0.  intros H. eapply Sctxt in H.
  simpl in H. exact H.
Qed.

Lemma InT_seqextL : forall {W : Type} Gam Delt A,
    InT A Gam ->
    existsT2 Phi1 Phi2, @seqext W Phi1 Phi2 Delt [] ([A], []) = (Gam, Delt).
Proof.
  induction Gam; intros Delt A Hin.
  inversion Hin.
  inversion Hin. subst.
  repeat eexists. unfold seqext.
  do 2 rewrite app_nil_r. erewrite app_nil_l.
     reflexivity.
  subst. destruct (IHGam  Delt _ X) as [H1 [H2 H3]].
  unfold seqext in *.
  inversion H3.
  repeat rewrite app_nil_r.
  repeat eexists. rewrite app_comm_cons. reflexivity.
Qed.

Lemma InT_seqextR : forall {W : Type} Gam Delt B,
    InT B Delt ->
    existsT2 Psi1 Psi2, @seqext W Gam [] Psi1 Psi2 ([], [B]) = (Gam, Delt).
Proof.
  induction Delt; intros A Hin.
  inversion Hin.
  inversion Hin. subst.
  repeat eexists. unfold seqext.
  do 2 rewrite app_nil_r. erewrite app_nil_l.
     reflexivity.
  subst. destruct (IHDelt _ X) as [H1 [H2 H3]].
  unfold seqext in *.
  inversion H3.
  repeat rewrite app_nil_r.
  repeat eexists. rewrite app_comm_cons. reflexivity.
Qed.

Lemma InT_seqext : forall {W : Type} Gam Delt A B,
    InT A Gam ->
    InT B Delt ->
    existsT2 Phi1 Phi2 Psi1 Psi2, @seqext W Phi1 Phi2 Psi1 Psi2 ([A], [B]) = (Gam, Delt).
Proof.
  intros until 0. intros Hin1 Hin2.
  destruct (@InT_seqextL _ _ Delt _ Hin1) as [H1 [H2 H3]].
  destruct (@InT_seqextR _ Gam _ _ Hin2) as [J1 [J2 J3]].
  unfold seqext in *.
  repeat rewrite app_nil_r in H3.
  repeat rewrite app_nil_r in J3.
  inversion H3. inversion J3.
  subst. repeat eexists.
Qed.

(* fmlsext copied from ../ll/fmlsext.v *)
Definition fmlsext (W : Type) Gam1 Gam2 (fmls : (list W)) := (Gam1 ++ fmls ++ Gam2).

Lemma fmlsext_fmlsext: forall V (Gam1 Gam2 Phi1 Phi2 : list V) seq,
  fmlsext Gam1 Gam2 (fmlsext Phi1 Phi2 seq) = fmlsext (Gam1 ++ Phi1) (Phi2 ++ Gam2) seq.
Proof. intros. unfold fmlsext.  rewrite !app_assoc. reflexivity. Qed.

Lemma map_fmlsext_fmlsext: forall V (Gam1 Gam2 Phi1 Phi2 : list V) seqs,
  map (fmlsext Gam1 Gam2) (map (fmlsext Phi1 Phi2) seqs) =
  map (fmlsext (Gam1 ++ Phi1) (Phi2 ++ Gam2)) seqs.
Proof. induction seqs. tauto.
simpl. rewrite IHseqs. rewrite fmlsext_fmlsext. reflexivity. Qed.

Lemma fmlsext_def : forall (W : Type) Phi1 Phi2 U,
      @fmlsext W Phi1 Phi2 U = (Phi1 ++ U ++ Phi2).
Proof. reflexivity. Qed.

Definition apfst U V W (f : U -> V) (p : U * W) := let (x, y) := p in (f x, y).
Definition apsnd U V W (f : U -> V) (p : W * U) := let (x, y) := p in (x, f y).

(** fst_ext_rls - adding left- and right-context
  to the antecedent of a sequent rule *)
Inductive fst_ext_rls U W rls : rlsT (list U * W) :=
  | fextI : forall Gam1 Gam2 ps c,
    rlsmap (apfst (fmlsext Gam1 Gam2)) rls ps c -> fst_ext_rls rls ps c.

Inductive snd_ext_rls U W rls : rlsT (U * list W) :=
  | sextI : forall Gam1 Gam2 ps c,
    rlsmap (apsnd (fmlsext Gam1 Gam2)) rls ps c -> snd_ext_rls rls ps c.

Definition fextI' U W rls Gam1 Gam2 ps c rpc :=
  @fextI U W rls Gam1 Gam2 _ _ (rmI _ _ ps c rpc).

Lemma fextI_eq' U W rls Gam1 Gam2 ps (c : list U * W) mps mc :
  rls ps c -> mps = map (apfst (fmlsext Gam1 Gam2)) ps ->
  mc = apfst (fmlsext Gam1 Gam2) c -> fst_ext_rls rls mps mc.
Proof. intros. subst. apply fextI'. exact X. Qed.

Definition fextI_eqc' U W rls Gam1 Gam2 ps (c : list U * W) mc rpc :=
  @fextI_eq' U W rls Gam1 Gam2 ps (c : list U * W) _ mc rpc eq_refl.

Lemma fst_snd_ext W (rls : rlsT (list W * list W)) :
  req (seqrule rls) (fst_ext_rls (snd_ext_rls rls)).
Proof. split ; intros ps c.
- intro sr. destruct sr. eapply fextI. eapply rmI_eq.
eapply sextI. apply rmI. exact r.
2: destruct c.  2: simpl.  2: unfold fmlsext.  2: reflexivity.
clear r. induction ps. reflexivity.
destruct a. simpl.  rewrite - IHps. unfold fmlsext. reflexivity.
- intro fs. destruct fs. inversion r. clear r. subst.
destruct X. inversion r. clear r. subst.
destruct c0. simpl. unfold fmlsext.
eapply Sctxt_eq. exact X. reflexivity. reflexivity.
clear X.  induction ps0. reflexivity.
destruct a. simpl.  rewrite IHps0. reflexivity. Qed.

Lemma snd_fst_ext W (rls : rlsT (list W * list W)) :
  req (seqrule rls) (snd_ext_rls (fst_ext_rls rls)).
Proof. split ; intros ps c.
- intro sr. destruct sr. eapply sextI. eapply rmI_eq.
eapply fextI. apply rmI. exact r.
2: destruct c.  2: simpl.  2: unfold fmlsext.  2: reflexivity.
clear r. induction ps. reflexivity.
destruct a. simpl.  rewrite - IHps. unfold fmlsext. reflexivity.
- intro fs. destruct fs. inversion r. clear r. subst.
destruct X. inversion r. clear r. subst.
destruct c0. simpl. unfold fmlsext.
eapply Sctxt_eq. exact X. reflexivity. reflexivity.
clear X.  induction ps0. reflexivity.
destruct a. simpl.  rewrite IHps0. reflexivity. Qed.

Lemma rm_mono U W (f : U -> W) rlsa rlsb :
  rsub rlsa rlsb -> rsub (rlsmap f rlsa) (rlsmap f rlsb).
Proof. intros rab ps c ra.
destruct ra.   pose (rab _ _ r).
apply rmI. apply r0. Qed.

Lemma fer_mono U W (rlsa rlsb : rlsT (list U * W)) :
  rsub rlsa rlsb -> rsub (fst_ext_rls rlsa) (fst_ext_rls rlsb).
Proof. intros rab ps c fea.
destruct fea.  destruct r.  pose (rab _ _ r).
eapply fextI. apply rmI. apply r0. Qed.

Lemma ser_mono U W (rlsa rlsb : rlsT (U * list W)) :
  rsub rlsa rlsb -> rsub (snd_ext_rls rlsa) (snd_ext_rls rlsb).
Proof. intros rab ps c sea.
destruct sea.  destruct r.  pose (rab _ _ r).
eapply sextI. apply rmI. apply r0. Qed.

(* derl_fst_ext_rls - similar for seqrule above *)
Lemma fst_ext_rls_fst_ext_rls (U W : Type) (pr : rlsT (list U * W)) :
  rsub (fst_ext_rls (fst_ext_rls pr)) (fst_ext_rls pr).
Proof. unfold rsub. intros. inversion X. subst. clear X.
inversion X0.  subst. clear X0. destruct X. destruct r.
destruct c. simpl.  rewrite fmlsext_fmlsext.
eapply fextI' in p.  simpl in p.
eapply arg1_cong_imp. 2: exact p.  clear p.
induction ps ; simpl. reflexivity.
rewrite IHps.  destruct a. simpl. rewrite fmlsext_fmlsext. reflexivity. Qed.

Definition fst_ext_rls_fst_ext_rls' (U W : Type) pr :=
  rsubD (@fst_ext_rls_fst_ext_rls U W pr).

Lemma derl_fst_ext_rls'' (U W : Type) (rules : rlsT (list U * W)) :
  forall Phi1 Phi2, (forall ps c, derl rules ps c ->
   derl (fst_ext_rls rules)
     (map (apfst (fmlsext Phi1 Phi2)) ps) (apfst (fmlsext Phi1 Phi2) c)) *
  (forall ps cs, dersl rules ps cs ->
    dersl (fst_ext_rls rules) (map (apfst (fmlsext Phi1 Phi2)) ps)
    (map (apfst (fmlsext Phi1 Phi2)) cs)).
Proof. intros Phi1 Phi2.
eapply (derl_dersl_rect_mut (rules := rules)
  (fun ps c => fun _ => derl (fst_ext_rls rules)
    (map (apfst (fmlsext Phi1 Phi2)) ps) (apfst (fmlsext Phi1 Phi2) c))
  (fun ps cs : list _ => fun _ => dersl (fst_ext_rls rules)
    (map (apfst (fmlsext Phi1 Phi2)) ps) (map (apfst (fmlsext Phi1 Phi2)) cs))).
- simpl. intros. apply asmI.
- intros. eapply dtderI. eapply fextI. apply rmI. eassumption.  assumption.
- simpl. apply dtNil.
- intros. rewrite map_app. simpl. apply dtCons ; assumption. Qed.

Definition derl_fst_ext_rls' U W rules Phi1 Phi2 :=
  fst (@derl_fst_ext_rls'' U W rules Phi1 Phi2).
Definition dersl_fst_ext_rls' U W rules Phi1 Phi2 :=
  snd (@derl_fst_ext_rls'' U W rules Phi1 Phi2).

Lemma derl_fst_ext_rls (U W : Type) (rules : rlsT (list U * W)) :
  rsub (fst_ext_rls (derl rules)) (derl (fst_ext_rls rules)).
Proof.  unfold rsub.  intros.  destruct X.  destruct r.
apply derl_fst_ext_rls'. assumption. Qed.

Lemma fst_ext_rls_derl_fst_ext_rls (U W : Type) (rules : rlsT (list U * W)) :
  rsub (fst_ext_rls (derl (fst_ext_rls rules))) (derl (fst_ext_rls rules)).
Proof.  eapply rsub_trans. apply derl_fst_ext_rls.
 unfold rsub.  intros.  eapply derl_mono. 2: eassumption.
 apply fst_ext_rls_fst_ext_rls. Qed.

Definition fst_ext_rls_derl_fst_ext_rls' U W rules :=
  rsubD (@fst_ext_rls_derl_fst_ext_rls U W rules).

(* simple version of weakening, new stuff added at beginning or end,
  could do more complicated, but why bother, have exchange *)
Definition wkL_valid V W rules (cl : list V) cr :=
  forall Gam1 Gam2, derrec rules (@emptyT _) (fmlsext Gam1 Gam2 cl, cr : W).
Definition wkL_valid' V W rules seq := @wkL_valid V W rules (fst seq) (snd seq).

Definition can_wkL V W rules seq :=
  derrec rules emptyT seq -> @wkL_valid' V W rules seq.

Lemma can_wkL_req V W rlsa rlsb seq : req rlsa rlsb ->
  @can_wkL V W rlsa seq -> can_wkL rlsb seq.
Proof. unfold can_wkL. unfold wkL_valid'. unfold wkL_valid.
intros rab da derb *.
specialize (da (derrec_rmono (snd rab) derb)).
exact (derrec_rmono (fst rab) (da Gam1 Gam2)). Qed.

Lemma weakeningL: forall V W seq rules, @can_wkL V W (fst_ext_rls rules) seq.
Proof. unfold can_wkL. intros.
eapply derrec_all_rect in X. exact X.
intros. contradiction H.
intros ps concl ljpc dsps fwk.  destruct ljpc.  inversion r.
destruct c0. unfold wkL_valid'. unfold wkL_valid. simpl. subst. clear r.
intros *.  rewrite fmlsext_fmlsext.
eapply derI. eapply fextI. eapply rmI_eq. apply X0.
reflexivity.  reflexivity.
apply dersrecI_forall. intros c0 incm.
apply InT_mapE in incm. cD.
eapply ForallTD_forall in fwk.
2: apply InT_map.  2: exact incm1.
simpl in incm0. destruct incm0. simpl in fwk.
unfold wkL_valid' in fwk.  unfold wkL_valid in fwk.  simpl in fwk.
rewrite - fmlsext_fmlsext. apply fwk.  Qed.

Print Implicit weakeningL.

(** exchange **)
(* properties can exchange adjacent sublists, and resulting sequent
  is derivable (not conditional on unexchanged version being derivable *)
Definition can_exchL W Y rules seq :=
  forall (Gam Gams : list W) (Delt : Y), seq = pair Gam Delt -> swapped Gam Gams ->
  derrec rules (@emptyT _) (pair Gams Delt).

Definition can_exchR W Y rules seq :=
  forall (Gam : Y) (Delt Delts : list W), seq = pair Gam Delt -> swapped Delt Delts ->
  derrec rules (@emptyT _) (pair Gam Delts).

Inductive sing_empty X : list X -> Type :=
  | se_empty : sing_empty []
  | se_single : forall a, sing_empty [a].

Lemma sing_empty_app X (xs ys : list X):
  sing_empty (xs ++ ys) -> sum (xs = []) (ys = []).
Proof. intro. inversion X0. destruct xs. tauto.
simpl in H0. discriminate H0.
destruct xs. tauto.
injection H0 as. destruct xs. simpl in H0. subst. tauto.
simpl in H0. discriminate H0.  Qed.

Lemma sing_empty_app_cons X z (xs ys : list X):
  sing_empty (xs ++ z :: ys) -> (xs = []) * (ys = []).
Proof. intro se. inversion se.
list_eq_ncT. inversion H0.  list_eq_ncT. sD. inversion H1. tauto.
list_eq_ncT. Qed.

Inductive fst_rel (A B : Type) (R : relationT A) : relationT (A * B) :=
  fst_relI : forall x y z, R x y -> @fst_rel A B R (x, z : B) (y, z).

Inductive snd_rel (A B : Type) (R : relationT A) : relationT (B * A) :=
  snd_relI : forall x y z, R x y -> @snd_rel A B R (z : B, x) (z, y).

Lemma fext_e: forall (U W : Type) (pr : rlsT (list U * W)) ps cl cr Phi1 Phi2,
  pr ps (cl, cr) ->
  fst_ext_rls pr (map (apfst (fmlsext Phi1 Phi2)) ps) (Phi1 ++ cl ++ Phi2, cr).
Proof.  intros * H. rewrite <- fmlsext_def.
  eapply fextI. eapply rmI_eq. exact H. reflexivity.  reflexivity.  Qed.

Lemma sext_e: forall (U W : Type) (pr : rlsT (U * list W)) ps cl cr Phi1 Phi2,
  pr ps (cl, cr) ->
  snd_ext_rls pr (map (apsnd (fmlsext Phi1 Phi2)) ps) (cl, Phi1 ++ cr ++ Phi2).
Proof.  intros * H. rewrite <- fmlsext_def.
  eapply sextI. eapply rmI_eq. exact H. reflexivity.  reflexivity.  Qed.

Ltac concl_in_app X0 r sea :=
  pose X0 as r ; apply sea in r ;
  destruct r ; subst ; rewrite ?app_nil_r ; rewrite ?app_nil_l ;
  simpl in X0 ; rewrite ?app_nil_r in X0.

Ltac fwl_tac mid := eexists ; split ;
  [> assoc_mid mid ; apply fext_e ; eassumption |
    apply ForallTI_forall ; intros x inms ; apply InT_mapE in inms ;
    destruct inms as [x0 p] ; destruct p as [sex int] ;
    destruct x0 ; simpl in sex ; unfold fmlsext in sex ; destruct sex ;
    eexists ; split ;
      [> eapply InT_map ; eassumption |
      simpl ; unfold fmlsext ; apply fst_relI ; swap_tac ]].

Ltac fwr_tac mid := eexists ; split ;
  [> assoc_mid mid ; apply sext_e ; eassumption |
    apply ForallTI_forall ; intros x inms ; apply InT_mapE in inms ;
    destruct inms as [x0 p] ; destruct p as [sex int] ;
    destruct x0 ; simpl in sex ; unfold fmlsext in sex ; destruct sex ;
    eexists ; split ;
      [> eapply InT_map ; eassumption |
      simpl ; unfold fmlsext ; apply snd_relI ; swap_tac ]].

Lemma exchL_std_rule: forall U W (rules : rlsT (list U * W)),
  (forall ps U S, rules ps (U, S) -> sing_empty U) ->
  forall ps c, fst_ext_rls rules ps c ->
    can_trf_rules (fst_rel (@swapped _)) (fst_ext_rls rules) ps c.
Proof. unfold can_trf_rules.
intros U W rules se ps c sqr c' fr.
pose (fun ps xs ys S rps =>
  sing_empty_app xs ys (se ps (xs ++ ys) S rps)) as sea.
inversion fr. subst. clear fr.
inversion sqr. clear sqr. subst.
inversion X0. destruct c as [pl pr].
simpl in H1. unfold fmlsext in H1.
inversion H1. subst. clear H1. clear X0.
inversion X. subst.
acacD'T2 ; subst.
- concl_in_app X1 r sea.  + fwl_tac H3.  + fwl_tac H1.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwl_tac H5.  + fwl_tac C.
+ list_eq_nc. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
simpl in X1. rewrite ?app_nil_r in X1.
fwl_tac H1.
- fwl_tac pl.
- concl_in_app X1 r sea.  + fwl_tac H5.  + fwl_tac H3.
- fwl_tac pl.
- fwl_tac pl.
- concl_in_app X1 r sea.  + fwl_tac H1.  + fwl_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwl_tac H3.  + fwl_tac B.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea. concl_in_app X1 r sea.
+ fwl_tac H5.  + fwl_tac C.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac B.
+ list_eq_nc. destruct e.  list_eq_nc. destruct H1. subst.
rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwl_tac H.
- fwl_tac pl.
Qed.

Print Implicit exchL_std_rule.

Lemma exchR_std_rule: forall U W (rules : rlsT (U * list W)),
  (forall ps U S, rules ps (U, S) -> sing_empty S) ->
  forall ps c, snd_ext_rls rules ps c ->
    can_trf_rules (snd_rel (@swapped _)) (snd_ext_rls rules) ps c.
Proof. unfold can_trf_rules.
intros U W rules se ps c sqr c' fr.
pose (fun ps xs ys U rps =>
  sing_empty_app xs ys (se ps U (xs ++ ys) rps)) as sea.
inversion fr. subst. clear fr.
inversion sqr. clear sqr. subst.
inversion X0. destruct c as [pl pr].
simpl in H1. unfold fmlsext in H1.
inversion H1. subst. clear H1. clear X0.
inversion X. subst.
acacD'T2 ; subst.
- concl_in_app X1 r sea.  + fwr_tac H3.  + fwr_tac H1.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwr_tac H5.  + fwr_tac C.
+ list_eq_nc. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
simpl in X1. rewrite ?app_nil_r in X1.
fwr_tac H1.
- fwr_tac pr.
- concl_in_app X1 r sea.  + fwr_tac H5.  + fwr_tac H3.
- fwr_tac pr.
- fwr_tac pr.
- concl_in_app X1 r sea.  + fwr_tac H1.  + fwr_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea.
+ fwr_tac H3.  + fwr_tac B.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac H.
- concl_in_app X1 r sea.  concl_in_app X1 r sea. concl_in_app X1 r sea.
+ fwr_tac H5.  + fwr_tac C.
+ list_eq_ncT. destruct e. subst. rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac B.
+ list_eq_nc. destruct e.  list_eq_nc. destruct H1. subst.
rewrite ?app_nil_r. rewrite ?app_nil_l.
  simpl in X1 ; rewrite ?app_nil_r in X1.
fwr_tac H.
- fwr_tac pr.
Qed.

Print Implicit exchR_std_rule.

Definition rev_pair {U W} (p : U * W) := let (x, y) := p in (y, x).

Lemma sext_rev_fext U W (rules : rlsT (U * list W)) ps c :
  snd_ext_rls rules ps c ->
  fst_ext_rls (rlsmap rev_pair rules) (map rev_pair ps) (rev_pair c).
Proof. intro ser. destruct ser.  inversion r. destruct c0.
clear r. subst. simpl.
eapply fextI.  eapply rmI_eq. apply rmI. exact X.
2: reflexivity.
clear X.  induction ps0. reflexivity.
simpl. rewrite IHps0.  destruct a. reflexivity. Qed.

Print Implicit sext_rev_fext.

(*
this is not going to be worthwhile without a bunch more lemmas
such as sext_rev_fext above, and more

Lemma exchR_std_rule: forall U W (rules : rlsT (U * list W)),
  (forall ps U S, rules ps (U, S) -> sing_empty S) ->
  forall ps c, snd_ext_rls rules ps c ->
    can_trf_rules (snd_rel (@swapped _)) (snd_ext_rls rules) ps c.
Proof. intros * se * ser.
pose (rlsmap rev_pair rules) as rrules.
pose (@exchL_std_rule _ _ rrules).
require c0.
{ intros * rr.  inversion rr. destruct c1. simpl in H1. inversion H1. subst.
eapply se. subst rrules. exact X. }
specialize (c0 (map rev_pair ps) (rev_pair c)).
require c0.  { subst rrules. exact (sext_rev_fext ser). }

destruct ser.
eapply fextI. inversion r.

*)

(* we may also want to refer to rules individually *)
Inductive Idrule (W : Type) : rlsT (rel (list W)) :=
  | Idrule_I : forall A, Idrule [] (pair [A] [A]).

Lemma sr_Id_alt X (A : X) ant suc: InT A ant -> InT A suc ->
  seqrule (@Idrule X) [] (ant, suc).
Proof. intros. apply InT_split in X1.
apply InT_split in X0. cD. subst.
eapply Sctxt_eq. apply (Idrule_I A).
simpl. reflexivity.  simpl. reflexivity.  simpl. reflexivity. Qed.


Require Export FiatFormal.Language.Ty.

(* Type enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT d) te.
Hint Unfold liftTE.

(* Substitution of Types in Type Environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
(* The following lemmas are similar to the ones in Ty.v,
   except that we've applied them to entire type environments.
 *)

Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te.
  auto.
  unfold liftTE.
   simpl. rewrite liftTT_liftTT.
   unfold liftTE in IHte. rewrite IHte. auto.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE.
 unfold liftTE.
 rewrite map_map.
 induction te.
  auto.
  simpl.
   unfold compose. rewrite substTT_liftTT.
   unfold compose in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT n t2) (liftTE n te).
Proof.
 intros. induction te.
  auto.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.


Require Import IO.
Require Import stdpp.tactics.
Require Import Coq.Classes.RelationClasses.

Class Step S : Type := { step : option io_evt -> S -> S -> Type }.
Class Space S : Type := { space : S -> nat }.

Section Steps.
  Context {C S: Type}.
  Context `{stepFn: Step S}.
  Context `{spaceFn: Space S}.

  Inductive steps : S -> S -> Type
    :=
    | st_refl s : steps s s
    | st_cons {s1 s2 i s3} :
        steps s1 s2 ->
        step i s2 s3 ->
        steps s1 s3.

  Definition steps_compose :
    forall {s1 s2 s3},
      steps s1 s2 -> steps s2 s3 ->
      steps s1 s3.
  Proof.
    intros.
    induction X0.
    - assumption.
    - eapply st_cons.
      + apply IHX0. exact X.
      + exact s.
  Defined.

  Theorem steps_compose_0_r :
    forall {s1} s2 (st1: steps s1 s2),
      steps_compose st1 (st_refl s2) = st1.
  Proof.
    reflexivity.
  Qed.

  Theorem steps_compose_0_l :
    forall s1 {s2} (st2: steps s1 s2),
      steps_compose (st_refl s1) st2 = st2.
  Proof.
    intros.
    induction st2; simpl.
    - reflexivity.
    - rewrite -> IHst2. reflexivity.
  Qed.

  Theorem steps_compose_assoc:
    forall {s1 s2 s3 s4}
           (st1: steps s1 s2) (st2: steps s2 s3) (st3: steps s3 s4),
      steps_compose st1 (steps_compose st2 st3) =
      steps_compose (steps_compose st1 st2) st3.
  Proof.
    intros.
    induction st3; simpl.
    - reflexivity.
    - f_equal. apply IHst3.
  Qed.

  Fixpoint steps_io {s1 s2} (st: steps s1 s2) : list io_evt :=
    match st with
    | st_refl _ => []
    | @st_cons _ _ None _ st' _ => steps_io st'
    | @st_cons _ _ (Some (read k)) _ st' _ => (read k) :: steps_io st'
    | @st_cons _ _ (Some (write k)) _ st' _ => (write k) :: steps_io st'
    end
  .

  Theorem steps_io_distrib :
    forall {s1 s2 s3} (st1: steps s1 s2) (st2: steps s2 s3),
      steps_io (steps_compose st1 st2) = steps_io st2 ++ steps_io st1.
  Proof.
    intros.
    induction st2; simpl.
    - reflexivity.
    - destruct i; try destruct i; simpl; f_equal; apply IHst2.
  Qed.

End Steps.

Hint Immediate st_refl.
Hint Constructors steps.


Add LoadPath "path to the directory containing library files".
Require Import EventPreliminaries.
Require Import EventDefinitions.
Require Import EventRelationFacts.
Open Scope event_scope.

Proposition congruence_causality `{Event}:
  forall x x' y y' : universe, x =:= x' -> y =:= y' -> x << y -> x' << y'.
Proof.
  intros x x' y y' H1 H2 H3.
  pose (H12 := proj2 H1). pose (H21 := proj1 H2).
  assert (H4 : x' << y). apply causality_is_transitive with x; assumption.
  apply causality_is_transitive with y; assumption.
Qed.

Proposition congruence_precedence `{Event}:
  forall x x' y y' : universe, x =:= x' -> y =:= y' -> x < y -> x' < y'.
Proof.
  intros x x' y y' H1 H2 H3.
  split.
  - pose (H31 := proj1 H3).
    apply congruence_causality with x y; assumption.
  - intro H4. pose (H32 := proj2 H3). apply H32.
    apply synchronisation_is_symmetric in H1.
    apply congruence_causality with y' x';
    apply synchronisation_is_symmetric in H2; assumption.
Qed.

Proposition congruence_exclusion `{Event}:
  forall x x' y y' : universe, x =:= x' -> y =:= y' -> x # y -> x' # y'.
Proof.
  intros x x' y y' H1 H2 H3.
  elim H3; intro H4.
  - left. apply congruence_precedence with x y; assumption.
  - right. apply congruence_precedence with y x; assumption.
Qed.

Proposition congruence_independence `{Event}:
  forall x x' y y' : universe, x =:= x' -> y =:= y' -> x !! y -> x' !! y'.
Proof.
  intros x x' y y' H1 H2 H3.
  pose (H31 := proj1 H3). pose (H32 := proj2 H3).
  split; intro H4.
  - assert (H5 : x << y).
      apply synchronisation_is_symmetric in H1.
      apply synchronisation_is_symmetric in H2.
      apply congruence_causality with x' y'; assumption.
    contradiction.
  - assert (H5 : y << x).
      apply synchronisation_is_symmetric in H1.
      apply synchronisation_is_symmetric in H2.
      apply congruence_causality with y' x'; assumption.
    contradiction.
Qed.


(* TLC in Coq
 *
 * Module: tlc.logic.derives
 * Purpose: Contains the axioms for the syntactic proof system.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import tlc.component.component.
Require Import tlc.logic.context.
Require Import tlc.semantics.all_semantics.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.result.
Require Import tlc.utility.seq.

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

(* Basic syntactic rules and axioms *)
Section derives.

  Variable C : component.

  (* Meaning: Within context Z for component C, A is true *)
  Reserved Notation "Z ||- A" (at level 70, no associativity).

  (* These rules and axioms use the following naming convention:
   * - Every constructor begins with D, followed by one of:
   *    - A for rules/axioms specific to this implementation
   *    - S for rules/axioms from sequent logic
   *    - T for rules/axioms from temporal logic
   *    - P for rules/axioms from the program logic
   * - Constructors that end with P operate on the premises
   * - Constructors that end with C operate on the conclusion
   * - Sequent logic rules/axioms are named for the forms they operate on
   * - Temporal logic rules/axioms are named sequentially as in the paper
   * - Program logic rules/axioms are named as in the paper
   *)
  Inductive derives : context -> assertion -> Prop :=
  (* Variable context *)
  | DVThin Delta Gamma x A :
    (* Introduce a fresh rigid variable to the context *)
    x \notin ((context_rigids (Context Delta Gamma)) ++
      (assertion_rigids A)) ->
    Context Delta Gamma ||- A ->
    Context (x :: Delta) Gamma ||- A
  | DVContraction Delta Gamma x A :
    Context (x :: x :: Delta) Gamma ||- A ->
    Context (x :: Delta) Gamma ||- A
  | DVExchange Delta1 Delta2 Gamma x1 x2 A :
    Context (x1 :: Delta1 ++ x2 :: Delta2) Gamma ||- A ->
    Context (x2 :: Delta1 ++ x1 :: Delta2) Gamma ||- A

  (* Reduction *)
  | DReduceEq Z t t' :
    (* Every term is equal to its reduction *)
    [[t t]] = Success t' ->
    Z ||- {-A always (t = t') -}
  | DReduceCong Z A A' :
    (* Every assertion is congruent to its reduction *)
    [[A A]] = Success A' ->
    Z ||- {-A A <=> A' -}

  (* Injection *)
  | DInjection Delta Gamma t1 t2 c xh1 xh2 xt1 xt2 :
    term_construction t1 = Some (c, rcons xh1 xt1) ->
    term_construction t2 = Some (c, rcons xh2 xt2) ->
    size xh1 = size xh2 ->
    Context Delta Gamma ||- {-A
      t1 = t2 ->
      foldr (fun '(x1, x2) A => {-A x1 = x2 /\ A -})
        {-A xt1 = xt2 -} (zip xh1 xh2)
    -}

  (* Case analysis *)
  | DCaseAnalysis Z a cs A :
    (* Assumes that cs type-checks with a and is exhaustive *)
    destruct_cases a cs = Some A ->
    Z ||- A

  (* Sequent logic *)
  | DSFalse Delta Gamma A :
    Context Delta (AFalse :: Gamma) ||- A
  | DSAxiom Delta Gamma A :
    Context Delta (A :: Gamma) ||- A
  | DSThin Delta Gamma H A :
    Context Delta Gamma ||- A ->
    Context Delta (H :: Gamma) ||- A
  | DSContraction Delta Gamma H A :
    Context Delta (H :: H :: Gamma) ||- A ->
    Context Delta (H :: Gamma) ||- A
  | DSExchange Delta Gamma1 Gamma2 H1 H2 A :
    Context Delta (H1 :: Gamma1 ++ H2 :: Gamma2) ||- A ->
    Context Delta (H2 :: Gamma1 ++ H1 :: Gamma2) ||- A
  | DSCut Delta Gamma H A :
    Context Delta Gamma ||- H ->
    Context Delta (H :: Gamma) ||- A ->
    Context Delta Gamma ||- A
  | DSNotP Delta Gamma H A :
    Context Delta Gamma ||- H ->
    Context Delta ({-A ~H -} :: Gamma) ||- A
  | DSNotC Delta Gamma A :
    Context Delta (A :: Gamma) ||- AFalse ->
    Context Delta Gamma ||- {-A ~A -}
  | DSOrP Delta Gamma H1 H2 A :
    Context Delta (H1 :: Gamma) ||- A ->
    Context Delta (H2 :: Gamma) ||- A ->
    Context Delta ({-A H1 \/ H2 -} :: Gamma) ||- A
  | DSOrCL Delta Gamma A1 A2 :
    Context Delta Gamma ||- A1 ->
    Context Delta Gamma ||- {-A A1 \/ A2 -}
  | DSOrCR Delta Gamma A1 A2 :
    Context Delta Gamma ||- A2 ->
    Context Delta Gamma ||- {-A A1 \/ A2 -}
  | DSAndP Delta Gamma H1 H2 A :
    Context Delta (H1 :: H2 :: Gamma) ||- A ->
    Context Delta ({-A H1 /\ H2 -} :: Gamma) ||- A
  | DSAndC Delta Gamma A1 A2 :
    Context Delta Gamma ||- A1 ->
    Context Delta Gamma ||- A2 ->
    Context Delta Gamma ||- {-A A1 /\ A2 -}
  | DSIfP Delta Gamma Hp Hc A :
    Context Delta Gamma ||- Hp ->
    Context Delta (Hc :: Gamma) ||- A ->
    Context Delta ({-A Hp -> Hc -} :: Gamma) ||- A
  | DSIfC Delta Gamma Ap Ac :
    Context Delta (Ap :: Gamma) ||- Ac ->
    Context Delta Gamma ||- {-A Ap -> Ac -}
  | DSForAllP Delta Gamma t H H' A :
    term_closed_in [::] Delta t ->
    open_assertion [:: t] H = Success H' ->
    Context Delta (H' :: Gamma) ||- A ->
    Context Delta ({-A forall: H -} :: Gamma) ||- A
  | DSForAllC Delta Gamma x A A' :
    x \notin ((context_rigids (Context Delta Gamma)) ++
      (assertion_rigids {-A forall: A -})) ->
    open_assertion [:: TVariable x] A = Success A' ->
    Context (x :: Delta) Gamma ||- A' ->
    Context Delta Gamma ||- {-A forall: A -}
  | DSExistsP Delta Gamma x H H' A :
    x \notin ((context_rigids (Context Delta Gamma)) ++
      (assertion_rigids {-A exists: A -})) ->
    open_assertion [:: TVariable x] H = Success H' ->
    Context (x :: Delta) (H' :: Gamma) ||- A ->
    Context Delta ({-A exists: H -} :: Gamma) ||- A
  | DSExistsC Delta Gamma t A A' :
    term_closed_in [::] Delta t ->
    open_assertion [:: t] A = Success A' ->
    Context Delta Gamma ||- A' ->
    Context Delta Gamma ||- {-A exists: A -}

  (* Temporal logic future *)
  | DT1 Delta Gamma A :
    Context Delta Gamma ||- {-A always A -> A -}
  | DT2 Delta Gamma A :
    Context Delta Gamma ||- {-A (next ~A) <=> ~next A -}
  | DT3 Delta Gamma A1 A2 :
    Context Delta Gamma ||- {-A (next (A1 -> A2)) <=> (next A1 -> next A2) -}
  | DT4 Delta Gamma A1 A2 :
    Context Delta Gamma ||- {-A (always (A1 -> A2)) =>> (always A1 -> always A2) -}
  | DT5 Delta Gamma A :
    Context Delta Gamma ||- {-A (always A) -> always next A -}
  | DT6 Delta Gamma A :
    Context Delta Gamma ||- {-A (A =>> next A) -> (A =>> always A) -}

  (* Temporal logic past *)
  | DT9 Delta Gamma A :
    Context Delta Gamma ||- {-A previous A =>> previous^ A -}
  | DT10 Delta Gamma A1 A2 :
    Context Delta Gamma ||- {-A previous^ (A1 -> A2) <=> (previous^ A1 -> previous^ A2) -}
  | DT11 Delta Gamma A1 A2 :
    Context Delta Gamma ||- {-A alwaysp (A1 -> A2) =>> (alwaysp A1 -> alwaysp A2) -}
  | DT12 Delta Gamma A :
    Context Delta Gamma ||- {-A always A -> always previous^ A -}
  | DT13 Delta Gamma A :
    Context Delta Gamma ||- {-A (A =>> previous^ A) -> (A =>> alwaysp A) -}
  | DT15 Delta Gamma :
    Context Delta Gamma ||- previous^ AFalse

  (* Temporal logic mixed *)
  | DT16 Delta Gamma A :
    Context Delta Gamma ||- {-A A =>> next previous A -}
  | DT17 Delta Gamma A :
    Context Delta Gamma ||- {-A A =>> previous^ next A -}

  (* Temporal logic rules *)
  | DTGeneralization Delta Gamma A :
    non_temporal_assertion A ->
    Context Delta Gamma ||- A ->
    Context Delta Gamma ||- {-A always A -}
  | DT18 Delta Gamma A :
    Context Delta Gamma ||- {-A (forall: next A) <=> (next forall: A) -}

  (* Program logic *)
  | DPNode Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: (* n *)
      always ($$0 \in UNodes)
    -}
  | DPIR Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: (* e *)
      event []-> $$0 =>>
      (Fs' ' Fn, Fors, Fois) =
        request C ' Fn ' (Fs ' Fn) ' $$0
    -}
  | DPII Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: (* i, e *)
      event [$$1]<- $$0 =>>
      (Fs' ' Fn, Fors, Fois) =
        indication C ' Fn ' (Fs ' Fn) ' ($$1, $$0)
    -}
  | DPPe Delta Gamma :
    Context Delta Gamma ||- {-A
      event []~> CPE =>>
      (Fs' ' Fn, Fors, Fois) =
        periodic C ' Fn ' (Fs ' Fn)
    -}
  | DPOR Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: (* n, i, e *)
      on $$2, (self-event /\ ($$1, $$0) \in Fors) =>>
      eventually^ on $$2, event [$$1]-> $$0
    -}
  | DPOI Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: (* n, e *)
      on $$1, (self-event /\ $$0 \in Fois) =>>
      eventually^ on $$1, event []<- $$0
    -}
  | DPOR' Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: (* n, i, e *)
      on $$2, event [$$1]-> $$0 =>>
      eventuallyp^ (self-event /\ on $$2, (($$1, $$0) \in Fors))
    -}
  | DPOI' Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: (* n, e *)
      on $$1, event []<- $$0 =>>
      eventuallyp^ (self-event /\ on $$1, ($$0 \in Fois))
    -}
  | DPInit Delta Gamma :
    Context Delta Gamma ||- {-A self (Fs = fun: initialize C ' $$0) -}
  | DPPostPre Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: (* s *)
      self (Fs' = $$0 <=> next (Fs = $$0))
    -}
  | DPSEq Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: (* n *)
      Fn <> $$0 =>> Fs' ' $$0 = Fs ' $$0
    -}
  | DPASelf Delta Gamma :
    Context Delta Gamma ||- {-A self always self-event -}
  | DPSInv_1 Delta Gamma A :
    Context Delta Gamma ||- {-A self A -> restrict_assertion {-A self-event -} A -}
  | DPSInv_2 Delta Gamma A :
    Context Delta Gamma ||- {-A restrict_assertion {-A self-event -} A -> self A -}
  | DPAPer Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: (* n *)
      $$0 \in UCorrect -> always eventually on $$0, event []~> CPE
    -}
  | DPFLoss Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: forall: (* n, n', m, i *)
      $$2 \in UCorrect ->
      always^ eventually^ (on $$3, event [$$0]-> CFLSend ' $$2 ' $$1) =>>
      always^ eventually^ (on $$2, event [$$0]<- CFLDeliver ' $$3 ' $$1)
    -}
  | DPFDup Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: forall: (* n, n', m, i *)
      always eventually on $$2, event [$$0]<- CFLDeliver ' $$3 ' $$1 ->
      always eventually on $$3, event [$$0]-> CFLSend ' $$2 ' $$1
    -}
  | DPNForge Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: forall: (* n, n', m, i *)
      on $$2, event [$$0]<- CFLDeliver ' $$3 ' $$1 =>>
      eventuallyp on $$3, event [$$0]-> CFLSend ' $$2 ' $$1
    -}
  (* TODO: UniOR *)
  | DPUniOI Delta Gamma :
    Context Delta Gamma ||- {-A
      forall: forall: forall: (* n, ois, e *)
      (((FCount ' $$0 ' $$1) <= 1) /\
       always^ (self-event /\ Fn = $$2 -> $$0 \notin $$1) /\
       alwaysp^ (self-event /\ Fn = $$2 -> $$0 \notin $$1)) =>>
      (on $$2, event[]<- $$0) =>>
      alwaysp^ (~ on $$2, event[]<- $$0) /\ always^ ~ on $$2, event[]<- $$0
    -}
  where "Z ||- A" := (derives Z A).

End derives.

Notation "Z ||- C , A" := (derives C Z A)
  (at level 70, no associativity).

Hint Constructors derives : core.

(* Extract the context from a syntactic proof *)
Definition derives_context C Z A (H : Z ||- C, A) := Z.

(* Extract the assertion from a syntactic proof *)
Definition derives_assertion C Z A (H : Z ||- C, A) := A.

(* Extract the variables from a syntactic proof *)
Definition derives_rigids Z A :=
  (context_rigids Z) ++ (assertion_rigids A).

(* Determine whether a proof is closed under its bindings *)
Definition derives_closed
  (Delta : context_bindings) (Gamma : context_assumptions) A :=
  all (assertion_closed_in [::] Delta) (A :: Gamma).

(* Every variable within a proof is bound *)
Lemma DClosed (Delta : context_bindings) (Gamma : context_assumptions) A :
  derives_closed Delta Gamma A.
Proof.
Admitted.

(* There is always a fresh variable that does not appear in a syntactic proof *)
Lemma DFresh Z A :
  exists x, x \notin derives_rigids Z A.
Proof.
Admitted.

(* If a term appears inside of a construction, the term and construction
 * must not be equal. Example: n <> n.+1
 *)
Lemma DSubInjection C Delta Gamma t1 t2 c xs :
  term_construction t2 = Some (c, xs) ->
  t1 \in xs ->
  Context Delta Gamma ||- C, {-A t1 <> t2 -}.
Proof.
Admitted.

(* Tactics
 * Some of these tactics are named for their Coq equivalents.  For example,
 * dclear uses the DSThin axiom but operates similarly to clear.
 *)

(* Tactics relating to fresh variables *)
Ltac dclearv := apply DVThin.
Ltac dsimplfresh :=
  repeat match goal with
  | Hf : is_true (_ \notin (derives_rigids _ _)) |- _ =>
    rewrite /derives_rigids /context_rigids /= ?cats0 ?cat0s in Hf
  | Hf : is_true (_ \notin _) |- _ =>
    try rewrite computable_term_rigids ?cats0 ?cat0s in Hf; last by []
  end;
  repeat match goal with
  (* Break down compounds *)
  | Hf : is_true (_ \notin (_ :: _)) |- _ =>
    let Hf' := fresh Hf in
    rewrite in_cons in Hf; move/norP: Hf => [/eqP Hf' Hf]
  | Hf : is_true (_ \notin (_ ++ _)) |- _ =>
    rewrite mem_cat in Hf; move/norP: Hf => Hf
  | Hf : is_true (?x \notin ?ys) /\ is_true (?x \notin _) |- _ =>
    let Hf' := fresh Hf in
    move: Hf => [Hf' Hf]
  (* Remove duplicates and tautologies *)
  | Hf : is_true (_ \notin [::]) |- _ =>
    clear Hf
  | Hf : is_true (?x \notin ?ys), Hf' : is_true (?x \notin ?ys) |- _ =>
    clear Hf'
  | Hf : ?x <> ?y, Hf' : ?x <> ?y |- _ =>
    clear Hf'
  end.
Tactic Notation "dfresh" ident(x) :=
  match goal with
  | |- context[ ?Z ||- _, ?A ] =>
    let Hxf := fresh "Hf_" x in
    case: (DFresh Z A) => x Hxf; dsimplfresh
  end.
Ltac dautofresh :=
  repeat match goal with
  | |- context[ context_rigids _ ] =>
    rewrite /context_rigids /= ?cats0 ?cat0s
  | |- is_true (_ \notin (term_rigids _)) =>
    rewrite computable_term_rigids; last by []
  | |- is_true (_ \notin (_ :: _)) =>
    rewrite in_cons; apply/norP; split; [try by apply/eqP | try by [] ]
  | |- is_true (_ \notin (_ ++ _)) =>
    rewrite mem_cat; apply/norP; split; try by []
  end.

(* Injection tactics *)
Ltac dinject t1_ t2_ :=
  eapply DSCut;
    first (by eapply DInjection with (t1 := t1_) (t2 := t2_));
    simpl.
Ltac dinjection :=
  match goal with
  | |- context[ {-A ?t1_ = ?t2_ -} ] => dinject t1_ t2_
  end.

(* Sequent logic tactics *)
Ltac dexfalso := apply DSFalse.
Ltac dhead := apply DSAxiom.
Ltac dclear := apply DSThin.
Ltac dhave H :=
  match goal with
  | |- derives ?C (Context ?Delta ?Gamma) ?A =>
    apply (@DSCut C Delta Gamma H A)
  end.
Ltac duse L :=
  eapply DSCut; first by repeat dclear; eapply L.
Ltac dnotp := apply DSNotP.
Ltac dnot := apply DSNotC.
Ltac dorp := apply DSOrP.
Ltac dleft := apply DSOrCL.
Ltac dright := apply DSOrCR.
Ltac dsplitp := apply DSAndP.
Ltac dsplit := apply DSAndC.
Ltac difp := apply DSIfP.
Ltac dif := apply DSIfC.
Tactic Notation "dforallp" constr(x) :=
  eapply DSForAllP with (t := x);
  [try by dautoclosed | try by dautoopen | dclean].
Tactic Notation "dforall" ident(y) :=
  dfresh y; eapply DSForAllC with (x := y);
  [dautofresh; try by [] | try by dautoopen | dclean].
Tactic Notation "dexistsp" ident(y) :=
  dfresh y; eapply DSExistsP with (x := y);
  [dautofresh; try by [] | try by dautoopen | dclean].
Tactic Notation "dexists" constr(x) :=
  eapply DSExistsC with (t := x);
  [try by dautoclosed | try by dautoopen | dclean].


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2013-04-18

* Matrix interpretation over domain tropical

*)

Set Implicit Arguments.

Require Import ATrs ARedPair2 APolyInt_MA2 AMonAlg2 Equality
  ATropicalInt2 ListForall ListUtil ZUtil LogicUtil BoolUtil
  AMatrixBasedInt2_Trop VecUtil VecArith2 AMatrixInt2 cpf2color
  cpf OrdSemiRing2 Matrix2 cpf_util.

(***********************************************************************)
(** ** Matrix interpretation over domain tropical. *)

Section S.

  Variable arity: symbol -> nat.
  Variable dim : nat.

  Notation Sig := (Sig arity).
  Notation dim_pos := (dim_pos dim).
  Notation mint := (matrixInt_trop matrix_trop dim).

  (** Cast *)

  Definition matrix_cast_trop n m (Heq: n = m)(p: mint n) : mint m.
  rewrite <- Heq; auto.
  Defined.

  (** Default matrix interpretation over domain tropical. *)

  Definition default_matrix_trop (n: nat) :=
    mkMatrixInt_trop (id_vec_trop dim_pos) (Vconst (id_matrix_trop dim) n).

  (** [fun_of_pairs_matrix_trop_list] is a representation for an interpretation
     associating to every function symbol of arity [n], an natural matrix
     with [n] variables. It is represented by a list of pairs [(g, mi)],
     where [g] is a function symbol and [mi] is its interpretation. *)

  Section fun_of_pairs_matrix_trop_list.

    Variable f : symbol.

    Fixpoint fun_of_matrix_trop_list (l : list {g: symbol & mint (arity g)})
      : mint (arity f) :=
      match l with
        | existT g m :: l' =>
          match @eq_symb_dec Sig g f with
            | left h => matrix_cast_trop (f_equal arity h) m
            | right _ => fun_of_matrix_trop_list l'
          end
        | nil => default_matrix_trop (arity f)
      end.

  End fun_of_pairs_matrix_trop_list.

  (***********************************************************************)
  (** ** Matrix interpretation in the setting of monotone algebras. *)

  (*Require Import ARedPair2 APolyInt_MA2 AMonAlg2 Equality ATropicalInt2.*)

  Section matrixMethodConf_trop.

    Variable l : list {g : symbol & mint (arity g)}.

    Notation "x >> y" := (gtt x y) (at level 70).

    Variable A0_gt_A1 : A0t >> A1t.

    Definition trsInt_trop (f : Sig) := fun_of_matrix_trop_list f l.

    Definition TMatrixInt_trop := mkMatrixMethodConf_trop Sig trsInt_trop.

    Definition MatrixTrop_MonoAlgType := matAlg_trop TMatrixInt_trop.

    (** Weak reduction pair for matrix intepretration. *)

    Definition MatrixTrop_WeakRedPair := bwrp MatrixTrop_MonoAlgType.

    (** Reduction pair associcated to a monotone algebra. *)

    Definition matrix_trop_wrp := mkbWeakRedPair
      (wf_succ MatrixTrop_WeakRedPair)
      (sc_succ MatrixTrop_WeakRedPair)(bsucc_sub MatrixTrop_WeakRedPair)
      (sc_succeq MatrixTrop_WeakRedPair) (cc_succeq MatrixTrop_WeakRedPair)
      (ARedPair2.refl_succeq MatrixTrop_WeakRedPair)
      (ARedPair2.succ_succeq_compat MatrixTrop_WeakRedPair)
      (bsucceq_sub MatrixTrop_WeakRedPair)
      (ARedPair2.trans_succ MatrixTrop_WeakRedPair)
      (ARedPair2.trans_succeq MatrixTrop_WeakRedPair).

  End matrixMethodConf_trop.

  (****************************************************************************)
  (** ** Boolean function for matrix interpretation over domain
     tropical. *)

  Section BoolMint_tropical.

    Notation "x >> y" := (gtt x y) (at level 70).

    (** Define boolean function for [gt] over domain tropical. *)

    Definition bgt_trop m n :=
      match gt_dect m n with
        | left _ => true
        | right _ => false
      end.

    (** Correcntess proof of [bgt] over domain tropical. *)

    Lemma bgt_trop_ok : forall m n, bgt_trop m n = true <-> (m >> n)%Z.

    Proof.
      intros. unfold bgt_trop.
      case_eq (gt_dect m n); intuition.
    Qed.

    (** Define boolean function for [ge] over domain tropical. *)

    Definition bge_trop m n := bgt_trop m n || beq_TropicalDom m n.

    (** Correctness proof of [bge] over domain tropical. *)

    Lemma bge_trop_ok : forall m n, bge_trop m n = true <-> get m n.

    Proof.
      intros m n. intuition.
      unfold get. unfold bge_trop in H. rewrite orb_eq in H.
      destruct H; try discr.
      apply bgt_trop_ok in H. left. apply H.
      apply beq_TropicalDom_ok in H. right. apply H.
      (* -> *)
      unfold get in H. destruct H.
      unfold bge_trop. rewrite orb_eq.
      left. rewrite bgt_trop_ok. apply H.
      unfold bge_trop. rewrite orb_eq.
      right. rewrite beq_TropicalDom_ok. apply H.
    Qed.

    (** Define boolean function of [mat_ge]. *)

    Definition bmat_ge_trop (m n : nat) (M N: matrix_trop m n) :=
      match mat_ge_dec_trop M N with
        | left _ => true (* M >=m N *)
        | right _ => false (* ~ M >=m N *)
      end.

    (** Correctness proof of [bmat_ge]. *)

    Lemma bmat_ge_trop_ok: forall (m n: nat) (M N: matrix_trop m n),
                             bmat_ge_trop M N = true <-> mat_ge_trop M N.
    Proof.
      intros m n M N. unfold bmat_ge_trop.
      case_eq (mat_ge_dec_trop M N); intuition.
    Qed.

    (** Define boolean function of [mint_ge] over domain tropical. *)

    Definition bmint_ge_trop n (l r: mint n) : bool :=
      bVforall2n (bmat_ge_trop (n:=dim))(args_trop l) (args_trop r) &&
      bVforall2n (fun m n => bge_trop m n) (const_trop l) (const_trop r).

    (** Correctness proof of [bmint_ge] over domain tropical. *)

    Lemma bmint_ge_trop_ok: forall n (l r: mint n),
      bmint_ge_trop l r = true <-> mint_ge_trop l r.

    Proof.
      intros n l r. split.
      (* [1]. -> *)
      intro H. unfold mint_ge_trop.
      (* Left part. *)
      split. unfold bmint_ge_trop in H. rewrite andb_eq in H.
      destruct H. rewrite bVforall2n_ok in H. apply H.
      (* Proving boolean function of [bmat_ge]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_ge_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_ge_trop_ok. hyp.
      (* Right part. *)
      unfold bmint_ge_trop in H. rewrite andb_eq in H.
      destruct H. rewrite bVforall2n_ok in H0. apply H0.
      (* Proving boolean function of [bge]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bge_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bge_trop_ok. hyp.
      (* [2]. <- *)
      intro H. unfold bmint_ge_trop.
      rewrite andb_eq. split.
      (* Left part. *)
      rewrite bVforall2n_ok.
      unfold mint_ge_trop in H. destruct H.
      apply H.
      (* Proving boolean function of [bmat_ge]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_ge_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_ge_trop_ok. hyp.
      (* Right part. *)
      rewrite bVforall2n_ok. unfold mint_ge_trop in H.
      destruct H. apply H0.
      (* Proving boolean function of [bge]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bge_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bge_trop_ok. hyp.
    Qed.

    (** Define boolean function for [gtx] over domain tropical. *)

    Definition bgtx_trop (x y: TropicalDom) : bool :=
      bgt_trop x y || beq_TropicalDom x PlusInf && beq_TropicalDom y PlusInf.

    (* REMARK: declare import of ATropicalBasedInt here because of the
    inconsitent type. *)

    Require Import ATropicalBasedInt2.

    (** Correctness proof of [bgtx]. *)

    Lemma bgtx_trop_ok : forall x y, bgtx_trop x y = true <-> gtx_trop x y.
    Proof.
      intros x y. split.
      (* -> *)
      intro H. unfold bgtx_trop in H.
      rewrite orb_eq in H. destruct H.
      unfold gtx_trop.
      (* Left part. *)
      left. apply bgt_trop_ok. hyp.
      (* Right part. *)
      rewrite andb_eq in H. destruct H.
      unfold gtx_trop. right. unfold eqAt.
      rewrite beq_TropicalDom_ok in H. rewrite beq_TropicalDom_ok in H0.
      auto.
      (* <- *)
      intro H. unfold bgtx_trop. rewrite orb_eq. unfold gtx_trop in H.
      destruct H. left.
      rewrite bgt_trop_ok. hyp.
      right. rewrite andb_eq. split.
      unfold eqAt in H. rewrite beq_TropicalDom_ok. destruct H; auto.
      rewrite beq_TropicalDom_ok. destruct H; auto.
    Qed.

    (** Defintion boolean function of [mat_gt]. *)

    Definition bmat_gt_trop (M N: matrix_trop dim dim) :=
      match mat_gt_dec_trop M N with
        | left _ => true (* M >=m N *)
        | right _ => false (* ~ M >=m N *)
      end.

    (** Correctness proof of [bmat_gt].*)

    Lemma bmat_gt_trop_ok : forall (M N: matrix_trop dim dim),
                              bmat_gt_trop M N = true <-> mat_gt_trop M N.
    Proof.
      intros M N. unfold bmat_gt_trop.
      case_eq (mat_gt_dec_trop M N); intuition.
    Qed.

    (** Define boolean function for [mint_gt] over domain tropical. *)

    Definition bmint_gt_trop n (l r : mint n) : bool :=
      bVforall2n bmat_gt_trop (args_trop l) (args_trop r) &&
      bVforall2n (fun m n => bgtx_trop m n) (const_trop l) (const_trop r).

    (** Correctness proof of [bmint_gt] over domain tropical. *)

    Lemma bmint_gt_trop_ok : forall n (l r : mint n),
      bmint_gt_trop l r = true <-> mint_gt_trop l r.
    Proof.
      intros n l r. split.
      (* -> *)
      intro H. unfold bmint_gt_trop in H.
      rewrite andb_eq in H. destruct H.
      unfold mint_gt_trop. split.
      (* Left part. *)
      rewrite bVforall2n_ok in H. apply H.
      (* Proving boolean function of [bmat_gt]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_gt_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_gt_trop_ok. hyp.
      (* Right part. *)
      rewrite bVforall2n_ok in H0. apply H0.
      (* Proving boolean function of [bgtx]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bgtx_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bgtx_trop_ok. hyp.
      (* [2]. <- *)
      intro H. unfold bmint_gt_trop.
      rewrite andb_eq. split.
      (* Left part. *)
      rewrite bVforall2n_ok. unfold mint_gt_trop in H.
      destruct H. apply H.
      (* Proving boolean function of [bmat_gt]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_gt_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_gt_trop_ok. hyp.
      (* Right part. *)
      rewrite bVforall2n_ok. unfold mint_gt_trop in H.
      destruct H. apply H0.
      (* Proving boolean function of [bgtx]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bgtx_trop_ok. hyp.
      (* <- *)
      intro H1. rewrite bgtx_trop_ok. hyp.
    Qed.

  End BoolMint_tropical.

End S.


Load GradVer20Hook_import.
Import Semantics.

Definition dfrmphi (p : phi) :=
  exists p', sfrmphi [] p' /\ phiEquals p p'.

Theorem hasWellFormedSubtype : forall p,
  phiSatisfiable p ->
  ∃ p' : phi, phiSatisfiable p' ∧ sfrmphi [] p' ∧ phiImplies p' p.
Proof.
Admitted.

(* concretization *)
Definition gGammaX (phi : gphi) : pphi :=
  match fst phi with
  | false => (fun p => p = snd phi)
  | true => (fun p => (exists p', p = p' ++ snd phi)
                   /\ dfrmphi p
                   /\ phiSatisfiable p)
  end.

Theorem gammaEq1 : forall gp p,
  gGammaX gp p -> (exists p', phiEquals p p' /\ gGamma gp p').
Proof.
  unfold gGamma, gGammaX.
  intros.
  destruct gp. simpl in *.
  destruct b.
  - unf. subst.
    invE H0 x0. unf.
    exists x0.
    split; auto.
    split; auto.
      unfold phiSatisfiable in *.
      unf. apply H1 in H0.
      eex.
    split; auto.
    repeat intro.
    apply H1 in H0.
    eapp evalphiSuffix.
  - subst.
    eex.
Qed.

Theorem gammaEq2 : forall gp p,
  gGamma gp p -> (exists p', phiEquals p p' /\ gGammaX gp p').
Proof.
  unfold gGamma, gGammaX.
  intros.
  destruct gp. simpl in *.
  destruct b.
  - unf.
    exists ( ++ p1).
    admit.
  - subst.
    eex.
Qed.

Definition ppGood (pp : pphi) :=
  (exists p, pp p) /\
  (forall p, pp p -> good p).

Definition ppIsSingleton (p : phi) (pp : pphi) :=
  pp p /\ (forall p', pp p' -> p' = p).

Definition ppHasMaximum (p : phi) (pp : pphi) :=
  pp p /\ (forall p', pp p' -> phiImplies p' p).

Inductive gAlpha : pphi -> gphi -> Prop :=
| AlphaNonGradual : forall (pp : pphi) (p : phi),
  ppGood pp ->

  ppIsSingleton p pp ->
  gAlpha pp (false, p)
| AlphaGradual : forall (pp : pphi) (p : phi),
  ppGood pp ->
  (forall p, ~ ppIsSingleton p pp) ->

  ppHasMaximum p pp ->
  gAlpha pp (true, p)
| AlphaTotal : forall (pp : pphi),
  ppGood pp ->
  (forall p, ~ ppIsSingleton p pp) ->
  (forall p, ~ ppHasMaximum p pp) ->

  gAlpha pp (true, [])
.

Theorem alphaSound : forall pp1 gp pp2,
  gAlpha pp1 gp ->
  gGamma gp pp2 ->
  pincl pp1 pp2.
Proof.
  intros.
  inversionx H0.
  - inversionx H1.
    unfold
      pincl,
      pSingleton,
      ppIsSingleton
    in *. unf.
    intros.
    apply H1 in H3.
    subst.
    congruence.
  - inversionx H1.
    unfold
      pincl,
      ppHasMaximum,
      ppIsSingleton
    in *. unf.
    intros.
    split.
    * eapp H2.
    * eapp H1.
  - inversionx H1.
    unfold
      pincl,
      ppHasMaximum,
      ppIsSingleton
    in *.
    intros.
    split.
    * eapp H2.
    * unfold phiImplies.
      intros.
      constructor.
Qed.

Require Import Coq.Logic.Classical_Pred_Type.

Theorem alphaOptimal : forall pp1 gp1 pp2 gp2 pp3,
  gAlpha pp1 gp2 ->
  gGamma gp1 pp2 ->
  gGamma gp2 pp3 ->
  pincl pp1 pp2 ->
  pincl pp3 pp2.
Proof.
  intros.
  inversionx H0; inversionx H2.
  - unfold
      pincl,
      pSingleton,
      ppIsSingleton
    in *. unf.
    intros. subst.
    apply H3.
    assumption.
  - inversionx H1.
    * (* contradict *)
      specialize (H5 p0).
      contradict H5.
      unfold
        pincl,
        pSingleton,
        ppHasMaximum,
        ppIsSingleton
      in *. unf.
      split; auto.
      intros.
      apply H3 in H1.
      apply H3 in H5.
      subst.
      congruence.
    * unfold
        pincl,
        ppHasMaximum,
        ppIsSingleton
      in *.
      intros. unf.
      split; auto.
      apply (phiImpliesTrans p2 p0 p1); auto.
      apply H3 in H1.
      unf.
      auto.
  - inversionx H1.
    * (* contradict *)
      specialize (H5 p0).
      contradict H5.
      unfold
        pincl,
        pSingleton,
        ppGood,
        ppHasMaximum,
        ppIsSingleton
      in *. unf.
      assert (p0 = x0). eapp H3. subst.
      split; auto.
      intros.
      apply H3 in H1. subst.
      congruence.
    * (* contradict everything but phi = true *)
      unfold
        pincl,
        ppHasMaximum,
        ppIsSingleton
      in *.
      intros. unf.
      destruct (classic (phiImplies [] p0)).
      + split; auto.
        apply (phiImpliesTrans p1 [] p0); auto.
      + (* contradict *)
        assert (~ phiImplies [] p).

        unfold phiImplies in H1.

        rewrite not_all_ex_not in H1.
      destruct p0; try tauto.
      intros. unf.
      split; auto.
      apply (phiImpliesTrans p2 p0 p1); auto.
      apply H3 in H1.
      unf.
      auto.

      inversionx H1.
    unfold
      pincl,
      ppHasMaximum,
      ppIsSingleton
    in *.
    intros.
    split.
    * eapp H2.
    * unfold phiImplies.
      intros.
      constructor.
Qed.

(* disjunciton of phi *)
Definition phid := list phi.

Definition evalphid H r A (pd : phid) :=
  exists p, In p pd /\ evalphi H r A p.

(* helping defs *)
Definition isIntersection (pd1 pd2 pdi : phid) :=
  forall H r A, evalphid H r A pd1 /\ evalphid H r A pd2 <-> evalphid H r A pdi.

Definition splitPhi (p : phi) : prod A_s phi :=
  fold_right
    (fun p pr =>
      match p with
      | phiAcc e f => ((e, f) :: fst pr, snd pr)
      | _ => (fst pr, p :: snd pr)
      end)
    ([], [])
    p.

Lemma splitPhiAlt : forall p,
  splitPhi p =
    (staticFootprint p,
     filter (fun p' => match p' with
                         | phiAcc _ _ => false
                         | _ => true
                         end) p).
Proof.
  induction p0; intros; simpl in *; try tauto.
  rewrite IHp0. simpl.
  destruct a; tauto.
Qed.

Definition mergePhi (pa : A_s) (pb : phi) : phi :=
  map (fun p => phiAcc (fst p) (snd p)) pa ++ pb.

(* mapRem *)
Definition isCutAt {T : Type} xs ys1 (y : T) ys2 : Prop := xs = ys1 ++ y :: ys2.

Lemma isCutAtClassic : forall {T : Type} xs ys1 (y : T) ys2,
  isCutAt xs ys1 y ys2 ->
  In y xs /\ incl ys1 xs /\ incl ys2 xs.

Fixpoint mapRem {T U : Type} (f : T -> list T -> U) (xs : list T) :=
  match xs with
  | [] => []
  | x :: xs => f x xs :: mapRem (fun y ys => f y (x :: ys)) xs
  end.

Lemma in_mapRem_iff : forall {T U : Type} y xs (f : T -> list T -> U),
  In y (mapRem f xs) <->
  exists xs1 x xs2, f x (xs1 ++ xs2) = y /\ isCutAt xs xs1 x xs2.
Proof.
  induction xs; intros; simpl in *.
  - split; intros; try tauto.
    unf. inversionx H2.
    destruct x0; discriminate.
  - split; intros.
    * inversionx H0.
      + exists []. exists a. exists xs.
        unfold isCutAt.
        split; tauto.
      + apply IHxs in H1. unf. subst.
        unfold isCutAt in H2. subst.
        exists (a :: x0). exists x1. exists x2.
        unfold isCutAt.
        split; tauto.
    * unf. subst.
      inversionx H2.
      destruct x0; simpl in *.
      + inversionx H1.
        auto.
      + inversionx H1.
        apply or_intror.
        apply IHxs.
        repeat eex.
Qed.

(* meet operation *)
Fixpoint meetSplit (pa1 pa2 : A_s) (pb : phi) : phid :=
  match pa1 with
  | [] => [map (fun p => phiAcc (fst p) (snd p)) pa2 ++ pb]
  | A :: pa1 =>
    map (fun p => phiAcc (fst A) (snd A) :: p)
    (
      meetSplit pa1 pa2 pb
      ++
      concat
      (
        mapRem
        (fun A' pa2 =>
          if f_decb (snd A) (snd A')
          then map (fun p => phiEq (fst A) (fst A') :: p) (meetSplit pa1 pa2 pb)
          else []
        )
        pa2
      )
    )
  end.

Definition meetSingle (p1 p2 : phi) : phid :=
  let ps1 := splitPhi p1 in
  let ps2 := splitPhi p2 in
  meetSplit (fst ps1) (fst ps2) (snd ps1 ++ snd ps2).

Definition meet (pd1 pd2 : phid) : phid :=
  flat_map (fun ps => meetSingle (fst ps) (snd ps)) (list_prod pd1 pd2).

(*
(*BEGIN test*)
Open Scope string.
Eval compute in meetSingle [phiAcc (ex (xUserDef "a")) "f"; phiAcc (ex (xUserDef "b")) "f"] [].
Eval compute in meetSingle [] [phiAcc (ex (xUserDef "a")) "f"; phiAcc (ex (xUserDef "b")) "f"].
Eval compute in meetSingle [phiAcc (ex (xUserDef "a")) "f"] [phiAcc (ex (xUserDef "b")) "f"].
Eval compute in meetSingle [phiAcc (ex (xUserDef "a")) "f"] [phiAcc (ex (xUserDef "b")) "g"].
Eval compute in meetSingle [phiAcc (ex (xUserDef "a")) "f"; phiAcc (ex (xUserDef "b")) "f"] [phiAcc (ex (xUserDef "c")) "f"].
Eval compute in meetSingle [phiAcc (ex (xUserDef "a")) "f"; phiAcc (ex (xUserDef "b")) "f"]
                           [phiAcc (ex (xUserDef "a")) "f"; phiAcc (ex (xUserDef "b")) "f"].
Close Scope string.
(*END test*)
 *)

Lemma evalphiSplitMerge : forall p,
  let ps := splitPhi p in
  forall H r A,
  evalphi H r A p <->
  evalphi H r A (map (λ p, phiAcc (fst p) (snd p)) (fst ps) ++ snd ps)
  .
Proof.
  induction p0; intros; simpl in *; try tauto.
  subst ps.
  split; intros.
  - inversionx H1.
    apply IHp0 in H12.
    destruct a; simpl in *;
    try (apply evalphiSymm;
        rewriteRev app_comm_cons;
        eca; simpl;
        apply evalphiSymm;
        assumption).
    eca.
  - destruct a; simpl in *;
    try (apply evalphiSymm in H1;
        rewriteRevIn app_comm_cons H1;
        inversionx H1;
        eca;
        common;
        apply evalphiSymm in H12;
        eapp IHp0).
    inversionx H1.
    eca.
    eapp IHp0.
Qed.

Lemma evalphidApp : forall H r A p1 p2,
  evalphid H r A (p1 ++ p2) <->
  evalphid H r A p1 \/ evalphid H r A p2.
Proof.
  unfold evalphid. intros.
  split; intros; unf.
  - apply in_app_iff in H1.
    inversionx H1.
    * apply or_introl. eex.
    * apply or_intror. eex.
  - inversionx H1; unf; eex; intuition.
Qed.

Lemma meetSplitAugment1 : forall ps1 ps2 ps p H r A,
  let mc := map (cons (phiAcc (fst p) (snd p))) in
    (evalphid H r A (mc (meetSplit ps1 ps2 ps)) \/
     exists xs1 x xs2,
      isCutAt ps2 xs1 x xs2 /\ snd p = snd x /\
      evalphid H r A (mc (map (cons (phiEq (fst p) (fst x))) (meetSplit ps1 (xs1 ++ xs2) ps))))
    <->
    (evalphid H r A (meetSplit (p :: ps1) ps2 ps))
   .
Proof.
  split; simpl in *; unfold evalphid in *; intuition; unf; intuition.
  - apply in_map_iff in H2. unf. subst.
    eex.
    apply in_map_iff. eex.
    intuition.
  - apply in_map_iff in H4. unf. subst.
    destruct p0, x1. simpl in *. subst.
    eex.
    apply in_map_iff. eex.
    apply in_app_iff. apply or_intror.
    apply in_concat. eex.
    apply in_mapRem_iff. repeat eex.
    simpl.
    dec (string_dec f1 f1).
    tauto.
  - apply in_map_iff in H1. unf. subst.
    apply in_app_iff in H4.
    inversionx H4.
    * constructor. eex.
      apply in_map_iff. eex.
    * apply in_concat in H1. unf.
      apply in_mapRem_iff in H1. unf. subst.
      destruct p0, x3. simpl in *.
      dec (string_dec f0 s0); try tauto.
      apply in_map_iff in H4. unf. subst.
      apply or_intror. repeat eex.
      apply in_map_iff. eex.
      apply in_map_iff. eex.
Qed.

Lemma meetSplitAugment : forall ps1 ps2 ps p' H r A,
   footprint' H r p' = [] ->
   (
    (evalphid H r A (meetSplit ps1 ps2 ps) /\ evalphi' H r [] p')
    <->
    (evalphid H r A (meetSplit ps1 ps2 (p' :: ps)))
   ).
Proof.
  induction ps1; intros; unf; simpl in *.
  - split; intros; unfold evalphid in *; unf; simpl in *.
    * inversionx H3; try tauto.
      eex.
      apply evalphiSymm. simpl.
      eca; rewrite H1.
      + apply inclEmpty.
      + assumption.
      + apply evalphiSymm.
        common.
        assumption.
    * inversionx H2; try tauto.
      apply evalphiSymm in H4.
      simpl in H4.
      inversionx H4. rewrite H1 in *.
      eex.
      eex.
      apply evalphiSymm in H13.
      common.
      assumption.
  - destruct a. simpl in *.
    split; intros; unfold evalphid in *; unf; simpl in *.
    * apply in_map_iff in H3. unf.
      apply in_app_iff in H6.
      inversionx H6.
      + inversionx H5. inversionx H14. common.
        simpl in *. rewrite H11 in *.
        apply (IHps1 ps2 ps p' H0 r (Aexcept A [(o0, f0)])) in H1. unf.
        lapply H3; intros; eauto.
        unf. exists (phiAcc e0 f0 :: x0).
        split.
          apply in_map_iff. eex. intuition.
        eca; simpl; rewrite H11; auto.
        eca.
      + apply in_concat in H2. unf.
        apply in_mapRem_iff in H2. unf. subst.
        destruct x3. simpl in *.
        dec (string_dec f0 s0); try tauto.
        apply in_map_iff in H6. unf. subst.
        inversionx H5. inversionx H15.
        simpl in *. rewrite H12 in *.
        apply (IHps1 (x2 ++ x4) ps p' H0 r (Aexcept A [(o0, s0)])) in H1. unf.
        lapply H2; intros.
          unf. exists (phiAcc e0 s0 :: phiEq e0 e1 :: x1).
          split.
            apply in_map_iff. eex.
            apply in_app_iff. apply or_intror.
            apply in_concat. eex.
              apply in_mapRem_iff. repeat eex.
              simpl. dec (string_dec s0 s0).
              apply in_map_iff. eex.
            eca; simpl; rewrite H12; auto.
              eca.
            inversionx H16.
            inversionx H21.
            eca; simpl. eca.
            common.
            assumption.
        split; auto.
        eex.
        inversionx H16.
        common.
        assumption.
    * apply in_map_iff in H2. unf. subst.
      apply in_app_iff in H5.
      inversionx H5.
      + inversionx H4.
        inversionx H13.
        simpl in *. rewrite H10 in *.
        apply (IHps1 ps2 ps p' H0 r (Aexcept A [(o0, f0)])) in H1. unf.
        lapply H4; intros; eex; try apply H1.
        unf.
        exists (phiAcc e0 f0 :: x0). split.
          apply in_map_iff. eex.
          intuition.
        eca; simpl; rewrite H10; auto.
        eca.
      + apply in_concat in H2. unf.
        apply in_mapRem_iff in H2. unf. subst.
        destruct x3. simpl in *.
        dec (string_dec f0 s0); try tauto.
        apply in_map_iff in H5. unf. subst.
        inversionx H4. inversionx H14. simpl in *. rewrite H11 in *.
        apply (IHps1 (x2 ++ x4) ps p' H0 r (Aexcept A [(o0, s0)])) in H1. unf.
        lapply H3; intros; unf.
          split; auto.
          exists (phiAcc e0 s0 :: phiEq e0 e1 :: x1).
          split.
            apply in_map_iff. eex.
            apply in_app_iff. apply or_intror.
            apply in_concat. eex.
              apply in_mapRem_iff. repeat eex.
              simpl. dec (string_dec s0 s0).
              apply in_map_iff. eex.
            eca; simpl; rewrite H11; auto.
              eca.
            inversionx H15.
            inversionx H21.
            eca; simpl. eca.
            common.
            assumption.
        eex.
        inversionx H15. common.
        assumption.
Qed.

Lemma InEnsuresCutAt : forall {T : Type} (x : T) p,
  In x p ->
  exists xs1 xs2, isCutAt p xs1 x xs2.
Proof.
  induction p0; intros; simpl in *; try tauto.
  inversionx H0.
  - exists []. exists p0.
    unfold isCutAt.
    tauto.
  - intuition.
    unf.
    exists (a :: x1). exists x2.
    unfold isCutAt in *.
    subst.
    tauto.
Qed.

Lemma fstSplitPhiMergePhi : forall p A,
  fst (splitPhi (mergePhi A (snd (splitPhi p)))) = A.
Proof.
  unfold mergePhi.
  induction p0; induction A; intros; simpl in *.
  - tauto.
  - destruct a. simpl.
    apply f_equal2; auto.
  - specialize (IHp0 []).
    destruct a; simpl in *; auto.
  - destruct a0. simpl.
    apply f_equal2; auto.
Qed.

Lemma sndSplitPhiMergePhi : forall p A,
  snd (splitPhi (mergePhi A (snd (splitPhi p)))) = snd (splitPhi p).
Proof.
  unfold mergePhi.
  induction p0; induction A; intros; simpl in *.
  - tauto.
  - assumption.
  - specialize (IHp0 []).
    destruct a; simpl in *;
    try apply f_equal2; auto.
  - assumption.
Qed.

Lemma evalphiIsCutAt : forall H r A A1 A2 e o f p,
  evale' H r e = Some (vo o) ->
  isCutAt (staticFootprint p) A1 (e, f) A2 ->
  incl [(o, f)] A ->
  evalphi H r A p <->
  evalphi H r (Aexcept A [(o, f)]) (mergePhi (A1 ++ A2) (snd (splitPhi p))).
Proof.
  unfold isCutAt, mergePhi.
  intros.
  rewrite evalphiSplitMerge.
  assert (fst (splitPhi p0) = A1 ++ (e0, f0) :: A2).
    rewrite splitPhiAlt. assumption.
  rewrite H4.
  repeat rewrite map_app.
  set (mm := map (λ p : e * f, phiAcc (fst p) (snd p))).
  assert (
    evalphi H0 r A ((mm A1 ++ mm ((e0, f0) :: A2)) ++ snd (splitPhi p0))
    <->
    evalphi H0 r A ((mm ((e0, f0) :: A2) ++ mm A1) ++ snd (splitPhi p0))
    ) as rw1.
    split; intros;
    apply evalphiApp in H5; unf;
    apply evalphiSymm in H6;
    rewrite footprintApp in H7;
    rewrite Aexcept2AppComm in H7;
    rewriteRevIn footprintApp H7;
    eapp evalphiAppRev.
  assert (
    evalphi H0 r (Aexcept A [(o0, f0)]) ((mm A1 ++ mm A2) ++ snd (splitPhi p0))
    <->
    evalphi H0 r (Aexcept A [(o0, f0)]) ((mm A2 ++ mm A1) ++ snd (splitPhi p0))
    ) as rw2.
    split; intros;
    apply evalphiApp in H5; unf;
    apply evalphiSymm in H6;
    rewrite footprintApp in H7;
    rewrite Aexcept2AppComm in H7;
    rewriteRevIn footprintApp H7;
    eapp evalphiAppRev.
  subst mm.
  rewrite rw1, rw2.
  repeat rewriteRev app_assoc.
  simpl.
  assert (forall p, evalphi H0 r A (phiAcc e0 f0 :: p) <->
                    evalphi H0 r (Aexcept A [(o0, f0)]) p)
  as rw.
    split; intros.
      inversionx H5. inversionx H15. simpl in *. rewrite H12 in *. inversionx H1. assumption.
      eca; simpl; rewrite H1; auto. eca. apply in_eq.
  rewrite rw.
  tauto.
Qed.

Lemma meetSplitWorks : forall p1 p2,
  let ps1 := splitPhi p1 in
  let ps2 := splitPhi p2 in
  forall H r A,
  (evalphi H r A p1 /\ evalphi H r A p2) <->
  (evalphid H r A (meetSplit (fst ps1) (fst ps2) (snd ps1 ++ snd ps2))).
Proof.
  induction p1; intros; simpl in *; unf.
    split; intros; unfold evalphid in *; unf.
      eappIn evalphiSplitMerge H3. subst ps2. eex. intuition.
      split; try constructor. apply InSingle in H1. subst. eapp evalphiSplitMerge.
  destruct (classic (exists e0 f0, a = phiAcc e0 f0)).
  - unf. subst. subst ps1 ps2.
    split; unfold evalphid in *; intros; unf.
    * inversionx H2. inversionx H12. simpl in *. rewrite H9 in *.
      destruct (classic (In (o0, x1) (footprint H0 r p2))) as [fp2 | fp2].
      + apply staticVSdynamicFP in fp2. unf.
        apply InEnsuresCutAt in H4. unf.

        assert (evalphi H0 r (Aexcept A [(o0, x1)]) p1 ∧
                evalphi H0 r (Aexcept A [(o0, x1)]) (mergePhi (x3 ++ x4) (snd (splitPhi p2)))) as IH.
          split; auto.
          eappIn evalphiIsCutAt H4.
          rewriteRev H4. assumption.
        apply IHp1 in IH. unf.
        exists (phiAcc x0 x1 :: phiEq x0 x2 :: x5).
        split.
          apply in_map_iff. eex.
          apply in_app_iff. apply or_intror.
          apply in_concat.
          exists (map (λ p0, phiEq x0 x2 :: p0) (meetSplit (fst (splitPhi p1)) (x3 ++ x4) (snd (splitPhi p1) ++ snd (splitPhi p2)))).
          split.
            apply in_mapRem_iff.
            exists x3. exists (x2, x1). exists x4.
            split.
              simpl.
              dec (string_dec x1 x1). tauto.
            rewrite splitPhiAlt. assumption.
          apply in_map_iff. eex.
          rewrite fstSplitPhiMergePhi in H5.
          rewrite sndSplitPhiMergePhi in H5.
          assumption.
        eca; simpl; rewrite H9.
          auto.
          eca.
        eca; simpl.
          apply inclEmpty.
          eca.
        common.
        assumption.
      + assert (evalphi H0 r (Aexcept A [(o0, x1)]) p1 ∧
                evalphi H0 r (Aexcept A [(o0, x1)]) p2) as IH.
          split; auto. eapp evalphiRemoveAexcept.
          unfold disjoint. intros. apply or_comm. apply imply_to_or. intros. simpl in *.
          inversionx H1; tauto.
        apply IHp1 in IH. unf.
        exists (phiAcc x0 x1 :: x2).
        split.
          apply in_map_iff. eex.
          apply in_app_iff. auto.
        eca; simpl; rewrite H9.
          auto.
          eca.
        assumption.
    * simpl in *.
      rewrite in_map_iff in H1. unf.
      rewrite in_app_iff in H4. inversionx H4.
      + inversionx H3. inversionx H12.
        simpl in *. rewrite H9 in *.
        assert (evalphi H0 r (Aexcept A [(o0, x1)]) p1 ∧
                evalphi H0 r (Aexcept A [(o0, x1)]) p2) as IH.
          eapp IHp1.
        unf.
        split.
          eca; simpl; rewrite H9.
            auto.
            eca.
            assumption.
          eapp evalphiAexcept.
      + apply in_concat in H2. unf.
        apply in_mapRem_iff in H2. unf. subst.
        destruct x5. simpl in *.
        dec (string_dec x1 s0).
        apply in_map_iff in H4. unf. subst.
        inversionx H3. inversionx H13.
        simpl in *. rewrite H10 in *.
        inversionx H14. simpl in *. common.
        assert (evalphi H0 r (Aexcept A [(o0, s0)]) p1 ∧
                evalphi H0 r (Aexcept A [(o0, s0)]) (mergePhi (x4 ++ x6) (snd (splitPhi p2)))) as IH.
          eapp IHp1.
          eex.
          rewrite fstSplitPhiMergePhi.
          rewrite sndSplitPhiMergePhi.
          assumption.
        unf.
        split.
          eca; simpl; rewrite H10; auto. eca.
          rewrite splitPhiAlt in H5. simpl in *.
          inversionx H16. common. rewrite H10 in *. inversionx H12.
          eappIn evalphiIsCutAt H5.
          rewrite H5. assumption.
  - subst ps1 ps2.
    split; intros.
    * unf. inversionx H3.
      destruct a; simpl in *;
      try (contradict H1; eex; fail);
      rewriteRev meetSplitAugment;
      try tauto;
      split; auto;
      apply IHp1;
      split; common; auto.
    * destruct a; simpl in *;
      try (contradict H1; eex; fail);
      rewriteRevIn meetSplitAugment H2;
      try tauto; unf;
      apply IHp1 in H3; unf;
      split; try tauto;
      eca; simpl; common; auto;
      apply inclEmpty.
Qed.

Theorem meetWorks : forall pd1 pd2,
  isIntersection pd1 pd2 (meet pd1 pd2).
Proof.
  unfold isIntersection, meet, meetSingle, evalphid.
  induction pd1; simpl.
  - split; intros; unf; tauto.
  - split; intros; unf.
    * rewrite flat_map_app.
      inversionx H2.
      + assert (evalphi H0 r A x1 /\ evalphi H0 r A x0) as ss.
          auto.
        apply meetSplitWorks in ss. unfold evalphid in ss. unf.
        exists x2.
        split; auto.
        rewrite in_app_iff. constructor.
        apply in_flat_map.
        exists (x1, x0).
        split; auto.
        rewrite in_map_iff. eex.
      + specialize (IHpd1 pd2 H0 r A).
        inversionx IHpd1.
        lapply H2; intros.
          unf. eex. intuition.
        split; eex.
    * rewrite flat_map_app in H1.
      rewrite in_app_iff in H1.
      inversionx H1.
      + apply in_flat_map in H2. unf.
        apply in_map_iff in H2. unf. subst.
        simpl in *.
        assert (evalphi H0 r A a /\ evalphi H0 r A x2).
          eapp meetSplitWorks.
        unfold evalphid.
        eex. unf.
        split; eex.
      + specialize (IHpd1 pd2 H0 r A).
        inversionx IHpd1.
        lapply H4; intros.
          unf. eex.
        eex.
Qed.


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 A B O P T X Tprime : Universe, ((wd_ X T /\ (wd_ O P /\ (wd_ A B /\ (col_ A B X /\ (col_ A B T /\ (col_ T X Tprime /\ (col_ A B T /\ col_ A X T))))))) -> col_ A B Tprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Relations.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Context.
Require Import Local.AbstractRewriting.
Require Import Local.Axiomatic.
Require Import Local.Reduction.
Require Import Local.Residuals.
Require Import Local.Confluence.

(* The following method is present on the "Factorization and Normalization,
   Essentially" paper, and was hinted to me by dr. Accattoli through private
   communication. This seems way simpler than what I was trying to do. *)

(* TODO: we have some unusual rules here... perhaps we should name them. *)

Inductive inner: relation pseudoterm :=
  | inner_nonstatic_ctxjmp:
    forall h xs ts c,
    nonstatic h ->
    length xs = length ts ->
    inner (bind (h (jump #h xs)) ts c)
      (bind
         (h (apply_parameters xs 0 (lift (S #h) (length ts) c)))
         ts c)
  | inner_gc:
    GC inner
  (*| inner_eta:
    (* It is important that this doesn't change the name in subject position at
       the head of the term. *)
    forall b ts h k xs j,
    static h ->
    (* TODO: we might have to tweak this definition a bit. *)
    b = h (jump k xs) ->
    k <> #h ->
    inner
      (bind b ts
         (jump (lift (length ts) 0 j)
            (low_sequence (length ts))))
      (subst j 0 b) *)
  | inner_bind_left:
    LEFT inner
  | inner_bind_right:
    forall b ts c1 c2,
    [c1 => c2] -> inner (bind b ts c1) (bind b ts c2).

Lemma step_inner:
  inclusion inner step.
Proof.
  induction 1; auto with cps.
Qed.

Global Hint Resolve step_inner: cps.

(* Hindley's local postponement lemma. TODO: move me. *)

Lemma local_postponement:
  forall {T} (R S: relation T),
  inclusion (comp S R) (comp rt(R) r(S)) ->
  inclusion rt(union R S) (comp rt(R) rt(S)).
Proof.
  intros.
  (* Let us slightly change our hypothesis. *)
  assert (inclusion (comp S rt(R)) (comp rt(R) r(S))).
  - unfold inclusion; intros.
    rename y into z.
    destruct H0 as (y, ?, ?).
    generalize dependent x.
    (* For some reason I can't use clos_refl_trans_ind_right... *)
    apply clos_rt_rt1n_iff in H1.
    induction H1; intros w ?.
    + exists w; auto with cps.
    + apply clos_rt_rt1n_iff in H1.
      destruct H with w y as (v, ?, ?); eauto with cps.
      destruct H4.
      * destruct IHclos_refl_trans_1n with v as (u, ?, ?); auto.
        exists u; eauto with cps.
      * exists z; eauto with cps.
  - clear H; rename H0 into H.
    (* Now we can proceed into the proof. *)
    intros x y ?.
    (* Same thing as above! *)
    apply clos_rt_rt1n_iff in H0.
    induction H0.
    + exists x; auto with cps.
    + apply clos_rt_rt1n_iff in H1.
      destruct H0.
      * destruct IHclos_refl_trans_1n as (w, ?, ?).
        exists w; eauto with cps.
      * destruct IHclos_refl_trans_1n as (w, ?, ?).
        destruct H with x w as (v, ?, ?); eauto with cps.
        apply clos_r_clos_rt in H5.
        exists v; eauto with cps.
Qed.

Axiom parallel_inner: relation pseudoterm.

Conjecture inner_parallel_inner:
  inclusion inner parallel_inner.

Local Hint Resolve inner_parallel_inner: cps.

Conjecture parallel_inner_rt_inner:
  inclusion parallel_inner rt(inner).

Local Hint Resolve parallel_inner_rt_inner: cps.

Lemma rt_inner_and_rt_parallel_inner_are_equivalent:
  same_relation rt(inner) rt(parallel_inner).
Proof.
  split; induction 1; eauto with cps.
Qed.

Conjecture merge:
  inclusion (comp parallel_inner head) parallel.

(* This lemma will need to perform induction on the number of consecutive head
   jumps in a redex. If the redex is regular, this may be calculated, but it'll
   be somewhat annoying to formalize. *)

Conjecture split:
  inclusion parallel (comp rt(head) parallel_inner).

Theorem factorization:
  inclusion star (comp rt(head) rt(inner)).
Proof.
  assert (inclusion rt(union head parallel_inner)
    (comp rt(head) rt(parallel_inner))).
  - apply local_postponement.
    unfold inclusion; intros.
    destruct split with x y as (z, ?, ?).
    + apply merge; auto.
    + exists z; auto with cps.
  - unfold inclusion; intros.
    destruct H with x y as (z, ?, ?).
    + clear H.
      (* Relexive and transitive cases are trivial. *)
      induction H0; eauto with cps.
      (* TODO: fix me!

      (* Though we usually would argue that a step is either essential or not,
         this is not the case here due to eta reduction: there are cases in
         which a step should be split into a head reduction followed by an inner
         reduction. So we take another route here by using [split]. *)
      apply parallel_step in H.
      apply split in H.
      destruct H as (z, ?, ?).
      (* Now, this is clearly true. *)
      apply rt_trans with z.
      * clear H0 y.
        induction H; eauto with cps.
      * auto with cps.
      *)
      admit.
    + apply rt_inner_and_rt_parallel_inner_are_equivalent in H2.
      eauto with cps.
Admitted.

Corollary star_characterization:
  same_relation star (comp rt(head) rt(inner)).
Proof.
  split.
  - apply factorization.
  - intros x z ?.
    (* Clearly true. *)
    destruct H as (y, ?, ?).
    apply star_trans with y.
    + clear H0 z.
      induction H; eauto with cps.
    + clear H x.
      induction H0; eauto with cps.
Qed.