(* To install ITree, do:
     opam install coq-itree *)
From ITree Require Import
     ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From Paco Require Import paco.

Require Import Coq.Program.Basics.
Require Import Nat.
Require Import PeanoNat.
Require Import Coq.Logic.Eqdep_dec.
Require Import RelationClasses.
Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.Morphisms.
Require Import List.
Import ListNotations.

Local Open Scope equiv_scope.
Local Open Scope program_scope.

Require Import misc.
Require Import regular.
Require Import semiring.
Require Import tree.

Variant unbiasedE : Type -> Type :=
| GetUnbiased : unbiasedE bool.

Section itree_all.
  Context {A : Type} {E : Type -> Type} (P : A -> Prop).

  Inductive itree_allF (R : itree E A -> Prop) : itree' E A -> Prop :=
  | itree_allF_ret : forall x, P x -> itree_allF R (RetF x)
  | itree_allF_tau : forall t, R t -> itree_allF R (TauF t)
  | itree_allF_vis : forall {A} (e : E A) f,
      (forall x, R (f x)) ->
      itree_allF R (VisF e f).

  Definition itree_all_ R : itree E A -> Prop :=
    fun t => itree_allF R (observe t).

  Lemma itree_allF_mono R R' t
        (IN: itree_allF R t)
        (LE: R <1= R') :
    itree_allF R' t.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_all__mono : monotone1 (itree_all_).
  Proof. do 2 red. intros. eapply itree_allF_mono; eauto. Qed.
  Hint Resolve itree_all__mono : paco.

  Definition itree_all : itree E A -> Prop :=
    paco1 itree_all_ bot1.

  Lemma itree_allF_impl (t : itree' E A) (Q1 Q2 : itree E A -> Prop) :
    (forall t, Q1 t -> Q2 t) ->
    itree_allF Q1 t -> itree_allF Q2 t.
  Proof.
    intros H0 H1.
    destruct t; inversion H1; subst; constructor; auto.
    apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H4; subst; auto.
  Qed.

  Lemma itree_all_impl (t : itree E A) (Q1 Q2 : itree E A -> Prop) :
    (forall t, Q1 t -> Q2 t) ->
    paco1 itree_all_ Q1 t -> paco1 itree_all_ Q2 t.
  Proof.
    revert t.
    pcofix CH.
    intros t H0 H1.
    punfold H1; pstep.
    eapply itree_allF_impl.
    2: { apply H1. }
    intros t' [H2 | H2].
    - right; apply CH; auto.
    - right; auto.
  Qed.

  (* Lemma itree_allF_all_ {t : itree E A} r : *)
  (*   itree_allF r (observe t) <-> itree_all_ r t. *)
  (* Proof. firstorder. Qed. *)

  (* Global Instance Proper_itree_all' r *)
  (*   : Proper (eq_itree eq ==> flip impl) (paco1 itree_all_ r). *)
  (* Proof. *)
  (*   pcofix CH. *)
  (*   intros t1 t2 Heq Hall. *)
  (*   punfold Hall; pstep. *)
  (*   unfold itree_all_ in *. *)
  (*   punfold Heq. unfold eqit_ in Heq. *)
  (*   destruct (observe t1); destruct (observe t2); inversion Heq; subst; try congruence. *)
  (*   - inversion Hall; subst; constructor; auto. *)
  (*   - inversion Hall; subst. *)
  (*     destruct REL as [REL | REL]. *)
  (*     2: { inversion REL. } *)
  (*     constructor. *)
  (*     destruct H0 as [H0 | H0]. *)
  (*     + right. eapply CH. apply REL. auto. *)
  (*     + right. apply CH0. *)
  (*     constructor. right. *)
  (*     eapply CH. apply REL. *)
  (*     destruct H0 as [H0 | H0]. *)
  (*     + eapply itree_allF_impl. *)
  (*       2: { apply Hall. *)
  (*     2: { inversion H0. } *)
  (*     destruct REL as [H1 | H1]. *)
  (*     2: { inversion H1. } *)
  (*     constructor. right. eapply CH; eauto. *)
  (*   - eapply fold_eqitF with (t3 := Vis e k) (t4 := Vis e0 k0) in Heq; auto. *)
  (*     apply eqitree_inv_Vis_r in Heq. *)
  (*     destruct Heq as [k' [H0 Heq]]. *)
  (*     simpl in H0. *)
  (*     inversion H0; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H3; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H6; subst. *)
  (*     constructor; intros x. *)
  (*     right; eapply CH; eauto. *)
  (*     inversion Hall; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H6; subst. *)
  (*     apply Eqdep.EqdepTheory.inj_pair2 in H7; subst. *)
  (*     destruct (H3 x) as [H | H]; auto; inversion H. *)
  (* Qed. *)

  Global Instance Proper_itree_all : Proper (eq_itree eq ==> flip impl) itree_all.
  Proof.
    pcofix CH.
    intros t1 t2 Heq Hall.
    punfold Hall; pstep.
    unfold itree_all_ in *.
    punfold Heq. unfold eqit_ in Heq.
    destruct (observe t1); destruct (observe t2); inversion Heq; subst; try congruence.
    - inversion Hall; subst; constructor; auto.
    - inversion Hall; subst.
      destruct H0 as [H0 | H0].
      2: { inversion H0. }
      destruct REL as [H1 | H1].
      2: { inversion H1. }
      constructor. right. eapply CH; eauto.
    - eapply fold_eqitF with (t3 := Vis e k) (t4 := Vis e0 k0) in Heq; auto.
      apply eqitree_inv_Vis_r in Heq.
      destruct Heq as [k' [H0 Heq]].
      simpl in H0.
      inversion H0; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H6; subst.
      constructor; intros x.
      right; eapply CH; eauto.
      inversion Hall; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H6; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H7; subst.
      destruct (H3 x) as [H | H]; auto; inversion H.
  Qed.
End itree_all.
Hint Resolve itree_all__mono : paco.

Section in_itree_lang.
  Context {A : Type} (P : A -> Prop).

  Inductive in_itree_langF (R : itree unbiasedE A -> list bool -> Prop)
    : itree' unbiasedE A -> list bool -> Prop :=
  | in_itree_langF_ret_true : forall x,
      P x ->
      in_itree_langF R (RetF x) []
  | in_itree_langF_tau : forall t bs, R t bs -> in_itree_langF R (TauF t) bs
  | in_itree_langF_vis_true : forall f bs,
      R (f true) bs ->
      in_itree_langF R (VisF GetUnbiased f) (true :: bs)
  | in_itree_langF_vis_false : forall f bs,
      R (f false) bs ->
      in_itree_langF R (VisF GetUnbiased f) (false :: bs).

  Definition in_itree_lang_ R : itree unbiasedE A -> list bool -> Prop :=
    fun t bs => in_itree_langF R (observe t) bs.

  Lemma in_itree_langF_mono R R' t bs
        (IN: in_itree_langF R t bs)
        (LE: R <2= R') :
    in_itree_langF R' t bs.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma in_itree_lang__mono : monotone2 (in_itree_lang_).
  Proof. do 2 red. intros. eapply in_itree_langF_mono; eauto. Qed.
  Hint Resolve in_itree_lang__mono : paco.

  Definition in_itree_lang : itree unbiasedE A -> list bool -> Prop :=
    paco2 in_itree_lang_ bot2.

  (* Fixpoint in_itree_aux (t : itree unbiasedE A) (bs : list bool) (n : nat) : bool := *)
  (*   match n with *)
  (*   | O => false *)
  (*   | S n' => match observe t with *)
  (*            | RetF x => P x *)
  (*            | TauF t' => in_itree_aux t' bs n' *)
  (*            | VisF GetUnbiased k => *)
  (*              match bs with *)
  (*              | nil => false *)
  (*              | false :: bs' => in_itree_aux (k false) bs' n' *)
  (*              | true :: bs' => in_itree_aux (k true) bs' n' *)
  (*              end *)
  (*            end *)
  (*   end. *)

  (* Definition in_itree (t : itree unbiasedE A) (bs : list bool) : bool := *)
  (*   in_itree_aux t bs (S (length bs)). *)

  (* Lemma in_itree_spec (t : itree unbiasedE A) (bs : list bool) : *)
  (*   itree_notau t -> *)
  (*   in_itree_aux t bs (S (length bs)) = true <-> in_itree_lang t bs. *)
  (* Proof. *)
  (*   revert t. *)
  (*   induction bs; simpl; intros t Hnotau. *)
  (*   - punfold Hnotau; unfold itree_notau_ in Hnotau. *)
  (*     destruct (observe t) eqn:Ht. *)
  (*     + split; intro H. *)
  (*       * pstep; unfold in_itree_lang_; rewrite Ht; constructor; auto. *)
  (*       * punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*         inversion H; auto. *)
  (*     + inversion Hnotau. *)
  (*     + destruct e. *)
  (*       split; intro H; try congruence. *)
  (*       punfold H; unfold in_itree_lang_ in H; rewrite Ht in H; inversion H. *)
  (*   - punfold Hnotau; unfold itree_notau_ in Hnotau. *)
  (*     destruct (observe t) eqn:Ht. *)
  (*     + split; intro H. *)
  (*       * pstep; unfold in_itree_lang_; rewrite Ht; constructor; auto. *)
  (*       * punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*         inversion H; auto. *)
  (*     + inversion Hnotau. *)
  (*     + destruct e. *)
  (*       inversion Hnotau. *)
  (*       apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*       apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst. *)
  (*       destruct a. *)
  (*       * specialize (H0 true). *)
  (*         destruct H0 as [H0 | H0]. *)
  (*         2: inversion H0. *)
  (*         specialize (IHbs (k true) H0); destruct IHbs as [IH IH']. *)
  (*         split; intro H. *)
  (*         -- pstep; unfold in_itree_lang_; rewrite Ht; constructor. *)
  (*            left; apply IH; auto. *)
  (*         -- punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*            inversion H; subst. *)
  (*            destruct H3 as [H3 | H3]. *)
  (*            2: inversion H3. *)
  (*            apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*            apply IH'; auto. *)
  (*       * specialize (H0 false). *)
  (*         destruct H0 as [H0 | H0]. *)
  (*         2: inversion H0. *)
  (*         specialize (IHbs (k false) H0); destruct IHbs as [IH IH']. *)
  (*         split; intro H. *)
  (*         -- pstep; unfold in_itree_lang_; rewrite Ht; constructor. *)
  (*            left; apply IH; auto. *)
  (*         -- punfold H; unfold in_itree_lang_ in H; rewrite Ht in H. *)
  (*            inversion H; subst. *)
  (*            destruct H3 as [H3 | H3]. *)
  (*            2: inversion H3. *)
  (*            apply Classical_Prop.EqdepTheory.inj_pair2 in H1; subst. *)
  (*            apply IH'; auto. *)
  (* Qed. *)

  (* Lemma in_itree_reflect (t : itree unbiasedE A) (bs : list bool) : *)
  (*   itree_notau t -> *)
  (*   reflect (in_itree_lang t bs) (in_itree t bs). *)
  (* Proof. *)
  (*   intro Hnotau. *)
  (*   generalize (in_itree_spec t bs Hnotau); intro H. *)
  (*   unfold in_itree. *)
  (*   destruct (in_itree_aux t bs (S (length bs))); constructor. *)
  (*   - apply H; auto. *)
  (*   - intro HC. *)
  (*     assert (false = true). *)
  (*     { apply H; auto. } *)
  (*     congruence. *)
  (* Qed. *)
End in_itree_lang.
Hint Resolve in_itree_lang__mono : paco.

Section itree_lang.
  Context {A : Type} (P : A -> Prop).

  (* CoInductive itree_lang' : itree unbiasedE A -> (nat -> option (list bool)) -> Prop := *)
  (* | itree_lang'_false : forall x, P x = false -> itree_lang' (Ret x) seq_zero *)
  (* | itree_lang'_true : forall x, P x = true -> itree_lang' (Ret x) (seq_one []) *)
  (* | itree_lang'_vis : forall f s1 s2, *)
  (*     itree_lang' (f true) s1 -> *)
  (*     itree_lang' (f false) s2 -> *)
  (*     itree_lang' (Vis GetUnbiased f) (seq_union (option_map (cons true) ∘ s1) *)
  (*                                                (option_map (cons false) ∘ s2)). *)

  (** See Eq/Eq.v in the ITree development for explanation of this
      construction (eqitF, eqit_, etc.). *)
  Inductive itree_langF (R : itree unbiasedE A -> (nat -> option (list bool)) -> Prop)
    : itree' unbiasedE A -> (nat -> option (list bool)) -> Prop :=
  | itree_langF_ret_false : forall x, ~ P x -> itree_langF R (RetF x) seq_zero
  | itree_langF_ret_true : forall x s,
      P x ->
      s === seq_one [] ->
      itree_langF R (RetF x) s
  | itree_langF_tau : forall t s1 s2, R t s1 -> s1 === s2 -> itree_langF R (TauF t) s2
  | itree_langF_vis : forall f s1 s2 s,
      R (f true) s1 ->
      R (f false) s2 ->
      s === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      itree_langF R (VisF GetUnbiased f) s.

  Definition itree_lang_ R : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    fun t s => itree_langF R (observe t) s.

  Lemma itree_langF_mono R R' t s
        (IN: itree_langF R t s)
        (LE: R <2= R') :
    itree_langF R' t s.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_lang__mono : monotone2 (itree_lang_).
  Proof. do 2 red. intros. eapply itree_langF_mono; eauto. Qed.
  Hint Resolve itree_lang__mono : paco.

  Definition itree_lang : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    paco2 itree_lang_ bot2.

  Definition itree_lang' r : itree unbiasedE A -> (nat -> option (list bool)) -> Prop :=
    paco2 itree_lang_ r.

  Lemma itree_langF_impl (t : itree' unbiasedE A) s
        (r1 r2 : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
    (forall t s, r1 t s -> r2 t s) ->
    itree_langF r1 t s -> itree_langF r2 t s.
  Proof.
    intros H0 H1.
    destruct t; inversion H1; subst.
    - constructor; auto.
    - constructor; auto.
    - econstructor; eauto.
    - apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H2; subst; auto.
      econstructor; eauto.
  Qed.

  Lemma itree_lang_impl
        (t : itree unbiasedE A) s
        (r1 r2 : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
    (forall t s, r1 t s -> r2 t s) ->
    paco2 itree_lang_ r1 t s -> paco2 itree_lang_ r2 t s.
  Proof.
    revert t s.
    pcofix CH.
    intros t s H0 H1.
    punfold H1; pstep.
    eapply itree_langF_impl.
    2: { apply H1. }
    intros t' s' [H2 | H2].
    - right; apply CH; auto.
    - right; auto.
  Qed.

  Global Instance Proper_itree_langF R
    : Proper (eq ==> seq_bijection_upto_0 ==> iff) (itree_langF R).
  Proof.
    intros ? t ? s1 s2 Hbij; subst; split; intro H0.
    - induction H0.
      + symmetry in Hbij; apply seq_bijection_upto_0_zero in Hbij.
        subst; constructor; auto.
      + constructor; auto; rewrite <- Hbij; auto.
      + econstructor; eauto; rewrite H0; auto.
      + econstructor; eauto; rewrite <- Hbij; auto.
    - induction H0.
      + apply seq_bijection_upto_0_zero in Hbij; subst; constructor; auto.
      + constructor; auto; rewrite Hbij; auto.
      + econstructor; eauto; rewrite Hbij; auto.
      + econstructor; eauto; rewrite Hbij; auto.
  Qed.

  Lemma itree_lang_lang' r t s :
    itree_lang t s -> itree_lang' r t s.
  Proof.
    revert t s.
    pcofix CH; intros t s.
    unfold itree_lang, itree_lang' in *.
    intro H. pstep.
    punfold H.
    unfold itree_lang_ in *.
    destruct (observe t).
    + inversion H; subst; constructor; auto.
    + inversion H; subst.
      eapply itree_langF_tau; eauto.
      right. apply CH.
      destruct H1. apply H0. inversion H0.
    + destruct e.
      inversion H; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
      econstructor; eauto.
      * destruct H1 as [H1 | H1].
        -- apply CH in H1; right; eauto.
        -- inversion H1.
      * destruct H2 as [H2 | H2].
        -- apply CH in H2; right; eauto.
        -- inversion H2.
  Qed.

  Global Instance Proper_itree_lang' r
    : Proper (eq ==> seq_bijection_upto_0 ==> flip impl) (paco2 itree_lang_ r).
  Proof.
    intros ? t ? s1 s2 Hbij H; subst.
    pstep; punfold H; unfold itree_lang_.
    rewrite Hbij; apply H.
  Qed.

  Global Instance Proper_itree_lang : Proper (eq_itree eq ==> eq ==> flip impl) itree_lang.
  Proof.
    pcofix CH; intros x y Heq s1 s2 ? Hlang; subst.
    punfold Heq; unfold eqit_ in Heq.
    punfold Hlang; unfold itree_lang_ in Hlang.
    pstep; unfold itree_lang_.
    destruct (observe x); inversion Heq; subst;
      try congruence; rewrite <- H in Hlang; clear H.
    - inversion Hlang; subst; constructor; auto.
    - inversion Hlang; subst.
      repeat destruct_upaco.
      econstructor; eauto.
    - destruct e.
      apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
      inversion Hlang; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H; subst.
      repeat destruct_upaco.
      unfold id in REL.
      econstructor; eauto.
      + right; specialize (REL true); destruct_upaco.
        eapply CH in REL; eauto.
      + right; specialize (REL false); destruct_upaco.
        eapply CH in REL; eauto.
  Qed.
End itree_lang.
Hint Resolve itree_lang__mono : paco.

Section itree_lang2.
  Context {A : Type} (P : A -> Prop).

  (** See Eq/Eq.v in the ITree development for explanation of this
      construction (eqitF, eqit_, etc.). *)
  Inductive itree_lang2F (R : itree unbiasedE A ->
                              (nat -> option (list bool)) ->
                              (nat -> option (list bool)) -> Prop)
    : itree' unbiasedE A -> (nat -> option (list bool)) -> (nat -> option (list bool)) -> Prop :=
  | itree_lang2F_ret_false : forall x, ~ P x -> itree_lang2F R (RetF x) seq_zero seq_zero
  | itree_lang2F_ret_true : forall x s1 s2,
      P x ->
      s1 === seq_one [] ->
      s2 === seq_one [] ->
      itree_lang2F R (RetF x) s1 s2
  | itree_lang2F_tau : forall t s1 s1' s2 s2',
      R t s1 s1' ->
      s1 === s2 ->
      s1' === s2' ->
      s2 === s2' ->
      itree_lang2F R (TauF t) s2 s2'
  | itree_lang2F_vis : forall f s1 s1' s2 s2' s s',
      R (f true) s1 s1' ->
      R (f false) s2 s2' ->
      s === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      s' === seq_union (option_map (cons true) ∘ s1) (option_map (cons false) ∘ s2) ->
      itree_lang2F R (VisF GetUnbiased f) s s'.

  Definition itree_lang2_ R : itree unbiasedE A ->
                              (nat -> option (list bool)) ->
                              (nat -> option (list bool)) -> Prop :=
    fun t s => itree_lang2F R (observe t) s.

  Lemma itree_lang2F_mono R R' t s1 s2
        (IN: itree_lang2F R t s1 s2)
        (LE: R <3= R') :
    itree_lang2F R' t s1 s2.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_lang2__mono : monotone3 (itree_lang2_).
  Proof. do 2 red. intros. eapply itree_lang2F_mono; eauto. Qed.
  Hint Resolve itree_lang2__mono : paco.

  Definition itree_lang2 : itree unbiasedE A ->
                           (nat -> option (list bool)) ->
                           (nat -> option (list bool)) -> Prop :=
    paco3 itree_lang2_ bot3.
End itree_lang2.

Hint Resolve itree_lang2__mono : paco.

Lemma observe_Ret {A : Type} {E : Type -> Type} (t : itree E A) (x : A) :
  observe t = RetF x ->
  t ≅ Ret x.
Proof.
  intro H; pstep; unfold eqit_; simpl; rewrite H; constructor; reflexivity.
Qed.

Lemma observe_Tau {A : Type} {E : Type -> Type} (t1 t2 : itree E A) :
  observe t1 = TauF t2 ->
  t1 ≅ Tau t2.
Proof.
  intro H; pstep; unfold eqit_; simpl.
  rewrite H; apply EqTau; left; apply Reflexive_eqit_eq.
Qed.

Lemma observe_Vis {A B : Type} {E : Type -> Type} (t : itree E A) (e : E B) (f : B -> itree E A) :
  observe t = VisF e f ->
  t ≅ Vis e f.
Proof.
  intro H; pstep; unfold eqit_; simpl.
  rewrite H; constructor; left; apply Reflexive_eqit_eq.
Qed.

Lemma seq_product_option_mult_comm (s1 s2 : nat -> option (list bool)) (b : bool) :
  seq_product MonoidList (option_map (cons b) ∘ s1) s2 =
  option_map (cons b) ∘ (seq_product MonoidList s1 s2).
Proof.
  replace (option_map (cons b)) with (option_mult MonoidList (Some [b])) by reflexivity.
  apply seq_product_option_mult_comm; apply MonoidLawsList.
Qed.

Lemma itree_lang_langF {A : Type} (P : A -> Prop) r t s :
  itree_lang_ P r t s ->
  itree_langF P r (observe t) s.
Proof. firstorder. Qed.

Lemma itree_langF_lang {A : Type} (P : A -> Prop) r t s :
  itree_langF P r (observe t) s ->
  itree_lang_ P r t s.
Proof. firstorder. Qed.

Lemma itree_lang_unfold_bind {A B : Type} (t : itree unbiasedE A) (k : A -> itree unbiasedE B) s r P :
  paco2 (itree_lang_ P) r (match observe t with
                           | RetF r => k r
                           | TauF t0 => Tau (x <- t0;; k x)
                           | VisF e ke => Vis e (fun x => x <- ke x;; k x)
                           end) s ->
  paco2 (itree_lang_ P) r (x <- t;; k x) s.
Proof.
  revert t k s.
  pcofix CH; intros t k s H.
  punfold H. pstep.
  unfold itree_lang_ in H.
  unfold ITree.bind.
  unfold ITree.subst.
  compute.
  apply itree_lang_langF.
  rewrite _observe_observe.
  destruct (observe t) eqn:Ht.
  - unfold itree_lang_.
    eapply itree_langF_impl.
    2: { eauto. }
    intros t' s' [H0 | H0].
    + left; eapply itree_lang_impl; eauto.
    + right; auto.
  - inversion H; subst.
    econstructor; eauto.
    destruct H1 as [H1 | H1].
    + left; eapply itree_lang_impl; eauto.
    + right; auto.
  - destruct e.
    inversion H; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
    destruct H2 as [H2 | H2]; destruct H1 as [H1 | H1];
      econstructor; eauto; left; eapply itree_lang_impl; eauto.
Qed.

Lemma itree_lang_unfold_iter {A B : Type} P (f : A -> itree unbiasedE (A + B)) x s r :
  paco2 (itree_lang_ P) r (lr <- f x ;; match lr with
                                       | inl l => Tau (ITree.iter f l)
                                       | inr r => Ret r
                                       end) s ->
  paco2 (itree_lang_ P) r (ITree.iter f x) s.
Proof.
  revert f x s.
  pcofix CH; intros f x s H.
  punfold H. pstep.
  unfold itree_lang_ in *.
  unfold ITree.bind in H.
  unfold ITree.subst in H.
  compute in H.
  apply itree_langF_lang.
  rewrite 2!_observe_observe in H.
  unfold ITree.iter. compute.
  apply itree_lang_langF.
  rewrite _observe_observe.
  destruct (observe (f x)) eqn:Hfx.
  - destruct r1.
    + unfold itree_lang_.
      simpl in *.
      inversion H; subst.
      econstructor; eauto.
      destruct H1 as [H1 | H1].
      * left; eapply itree_lang_impl; eauto.
      * right; apply CH0; auto.
    + inversion H; subst; constructor; auto.
  - inversion H; subst.
    econstructor; eauto.
    destruct H1 as [H1 | H1].
    * left; eapply itree_lang_impl; eauto.
    * right; apply CH0; auto.
  - destruct e.
    inversion H; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H0; subst.
    destruct H2 as [H2 | H2]; destruct H1 as [H1 | H1];
      econstructor; eauto; left; eapply itree_lang_impl; eauto.
Qed.

Lemma itree_lang_bind {A : Type} (t1 : itree unbiasedE (unit + A)) (t2 : unit -> itree unbiasedE A)
      (P : A -> Prop) (s1 s1' s2 : nat -> option (list bool))
      (r : itree unbiasedE A -> (nat -> option (list bool)) -> Prop) :
  itree_lang (cotuple (const True) (const False)) t1 s1 ->
  itree_lang (cotuple (const False) P) t1 s1' ->
  r (t2 tt) s2 ->
  paco2 (itree_lang_ P) r (lr <- t1;; match lr with
                                     | inl l => Tau (t2 l)
                                     | inr r => Ret r
                                     end) (seq_union s1' (seq_product MonoidList s1 s2)).
Proof.
  intros H0 H1 H2.
  revert H0 H1.
  revert t1 s1 s1'.
  pcofix CH. intros t1 s1 s1'.
  intros H0 H1.
  apply itree_lang_unfold_bind.
  pstep.
  punfold H0. punfold H1.
  unfold itree_lang_ in *.
  destruct (observe t1) eqn:Ht1.
  - destruct r0 eqn:Hr.
    + inversion H0; subst.
      * simpl in H3; exfalso; apply H3; apply I.
      * clear H3.
        inversion H1; subst.
        2: { inversion H3. }
        clear H3.
        pstep_reverse. rewrite H4.
        rewrite seq_union_zero_l.
        rewrite seq_product_unit_l.
        pstep.
        destruct u.
        econstructor; eauto; reflexivity.
        apply MonoidLawsList.
    + inversion H0; subst.
      2: { inversion H3. }
      clear H3.
      inversion H1; subst; simpl in H3.
      * pstep_reverse.
        rewrite seq_union_zero_l.
        rewrite seq_product_zero_l.
        pstep.
        constructor; auto.
      * constructor; auto.
        rewrite seq_product_zero_l.
        rewrite seq_union_zero_r; auto.
  - econstructor; eauto; try reflexivity.
    right. apply CH.
    + inversion H0; subst. rewrite <- H4. destruct H3.
      apply H. inversion H.
    + inversion H1; subst. rewrite <- H4. destruct H3.
      apply H. inversion H.
  - inversion H0; subst; clear H0.
    destruct e; clear H3.
    apply Eqdep.EqdepTheory.inj_pair2 in H4; subst.
    inversion H1; subst; clear H1.
    apply Eqdep.EqdepTheory.inj_pair2 in H; subst.
    destruct H7 as [H7 | H7].
    2: { inversion H7. }
    destruct H5 as [H5 | H5].
    2: { inversion H5. }
    destruct H3 as [H3 | H3].
    2: { inversion H3. }
    destruct H0 as [H0 | H0].
    2: { inversion H0. }
    pstep_reverse.
    rewrite H4, H8.
    rewrite seq_product_union_distr_r.
    rewrite 2!seq_product_option_mult_comm.
    rewrite seq_union_comm_4.
    rewrite 2!seq_union_compose.
    pstep.
    econstructor; eauto; reflexivity.
Qed.

Lemma itree_lang_iter_reps_product_P {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) P l :
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (const False) P) t s2 ->
  itree_lang (cotuple (const False) P)
             (ITree.iter (fun _ => x <- t ;;
                                match x with
                                | inl n =>
                                  if n =? l
                                  then ret (inl tt)
                                  else ret (inr (inl n))
                                | inr y =>
                                  ret (inr (inr y))
                                end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2. clear P.
    revert Hl. revert t l s1.
    pcofix CH.
    intros t l s1 H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1.
           apply PeanoNat.Nat.eqb_neq in H1.
           rewrite PeanoNat.Nat.eqb_sym in H1.
           rewrite H1.
           pstep; constructor; intuition.
        -- clear H1.
           pstep; constructor; intuition.
      * destruct r0.
        -- simpl in H1; subst.
           rewrite PeanoNat.Nat.eqb_refl.
           pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hr. revert t l s2.
    pcofix CH.
    intros t l s2 H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- clear H1. pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst; constructor; auto.
        -- simpl in H1.
           pstep; constructor; auto.
      * destruct r0.
        -- inversion H1.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.

Lemma itree_all_itree_lang_iter_P {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) P l :
  itree_all (cotuple (eq l) (const True)) t ->
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (const False) P) t s2 ->
  itree_lang P (ITree.iter (fun _ => x <- t ;;
                                  match x with
                                  | inl _ => ret (inl tt)
                                  | inr y => ret (inr y)
                                  end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hall Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2. clear P.
    revert Hall Hl. revert t s1.
    pcofix CH.
    intros t s1 Hall H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    punfold Hall. unfold itree_all_ in Hall.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- inversion Hall; subst; simpl in *; congruence.
        -- pstep; constructor; intuition.
      * destruct r0.
        -- pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion Hall; subst.
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      inversion H0; subst.
      destruct H2; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      inversion Hall; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H4; subst.
      pose proof (H1 false) as H2.
      specialize (H1 true).
      destruct H2 as [H2 | H2].
      2: { inversion H2. }
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hall Hr. revert t s2.
    pcofix CH.
    intros t s2 Hall H0.
    apply itree_lang_unfold_bind.
    punfold Hall. unfold itree_all_ in Hall.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0; pstep; constructor; auto.
      * destruct r0.
        -- inversion H1.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion Hall; subst.
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      inversion H0; subst.
      destruct H2; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      inversion Hall; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H4; subst.
      pose proof (H1 false) as H2.
      specialize (H1 true).
      destruct H2 as [H2 | H2].
      2: { inversion H2. }
      destruct H1 as [H1 | H1].
      2: { inversion H1. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.

Lemma itree_lang_iter_reps_product_lbl {A : Type} (t : itree unbiasedE (nat + A))
      (s1 s2 : nat -> option (list bool)) l m :
  l <> m ->
  itree_lang (cotuple (eq l) (const False)) t s1 ->
  itree_lang (cotuple (eq m) (const False)) t s2 ->
  itree_lang (cotuple (eq m) (const False))
             (ITree.iter (fun _ => x <- t ;;
                                match x with
                                | inl n =>
                                  if n =? l
                                  then ret (inl tt)
                                  else ret (inr (inl n))
                                | inr y =>
                                  ret (inr (inr y))
                                end) tt)
             (seq_product MonoidList (seq_reps MonoidList s1) s2).
Proof.
  intros Hneq Hl Hr.
  pcofix CH.
  apply itree_lang_unfold_iter.
  rewrite seq_reps_unfold.
  rewrite seq_product_union_distr_r.
  rewrite seq_product_unit_l.
  2: { apply MonoidLawsList. }
  rewrite seq_product_assoc.
  2: { apply MonoidLawsList. }
  apply itree_lang_bind; auto.
  - clear CH. clear r. clear Hr. clear s2.
    revert Hneq Hl. revert t l m s1.
    pcofix CH.
    intros t l m s1 Hneq H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1.
           apply PeanoNat.Nat.eqb_neq in H1.
           rewrite PeanoNat.Nat.eqb_sym in H1.
           rewrite H1.
           pstep; constructor; intuition.
        -- clear H1.
           pstep; constructor; intuition.
      * destruct r0.
        -- simpl in H1; subst.
           rewrite PeanoNat.Nat.eqb_refl.
           pstep; constructor; auto; apply I.
        -- inversion H1.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - clear CH. clear r. clear Hl. clear s1.
    revert Hneq Hr. revert t l s2.
    pcofix CH.
    intros t l s2 Hneq H0.
    apply itree_lang_unfold_bind.
    punfold H0. unfold itree_lang_ in H0.
    destruct (observe t) eqn:Ht.
    + inversion H0; subst.
      * destruct r0.
        -- simpl in H1; pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst; constructor; auto.
        -- simpl in H1; pstep; constructor; auto.
      * destruct r0.
        -- pstep.
           destruct (PeanoNat.Nat.eqb_spec n l); subst.
           ++ simpl in H1; subst; congruence.
           ++ constructor; auto.
        -- simpl in H1.
           pstep; constructor; auto.
    + inversion H0; subst.
      destruct H1; subst.
      * pstep; econstructor; eauto.
      * inversion H.
    + inversion H0; subst.
      destruct e; clear H1.
      apply Classical_Prop.EqdepTheory.inj_pair2 in H2; subst.
      destruct H5 as [H5 | H5].
      2: { inversion H5. }
      destruct H3 as [H3 | H3].
      2: { inversion H3. }
      pstep; econstructor; eauto; right; apply CH; auto.
  - apply MonoidLawsList.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                    Fieska_Normal.v                                 *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Fop) M1) _ ) _ => status M1
| App (App (Op Eop) M1) M2  => match status M1 with Active => Active | _ => status M2 end
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : Fieska -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
eapply2 ref_irreducible.
red; split_all. inversion H.
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 7 *)
eapply2 IHnor1.
(* 6 *)
eapply2 IHnor2.
(* 5 *)
gen2_case H4 H P; subst; inv1 compound; subst; split_all; discriminate.
(* 4 *)
gen2_case H4 H M2; subst; inv1 compound; subst; split_all; discriminate.
(* 3 *)
gen2_case H4 H M; subst; inv1 compound; subst; split_all; discriminate.
(* 2 *)
gen2_case H3 H M; subst; inv1 compound; subst; split_all; discriminate.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem Fieska_progress : forall (M : Fieska), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all. 2: right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 f. discriminate.  gen_case H5 f1. gen_case H5 o.
discriminate.
(* 1 *)
gen2_case H3 H5 f.
gen2_case H3 H5 o; try (right; eauto; fail); try (left; auto; fail).
inversion H4; subst; try (right; eauto; fail); try (left; auto; fail).
inversion H0; subst; try (right; eauto; fail); try (left; auto; fail).
right. assert(o0 = o1 \/ o0 <> o1) by decide equality.
inversion H1; subst; eauto.
left. eapply2 nf_active. simpl in *. rewrite H6. auto.
inversion H0; subst; try (left; auto; fail); try (right; eauto; fail).
left; eapply2 nf_active. inversion H6; simpl; auto.
left; eapply2 nf_active. inversion H6; simpl; auto.
inversion H5; subst; try (right;  eauto; fail).
inversion H3; subst; inversion H7; subst; try (right;  eauto; fail); try (left; auto; fail).
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing ~<~  $\preceq$ #⪯# *)
(** printing ~=~  $\sim$ #~# *)
(* printing ===>  $\longmapsto$ *)
(** printing ===>  $\Downarrow$ #⇓# *)
(** printing [[  $[$ *)
(** printing ]]  $]$ *)
(** printing \\  $\backslash$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(** printing mkc_base    $\mathtt{Base}$ *)
(** printing mkc_int     $\intg$ *)
(** printing mkc_integer $\mathtt{int}$ *)

Lemma eq_term_equals_sym_tsp {p} :
  forall lib (ts : cts(p)) eqa (eqb : per-fam(eqa))
         a1 a2
         (e : eqa a1 a1) (e1 : eqa a1 a2) (e2 : eqa a2 a1)
         v1 B1 v2 B2,
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       type_sys_props lib ts
                      (substc a1 v1 B1)
                      (substc a2 v2 B2)
                      (eqb a1 a2 e))
    -> eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)
       # eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)
       # eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2).
Proof.
  introv ftspb.
  (* 1 *)
  assert (eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)) as eqt1.

  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a1 a2 e1); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v2 B2) tygt.
  apply uv2 in tygt; sp.

  (* 2 *)
  assert (eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)) as eqt2.

  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a2 a1 e2); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.

  generalize (tygs (substc a1 v1 B1) (substc a1 v2 B2) (eqb a1 a1 e)); intro i.
  repeat (dest_imp i h); repnd.
  rw i in tygt.
  rev_implies_ts_or (substc a2 v1 B1) tygt.
  apply uv2 in tygt; sp.

  (* 3 *)
  assert (eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)) as eqt3.
  apply eq_term_equals_trans with (eq2 := eqb a1 a1 e); sp.
  apply eq_term_equals_sym; sp.

  sp.
Qed.

Lemma eq_term_equals_sym_tsp2 {p} :
  forall lib
         (ts : cts(p))
         (eqa : per)
         (eqb : per-fam(eqa))
         v1 B1 v2 B2,
    term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e))
     # (forall a1 a2 (e2 : eqa a2 a1) (e : eqa a1 a1),
          eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e))
     # (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa a2 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)).
Proof.
  introv teta ftspb.

  (* 1 *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)) as eqt1.
  intros.
  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a1 a2 e1); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v2 B2) tygt.
  apply uv2 in tygt; sp.

  (* 2 *)
  assert (forall a1 a2 (e2 : eqa a2 a1) (e : eqa a1 a1),
            eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)) as eqt2.
  intros.
  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a2 a1 e2); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.

  generalize (tygs (substc a1 v1 B1) (substc a1 v2 B2) (eqb a1 a1 e)); intro i.
  repeat (dest_imp i h); repnd.
  rw i in tygt.
  rev_implies_ts_or (substc a2 v1 B1) tygt.
  apply uv2 in tygt; sp.

  (* 3 *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa a2 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)) as eqt3.
  intros.
  assert (eqa a1 a1) as e by (apply teta with (t2 := a2); sp).
  apply eq_term_equals_trans with (eq2 := eqb a1 a1 e); sp.
  apply eq_term_equals_sym; sp.

  sp.
Qed.

Lemma type_sys_props_eqb_comm {p} :
  forall lib (ts : cts(p)) eqa (eqb : per-fam(eqa))
         a1 a2
         (e : eqa a1 a2) (e1 : eqa a2 a1) (e2 : eqa a1 a1) (e3 : eqa a2 a2)
         v1 B1 v2 B2,
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       type_sys_props lib ts (substc a1 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e))
    -> type_sys_props lib ts (substc a2 v1 B1) (substc a1 v2 B2) (eqb a1 a2 e).
Proof.
  introv e1 e2 e3 ftspb.

  generalize (eq_term_equals_sym_tsp lib ts eqa eqb a2 a1 e3 e1 e
                                     v1 B1 v2 B2); intro i.
  dest_imp i h.
  destruct i as [eqtb2 i].
  destruct i as [eqtb1 eqtb3].

  prove_type_sys_props Case; intros; try (complete sp).

  - Case "uniquely_valued".
    repdors.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    implies_ts_or_eq (substc a2 v1 B1) T3 (substc a1 v2 B2) h.
    apply uv2 in h.
    apply eq_term_equals_trans with (eq2 := eqb a2 a1 e1); sp.
    apply eq_term_equals_sym; sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    rev_implies_ts_or_eq (substc a1 v2 B2) T3 (substc a2 v1 B1) h.
    apply uv2 in h.
    apply eq_term_equals_trans with (eq2 := eqb a2 a1 e1); sp.
    apply eq_term_equals_sym; sp.

  - Case "type_symmetric".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyst2 T3 (eqb a1 a2 e)); intro i.
    dest_imp i h; repnd.
    generalize (tyt2 T3 (eqb a1 a2 e)); intro j.
    dest_imp j h; repnd.
    generalize (tys2 (substc a2 v1 B1) T3 eq'); intro k.
    repeat (dest_imp k h).
    apply eq_term_equals_trans with (eq2 := eqb a1 a2 e); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyt2 T3 (eqb a1 a2 e)); intro i.
    dest_imp i h; repnd.
    generalize (tyst2 T3 (eqb a1 a2 e)); intro j.
    dest_imp j h; repnd.
    generalize (tys2 (substc a1 v2 B2) T3 eq'); intro k.
    repeat (dest_imp k h).
    apply eq_term_equals_trans with (eq2 := eqb a1 a2 e); sp.

  - Case "type_transitive".
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyt2 T3 eq'); intro k.
    dest_imp k h; repnd; sp.

  - Case "type_stransitive".
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyst2 T3 eq'); intro k.
    dest_imp k h; repnd; sp.

  - Case "type_value_respecting".

    repdors; subst.

    (* 1 *)
    generalize (ftspb a2 a2 e3); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyvr2 (substc a2 v1 B1) T3); intro i.
    dest_imp i h.
    dest_imp i h.

    generalize (ftspb a1 a2 e); intro j.
    onedtsp uv3 tys3 tyt3 tyst3 tyvr3 tes3 tet3 tevr3 tygs3 tygt3 dum3.
    generalize (tygs3 (substc a1 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e)); intro k.
    repeat (dest_imp k h); repnd.
    rw k in tygt3.
    rev_implies_ts_or (substc a2 v1 B1) tygt3.
    apply uv2 in tygt3.
    generalize (tys2 (substc a2 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e)); intro l.
    dest_imp l h.

    (* 2 *)
    generalize (ftspb a1 a1 e2); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyvr2 (substc a1 v2 B2) T3); intro i.
    dest_imp i h.
    dest_imp i h.

    generalize (ftspb a1 a2 e); intro j.
    onedtsp uv3 tys3 tyt3 tyst3 tyvr3 tes3 tet3 tevr3 tygs3 tygt3 dum3.
    implies_ts_or (substc a1 v2 B2) tygt3.
    apply uv2 in tygt3.
    generalize (tys2 (substc a1 v1 B1) T3 (eqb a1 a2 e)); intro l.
    dest_imp l h.

  - Case "term_symmetric".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "term_transitive".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "term_value_respecting".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "type_gsymmetric".
    repdors; subst.
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "type_gtransitive".

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tys2 (substc a2 v1 B1) (substc a1 v2 B2) (eqb a2 a1 e1)); sp.

(*
  - Case "type_gtransitive".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tygt2 (substc a2 v1 B1) T3 T4 eq1 eq2); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tygt2 (substc a1 v2 B2) T3 T4 eq1 eq2); sp.
*)

  - Case "type_mtransitive".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
    generalize (tymt2 (substc a2 v1 B1) T3 T4 eq1 eq2); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
    generalize (tymt2 (substc a1 v2 B2) T3 T4 eq1 eq2); sp.
Qed.

Lemma eq_term_equals_type_family {p} :
  forall lib (T1 T2 : @CTerm p) eqa1 eqa2 eqb1 eqb2 ts A v B A' v' B'
         (C : CTerm -> forall v : NVar, CVTerm [v] -> CTerm),
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> computes_to_valc lib T1 (C A v B)
    -> type_sys_props lib ts A A' eqa2
    -> (forall (a a' : CTerm) (e : eqa2 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb2 a a' e))
    -> eq_term_equals eqa2 eqa1
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2))
       # type_family lib C ts T1 T2 eqa2 eqb2
       # type_family lib C ts T2 T1 eqa2 eqb2.
Proof.
  introv c1 c2 tf co1 tspa ftspb; introv.
  unfold type_family in tf; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.

  (* First clause *)
  assert (eq_term_equals eqa2 eqa1) as eqta.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  apply uv with (T3 := A'0); sp.

  (* Second clause *)
  assert (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
             eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as feqtb.
  intros.
  generalize (t0 a1 a2 e1); intro ts1.
  assert (ts (substc a1 v0 B0) (substc a2 v' B') (eqb2 a1 a2 e2))
         as ts2
         by (generalize (ftspb a1 a2 e2); intro i;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (ftspb a1 a2 e2); intro tsp.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  implies_ts_or (substc a2 v' B') ts1.
  apply uv in ts1.
  apply eq_term_equals_sym; auto.

  (* Third clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2)) as feqtb1.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  assert (ts (substc a1 v0 B0) (substc a2 v' B') (eqb2 a1 a2 e2))
         as ts1
         by (generalize (ftspb a1 a2 e2); intro i;
             onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp).
  implies_ts_or (substc a1 v' B') ts1.
  apply uv in ts1; sp.

  (* Fourth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2)) as feqtb2.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (ftspb a2 a1 e2); intro tsp2.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  assert (ts (substc a2 v0 B0) (substc a1 v' B') (eqb2 a2 a1 e2))
         as ts1
         by (generalize (ftspb a2 a1 e2); intro i;
             onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp).
  apply tygs2 in ts1; sp.
  rev_implies_ts_or (substc a1 v0 B0) ts1.
  apply uv in ts1; sp.

  (* Fifth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2)) as feqtb3.
  intros.
  assert (eqa2 a1 a1)
         as e11
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  generalize (feqtb1 a1 a2 e11 e1); intro tsp1.
  generalize (feqtb2 a1 a2 e11 e2); intro tsp2.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e11); sp.
  apply eq_term_equals_sym; auto.

  (* this gets the first non type_family clauses *)
  sp.

  (* we prove the first type_family *)
  unfold type_family.
  exists A0 A'0 v0 v'0 B0 B'0; sp; spcast; sp.

  apply (type_sys_props_ts_uv2 lib) with (C := A') (eq1 := eqa1); sp.

  assert (eqa1 a a') as e' by (rw <- eqta; auto).
  generalize (feqtb a a' e' e); intro eqtb.
  generalize (ftspb a a' e); intro tspb.
  apply (type_sys_props_ts_uv2 lib) with (C := substc a' v' B') (eq1 := eqb1 a a' e'); sp.

  (* we prove the second type_family *)
  unfold type_family.
  exists A'0 A0 v'0 v0 B'0 B0; sp; spcast; sp.

  assert (ts A0 A'0 eqa2)
         as i by (apply (type_sys_props_ts_uv2 lib) with (C := A') (eq1 := eqa1); sp).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tygs A0 A'0 eqa2); intro j; dest_imp j h.
  rw <- j; sp.

  assert (eqa1 a' a)
         as e1
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             auto).
  assert (eqa2 a' a) as e2 by (rw eqta; auto).
  generalize (t0 a' a e1); intro tsb1.
  generalize (feqtb a' a e1 e2); intro eqtb.
  generalize (ftspb a' a e2); intro tspb.

  assert (ts (substc a' v0 B0) (substc a v'0 B'0) (eqb2 a a' e))
         as i
         by (apply (type_sys_props_ts_uv3 lib) with (C := substc a v' B') (eq1 := eqb1 a' a e1) (eq2 := eqb2 a' a e2); sp).
  apply (type_sys_props_ts_sym3 lib) with (C := substc a v' B') (eq1 := eqb2 a' a e2); sp.
Qed.

Lemma eq_term_equals_type_family2 {p} :
  forall lib (T1 T2 : @CTerm p) eqa1 eqa2 eqb1 eqb2 ts A v B A' v' B'
         (C : CTerm -> forall v : NVar, CVTerm [v] -> CTerm),
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> computes_to_valc lib T2 (C A v B)
    -> type_sys_props lib ts A A' eqa2
    -> (forall (a a' : CTerm) (e : eqa2 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb2 a a' e))
    -> eq_term_equals eqa2 eqa1
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2))
       # type_family lib C ts T1 T2 eqa2 eqb2
       # type_family lib C ts T2 T1 eqa2 eqb2.
Proof.
  introv c1 c2 tf co1 tspa ftspb; introv.
  unfold type_family in tf; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  generalize (type_sys_props_ts_refl lib ts A'0 A' eqa2); intro k; dest_imp k h; repnd.

  (* First clause *)
  assert (eq_term_equals eqa2 eqa1) as eqta.
  apply (type_sys_props_eq_term_equals lib) with (ts := ts) (A := A0) (B := A'0) (C := A'); sp.

  (* Second clause *)
  assert (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
             eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as feqtb.
  intros.
  assert (eqa1 a1 a1)
         as e3
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  assert (eqa2 a1 a1)
         as e4
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  assert (eqa2 a2 a1)
         as e5 by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (t0 a1 a2 e1); intro ts1.
  generalize (ftspb a2 a1 e5); intro i.
  generalize (eq_term_equals_sym_tsp lib ts eqa2 eqb2 a1 a2 e4 e2 e5 v'0 B'0 v' B' ftspb); intro l; repnd.
  apply eq_term_equals_trans with (eq2 := eqb2 a2 a1 e5).
  apply eq_term_equals_sym.
  apply (type_sys_props_eq_term_equals lib)
        with (ts := ts) (A := substc a1 v0 B0) (B := substc a2 v'0 B'0) (C := substc a1 v' B'); sp.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e4); sp.
  apply eq_term_equals_sym; sp.

  (* Third clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2)) as feqtb1.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  generalize (ftspb a1 a2 e2); intro tsp2.
  apply type_sys_props_ts_refl in tsp1; repnd.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  implies_ts_or (substc a2 v' B') tsp0.
  apply uv in tsp0; sp.
  apply eq_term_equals_sym; sp.

  (* Fourth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2)) as feqtb2.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  generalize (ftspb a2 a1 e2); intro tsp2.
  apply type_sys_props_ts_refl in tsp1; repnd.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  rev_implies_ts_or (substc a2 v'0 B'0) tsp1.
  apply uv in tsp1; sp.
  apply eq_term_equals_sym; sp.

  (* Fifth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2)) as feqtb3.
  intros.
  assert (eqa2 a1 a1)
         as e11
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  generalize (feqtb1 a1 a2 e11 e1); intro tsp1.
  generalize (feqtb2 a1 a2 e11 e2); intro tsp2.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e11); sp.
  apply eq_term_equals_sym; auto.

  (* this gets the first non type_family clauses *)
  sp.

  (* we prove the first type_family *)
  unfold type_family.
  exists A0 A'0 v0 v'0 B0 B'0; sp; spcast; sp.

  apply (type_sys_props_ts_uv lib) with (C := A') (eq1 := eqa1); sp.

  assert (eqa1 a a') as e1 by (rw <- eqta; auto).
  assert (eqa2 a' a)
         as e2
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (ftspb a' a e2); intro i.

  generalize (t0 a a' e1); intro j.
  apply (type_sys_props_ts_uv4 lib) with (C := substc a v' B') (eq1 := eqb1 a a' e1) (eq2 := eqb2 a' a e2); sp.

  (* we prove the second type_family *)
  unfold type_family.
  exists A'0 A0 v'0 v0 B'0 B0; sp; spcast; sp.

  assert (ts A0 A'0 eqa2)
         as i by (apply (type_sys_props_ts_uv lib) with (C := A') (eq1 := eqa1); sp).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tygs A'0 A0 eqa2); intro j; dest_imp j h.
  rw j; sp.

  assert (eqa1 a' a)
         as e1
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             auto).
  assert (eqa2 a' a) as e2 by (rw eqta; auto).
  generalize (t0 a' a e1); intro tsb1.
  generalize (ftspb a a' e); intro tspb.

  assert (ts (substc a' v0 B0) (substc a v'0 B'0) (eqb2 a a' e))
         as i
         by (apply (type_sys_props_ts_uv4 lib) with (C := substc a' v' B') (eq1 := eqb1 a' a e1) (eq2 := eqb2 a a' e); sp).
  apply (type_sys_props_ts_sym2 lib) with (C := substc a' v' B') (eq1 := eqb2 a a' e); sp.
Qed.

Lemma type_family_trans {p} :
  forall lib C (ts : cts(p)) T1 T2 T3 eqa eqb eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc lib T1 (C A v B)
    -> computes_to_valc lib T2 (C A' v' B')
    -> type_sys_props lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb a a' e))
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> type_family lib C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa eqa1
       # eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa1 a1 a2),
            eq_term_equals (eqb a1 a2 e1) (eqb1 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family lib C ts T1 T3 eqa eqb.
Proof.
  introv c1 c2 co1 co2 tspa ftspb tf1 tf2.
  allunfold @type_family; exrepnd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  (* We prove the first clause *)
  assert (eq_term_equals eqa eqa1)
         as eqta1
         by (generalize (uv A' eqa1); sp).

  (*  *)
  assert (eq_term_equals eqa eqa2)
         as eqta2 by (generalize (uv A'0 eqa2); sp).

  (* We prove the second clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta3
         by (apply eq_term_equals_trans with (eq2 := eqa); sp;
             apply eq_term_equals_sym; sp).

  (* We prove the third clause *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa1 a1 a2),
            eq_term_equals (eqb a1 a2 e1) (eqb1 a1 a2 e2)) as eqtb1.
  intros.
  generalize (tf1 a1 a2 e2); intro ts1.
  generalize (ftspb a1 a2 e1); intro tsp.
  apply (type_sys_props_eq_term_equals2 lib)
        with (ts := ts) (A := substc a1 v B) (B := substc a2 v' B') (C := substc a1 v B); sp.

  (* *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb2 a2 a1 e2)) as eqtb2.
  intros.
  generalize (tf2 a2 a1 e2); intro ts1.
  generalize (ftspb a1 a2 e1); intro tsp.
  apply (type_sys_props_eq_term_equals3 lib)
        with (ts := ts) (A := substc a1 v'0 B'0) (B := substc a2 v' B') (C := substc a1 v B); sp.

  (* *)
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v B v' B' tet ftspb); intro i; repnd.

  (* We prove the fourth clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as eqtb3.
  intros.
  assert (eqa a1 a2) as e3 by (rw eqta1; auto).
  assert (eqa a2 a1) as e4 by sp.
  generalize (eqtb1 a1 a2 e3 e1); intro k.
  generalize (eqtb2 a2 a1 e4 e2); intro l.
  apply eq_term_equals_trans with (eq2 := eqb a1 a2 e3); sp.
  apply eq_term_equals_sym; sp.
  apply eq_term_equals_trans with (eq2 := eqb a2 a1 e4); sp.

  (* We prove the third clause *)
  sp.

  exists A A'0 v v'0 B B'0; sp; spcast; sp.
  generalize (tyt A'0 eqa2); sp.

  assert (eqa a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e3 by (rw <- eqta2; auto).
  assert (eqa1 a a') as e4 by (rw <- eqta1; auto).

  generalize (tf1 a a' e4); intro ts1.
  generalize (tf2 a' a' e3); intro ts2.
  generalize (ftspb a a' e); intro tspb.

  apply (type_sys_props_ts_trans lib) with (B := substc a' v' B') (eq1 := eqb1 a a' e4) (eq2 := eqb2 a' a' e3); sp.
Qed.

Lemma type_sys_props_eq {p} :
  forall lib (ts : cts(p)) A B C eq1 eq2,
    type_sys_props lib ts A C eq1
    -> type_sys_props lib ts B C eq2
    -> ts A B eq1.
Proof.
  introv tsp1 tsp2.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
  generalize (tygs B C eq2); intro i; dest_imp i h.
  rw i in tygt.
  generalize (tyt2 B eq2); sp.
Qed.

Lemma type_sys_props_ts_trans2 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts A C eq2
    -> type_sys_props lib ts A D eq
    -> ts B C eq.
Proof.
  introv ts1 ts2 tsp.
  generalize (type_sys_props_ts_uv2 lib ts B A D eq1 eq); intro i; repeat (dest_imp i h).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tygs A B eq); intro j; dest_imp j h.
  rw j in i.
  generalize (tymt A B C eq eq2); sp.
Qed.

Lemma type_sys_props_ts_trans3 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts B D eq
    -> ts A C eq1.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tymt B A C eq1 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans4 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts B D eq
    -> ts A C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tymt B A C eq1 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans5 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts A C eq2
    -> type_sys_props lib ts A D eq
    -> ts B C eq1 # ts B C eq2 # ts C C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tygs A B eq1); intro j; dest_imp j h.
  generalize (tygs A C eq2); intro i; dest_imp i h.
  rw j in ts1.
  applydup i in ts2 as ts3.
  generalize (tymt A B C eq1 eq2); sp;
  generalize (tymt A C C eq2 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans6 {p} :
  forall lib (ts : cts(p)) A B C eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts A B eq
    -> ts A C eq1 # ts A C eq2 # ts C C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tyt C eq2); sp.
  generalize (dum B A C eq1 eq2); sp.
Qed.

Lemma type_family_refl {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_sys_props lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_sys_props lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> computes_to_valc lib T1 (C A v B)
    -> type_family lib C ts T1 T2 eqa eqb
    -> type_family lib C ts T1 T1 eqa eqb
       # type_family lib C ts T2 T2 eqa eqb.
Proof.
  introv c1 c2 tspa tspb co1 tf.
  allunfold @type_family; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.

  dands.

  exists A A v v B B; sp; spcast; sp.

  generalize (type_sys_props_ts_refl lib ts A A' eqa); sp.

  assert (eqa a' a')
         as e'
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt;
             apply tet with (t2 := a); sp).
  generalize (tspb a a' e); intro i.
  generalize (tspb a' a' e'); intro j.
  apply (type_sys_props_eq lib) with (C := substc a' v' B') (eq2 := eqb a' a' e'); sp.

  exists A'0 A'0 v'0 v'0 B'0 B'0; sp; spcast; sp.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tyst A'0 eqa); sp.

  assert (eqa a a)
         as e'
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt;
             apply tet with (t2 := a'); sp).
  generalize (tspb a a' e); intro i.
  generalize (t0 a a' e); intro j.
  generalize (t0 a a e'); intro k.

  generalize (type_sys_props_ts_trans2 lib ts (substc a v B) (substc a v'0 B'0) (substc a' v'0 B'0) (substc a' v' B') (eqb a a e') (eqb a a' e) (eqb a a' e)); sp.
Qed.

(*
Lemma type_family_trans :
  forall C ts T1 T2 T3 eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc T1 (C A v B)
    -> type_sys_props ts A A' eqa1
    -> (forall (a a' : CTerm) (e : eqa1 a a'),
          type_sys_props ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb1 a a' e))
    -> type_family C ts T1 T2 eqa1 eqb1
    -> type_family C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family C ts T1 T3 eqa1 eqb1.
Proof.
  introv c1 c2 co tspa ftspb tf1 tf2.
  allunfold type_family; exrepnd.
  computes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  computes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  (* We prove the first clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta
         by (generalize (tygt A A'1 A'0 eqa1 eqa2); sp;
             apply uv with (T3 := A'0); sp).

  (* We prove the second clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)).
  intros.
  assert (eqa1 a1 a1) as e3 by (apply tet with (t2 := a2); auto).
  generalize (tf1 a1 a1 e3); intro ts1.
  generalize (tf2 a1 a2 e2); intro ts2.
  generalize (ftspb a1 a2 e1); intro tsp.

  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tygt2 (substc a1 v B)
                    (substc a1 v'1 B'1)
                    (substc a2 v'0 B'0)
                    (eqb1 a1 a1 e3)
                    (eqb2 a1 a2 e2)); sp.
  implies_ts_or (substc a2 v' B') X.
  apply uv2 in X; sp.

  (* We prove the third clause *)
  sp.

  exists A A'0 v v'0 B B'0; sp.
  generalize (tygt A A'1 A'0 eqa1 eqa2); sp.

  assert (eqa1 a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e2 by (rw <- eqta; sp).

  generalize (tf1 a a' e); intro ts1.
  generalize (tf2 a' a' e2); intro ts2.
  generalize (ftspb a a' e); intro tspb.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tygt2 (substc a v B)
                    (substc a' v'1 B'1)
                    (substc a' v'0 B'0)
                    (eqb1 a a' e)
                    (eqb2 a' a' e2)); sp.
Qed.
*)

Lemma type_family_trans2 {p} :
  forall lib C (ts : cts(p)) T1 T2 T3 eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc lib T2 (C A v B)
    -> type_sys_props lib ts A A' eqa1
    -> (forall (a a' : CTerm) (e : eqa1 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb1 a a' e))
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> type_family lib C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family lib C ts T1 T3 eqa1 eqb1.
Proof.
  introv c1 c2 co tspa ftspb tf1 tf2.
  allunfold @type_family; exrepnd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.

  (* We prove the first clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta
         by (implies_ts_or A' tf4; apply uv in tf4; sp).

  (* We prove the second clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)).
  intros.
  generalize (tf2 a1 a2 e2); intro ts2.
  generalize (ftspb a1 a2 e1); intro tsp.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v' B') ts2.
  apply uv2 in ts2; sp.

  (* We prove the third clause *)
  sp.

  exists A1 A'0 v1 v'0 B1 B'0; sp; spcast; sp.
  generalize (tymt A A1 A'0 eqa1 eqa2); sp.

  assert (eqa1 a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e2 by (rw <- eqta; sp).

  generalize (tf1 a a' e); intro ts1.
  generalize (tf2 a' a' e2); intro ts2.
  generalize (ftspb a' a' e1); intro tspb.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
  generalize (tymt2 (substc a' v B)
                    (substc a v1 B1)
                    (substc a' v'0 B'0)
                    (eqb1 a a' e)
                    (eqb2 a' a' e2)); sp.
Qed.

Lemma type_family_cequivc {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A1 v1 B1 A2 v2 B2 A v B,
    cequivc lib T1 T2
    -> computes_to_valc lib T1 (C A1 v1 B1)
    -> computes_to_valc lib T2 (C A2 v2 B2)
    -> cequivc lib A1 A2
    -> bcequivc lib [v1] B1 [v2] B2
    -> ts A1 A eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v B)
                         (eqb a1 a2 e))
    -> type_sys_props lib ts A1 A eqa
    -> type_family lib C ts T1 T2 eqa eqb.
Proof.
  introv ceq co1 co2 ca cb tsa ftspb tspa.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  unfold type_family.
  exists A1 A2 v1 v2 B1 B2; sp; spcast; sp.

  assert (eqa a' a') as e' by (apply tet with (t2 := a); sp).

  generalize (ftspb a' a' e'); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tyvr2 (substc a' v1 B1) (substc a' v2 B2)); intro k.
  dest_imp k h.
  dest_imp k h.
  apply bcequivc1 with (t := a') in cb; auto.

  generalize (ftspb a a' e); intro i.
  generalize (ftspb a' a' e'); intro j.

  generalize (type_sys_props_eq lib ts (substc a v1 B1) (substc a' v1 B1) (substc a' v B) (eqb a a' e) (eqb a' a' e')); intro l; repeat (dest_imp l h).
  generalize (type_sys_props_ts_trans3 lib ts (substc a v1 B1) (substc a' v1 B1) (substc a' v2 B2) (substc a' v B) (eqb a a' e) (eqb a' a' e') (eqb a' a' e')); sp.
Qed.

Lemma type_family_cequivc2 {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A1 v1 B1 A2 v2 B2 A v B,
    cequivc lib T1 T2
    -> computes_to_valc lib T1 (C A1 v1 B1)
    -> computes_to_valc lib T2 (C A2 v2 B2)
    -> cequivc lib A1 A2
    -> bcequivc lib [v1] B1 [v2] B2
    -> ts A A1 eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v B)
                         (substc a2 v1 B1)
                         (eqb a1 a2 e))
    -> type_sys_props lib ts A A1 eqa
    -> type_family lib C ts T1 T2 eqa eqb.
Proof.
  introv ceq co1 co2 ca cb tsa ftspb tspa.

  apply @type_family_cequivc
        with
        (A1 := A1)
        (v1 := v1)
        (B1 := B1)
        (A2 := A2)
        (v2 := v2)
        (B2 := B2)
        (A := A)
        (v := v)
        (B := B); sp;
  try (complete (apply (type_sys_props_sym lib); sp)).

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp.

  assert (eqa a2 a1) as e1 by sp.
  assert (eqa a1 a1) as e2 by (apply tet with (t2 := a2); sp).
  assert (eqa a2 a2) as e3 by (apply tet with (t2 := a1); sp).

  apply type_sys_props_sym; sp.
  apply type_sys_props_eqb_comm; sp.
Qed.

(*
Lemma type_family_eq_term_equals :
  forall T1 T2 eqa1 eqa2 eqb1 eqb2 ts C,
    (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
       eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
    -> type_family C ts T1 T2 eqa1 eqb1
    -> eq_term_equals eqa2 eqa1
    -> type_family C ts T1 T2 eqa2 eqb2.
Proof.
  introv feqtb tf eqta.
  allunfold type_family; exrepd.
  exists A A' v v' B B'; sp.
Qed.
*)

Lemma is_per_iff {p} :
  forall eq1 eq2,
    (forall x y : @CTerm p, inhabited (eq1 x y) <=> inhabited (eq2 x y))
    -> is_per eq1
    -> is_per eq2.
Proof.
  unfold is_per; introv iff isper1.
  destruct isper1 as [sym tran]; sp.
  discover; sp.
  apply iff.
  apply tran with (y := y); sp; apply iff; sp.
Qed.

Lemma eq_term_equals_implies_inhabited {p} :
  forall a b,
    @eq_term_equals p a b
    -> (inhabited a <=> inhabited b).
Proof.
  unfold eq_term_equals, inhabited; sp; split; sp; exists t.
  allrw <-; sp.
  allrw; sp.
Qed.

Lemma is_per_sym {p} :
  forall (a b : @CTerm p) eq,
    is_per eq
    -> inhabited (eq a b)
    -> inhabited (eq b a).
Proof.
  introv isper inh.
  allunfold @is_per; sp.
Qed.

Lemma is_per_trans {p} :
  forall (a b c : @CTerm p) eq,
    is_per eq
    -> inhabited (eq a b)
    -> inhabited (eq b c)
    -> inhabited (eq a c).
Proof.
  introv isper inh.
  allunfold @is_per; sp.
  generalize (isper a b c); sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals {p} :
  forall lib (ts : cts(p)) R eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R x y) (mkc_apply2 R x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R x y) (mkc_apply2 R x y) (eq2 x y))
    -> (forall x y, eq_term_equals (eq1 x y) (eq2 x y)).
Proof.
  introv tsp tseq; intros.
  generalize (tseq x y); intro j.
  generalize (tsp x y); intro k.
  repeat (dest_imp k h).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  implies_ts_or (mkc_apply2 R x y) j.
  apply uv in j; sp.
Qed.

Lemma weq_eq_term_equals {p} :
  forall lib (eqa1 eqa2 : per(p))
         eqb1 eqb2 t1 t2,
    (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
       eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
    -> eq_term_equals eqa1 eqa2
    -> weq lib eqa1 eqb1 t1 t2
    -> weq lib eqa2 eqb2 t1 t2.
Proof.
  introv eqbeq eqaeq weqt.
  induction weqt as [t t' a f a' f' e c c' h h'].
  duplicate e as e'.
  rw eqaeq in e.
  apply @weq_cons with (a := a) (a' := a') (f := f) (f' := f') (e := e); sp.
  apply h'.
  generalize (eqbeq a a' e' e); intro eqb.
  rw eqb; sp.
Qed.

Lemma weq_sym {p} :
  forall lib eqa eqb t1 t2 v1 v2 B1 B2 (ts : cts(p)),
    term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t1 t2
    -> weq lib eqa eqb t2 t1.
Proof.
  introv teqsa teqta ftsp weq1.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  duplicate e as e'.
  apply teqsa in e.
  apply @weq_cons with (a := a') (f := f') (a' := a) (f' := f) (e := e); sp.
  apply h'; sp.
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2); introv i.
  dest_imp i hyp; sp.
  generalize (i a a' e' e); intro eqeb.
  rw eqeb.
  generalize (ftsp a' a e); intro tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp.
Qed.

Lemma eq_family_trans1 {p} :
  forall lib eqa eqb
         a a1 a2 t1 t2
         ts v1 B1 v2 B2
         (e1 : eqa a a1) (e2 : eqa a a2),
    (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
       type_sys_props lib ts
                      (substc a1 v1 B1)
                      (substc a2 v2 B2)
                      (eqb a1 a2 e))
    -> eqb a a1 e1 t1 t2
    -> eqb a a2 e2 t1 t2.
Proof.
  introv ftsp eqb1.
  generalize (ftsp a a1 e1); intro tsp1.
  onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
  generalize (ftsp a a2 e2); intro tsp2.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.
  generalize (uv2 (substc a1 v2 B2) (eqb a a1 e1)); intro i; sp.
  rw i; sp.
Qed.

Lemma weq_trans {p} :
  forall lib eqa eqb t1 t2 t3 ts v1 B1 v2 B2,
    term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t1 t2
    -> weq lib eqa eqb t2 t3
    -> weq lib eqa eqb t1 t3.
Proof.
  introv teqsa teqta ftsp weq1.
  generalize t3; clear t3.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  introv weq2.
  inversion weq2 as [x g a'0 f'0 e0 d d' h1].
  ccomputes_to_eqval.
  assert (eqa a a'0) as e' by (apply teqta with (t2 := a'); sp).
  apply @weq_cons with (a := a) (f := f) (a' := a'0) (f' := f'0) (e := e');
    try (complete (spcast; sp)); introv hyp.
  apply h' with (b' := b'); sp.
  apply (eq_family_trans1 lib) with (a1 := a'0) (ts := ts) (v1 := v1) (B1 := B1) (v2 := v2) (B2 := B2) (e1 := e'); sp.
  apply h1.
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2); intro i; sp.
  duplicate e0 as e1.
  apply teqsa in e0.
  duplicate e' as e2.
  apply teqsa in e'.
  generalize (i a' a'0 e1 e0); intro eq1.
  rw eq1.
  generalize (i a a'0 e2 e'); intro eq2.
  rw eq2 in hyp.
  apply (eq_family_trans1 lib) with (a1 := a) (ts := ts) (v1 := v1) (B1 := B1) (v2 := v2) (B2 := B2) (e1 := e'); sp.
  generalize (ftsp a'0 a e'); intro tsp.
  onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
  apply tet1 with (t2 := b); sp.
Qed.

(*
Lemma weq_cequivc2 :
  forall eqa eqb ts v1 B1 v2 B2 a a' e f f' b b',
    term_equality_respecting eqa
    -> term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq eqa eqb (mkc_apply f b) (mkc_apply f b)
    -> eqb a a' e b b'
    -> cequivc f f'
    -> weq eqa eqb (mkc_apply f b) (mkc_apply f' b').
Proof.
  introv tera tesa teta ftspb weq1 eqb1 ceq.
  generalize f' b' eqb1 ceq; clear ceq eqb1 b' f'.
  remember (mkc_apply f b).
  generalize Heqc; clear Heqc.
  induction weq1.
  introv eq eqb1 ceq; subst.
  generalize (cequivc_mkc_sup t' t'0 a' f'); intros i.
  repeat (dest_imp i hyp); exrepnd.
  rename b' into f'0.
  unfold term_equality_respecting in tera.
  generalize (tera a' a'0); intro j.
  repeat (dest_imp j hyp).
  apply teta with (t2 := a); sp.
  apply weq_cons with (a := a') (f := f') (a' := a'0) (f' := f'0) (e := j); sp.
  apply X with (b := b'); sp.

  generalize (eq_term_equals_sym_tsp2 ts eqa eqb v1 B1 v2 B2); introv i.
  repeat (dest_imp i hyp); repnd.
  assert (eqa a' a) as e' by sp.
  generalize (i a a' e e'); intro eqt; rw eqt.
  generalize (ftspb a' a e'); intro tspb.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  apply tes.
  generalize (eq_family_trans1 eqa eqb a' a'0 a b b' ts v1 B1 v2 B2 j e'); sp.

Abort.
*)

Lemma weq_cequivc {p} :
  forall lib eqa eqb t t1 t2 ts v1 B1 v2 B2,
    term_equality_respecting lib eqa
    -> term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t t1
    -> cequivc lib t1 t2
    -> weq lib eqa eqb t t2.
Proof.
  introv tera tesa teta ftspb weq1.
  generalize t2; clear t2.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  introv ceq.
  rename t' into t1.
  rename a' into a1.
  rename f' into f1.
  spcast.
  generalize (cequivc_mkc_sup lib t1 t2 a1 f1); intros i.
  repeat (dest_imp i hyp); exrepnd.
  rename a' into a2.
  rename b' into f2.
  unfold term_equality_respecting in tera.
  generalize (tera a1 a2); intro j.
  repeat (dest_imp j hyp); spcast; sp.
  apply teta with (t2 := a); sp.
  generalize (teta a a1 a2); intro k; repeat (dest_imp k hyp).
  apply @weq_cons with (a := a) (f := f) (a' := a2) (f' := f2) (e := k);
    try (complete (spcast; sp)); introv hyp.
  apply h' with (b' := b'); sp.

  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2 teta ftspb); introv i.
  repeat (dest_imp i hyp); repnd.
  assert (eqa a a) as e' by (apply teta with (t2 := a1); sp).
  generalize (i3 a a1 e e'); intro eqt1; rw eqt1.
  generalize (i3 a a2 k e'); intro eqt2; rw eqt2 in hyp; sp.

  apply sp_implies_cequivc_apply; sp.
Qed.

Lemma type_sys_props_cequivc {p} :
  forall lib (ts : cts(p)) A B C eq,
    type_sys_props lib ts A B eq
    -> cequivc lib A C
    -> ts A C eq.
Proof.
  introv tsp ceq.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tyvr A C); sp.
Qed.

Lemma iff_inhabited_if_eq_term_equals {p} :
  forall (eq1 eq2 : per(p)), (eq1 <=2=> eq2) -> (inhabited eq1 <=> inhabited eq2).
Proof.
  introv eqs.
  unfold inhabited; split; intro k; exrepnd; exists t;
  generalize (eqs t t); clear eqs; intro eqs;
  allrw; sp; allrw <-; sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals1 {p} :
  forall lib (ts : cts(p)) R R1 R2 eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R x y) (mkc_apply2 R1 x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R x y) (mkc_apply2 R2 x y) (eq2 x y))
    -> (forall x y, (eq1 x y) <=2=> (eq2 x y)).
Proof.
  introv tsp k; intros t1 t2.
  generalize (k t1 t2); clear k; intro k.
  generalize (tsp t1 t2); clear tsp; intro tsp; repeat (autodimp tsp hyp).
  generalize (type_sys_props_eq_term_equals4
                lib ts
                (mkc_apply2 R t1 t2)
                (mkc_apply2 R2 t1 t2)
                (mkc_apply2 R1 t1 t2)
                (eq2 t1 t2) (eq1 t1 t2) k tsp); sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals2 {p} :
  forall lib (ts : cts(p)) R1 R2 R3 eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R2 x y) (mkc_apply2 R3 x y) (eq2 x y))
    -> (forall x y, (eq1 x y) <=2=> (eq2 x y)).
Proof.
  introv tsp k; intros t1 t2.
  generalize (k t1 t2); clear k; intro k.
  generalize (tsp t1 t2); clear tsp; intro tsp; repeat (autodimp tsp hyp).
  generalize (type_sys_props_eq_term_equals3
                lib ts
                (mkc_apply2 R3 t1 t2)
                (mkc_apply2 R2 t1 t2)
                (mkc_apply2 R1 t1 t2)
                (eq2 t1 t2) (eq1 t1 t2) k tsp); sp.
Qed.


(**
  This module defines functions and notations shared by all of the
  modules in this package.

  Copyright (C) 2018 Larry D. Lee Jr. <llee454@gmail.com>

  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU Lesser General Public License as
  published by the Free Software Foundation, either version 3 of the
  License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public
  License along with this program. If not, see
  <https://www.gnu.org/licenses/>.
*)

(**
  The following notations are introduced here
  to simplify sequences of algebraic rewrites
  which would otherwise be expressed as long
  sequences of eq_ind*.
*)

Notation "A || B @ X 'by' E"
  := (eq_ind_r (fun X => B) A E) (at level 40, left associativity).

Notation "A || B @ X 'by' <- H"
  := (eq_ind_r (fun X => B) A (eq_sym H)) (at level 40, left associativity).

(**
  The following notation can be used to define
  equality assertions. These are like unittests
  in that they check that a given expression
  reduces to a given value.
*)
Notation "A =:= B"
  := (eq_refl A : A = B) (at level 90).

(**
  Proves that every boolean value is either true
  or false.
*)
Definition bool_dec0
  :  forall b : bool, {b = true}+{b = false}
  := bool_rect
      (fun b => {b = true}+{b = false})
         (left (true = false) (eq_refl true))
         (right (false = true) (eq_refl false)).


From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
Import ListAutomationNotations.

From Coq Require Import Eqdep_dec PeanoNat Nat.
Require Import Coq.Vectors.Vector.
From Undecidability.Shared.Libs.PSL.Vectors Require Import Vectors.
Require Import EqdepFacts.

Local Notation vec := t.

From Undecidability Require Export FOL.Syntax.Core.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Section fix_signature.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  (* Substitution induction principle for formulas *)

  Fixpoint size {ff : falsity_flag} (phi : form) :=
    match phi with
    | atom _ _ => 0
    | falsity => 0
    | bin b phi psi => S (size phi + size psi)
    | quant q phi => S (size phi)
    end.

  Lemma size_ind {X : Type} (f : X -> nat) (P : X -> Prop) :
    (forall x, (forall y, f y < f x -> P y) -> P x) -> forall x, P x.
  Proof.
    intros H x. apply H.
    induction (f x).
    - intros y. lia.
    - intros y. intros [] % Nat.lt_eq_cases.
      + apply IHn; lia.
      + apply H. injection H0. now intros ->.
  Qed.

  Lemma subst_size {ff : falsity_flag} rho phi :
    size (subst_form rho phi) = size phi.
  Proof.
    revert rho; induction phi; intros rho; cbn; congruence.
  Qed.

  Lemma form_ind_subst' {ff : falsity_flag} :
    forall P : form -> Prop,
      (match ff return ((form Σ_funcs Σ_preds ops ff) -> Prop) -> Prop with
      | falsity_off => fun _ => True
      | falsity_on => fun P' => P' falsity
      end) P ->
      (forall P0 (t : vec term (ar_preds P0)), P (atom P0 t)) ->
      (forall (b0 : binop) (f1 : form), P f1 -> forall f2 : form, P f2 -> P (bin b0 f1 f2)) ->
      (forall (q : quantop) (f2 : form), (forall sigma, P (subst_form sigma f2)) -> P (quant q f2)) ->
      forall (f4 : form), P f4.
  Proof.
    intros P H1 H2 H3 H4 phi. induction phi using (@size_ind _ size).
    destruct phi; cbn in *.
    - easy.
    - apply H2.
    - apply H3; apply H; lia.
    - apply H4. intros sigma. apply H. rewrite subst_size. econstructor.
  Qed.

  Lemma form_ind_subst :
    forall P : form -> Prop,
      P falsity ->
      (forall P0 (t : vec term (ar_preds P0)), P (atom P0 t)) ->
      (forall (b0 : binop) (f1 : form), P f1 -> forall f2 : form, P f2 -> P (bin b0 f1 f2)) ->
      (forall (q : quantop) (f2 : form), (forall sigma, P (subst_form sigma f2)) -> P (quant q f2)) ->
      forall (f4 : form), P f4.
  Proof.
    apply (form_ind_subst' (ff := falsity_on)).
  Qed.

  Lemma form_ind_falsity  (P : form falsity_on -> Prop) :
    P falsity ->
    (forall  (P0 : Σ_preds ) (t : t term (ar_preds P0)), P (atom P0 t)) ->
    (forall  (b0 : binop) (f1 : form), P f1 -> forall f2 : form, P f2 -> P (bin b0 f1 f2)) ->
    (forall (q : quantop) (f2 : form), P f2 -> P (quant q f2)) ->
    forall (f4 : form), P f4.
  Proof.
    intros H1 H2 H3 H4 phi.
    change ((fun ff => match ff with falsity_on => fun phi => P phi | _ => fun _ => True end) falsity_on phi).
    induction phi; try destruct b; [apply H1|easy| apply H2|easy|apply H3|easy|apply H4]. 1: apply IHphi1; assumption. 1: apply IHphi2; assumption. apply IHphi; assumption.
  Qed.

  Lemma form_ind_no_falsity  (P : form falsity_off -> Prop) :
    (forall  (P0 : Σ_preds ) (t : t term (ar_preds P0)), P (atom P0 t)) ->
    (forall  (b0 : binop) (f1 : form), P f1 -> forall f2 : form, P f2 -> P (bin b0 f1 f2)) ->
    (forall (q : quantop) (f2 : form), P f2 -> P (quant q f2)) ->
    forall (f4 : form), P f4.
  Proof.
    intros H2 H3 H4 phi.
    change ((fun ff => match ff with falsity_on => fun phi => True | _ => fun _ => P phi end) falsity_off phi).
    induction phi; try destruct b; [easy|apply H2|easy|apply H3|easy|apply H4|easy].
    1: apply IHphi1; assumption.
    1: apply IHphi2; assumption.
       apply IHphi; assumption.
  Qed.

End fix_signature.

(* ** Substituion lemmas *)

Section Subst.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Lemma subst_term_ext (t : term) sigma tau :
    (forall n, sigma n = tau n) -> t`[sigma] = t`[tau].
  Proof.
    intros H. induction t; cbn.
    - now apply H.
    - f_equal. now apply map_ext_in.
  Qed.

  Lemma subst_term_id (t : term) sigma :
    (forall n, sigma n = var n) -> t`[sigma] = t.
  Proof.
    intros H. induction t; cbn.
    - now apply H.
    - f_equal. now erewrite map_ext_in, map_id.
  Qed.

  Lemma subst_term_var (t : term) :
    t`[var] = t.
  Proof.
    now apply subst_term_id.
  Qed.

  Lemma subst_term_comp (t : term) sigma tau :
    t`[sigma]`[tau] = t`[sigma >> subst_term tau].
  Proof.
    induction t; cbn.
    - reflexivity.
    - f_equal. rewrite map_map. now apply map_ext_in.
  Qed.

  Lemma subst_term_shift (t : term) s :
    t`[↑]`[s..] = t.
  Proof.
    rewrite subst_term_comp. apply subst_term_id. now intros [|].
  Qed.

  Lemma up_term (t : term) xi :
    t`[↑]`[up xi] = t`[xi]`[↑].
  Proof.
    rewrite !subst_term_comp. apply subst_term_ext. reflexivity.
  Qed.

  Lemma up_ext sigma tau :
    (forall n, sigma n = tau n) -> forall n, up sigma n = up tau n.
  Proof.
    destruct n; cbn; trivial.
    unfold funcomp. now rewrite H.
  Qed.

  Lemma up_var sigma :
    (forall n, sigma n = var n) -> forall n, up sigma n = var n.
  Proof.
    destruct n; cbn; trivial.
    unfold funcomp. now rewrite H.
  Qed.

  Lemma up_funcomp sigma tau :
    forall n, (up sigma >> subst_term (up tau)) n = up (sigma >> subst_term tau) n.
  Proof.
    intros [|]; cbn; trivial.
    setoid_rewrite subst_term_comp.
    apply subst_term_ext. now intros [|].
  Qed.

  Lemma subst_ext {ff : falsity_flag} (phi : form) sigma tau :
    (forall n, sigma n = tau n) -> phi[sigma] = phi[tau].
  Proof.
    induction phi in sigma, tau |- *; cbn; intros H.
    - reflexivity.
    - f_equal. apply map_ext. intros s. now apply subst_term_ext.
    - now erewrite IHphi1, IHphi2.
    - erewrite IHphi; trivial. now apply up_ext.
  Qed.

  Lemma subst_id {ff : falsity_flag} (phi : form) sigma :
    (forall n, sigma n = var n) -> phi[sigma] = phi.
  Proof.
    induction phi in sigma |- *; cbn; intros H.
    - reflexivity.
    - f_equal. erewrite map_ext; try apply map_id. intros s. now apply subst_term_id.
    - now erewrite IHphi1, IHphi2.
    - erewrite IHphi; trivial. now apply up_var.
  Qed.

  Lemma subst_var {ff : falsity_flag} (phi : form) :
    phi[var] = phi.
  Proof.
    now apply subst_id.
  Qed.

  Lemma subst_comp {ff : falsity_flag} (phi : form) sigma tau :
    phi[sigma][tau] = phi[sigma >> subst_term tau].
  Proof.
    induction phi in sigma, tau |- *; cbn.
    - reflexivity.
    - f_equal. rewrite map_map. apply map_ext. intros s. apply subst_term_comp.
    - now rewrite IHphi1, IHphi2.
    - rewrite IHphi. f_equal. now apply subst_ext, up_funcomp.
  Qed.

  Lemma subst_shift {ff : falsity_flag} (phi : form) s :
    phi[↑][s..] = phi.
  Proof.
    rewrite subst_comp. apply subst_id. now intros [|].
  Qed.

  Lemma up_form {ff : falsity_flag} xi psi :
    psi[↑][up xi] = psi[xi][↑].
  Proof.
    rewrite !subst_comp. apply subst_ext. reflexivity.
  Qed.

  Lemma up_decompose {ff : falsity_flag} sigma phi :
    phi[up (S >> sigma)][(sigma 0)..] = phi[sigma].
  Proof.
    rewrite subst_comp. apply subst_ext.
    intros [].
    - reflexivity.
    - apply subst_term_shift.
  Qed.

End Subst.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_lhs_top_reduce :
  forall T, subtype t_top T = match T with
                         | t_top => true
                         | t_sel_low x L T2' => subtype t_top T2'
                         | t_sel_equ x L T2' => subtype t_top T2'
                         | _ => false
                         end.
Proof.
  intros.

  remember (subtype t_top T) as sub_fn.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T; auto.
Qed.