Require Import FP.Data.Function.
Require Import FP.Data.Bool.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Ord.
Require Import FP.Relations.RelDec.
Require Import FP.Data.List.

Import FunctionNotation.
Import EqDecNotation.
Import EqvNotation.
Import OrdNotation.
Import ListNotation.
Import BoolNotation.

Section EqDec.
  Context {A} {AED:EqDec A}.

  Fixpoint list_eq_dec (xL:list A) (yL:list A) : bool :=
    match xL, yL with
    | nil, nil => true
    | x::xL', y::yL' => x =! y && list_eq_dec xL' yL'
    | _, _ => false
    end.

  Global Instance list_EqDec : EqDec (list A) := { eq_dec := list_eq_dec }.

  Context {ARDC:RelDecCorrect A eq eq_dec}.

  Global Instance list_Eq_RelDecCorrect : RelDecCorrect (list A) eq eq_dec.
  Admitted.
End EqDec.

Section Eqv.
  Context {A} {AE:Eqv A}.

  Inductive list_eqv : list A -> list A -> Prop :=
    | NilEqv : list_eqv nil nil
    | ConsEqv : forall x y xL yL, x ~= y -> list_eqv xL yL -> list_eqv (x::xL) (y::yL).

  Global Instance list_Eqv : Eqv (list A) := { eqv := list_eqv }.

  Context {AEE:EqvWF A}.

  Global Instance list_Equivalence : EqvWF (list A).
  Admitted.
End Eqv.

Section EqvDec.
  Context {A} {AED:EqvDec A}.

  Fixpoint list_eqv_dec (xL:list A) (yL:list A) : bool :=
    match xL, yL with
    | nil, nil => true
    | x::xL', y::yL' => x ~=! y && list_eqv_dec xL' yL'
    | _, _ => false
    end.

  Global Instance list_EqvDec : EqvDec (list A) := { eqv_dec := list_eqv_dec }.

  Context {AE:Eqv A} {ARDC:RelDecCorrect A eqv eqv_dec}.

  Global Instance list_Eqv_RelDecCorrect : RelDecCorrect (list A) eqv eqv_dec.
  Admitted.
End EqvDec.

Section Ord.
  Context {A} {AE:Eqv A} {AL:Ord A}.

  Inductive list_lt : list A -> list A -> Prop :=
    | NilLte : forall x xL,
        list_lt nil (x::xL)
    | HeadLte : forall x y xL yL,
        x < y -> list_lt (x::xL) (y::yL)
    | TailLte : forall x y xL yL,
        x ~= y -> list_lt xL yL -> list_lt (x::xL) (y::yL).

  Global Instance list_Ord : Ord (list A) := { lt := list_lt }.
End Ord.

Section OrdDec.
  Context {A:Type}.

  Fixpoint list_ord_dec_b (a_ord_dec:A -> A -> comparison) (xL:list A) (yL:list A) : comparison :=
    match xL, yL with
    | nil, nil => Eq
    | nil, _::_ => Lt
    | _::_, nil => Gt
    | x::xL', y::yL' =>
        match x `a_ord_dec` y with
        | Lt => Lt
        | Gt => Gt
        | Eq => list_ord_dec_b a_ord_dec xL' yL'
        end
    end.

  Context {ALD:OrdDec A}.

  Definition list_ord_dec : list A -> list A -> comparison := list_ord_dec_b ord_dec.

  Global Instance list_OrdDec : OrdDec (list A) := { ord_dec := list_ord_dec }.
End OrdDec.


Inductive bin  : Type :=
 | Zero : bin
 | One  : bin.

Definition add ( x : bin ) ( y : bin ) :=
  match x, y  with
  | Zero , _ => y
  | _ , Zero => x
  | One, One => Zero
  end.

Definition sub ( x : bin ) ( y : bin ) := add.

Theorem Closure : forall ( a b : bin ) , exists ( c : bin ) ,
    c = add a b.
Proof.
  intros a b. exists ( add a b).
  reflexivity.
Qed.

Theorem Associativity: forall ( a b c : bin ) ,
   add a  ( add b c ) = add ( add a b ) c.
Proof.
  intros a b c. destruct a. simpl. reflexivity.
  destruct b. unfold add. reflexivity.
  destruct c. simpl. reflexivity. simpl. reflexivity.
Qed.

Theorem Identity_left : forall ( a : bin ) , exists ( e : bin ),
  add e a = a.
Proof.
  intros a. exists Zero. reflexivity.
Qed.

Theorem Identity_right : forall ( a : bin ) , exists ( e : bin ),
  add a e = a.
Proof.
  intros a. exists Zero. destruct a. reflexivity.
  reflexivity.
Qed.

Theorem Inverse_left : forall ( a  : bin ) , exists ( b : bin ),
    add a b = Zero.
Proof.
 intros a. destruct a. exists Zero. reflexivity.
 exists One. reflexivity.
Qed.

Theorem Inverse_righ : forall ( a : bin ), exists ( b : bin ) ,
   add b a = Zero.
Proof.
  intros a. destruct a. exists Zero. reflexivity.
  exists One. reflexivity.
Qed.

Theorem Abelian_group : forall ( a b : bin ),
   add a b = add b a.
Proof.
  intros a b. destruct a.
  assert ( H1 : add Zero b = add b Zero ).
    destruct b. reflexivity. reflexivity.
  apply H1.
  assert ( H2 : add One b = add b One ).
    destruct b. reflexivity. reflexivity.
  apply H2.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependant
    interface [MSetWeakInterface.S] using lists without redundancy. *)

Require Import MSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists

   First, we provide sets as lists which are (morally) without redundancy.
   The specs are proved under the additional condition of no redundancy.
   And the functions returning sets are proved to preserve this invariant. *)

(** ** The set operations. *)

Module Ops (X: DecidableType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) : bool := if l then true else false.

  Fixpoint mem (x : elt) (s : t) : bool :=
    match s with
    | nil => false
    | y :: l =>
           if X.eq_dec x y then true else mem x l
    end.

  Fixpoint add (x : elt) (s : t) : t :=
    match s with
    | nil => x :: nil
    | y :: l =>
        if X.eq_dec x y then s else y :: add x l
    end.

  Definition singleton (x : elt) : t := x :: nil.

  Fixpoint remove (x : elt) (s : t) : t :=
    match s with
    | nil => nil
    | y :: l =>
        if X.eq_dec x y then l else y :: remove x l
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Definition union (s : t) : t -> t := fold add s.

  Definition diff (s s' : t) : t := fold remove s' s.

  Definition inter (s s': t) : t :=
    fold (fun x s => if mem x s' then add x s else s) s nil.

  Definition subset (s s' : t) : bool := is_empty (diff s s').

  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s).

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (s : t) : list elt := s.

  Definition choose (s : t) : option elt :=
     match s with
      | nil => None
      | x::_ => Some x
     end.

End Ops.

(** ** Proofs of set operation specifications. *)

Module MakeRaw (X:DecidableType) <: WRawSets X.
  Include Ops X.

  Section ForNotations.
  Notation NoDup := (NoDupA X.eq).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).

  Definition IsOk := NoDup.

  Class Ok (s:t) : Prop := ok : NoDup s.

  Hint Unfold Ok.
  Hint Resolve @ok.

  Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.

  Ltac inv_ok := match goal with
   | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:Ok nil |- _ => clear H; inv_ok
   | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok.
  Ltac constructors := repeat constructor.

  Fixpoint isok l := match l with
   | nil => true
   | a::l => negb (mem a l) && isok l
  end.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Lemma In_compat : Proper (X.eq==>eq==>iff) In.
  Proof.
  repeat red; intros. subst. rewrite H; auto.
  Qed.

  Lemma mem_spec : forall s x `{Ok s},
   mem x s = true <-> In x s.
  Proof.
  induction s; intros.
  split; intros; inv. discriminate.
  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
  right; rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma isok_iff : forall l, Ok l <-> isok l = true.
  Proof.
  induction l.
  intuition.
  simpl.
  rewrite andb_true_iff.
  rewrite negb_true_iff.
  rewrite <- IHl.
  split; intros H. inv.
  split; auto.
  apply not_true_is_false. rewrite mem_spec; auto.
  destruct H; constructors; auto.
  rewrite <- mem_spec; auto; congruence.
  Qed.

  Global Instance isok_Ok l : isok l = true -> Ok l | 10.
  Proof.
  intros. apply <- isok_iff; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
  left; eauto.
  inv; auto.
  Qed.

  Global Instance add_ok s x `(Ok s) : Ok (add x s).
  Proof.
  induction s.
  simpl; intuition.
  intros; inv. simpl.
  destruct X.eq_dec; auto.
  constructors; auto.
  intro; inv; auto.
  rewrite add_spec in *; intuition.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
  elim H. setoid_replace a with y; eauto.
  elim H3. setoid_replace x with y; eauto.
  elim n. eauto.
  Qed.

  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
  Proof.
  induction s; simpl; intros.
  auto.
  destruct X.eq_dec; inv; auto.
  constructors; auto.
  rewrite remove_spec; intuition.
  Qed.

  Lemma singleton_ok : forall x : elt, Ok (singleton x).
  Proof.
  unfold singleton; simpl; constructors; auto. intro; inv.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros. inv; auto. left; auto.
  Qed.

  Lemma empty_ok : Ok empty.
  Proof.
  unfold empty; constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; red; intros; inv.
  Qed.

  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
  Proof.
  unfold Empty; destruct s; simpl; split; intros; auto.
  intro; inv.
  discriminate.
  elim (H e); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
  Proof.
  unfold elements; intuition.
  Qed.

  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
  Proof.
  unfold elements; auto.
  Qed.

  Lemma fold_spec :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s').
  Proof.
  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction s; simpl in *; unfold flip; intros; auto; inv.
  intuition; inv.
  rewrite IHs, add_spec, InA_cons; intuition.
  Qed.

  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
  Proof.
  unfold inter, fold, flip.
  set (acc := nil (A:=elt)).
  assert (Hacc : Ok acc) by constructors.
  clearbody acc; revert acc Hacc.
  induction s; simpl; auto; intros. inv.
  apply IHs; auto.
  destruct (mem a s'); auto with *.
  Qed.

  Lemma inter_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  unfold inter, fold, flip; intros.
  set (acc := nil (A:=elt)) in *.
  assert (Hacc : Ok acc) by constructors.
  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
   intuition; unfold acc in *; inv.
  rewrite IFF; clear IFF. clearbody acc.
  revert acc Hacc x s' Hs Hs'.
  induction s; simpl; intros.
  intuition; inv.
  inv.
  case_eq (mem a s'); intros Hm.
  rewrite IHs, add_spec, InA_cons; intuition.
  rewrite mem_spec in Hm; auto.
  left; split; auto. rewrite H1; auto.
  rewrite IHs, InA_cons; intuition.
  rewrite H2, <- mem_spec in H3; auto. congruence.
  Qed.

  Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
  Qed.

  Lemma diff_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip.
  intuition; inv.
  intros. inv.
  rewrite IHs', remove_spec, InA_cons; intuition.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   subset s s' = true <-> Subset s s'.
  Proof.
  unfold subset, Subset; intros.
  rewrite is_empty_spec.
  unfold Empty; intros.
  intuition.
  specialize (H a). rewrite diff_spec in H; intuition.
  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
  rewrite diff_spec in H0; intuition.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   equal s s' = true <-> Equal s s'.
  Proof.
  unfold Equal, equal; intros.
  rewrite andb_true_iff, !subset_spec.
  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt), choose s = Some x -> In x s.
  Proof.
  destruct s; simpl; intros; inversion H; auto.
  Qed.

  Definition choose_spec2 : forall s : t, choose s = None -> Empty s.
  Proof.
  destruct s; simpl; intros.
  intros x H0; inversion H0.
  inversion H.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_spec' : forall s x f,
   In x (filter f s) -> In x s.
  Proof.
  induction s; simpl.
  intuition; inv.
  intros; destruct (f a); inv; intuition; right; eauto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  induction s; simpl.
  intuition; inv.
  intros.
  destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in E; auto. congruence.
  Qed.

  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
  Proof.
  induction s; simpl.
  auto.
  intros; inv.
  case (f a); auto.
  constructors; auto.
  contradict H0.
  eapply filter_spec'; eauto.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; induction s; simpl.
  intuition. inv.
  intros; inv.
  destruct (f a) as [ ]_eqn:F.
  rewrite IHs; intuition. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'; try discriminate.
  intros.
  rewrite <- F, <- (H' a); auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; induction s; simpl.
  split; [discriminate| intros (x & Hx & _); inv].
  intros.
  destruct (f a) as [ ]_eqn:F.
  split; auto.
  exists a; auto.
  rewrite IHs; firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_ok1' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (fst (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_ok2' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (snd (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok1' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok2' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Definition eq := Equal.
  Instance eq_equiv : Equivalence eq := _.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of lists without redundancy. *)

Module Make (X: DecidableType) <: WSets with Module E := X.
 Module Raw := MakeRaw X.
 Include WRaw2Sets X Raw.
End Make.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.
Require Import Logic.

Import ListNotations.

Require Import Omega. (* for omega tactic *)

(* Syntax of Clock-based Dynamic Logic *)

(* Syntax of SEP_exp (Synchonous Event Program) *)

(* ========================= Syntax of SEP_exp ========================*)

(* =============== Syntax of Expressions ===================*)

(* Arith Expression `e'*)

Inductive Var := var : nat -> Var.
(* in this version, I try to understand variables as identifications numbered by natural numbers,
which we believe is more convenient than considering them as strings in practical derivations*)

Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : Var -> e_exp |
  eplusC : e_exp -> e_exp -> e_exp |
  (*non-necessary expression*)
  eminusC : e_exp -> e_exp -> e_exp |
  emulC : e_exp -> e_exp -> e_exp |
  edivC : e_exp -> e_exp -> e_exp
.
Print e_exp.

Notation "e1 '+ e2" := (eplusC e1 e2) (at level 31, right associativity).
Locate "'+".
Notation "e1 '- e2" := (eminusC e1 e2) (at level 31, right associativity).

Notation "e1 '* e2" := (emulC e1 e2) (at level 21, right associativity).

(*** Open Scope e_exp_scope. ***)

Locate "*".
Check (enumC 4) '* (enumC 5 '+ enumC 6).
Coercion evarC : Var >-> e_exp.
Notation "e1 '/ e2" := (edivC e1 e2) (at level 21, right associativity).
Check (enumC 4) '/ (enumC 4).

Coercion enumC : nat >-> e_exp.
Definition x : Var := (var 1).
Definition y : Var := (var 2).
Definition z : Var := (var 3).
Definition k : Var := (var 4).

Check 4 '* (5 '+ 2).
Check (5 '+ 4) '* 8.
Check x '- 3.
Compute x '- 3.
Check 5 '+ 4 '* 5.

(* Boolean Expression `P'*)
Inductive P_exp :=
  PtrueC : P_exp |
  PlteC : e_exp -> e_exp -> P_exp |
  PnegC : P_exp -> P_exp |
  PandC : P_exp -> P_exp -> P_exp |
  (*non-necesarry expression*)
  PfalseC : P_exp |
  PltC : e_exp -> e_exp -> P_exp |
  PgtC : e_exp -> e_exp -> P_exp |
  PgteC : e_exp -> e_exp -> P_exp |
  PeqC : e_exp -> e_exp -> P_exp |
  PorC : P_exp -> P_exp -> P_exp |
  PimpC : P_exp -> P_exp -> P_exp
.
Print P_exp.

(* 33 - 41 *)
Notation "''tt'" := PtrueC (at level 35).
Notation "e1 '<= e2" := (PlteC e1 e2) (at level 33).
Notation "'~ P" := (PnegC P) (at level 36).
Notation "P1 '/\ P2" := (PandC P1 P2) (at level 37, right associativity).
Notation "''ff'" := PfalseC (at level 35).
Notation "e1 '< e2" := (PltC e1 e2) (at level 33).
Notation "e1 '> e2" := (PgtC e1 e2) (at level 33).
Notation "e1 '>= e2" := (PgteC e1 e2) (at level 33).
Notation "e1 '= e2" := (PeqC e1 e2) (at level 33).
Notation "P1 '\/ P2" := (PorC P1 P2) (at level 37, right associativity).
Notation "P1 '-> P2" := (PimpC P1 P2) (at level 38, right associativity).

Locate "'/\".
Check 'tt '-> 'ff.
Check 5 '+ x '>= 5 '-> 3 '> 7.
Compute 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
Definition state := Var -> nat.

(***
  Definging the evaluation for expressions is for checking the validation of FOL formulas after
  transformation.
***)

Fixpoint eval_e_exp (e : e_exp) (st : state) : nat :=
(* st maps each var name to a value --- it is a state *)
  match e with
  | enumC n => n
  | evarC s => st s
  | eplusC e1 e2 => (eval_e_exp e1 st) + (eval_e_exp e2 st)
  | eminusC e1 e2 => (eval_e_exp e1 st) - (eval_e_exp e2 st)
  | emulC e1 e2 => (eval_e_exp e1 st) * (eval_e_exp e2 st)
  | edivC e1 e2 => (eval_e_exp e1 st) / (eval_e_exp e2 st)
  end.

Fixpoint eval_P_exp (P : P_exp) (st : state) : Prop :=
  match P with
  | PtrueC => True
  | PlteC e1 e2 => (eval_e_exp e1 st) <= (eval_e_exp e2 st)
  | PnegC P' => ~ (eval_P_exp P' st)
  | PandC P1 P2 => (eval_P_exp P1 st) /\ (eval_P_exp P1 st)
  | PfalseC => False
  | PltC e1 e2 => (eval_e_exp e1 st) < (eval_e_exp e2 st)
  | PgtC e1 e2 => (eval_e_exp e1 st) > (eval_e_exp e2 st)
  | PgteC e1 e2 => (eval_e_exp e1 st) >= (eval_e_exp e2 st)
  | PeqC e1 e2 => (eval_e_exp e1 st) = (eval_e_exp e2 st)
  | PorC P1 P2 => (eval_P_exp P1 st) \/ (eval_P_exp P1 st)
  | PimpC P1 P2 => (eval_P_exp P1 st) -> (eval_P_exp P1 st)
  end.

(* =============== Syntax of Event ===================*)

(* Event *)
Inductive EvtElement :=
  sigC : Var -> e_exp -> EvtElement | (* Signal *)
  assC : Var -> e_exp -> EvtElement  (* Assignment *)
.
Check EvtElement.

Notation "s ! e" := (sigC s e) (at level 45).
Notation "x :=' e" := (assC x e) (at level 45).

(* currently we do not make distinguish between variable and clock names, both are strings*)
Definition c : Var := (var 5).
Definition d : Var := (var 6).
Definition c1 : Var  := (var 7).
Definition c2 : Var  := (var 8).
Definition c3 : Var  := (var 9).
Definition c4 : Var  := (var 10).

Check x :=' 4.
Compute x :=' 4.
Check c ! (x '+ 4).

Definition Evt := list EvtElement.

Check Evt.
Check (x :=' 4) :: (c!(x '+ 4)) :: nil.

(* ========================= Syntax of program ========================*)
Inductive SEP_exp : Type :=
  skip : SEP_exp | (* skip program $\varepsilon$ *)
  evtC : Evt -> SEP_exp | (* Event *)
  tstC : P_exp -> Evt -> SEP_exp | (* Test *)
  seqC : SEP_exp -> SEP_exp -> SEP_exp | (* sequence *)
  choC : SEP_exp -> SEP_exp -> SEP_exp | (* choice *)
  loopC : SEP_exp -> SEP_exp (* loop *)
.

Coercion evtC : Evt >-> SEP_exp.
Notation "{ a1 | .. | an }" := (cons a1 .. (cons an nil) .. ) (at level 45).
Notation "@ a" := (evtC a) (at level 46).
Definition idle : Evt := nil.
Notation "P ? a" := (tstC P a) (at level 48).
Notation "P1 ; P2" := (seqC P1 P2) (at level 49, left associativity).
Notation "P1 'U' P2" := (choC P1 P2) (at level 51, left associativity).
Notation "P **" := (loopC P) (at level 47, left associativity).

Locate "**".
Check x :=' 4 :: nil.
Check evtC (x :=' 4 :: nil).
Check { x :=' 4 }.
Check { x :=' 4 | c1 ! 5}.
Check @ { x :=' 4 | c1 ! 5 }.
Check idle.
Check x '> 0 ? {c!4}.

(* ========================================= Syntax of CDL Formula ===============================================*)

(* ================== CCSL ======================== *)
(* clock relation *)
(***
  Currently, we model clocks as `strings', becuase now we don't need to give its semantics.
  It won't work anymore if we consider its semantics later.
***)

Inductive CRel :=
  crSubClC : Var -> Var -> CRel |
  crExclC : Var -> Var -> CRel |
  crPrecC : Var -> Var -> CRel |
  crCausC : Var -> Var -> CRel
.
Check CRel.

Notation "c1 'sub' c2" := (crSubClC c1 c2) (at level 52).
Notation "c1 # c2" := (crExclC c1 c2) (at level 52).
Notation "c1 << c2" := (crPrecC c1 c2) (at level 52).
Notation "c1 <<= c2" := (crCausC c1 c2) (at level 52).

Check c1 << c2.
Check c1 # c2.
Check c1 sub c2.
Compute c1 << c2.

(* ================== CDL Formula ======================== *)
(* Clock relation in formula *)
Inductive rel :=
  rRelC : CRel -> rel |
  rConjC : list CRel -> rel
.
Print rel.

Coercion rRelC : CRel >-> rel.
Check c1 << c2.

Notation "/\{ c1 , .. , cn }" := (rConjC (cons c1 .. (cons cn nil) ..)).
Check /\{ c1 << c2 , c2 sub c3 , c1 <<= c3}.

(* Arith Expression `E' *)
(*DEL
(* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
Definition CntClk := string -> string.

(* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
Definition StClk := string -> string.
DEL*)

Inductive E_exp :=
  EvarC : Var -> E_exp |
  ECntClkC : Var -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : Var -> E_exp | (* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
  EnumC : nat -> E_exp |
  EplusC : E_exp -> E_exp -> E_exp |
  (* unecessary expression *)
  EmulC : E_exp -> E_exp -> E_exp |
  EminusC : E_exp -> E_exp -> E_exp |
  EdivC : E_exp -> E_exp -> E_exp
.
Print E_exp.

(* define two functions at the interpretation level for ECntClkC and EStClkC. *)
Variable fn : nat -> nat.
Variable gn : nat -> nat.

Coercion EvarC : Var >-> E_exp.
Notation "n( c )" := (ECntClkC c) (at level 52). (* the only DIFFERENCE between e_exp and E_exp *)
Notation "s( c )" := (EStClkC c) (at level 52).
Coercion EnumC : nat >-> E_exp.
Notation "e1 +' e2" := (EplusC e1 e2) (at level 55, right associativity).
Notation "e1 *' e2" := (EmulC e1 e2) (at level 53, right associativity).
Notation "e1 -' e2" := (EminusC e1 e2) (at level 55, right associativity).
Notation "e1 /' e2" := (EdivC e1 e2) (at level 53, right associativity).

Check 5 +' 3.
Check 5 '+ 3.
Check 5 *' (3 +' 5).
Check n(c) *' 4.
Compute n(c) *' 4.

(* CDL Formula *)
Inductive CDL_exp :=
  cdl_trueC : CDL_exp |
  cdl_ltC : E_exp -> E_exp -> CDL_exp |
  cdl_box1C : SEP_exp -> rel -> CDL_exp |
  cdl_box2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_negC : CDL_exp -> CDL_exp |
  cdl_andC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_forallC : Var -> CDL_exp -> CDL_exp |
  (* unnecessary expressions *)
  cdl_falseC : CDL_exp |
  cdl_lteC : E_exp -> E_exp -> CDL_exp |
  cdl_gtC : E_exp -> E_exp -> CDL_exp |
  cdl_gteC : E_exp -> E_exp -> CDL_exp |
  cdl_eqC : E_exp -> E_exp -> CDL_exp |
  cdl_dia1C : SEP_exp -> rel -> CDL_exp |
  cdl_dia2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_orC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_impC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_existsC : Var -> CDL_exp -> CDL_exp
.

Notation "'tt''" := cdl_trueC (at level 9). (* previous setting is 65, but I don't why it does not work sometimes *)
Notation "e1 <' e2" := (cdl_ltC e1 e2) (at level 61).
Notation "[ p ]' r" := (cdl_box1C p r) (at level 63, p at level 62, r at level 62).
Notation "[ p ] e" := (cdl_box2C p e) (at level 63, p at level 62, e at level 62).
Notation "~' e" := (cdl_negC e) (at level 67).
Notation "e1 /\' e2" := (cdl_andC e1 e2) (at level 69, right associativity).
Notation "'all' x , e" := (cdl_forallC x e) (at level 68, x at level 67).
(* unnecessary expressions *)
Notation "'ff''" := cdl_falseC (at level 9).
Notation "e1 <=' e2" := (cdl_lteC e1 e2) (at level 61).
Notation "e1 >' e2" := (cdl_gtC e1 e2) (at level 61).
Notation "e1 >=' e2" := (cdl_gteC e1 e2) (at level 61).
Notation "e1 =' e2" := (cdl_eqC e1 e2) (at level 61).
Notation "<< p >>' r" := (cdl_dia1C p r) (at level 63, p at level 51, r at level 51).
(* must be higher than the precedence of <<, which is 52 *)
Notation "<< p >> e" := (cdl_dia2C p e) (at level 63, p at level 51, e at level 51).
Notation "e1 \/' e2" := (cdl_orC e1 e2) (at level 71, right associativity).
Notation "e1 ->' e2" := (cdl_impC e1 e2) (at level 72, right associativity).
Notation "'ext' x , e" := (cdl_existsC x e) (at level 68, x at level 67).

Check tt'.
Check ff'.
Check (5 -' 3) <' 2.
Check ([ skip ]' c1 << c2) /\' 2 >' 5 /\' tt'.
Check [ @ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip] n(c) >' 0.
Check [(@ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip)** ]' c1<<c2.
Check [ skip ]' c1 << c2 .
Check all x , 4 =' 5.
Check ext x , 4 =' 5.

(* ===================================================== CDL Calculus ======================================*)

(*************************** Some   Auxiliary Functions ***************************)
(*check if a dynamic formula is a pure FOL formula *)

Fixpoint CheckPureFOL (e : CDL_exp) : Prop :=
  match e with
  | cdl_trueC => True
  | cdl_ltC e1 e2 => True
  | cdl_box1C p r => False
  | cdl_box2C p e' => False
  | cdl_negC e' => CheckPureFOL e'
  | cdl_andC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_forallC x e' => (CheckPureFOL e')
  | cdl_falseC => True
  | cdl_lteC e1 e2 => True
  | cdl_gtC e1 e2 => True
  | cdl_gteC e1 e2 => True
  | cdl_eqC e1 e2 => True
  | cdl_dia1C p r => False
  | cdl_dia2C p e' => False
  | cdl_orC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_impC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_existsC x e' => (CheckPureFOL e')
  end.

(* build a type for distinguishing pure FOL (i.e. Prop) or non-pure FOL *)
Inductive FOLF :=
  pureC : Prop -> FOLF |
  noPureC : FOLF
.

(* transform an E_exp to a FOL exp under a given state st. *)
(* here the functionality of st is to link the concept of `variable' in CDL we define to
the `nat' domain in Coq *)

Fixpoint Eexp_2_exp (e : E_exp) (st : state) : nat :=
  match e with
  | EvarC v => st v
  | ECntClkC c => fn (st c)
  | EStClkC c => gn (st c)
  | EnumC n => n
  | EplusC e1 e2 => (Eexp_2_exp e1 st) + (Eexp_2_exp e2 st)
  | EmulC e1 e2 => (Eexp_2_exp e1 st) * (Eexp_2_exp e2 st)
  | EminusC e1 e2 => (Eexp_2_exp e1 st) - (Eexp_2_exp e2 st)
  | EdivC e1 e2 => (Eexp_2_exp e1 st) / (Eexp_2_exp e2 st)
  end
.

(* transform a CDL exp to a FOLF formula *)
Fixpoint CDLexp_2_FOLF (e : CDL_exp) (st : state) : FOLF :=
  match e with
  | cdl_trueC => pureC True
  | cdl_ltC e1 e2 => pureC ((Eexp_2_exp e1 st) < (Eexp_2_exp e2 st))
  | cdl_box1C p r => noPureC (*once met dynamic operators, it is not a pure FOL formula *)
  | cdl_box2C p e' => noPureC
  | cdl_negC e' => match (CDLexp_2_FOLF e' st) with
                    | noPureC => noPureC
                    | pureC f => pureC (~ f)
                   end
  | cdl_andC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 /\ f2)
                      end
  | cdl_forallC x e' => match (CDLexp_2_FOLF e' st) with
                          | noPureC => noPureC
                          | pureC f => pureC (forall (x : nat), f)
                        end
  | cdl_falseC => pureC False
  | cdl_lteC e1 e2 => pureC ((Eexp_2_exp e1 st) <= (Eexp_2_exp e2 st))
  | cdl_gtC e1 e2 => pureC ((Eexp_2_exp e1 st) > (Eexp_2_exp e2 st))
  | cdl_gteC e1 e2 => pureC ((Eexp_2_exp e1 st) >= (Eexp_2_exp e2 st))
  | cdl_eqC e1 e2 => pureC ((Eexp_2_exp e1 st) = (Eexp_2_exp e2 st))
  | cdl_dia1C p r => noPureC (*once met dynamic operators, it is not a pure FOL formula *)
  | cdl_dia2C p e' => noPureC
  | cdl_orC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 \/ f2)
                     end
  | cdl_impC e1 e2 => match (CDLexp_2_FOLF e1 st), (CDLexp_2_FOLF e2 st) with
                        | noPureC , _ => noPureC
                        | _ , noPureC => noPureC
                        | (pureC f1) , (pureC f2) => pureC (f1 -> f2)
                      end
  | cdl_existsC x e' => match (CDLexp_2_FOLF e' st) with
                          | noPureC => noPureC
                          | pureC f => pureC (exists (x : nat), f)
                        end
  end.

Variable st0 : state.
Compute (CDLexp_2_FOLF tt' st0).
Compute (CDLexp_2_FOLF (tt' /\' x >=' 5) st0).
Compute (CDLexp_2_FOLF (tt' /\' (x >=' 5 ->' [ skip ] x >' 5 )) st0).
Compute (CDLexp_2_FOLF (tt' /\' (x >=' 5 ->' n(c) >' 5 )) st0).

(* transform a CDL_exp to Prop formula, if CDL_exp is not pure, simply return False, otherwise,
return the Prop formula corresponding to it. *)

Definition CDLexp_2_Prop (e : CDL_exp) (st : state) : Prop :=
  match (CDLexp_2_FOLF e st) with
    | noPureC => False
    | pureC f => f
  end.

Compute CDLexp_2_Prop (tt' /\' (x >=' 5 ->' [ skip ] x >' 5 )) st0.
Compute CDLexp_2_Prop (tt' /\' (x >=' 5 ->' n(c) >' 5 )) st0.

(* a structure of (true, false, `undefined') *)
Inductive Bool :=
  bBoolC : Prop -> Bool |
  bUndefC : Bool
.

(*
Notation "[ b ]" := (bBoolC b) (at level 74).
Notation "_|_" := bUndefC (at level 74).
*)

(* evaluate a pure FOL formula in CDL formula *)

(* during the derivation we need to translate expression e to expression E, or expression P_exp
to expression CDL_exp, in the semantics of dynamic logic, their
corresponding arithmetical opertors have the same meanings *)

Fixpoint e_2_E (e : e_exp) : E_exp :=
  match e with
  | enumC n => EnumC n
  | evarC s => EvarC s
  | eplusC e1 e2 => EplusC (e_2_E e1) (e_2_E e2)
  | eminusC e1 e2 => EminusC (e_2_E e1) (e_2_E e2)
  | emulC e1 e2 => EmulC (e_2_E e1) (e_2_E e2)
  | edivC e1 e2 => EdivC (e_2_E e1) (e_2_E e2)
  end.

Fixpoint Pexp_2_CDLexp (P : P_exp) : CDL_exp :=
  match P with
  | PtrueC => cdl_trueC
  | PlteC e1 e2 => cdl_lteC (e_2_E e1) (e_2_E e2)
  | PnegC P' => cdl_negC (Pexp_2_CDLexp P')
  | PandC P1 P2 => cdl_andC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  | PfalseC => cdl_falseC
  | PltC e1 e2 => cdl_ltC (e_2_E e1) (e_2_E e2)
  | PgtC e1 e2 => cdl_gtC (e_2_E e1) (e_2_E e2)
  | PgteC e1 e2 => cdl_gteC (e_2_E e1) (e_2_E e2)
  | PeqC e1 e2 => cdl_eqC (e_2_E e1) (e_2_E e2)
  | PorC P1 P2 => cdl_orC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  | PimpC P1 P2 => cdl_impC (Pexp_2_CDLexp P1) (Pexp_2_CDLexp P2)
  end.

(* -------------------------------computation of variables in cdl formula----------------------------------------*)
(***
Note that actually here we compute all occurrences of variables in a cdl formula, not really all variables, because
here we use `list' as the structure to `store' each appearance of free variables.
It is enough for us to check whether a variable is a free variable or not in a formula checking if it does not equal to
each occurrence of variables.
***)

(* compare the id of two variables *)
Definition eqv (x : Var) (y: Var) : bool :=
  match x, y with
  | var n, var m => if n =? m then true else false
  end.

(* this function check whether a variable (i.e. a string) belongs to a list of variables (list of string) *)
Fixpoint NotIn_bool (s : Var) (vec : list Var) : bool :=
  match vec with
  | nil => true
  | v :: vec' => if (eqv s v) then false else NotIn_bool s vec'
  end.

Compute NotIn_bool x (x :: y :: z :: nil).
Compute NotIn_bool c (x :: y :: z :: nil).

(* this is another version for Prop type, just in case we need it in building the proof system*)
Fixpoint NotIn (s : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => True
  | v :: vec' => if (eqv s v) then False else NotIn s vec'
  end.

Compute NotIn x (x :: y :: z :: nil).
Compute NotIn c (x :: y :: z :: nil).

Fixpoint In (s : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => False
  | v :: vec' => if (eqv s v) then True else In s vec'
  end.

Fixpoint E_exp_FV (e : E_exp) (bv : list Var) : list Var := (*bv : list of bounded variables at current time *)
  match e with
  | EvarC v => if (NotIn_bool v bv) then (v :: nil) else nil
  | ECntClkC c => if (NotIn_bool c bv) then (c :: nil) else nil
  | EStClkC c => if (NotIn_bool c bv) then (c :: nil) else nil
  | EnumC n => nil
  | EplusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EmulC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EminusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EdivC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  end
.

Compute E_exp_FV (x +' 3 *' n(c)) nil.
Compute E_exp_FV (x +' 3 *' z) nil.
Compute E_exp_FV (x +' 3 *' z) (x :: nil).

Fixpoint e_exp_FV (e : e_exp) (bv : list Var) : list Var :=
  match e with
  | enumC n => nil
  | evarC s => if (NotIn_bool s bv) then (s :: nil) else nil
  | eplusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | eminusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | emulC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | edivC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  end
.

Compute e_exp_FV (x '+ 3 '* 5) nil.
Compute e_exp_FV (x '+ 3 '* z) nil.
Compute e_exp_FV (x '+ 3 '/ z) (x :: nil).

Fixpoint P_exp_FV (P : P_exp) (bv : list Var) : list Var :=
  match P with
  | PtrueC => nil
  | PlteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PnegC P' => P_exp_FV P' bv
  | PandC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PfalseC => nil
  | PltC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgtC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PeqC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PorC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PimpC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  end
.

Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) nil.
Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) (x :: nil).
Compute P_exp_FV (y '<= 5 '/\ (3 '= 5 '* x)) (z :: nil).

Fixpoint EvtE_FV (e : EvtElement) (bv : list Var) : list Var :=
  match e with
  | sigC s e' => s :: (e_exp_FV e' bv)
  | assC s e' => e_exp_FV e' (s :: bv)
  end
.

Fixpoint Evt_FV (evt : Evt) (bv : list Var) : list Var :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_FV e bv) ++ (Evt_FV evt' bv)
  end
.

Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) nil.
Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) (y :: nil).

Fixpoint SEP_exp_FV (e : SEP_exp) (bv : list Var) : list Var :=
  match e with
  | skip => nil
  | evtC evt => (Evt_FV evt bv)
  | tstC P evt => (P_exp_FV P bv) ++ (Evt_FV evt bv)
  | seqC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | choC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | loopC e' => (SEP_exp_FV e' bv)
  end
.

Check x '> 2 ? { y :=' y '- z}.
Compute SEP_exp_FV ((@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) **) nil.

Fixpoint cdl_FV (e : CDL_exp) (bv : list Var) : list Var := (*bv : list of bounded variables at current time *)
  match e with
  | cdl_trueC => nil
  | cdl_ltC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_box1C p r => SEP_exp_FV p bv
  | cdl_box2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_negC e' => cdl_FV e' bv
  | cdl_andC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_forallC x1 e' => cdl_FV e' (x1 :: bv) (* x1 is a bounded variable *)
  | cdl_falseC => nil
  | cdl_lteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gtC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_eqC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_dia1C p r => SEP_exp_FV p bv
  | cdl_dia2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_orC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_impC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_existsC x1 e' => cdl_FV e' (x1 :: bv) (* x1 is a bounded variable *)
  end
.

Check ( all y , y =' 7 ) .
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) nil.
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) (y :: nil).
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( ext y , y =' 7 ) ) (y :: nil).

(* for list *)
Fixpoint cdl_FV_l (T : list CDL_exp) (bv : list Var) : list Var :=
  match T with
  | nil => nil
  | e :: T' => (cdl_FV e bv) ++ (cdl_FV_l T' bv)
  end.

Check nat.

(* compute FV for a function *)
(* here we do a trick. We pass to phi a variable with a variable id that we will never use in the context
(i.e., the var 0), and we add this variable to the bounded variable list bv, so that the final FV set of
phi will definitely not contain var 0.
Note that var 0 must not be used anywhere, or it would be dangerous since it is possible var 0
has already existed in the formul phi *)

Definition cdl_FV_f (phi : E_exp -> CDL_exp) (bv : list Var) : list Var :=
  cdl_FV (phi (var 0)) ((var 0) :: bv).

(* generate a new variable id *)
Fixpoint MaxId (FVSet : list Var) : nat :=
  match FVSet with
  | nil => 0 (* when there is no variables in the current environment FVSet, just start from the number 0 *)
  | v :: FVSet' => let n := MaxId FVSet' in (
                      match v with | var m =>
                        if le_lt_dec n m then m else (MaxId FVSet') (* le_lt_dec : <= *)
                      end
                      )
  end
.

(* ------------------------------ Compute the set of bounded variables for a formula -------------- *)
Fixpoint EvtE_BV (e : EvtElement) : list Var :=
  match e with
  | sigC s e' => nil
  | assC s e' => e_exp_FV e' bv
  end
.

Fixpoint Evt_FV (evt : Evt) (bv : list Var) : list Var :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_FV e bv) ++ (Evt_FV evt' bv)
  end
.

(* -------------------------------------- generate new variable in the context ----------------------- *)
Compute MaxId (var 1 :: var 3 :: var 5 :: var 6 :: nil).

Definition NewId (FVSet : list Var) : nat := (S (MaxId FVSet)).

Compute NewId (var 7 :: var 1 :: var 3 :: var 3 :: var 5 :: var 6 :: nil).
Compute NewId nil.

(* --------------------------------------- hbar function -------------------------------------------- *)
(* hbar Function : translate a relation to a FOL formula*)
Definition hbar_Rel (r : CRel) : CDL_exp :=
  match r with
  | crSubClC c1 c2 => (s(c1) =' 1 ->' s(c2) =' 1)
  | crExclC c1 c2 => (s(c1) =' 0 \/' s(c2) =' 1)
  | crPrecC c1 c2 => (n(c1) >' n(c2) \/' (n(c1) =' n(c2) ->' s(c1) =' 0))
  | crCausC c1 c2 => (n(c1) >=' n(c2))
  end.

Fixpoint hbar_l_conj (l : list CRel) : CDL_exp :=
  match l with
  | nil => tt'
  | r :: l' => (hbar_Rel r) /\' (hbar_l_conj l')
  end.

Definition hbar (r : rel) : CDL_exp :=
  match r with
  | rRelC R => hbar_Rel R
  | rConjC l => hbar_l_conj l
  end.

(* --------------------------------- transform E_exp to e_exp -------------------------------*)
(* a structure tht distinguish E_exp and e_exp *)
Inductive e_exp_type :=
  compC : e_exp -> e_exp_type |
  noCompC : e_exp_type
.

Fixpoint E_2_e (E : E_exp)  : e_exp_type :=
  match E with
  | EvarC x => compC (evarC x)
  | ECntClkC c => noCompC (* it does not compat with e_exp *)
  | EStClkC c => noCompC
  | EnumC n => compC (enumC n)
  | EplusC E1 E2 => match (E_2_e E1) , (E_2_e E2) with
                  | noCompC , _  => noCompC
                  | _ , noCompC => noCompC
                  | (compC e1) , (compC e2) => compC (eplusC e1 e2)
                  end
  | EmulC E1 E2 => match (E_2_e E1) , (E_2_e E2) with
                  | noCompC , _  => noCompC
                  | _ , noCompC => noCompC
                  | (compC e1) , (compC e2) => compC (emulC e1 e2)
                  end
  | EminusC E1 E2 => match (E_2_e E1) , (E_2_e E2) with
                    | noCompC , _  => noCompC
                    | _ , noCompC => noCompC
                    | (compC e1) , (compC e2) => compC (eminusC e1 e2)
                   end
  | EdivC E1 E2 => match (E_2_e E1) , (E_2_e E2) with
                    | noCompC , _  => noCompC
                    | _ , noCompC => noCompC
                    | (compC e1) , (compC e2) => compC (edivC e1 e2)
                   end
  end.

Compute (E_2_e ((x +' 5) -' (z *' (y +' 1 )))).
Compute (E_2_e ((x +' 5) -' (n(c) *' (y +' 1 )))).

(* ---------------------------------------- subsititution for an E_exp ----------------------------------- *)
(* the substitution defined here dose not garrentee the admissibility. *)

Fixpoint E_exp_subsE (e : E_exp) (E : E_exp) (x : Var) : E_exp :=
  match e with
  | EvarC v => if (eqv v x) then E else EvarC v
  | ECntClkC c => ECntClkC c (* do not consider replacing a clock-related variable *)
  | EStClkC c => EStClkC c
  | EnumC n => EnumC n
  | EplusC e1 e2 => EplusC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
  | EmulC e1 e2 => EmulC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
  | EminusC e1 e2 => EminusC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
  | EdivC e1 e2 => EdivC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
  end
.

Compute E_exp_subsE (x +' y) (y +' 1) x.
Compute E_exp_subsE (x *' z) (y *' 5) c.
Compute E_exp_subsE (n(c) *' z) (y *' 5) z.

Notation "e [ E 'subs-E' x ]" := (E_exp_subsE e E x) (at level 9).

Fixpoint e_exp_subse (e : e_exp) (exp : e_exp) (x : Var) : e_exp :=
  match e with
  | enumC n => enumC n
  | evarC s => if (eqv s x) then exp else evarC s
  | eplusC e1 e2 => eplusC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | eminusC e1 e2 => eminusC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | emulC e1 e2 => emulC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | edivC e1 e2 => edivC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  end
.

Compute (z '- 5) '* x '+ z.
Compute e_exp_subse ((z '- 5) '* x '+ z) y z.
Compute e_exp_subse ((z '- 5) '* x '+ z) (y '- 2) z.

Fixpoint P_exp_subse (P : P_exp) (exp : e_exp) (x : Var) : P_exp :=
  match P with
  | PtrueC => PtrueC
  | PlteC e1 e2 => PlteC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | PnegC P' => PnegC (P_exp_subse P' exp x)
  | PandC P1 P2 => PandC (P_exp_subse P1 exp x) (P_exp_subse P2 exp x)
  | PfalseC => PfalseC
  | PltC e1 e2 => PltC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | PgtC e1 e2 => PgtC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | PgteC e1 e2 => PgteC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | PeqC e1 e2 => PeqC (e_exp_subse e1 exp x) (e_exp_subse e2 exp x)
  | PorC P1 P2 => PorC (P_exp_subse P1 exp x) (P_exp_subse P2 exp x)
  | PimpC P1 P2 => PimpC (P_exp_subse P1 exp x) (P_exp_subse P2 exp x)
  end
.

Compute 'tt '/\ '~ (x '< 5).
Compute P_exp_subse ('tt '/\ '~ (x '< 5)) z x.
Compute P_exp_subse ('tt '/\ '~ (x '< 5)) (z '* 2) x.

Fixpoint EvtE_subse (e : EvtElement) (exp : e_exp) (x : Var) : EvtElement :=
  match e with
  | sigC s e' => sigC s (e_exp_subse e' exp x)
  | assC s e' => assC s (e_exp_subse e' exp x)
  end
.

Compute EvtE_subse (c ! x '+ 5) y x.
Compute EvtE_subse (x :=' (5 '* x '+ 3 '/ y)) (z '/ 5) x.

Fixpoint Evt_subse (evt : Evt) (exp : e_exp) (x : Var) : Evt :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_subse e exp x) :: (Evt_subse evt' exp x)
  end
.

Compute { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }.
Compute Evt_subse ( { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.
Compute Evt_subse ( { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) (z '+ 1) x.

Fixpoint SEP_exp_subse (e : SEP_exp) (exp : e_exp) (x : Var) : SEP_exp :=
  match e with
  | skip => skip
  | evtC evt => evtC (Evt_subse evt exp x)
  | tstC P evt => tstC (P_exp_subse P exp x) (Evt_subse evt exp x)
  | seqC e1 e2 => seqC (SEP_exp_subse e1 exp x) (SEP_exp_subse e2 exp x)
  | choC e1 e2 => choC (SEP_exp_subse e1 exp x) (SEP_exp_subse e2 exp x)
  | loopC e' => loopC (SEP_exp_subse e' exp x)
  end
.

Compute @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }.
Compute SEP_exp_subse ( @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.
Compute SEP_exp_subse ( @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) (z '- 2) x.

Fixpoint cdl_subsE (e : CDL_exp) (E : E_exp) (x : Var) : CDL_exp := (* e[E // x] *)
    match e with
    | cdl_trueC => cdl_trueC
    | cdl_ltC e1 e2 => cdl_ltC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
    | cdl_box1C p r => match (E_2_e E) with
                        | compC exp => cdl_box1C (SEP_exp_subse p exp x) r
                        | noCompC => cdl_box1C p r
                       end
    | cdl_box2C p e' => match (E_2_e E) with
                          | compC exp => cdl_box2C (SEP_exp_subse p exp x) (cdl_subsE e' E x)
                          | noCompC => cdl_box2C p e'
                        end
    | cdl_negC e' => cdl_negC (cdl_subsE e' E x)
    | cdl_andC e1 e2 => cdl_andC (cdl_subsE e1 E x) (cdl_subsE e2 E x)
    | cdl_forallC x1 e' => if (eqv x1 x) then cdl_forallC x1 e' else cdl_forallC x1 (cdl_subsE e' E x)
    | cdl_falseC => cdl_falseC
    | cdl_lteC e1 e2 => cdl_lteC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
    | cdl_gtC e1 e2 => cdl_gtC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
    | cdl_gteC e1 e2 => cdl_gteC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
    | cdl_eqC e1 e2 => cdl_eqC (E_exp_subsE e1 E x) (E_exp_subsE e2 E x)
    | cdl_dia1C p r => match (E_2_e E) with
                        | compC exp => cdl_dia1C (SEP_exp_subse p exp x) r
                        | noCompC => cdl_dia1C p r
                       end
    | cdl_dia2C p e' => match (E_2_e E) with
                          | compC exp => cdl_dia2C (SEP_exp_subse p exp x) (cdl_subsE e' E x)
                          | noCompC => cdl_dia2C p e'
                        end
    | cdl_orC e1 e2 => cdl_orC (cdl_subsE e1 E x) (cdl_subsE e2 E x)
    | cdl_impC e1 e2 => cdl_impC (cdl_subsE e1 E x) (cdl_subsE e2 E x)
    | cdl_existsC x1 e' => if (eqv x1 x) then cdl_existsC x1 e' else cdl_existsC x1 (cdl_subsE e' E x)
  end.

Notation "e [ E 'subs' x ]" := (cdl_subsE e E x) (at level 9).
Check [ skip ]' c1 << c2 .
Locate "/".
Locate "//".

Compute [ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2.
Compute ([ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2) [ y subs x ] .
Compute ([ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2) [ (y +' 1) subs x ] .
Compute ([ x '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }] x =' y +' 2) [ (y +' 2) subs x ] .

(* substitution for list *)
Fixpoint cdl_subsE_l (T : list CDL_exp) (E : E_exp) (x : Var) : list CDL_exp := (* T [x' // x] *)
  match T with
  | nil => nil
  | e :: T' => (cdl_subsE e E x) :: (cdl_subsE_l T' E x)
  end.

Notation "T [ E 'subs-l' x ]" := (cdl_subsE_l T E x) (at level 9).

(* ----------------------------------- check if a substitution is admissible --------------------------------- *)
Fixpoint commonEle (v1 : list Var) (v2 : list Var) : bool :=
  match v1 with
  | nil => false
  | e :: v1' => if (NotIn_bool e v2) then commonEle v1' v2 else true
  end.

Compute commonEle (x :: y :: nil) (z :: nil).
Compute commonEle (x :: y :: nil) (z :: y :: nil).

Fixpoint E_exp_chk (e : E_exp) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
  match e with
  | EvarC v => if andb (eqv v x) (commonEle ev bv) then False else True
  | ECntClkC c => True
  | EStClkC c => True
  | EnumC n => True
  | EplusC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
  | EmulC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
  | EminusC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
  | EdivC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
  end
.

Fixpoint e_exp_chk (e : e_exp) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
  match e with
  | enumC n => True
  | evarC s => if andb (eqv s x) (commonEle ev bv) then False else True
  | eplusC e1 e2 => (e_exp_chk e1 ev x bv) /\ (e_exp_chk e2 ev x bv)
  | eminusC e1 e2 => (e_exp_chk e1 ev x bv) /\ (e_exp_chk e2 ev x bv)
  | emulC e1 e2 => (e_exp_chk e1 ev x bv) /\ (e_exp_chk e2 ev x bv)
  | edivC e1 e2 => (e_exp_chk e1 ev x bv) /\ (e_exp_chk e2 ev x bv)
  end
.

Fixpoint EvtE_chk (e : EvtElement) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
  match e with
  | sigC s e' => True
  | assC s e' => e_exp_chk e' ev x (s :: bv)
  end
.

Fixpoint Evt_chk (evt : Evt) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_chk e ev x bv) /\ (Evt_chk e ev x ((EvtE_BV e nil) :: bv))
  end
.

Fixpoint SEP_exp_chk (p : SEP_exp) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
  match p with
  | skip => True
  | evtC evt => Evt_chk evt ev x bv
  | tstC P evt => (P_exp_chk P ev x bv) /\ (Evt_chk evt ev x bv) (* it is impossible to have any
    new bounded variables in P *)
  | seqC e1 e2 => (SEP_exp_chk e1 ev x bv) /\ (SEP_exp_chk e2 ev x (bv ++ (SEP_exp_BV e1 nil)))
  | choC e1 e2 => (SEP_exp_chk e1 ev x bv) /\ (SEP_exp_chk e2 ev x bv)
  | loopC e' => SEP_exp_chk e' ev x bv
  end
.

Fixpoint cdl_chk (e : CDL_exp) (ev : list Var) (x : Var) (bv : list Var) : Prop :=
    match e with
    | cdl_trueC => True
    | cdl_ltC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
    | cdl_box1C p r => SEP_chk p ev x bv
    | cdl_box2C p e' => (SEP_chk p ev x bv) /\ (cdl_chk e' ev x (bv ++ (SEP_exp_BV p nil)))
    | cdl_negC e' => cdl_chk e' ev x bv
    | cdl_andC e1 e2 => (cdl_chk e1 ev x bv) /\ (cdl_chk e2 ev x bv)
    | cdl_forallC x1 e' => cdl_chk e' ev x (x1 :: bv)
    | cdl_falseC => True
    | cdl_lteC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
    | cdl_gtC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
    | cdl_gteC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
    | cdl_eqC e1 e2 => (E_exp_chk e1 ev x bv) /\ (E_exp_chk e2 ev x bv)
    | cdl_dia1C p r => SEP_chk p ev x bv
    | cdl_dia2C p e' => (SEP_chk p ev x bv) /\ (cdl_chk e' ev x (bv ++ (SEP_exp_BV p nil)))
    | cdl_orC e1 e2 => (cdl_chk e1 ev x bv) /\ (cdl_chk e2 ev x bv)
    | cdl_impC e1 e2 => (cdl_chk e1 ev x bv) /\ (cdl_chk e2 ev x bv)
    | cdl_existsC x1 e' => cdl_chk e' ev x (x1 :: bv)
    end.

(* ====================================================== CDL Rules =============================================*)

Definition Gamma := list CDL_exp.
Definition Delta := list CDL_exp.

(***DEL Definition SequentL : Gamma -> CDL_exp -> Delta -> Prop.*)

(* we arrange a place special for the dynamic formula we want to verify in the sequent, other formulas in Gamma
and Delta are pure FOL formulas.

We define two types of sequent: sequentL and sequentR, where L and R indicate the verifiying formula is on the left
or right side of the sequent.
*)

Inductive place :=
  exp : CDL_exp -> place |
  empty : place
.

(*
Notation "'<<' e '>>'" := (exp e) (at level 74, e at level 72).
Notation "<< >>" := empty (at level 74).
Check << x <=' y >> .
Check << >>.
Locate "<< >>".
*)

Reserved Notation "{ T , p1 ==> p2 , D & FV }" (at level 75).
(*Reserved Notation "T ==> p , D" (at level 75).*)

Locate "==>".

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& a simple test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)

(*** as a test, we firstly implement a simple rule here, to check if everything in my mind would work well,
we first realize the rule:
    T[x'/x],x = e[x'/x] => E, D[x'/x]
    ---------------------------------
    T => [x := e] E, D

It is equavalent to realize the rule:
    forall x'. (x' not free in T, e, D) -> (T[x'/x],x = e[x'/x] => E, D[x'/x]) -> (T => [x := e] E, D)
***)

(* To be simple, we firstly define a sequent as a triple (\Gamma, formula, \Delta), where \Gamma and \Delta are the context of
the formula that we are going to transform. *)

(**DEL
Inductive tstSeq : Gamma -> place -> place -> Delta -> Type :=
  tst1 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (x : string),
          (
          forall (z : string),
          (tstSeq ((x =' (e_2_E e) [z subs-E x]) :: (T [ z subs-l x ]))
                   empty
                  (exp phi)
                  (D [ z subs-l x ]) )
        ) ->
    (tstSeq T empty (exp ([ @ {x :=' e} ] phi)) D)
where "{ T , p1 ==> p2 , D }" := (tstSeq T p1 p2 D)
.

(* Theorem thm1 : (x =' 1) :: nil , empty ==> [ @ {x :=' x '+ 1}] x >' 2 , nil .*)

Theorem thm1 : tstSeq ((y =' 1) :: nil) empty (exp ([ @ {y :=' y '+ z}] y >' 2)) nil .
Proof.
apply tst1.
intros. simpl.
Abort.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z}] y >' 2) , nil }.
DEL**)

(*DEL
Inductive tstSeq2 : Gamma -> place -> place -> Delta -> (list Var) -> Prop :=
  tst2 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (FV : list Var) (x : Var) (A : Evt),
          ( let n := NewId FV in
          (tstSeq2 ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                   empty
                  (exp ([ @ A ] phi))
                  (D [ (var n) subs-l x ])
                  (var n :: FV) )
        ) ->
    (tstSeq2 T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D FV)
  |
  tst3 : forall (T : Gamma) (D : Delta) (phi : CDL_exp) (FV : list Var),
          (
          tstSeq2 T
                   empty
                  (exp phi)
                  D
                  FV
        ) ->
    (tstSeq2 T empty (exp ([ @ idle ] phi)) D FV)
where "{ T , p1 ==> p2 , D & FV }" := (tstSeq2 T p1 p2 D FV)
.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z | y :=' y '+ 1}] y >' 2) , nil &
                (y :: z :: nil) }.
Proof.
apply tst2. cbv.
apply tst2. cbv.
apply tst3. cbv.
Abort.
*)

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&  end of test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)

(* =========================================== some auxiliary funcions ================= *)
(* transform a sequent to a CDL exp, which we will need to implement Rule (o) below *)
Fixpoint Gamma_2_CDLexp (T : Gamma) : CDL_exp :=
  match T with
  | nil => tt'
  | e :: T' => e /\' (Gamma_2_CDLexp T')
  end.

Fixpoint Delta_2_CDLexp (D : Gamma) : CDL_exp :=
  match D with
  | nil => ff'
  | e :: D' => e \/' (Delta_2_CDLexp D')
  end.

Definition place_2_CDLexp_L (p : place) : CDL_exp :=
  match p with
  | empty => tt'
  | exp e => e
  end.

Definition place_2_CDLexp_R (p : place) : CDL_exp :=
  match p with
  | empty => ff'
  | exp e => e
  end.

Definition Seq_2_CDLexp (T : Gamma) (p1 : place) (p2 : place) (D : Delta) : CDL_exp :=
  ((Gamma_2_CDLexp T) /\' (place_2_CDLexp_L p1))
  ->'
  ((place_2_CDLexp_R p2) \/' (Delta_2_CDLexp D))
.

Compute Seq_2_CDLexp ((x =' 1) :: (y >' 1) :: nil) empty (exp (z =' 3)) nil.

(* =========================================== construction of the proof system ================================================= *)

(* currently we do not consider the other direction of the rules and rules for the dual operator of `[p]'. *)
Inductive Seq : Gamma -> place -> place -> Delta -> (list Var) -> Prop :=
  (* ****************************** rules for atomic events and formula [p]rel *********************** *)
(* Rule (Phi) *)
  r_Phi_all_int1 : forall (T : Gamma) (D : Delta) (FV : list Var) (x : Var) (e : e_exp) (A : Evt) (phi : CDL_exp),
          let n := NewId FV in
          (
            Seq ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                      empty
                        (exp ([ @ A ] phi))
                          (D [ (var n) subs-l x ])
                            (var n :: FV)
          )
          ->
          (
            Seq T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D FV
          )
|

  r_Phi_all_int2 : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
          (
            Seq T empty (exp phi) D FV
          )
          ->
          (
            Seq T empty (exp ([ @ idle ] phi)) D FV
          )
|

(* Rule (Pi) *)
  r_Pi_all_int1 : forall (T : Gamma) (D : Delta) (FV : list Var) (x : Var) (e : e_exp) (A : Evt) (r : rel),
          let n := NewId FV in
          (
            Seq ((x =' (e_2_E e) [(var n) subs-E x]) :: (T [ (var n) subs-l x ]))
                      empty
                        (exp ([ @ A ]' r))
                          (D [ (var n) subs-l x ])
                            (var n :: FV)
          )
          ->
          (
            Seq T empty (exp ([ @ ((x :=' e) :: A) ]' r)) D FV
          )
|
  r_Pi_all_int2 : forall (T : Gamma) (D : Delta) (FV : list Var) (r : rel),
          (
            Seq T empty (exp (hbar r)) D FV
          )
          ->
          (
            Seq T empty (exp ([ @ idle ]' r)) D FV
          )
|

(* Rule P? *)
  r_Test_all_phi_int : forall (T : Gamma) (D : Delta) (FV : list Var) (P : P_exp) (A : Evt) (phi : CDL_exp),
          (
            Seq T empty (exp ((Pexp_2_CDLexp P) ->' [ @ A ] phi )) D FV
          )
          ->
          (
            Seq T empty (exp ([ P ? A ] phi)) D FV
          )
|
  r_Test_all_rel_int : forall (T : Gamma) (D : Delta) (FV : list Var) (P : P_exp) (A : Evt) (r : rel),
          (
            Seq T empty (exp ((Pexp_2_CDLexp P) ->' [ @ A ]' r )) D FV
          )
          ->
          (
            Seq T empty (exp ([ P ? A ]' r)) D FV
          )
|

(* Rule \pi\epsilon *)
  r_PiEp_all_int : forall (T : Gamma) (D : Delta) (FV : list Var) (r : rel),
          (
            Seq T empty ( exp (tt') ) D FV
          )
          ->
          (
            Seq T empty (exp ([ skip ]' r)) D FV
          )
|

(* Rule \epsilon *)
  r_Ep_all_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
          (
            Seq T empty ( exp phi ) D FV
          )
          ->
          (
            Seq T empty (exp ([ skip ] phi)) D FV
          )
|

(* Rule \pi[;] *)
  r_PiSeq_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ]' r /\' [ p ] ([ q ]' r)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p;q ]' r)) D FV
          )
|

(* Rule \pi[\cup] *)
  r_PiCho_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ]' r /\' [ q ]' r))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p U q ]' r)) D FV
          )
|

(* Rule \pi[*]u *)
  r_PiLoopU_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ; p ** ]' r))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ]' r)) D FV
          )
|

(* Rule \pi[*]i *)
  r_PiLoopI_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (r : rel),
          (
            Seq T empty
                    (exp ([ p ** ] ([ p ]' r)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ]' r)) D FV
          )
|

(* ****************************** rules for formula [p]\phi inherited from FODL *********************** *)
(* Rule [;] *)
  r_Seq_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp ([ p ] ([ q ] phi)))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ; q ] phi)) D FV
          )
|

(* Rule [U] *)
  r_Cho_all_int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (q : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp ([ p ] phi /\' [ q ] phi))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p U q ] phi)) D FV
          )
|

(* Rule [*]u *)
  r_LoopU_all_Int : forall (T: Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            Seq T empty
                    (exp (phi /\' [ p ; p ** ] phi))
                      D FV
          )
          ->
          (
            Seq T empty (exp ([ p ** ] phi)) D FV
          )
|

(*** here we also omit the rules ([]gen), (<>gen), ([*]ind), (<*>con) temporally since we actually do NOT
need them for derivatiion, they are just necessary for the relative completeness of the proof system. ***)

(* Rule [*]i *)
  r_LoopI_all : forall (T : Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            exists (inv : CDL_exp), (* invariant has to be manually provided *)
              (
                Seq T empty (exp inv) D (FV ++ (cdl_FV inv nil))
              )
              /\
              (
                Seq nil empty
                          (exp (inv ->' [ p ] inv))
                            nil
                              (cdl_FV (inv ->' [ p ] inv) nil)
              )
              /\
              (
                Seq nil empty
                          (exp (inv ->' phi))
                            nil
                              (cdl_FV (inv ->' phi) nil)
              )
          )
          ->
          (
            Seq T empty
                    (exp ([ p ** ] phi)) D FV
          )
|

(* Rule <*>i *)
  r_LoopI_dia : forall (T : Gamma) (D : Delta) (FV : list Var) (p : SEP_exp) (phi : CDL_exp),
          (
            exists (inv : E_exp -> CDL_exp), (* invariant has to be manually provided *)
              (
                let X := var (NewId (FV ++ (cdl_FV_f inv nil))) in
                (
                Seq T empty
                        (exp (ext X , (X >=' 0 /\' (inv X))))
                            D
                              (FV ++ (cdl_FV (ext X , (X >=' 0 /\' (inv X))) nil))
                )
              )
              /\
              (
                let X := var (NewId (cdl_FV_f inv nil)) in
                (
                Seq nil empty
                          (exp (
                                  all X, X >' 0 ->' ((inv X) ->' << p >> (inv (X -' 1)))
                               )
                          )
                            nil
                              (cdl_FV (all X, X >' 0 ->' ((inv X) ->' << p >> (inv (X -' 1)))) nil)
                )
              )
              /\
              (
                let X := var (NewId (cdl_FV_f inv nil)) in
                (
                Seq nil empty
                          (exp (
                                  ext X, X <=' 0 /\' ((inv X) ->' phi)
                               )
                          )
                            nil
                              (cdl_FV (ext X, X <=' 0 /\' ((inv X) ->' phi)) nil)
                )
              )
          )
          ->
          (
            Seq T empty
                    (exp (<< p ** >> phi)) D FV
          )
|

(* ****************************** rules of FOL *********************** *)
(* Rule (o) *)
  r_o_int : forall (T : Gamma) (D : Delta) (FV : list Var),
        (
          let fof := (Seq_2_CDLexp T empty empty D) in
          (
            forall (st : state), (CDLexp_2_Prop fof st)
            (* the Prop formula corresponding to the sequent: `Seq T empty empty D FV' *)
          )
        )
        ->
        (
          Seq T empty empty D FV
        )
|

(* Rule (ax) *)
  r_ax_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          True
        )
        ->
        (
          Seq T (exp phi) (exp phi) D FV
        )
|

(* Rule (cut) *)
  r_cut_int : forall (T : Gamma) (D : Delta) (FV : list Var),
        (
          forall (phi : CDL_exp),
            (
              Seq T empty (exp phi) D (FV ++ (cdl_FV phi nil))
            )
            /\
            (
              Seq T (exp phi) empty D (FV ++ (cdl_FV phi nil))
            )
        )
        ->
        (
          Seq T empty empty D FV
        )
|

(* Rule (~ r) *)
  r_negR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          Seq T (exp (~' phi)) empty D FV
        )
        ->
        (
          Seq T empty (exp phi) D FV
        )
|

(* Rule (~ l) *)
  r_negL_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp),
        (
          Seq T empty (exp (~' phi)) D FV
        )
        ->
        (
          Seq T (exp phi) empty D FV
        )
|

(* Rule (/\ r) *)
  r_andR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi1 : CDL_exp) (phi2 : CDL_exp),
        (
          (
            Seq T empty (exp phi1) D FV
          )
          /\
          (
            Seq T empty (exp phi2) D FV
          )
        )
        ->
        (
          Seq T empty (exp (phi1 /\' phi2)) D FV
        )
|

(* Rule (/\ l) *)
  r_andL_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi1 : CDL_exp) (phi2 : CDL_exp),
        (
          Seq (phi2 :: T)
                (exp phi1) empty D FV
        )
        ->
        (
          Seq T (exp (phi1 /\' phi2)) empty D FV
        )
|

(* Rule (all r) *)
  r_allR_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp) (x : Var),
        (
          let n := NewId FV in
          (
            Seq T empty
                    (
                      exp (phi [(var n) subs x])
                    )
                        D
                          ((var n) :: FV)
          )
        )
        ->
        (
          Seq T empty (exp (all x , phi)) D FV
        )
|

(* Rule (all l) *)

  r_allL_int : forall (T : Gamma) (D : Delta) (FV : list Var) (phi : CDL_exp) (x : Var),
        (
          exists (E : E_exp),
          (
            Seq (all x , phi) :: T
                    (
                      exp (phi [E subs x])
                    )
                      empty
                        D
                          (FV ++ (cdl_FV phi nil))
          )
        )
        ->
        (
          Seq T (exp (all x , phi)) empty D FV
        )

(* define the notation at the end *)
where "{ T , p1 ==> p2 , D & FV }" := (Seq T p1 p2 D FV)
.

Theorem tst1 : { nil, (exp tt') ==> (exp tt') , nil & nil }.
Proof.
apply r_ax_int.
auto.
Qed.

Theorem tstThm1 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z | y :=' y '+ 1}] y >' 2) , nil &
                (y :: z :: nil) }.
Proof.
apply r_Phi_all_int1. cbv.
apply r_Phi_all_int1. cbv.
apply r_Phi_all_int2. cbv.
Abort.


Require Import Basics.
Require Import Types.Forall Types.Sigma Types.Prod Types.WType.

(** In this file we define indexed W-types. We show that indexed W-types can be reduced to W-types whilst still having definitional computation rules. We also characterize the path space of indexed W-types. This allows us to derive sufficient conditions for an indexed W-type to be truncated. *)

(** This is mostly adapted from Jasper Hugunin's formalization in coq: https://github.com/jashug/IWTypes *)

(** On a more meta-theoretic note, this partly justifies the use of indexed inductive types in Coq with respect to homotopy type theory. *)

Inductive IW
  (I : Type) (** The indexing type *)
  (A : Type) (** The type of labels / constructors / data *)
  (B : A -> Type) (** The the type of arities / arguments / children *)
  (i : A -> I) (** The index map (for labels) *)
  (j : forall x, B x -> I) (** The index map for arguments *)
  : I -> Type :=
| iw_sup (x : A)
    : (forall (y : B x), IW I A B i j (j x y)) -> IW I A B i j (i x).

Definition iw_label {A B I i j} {l : I} (w : IW I A B i j l) : A :=
  match w with
  | iw_sup x y => x
  end.

Definition iw_arity {A B I i j} (l : I) (w : IW I A B i j l)
  : forall (y : B (iw_label w)), IW I A B i j (j (iw_label w) y) :=
  match w with
  | iw_sup x y => y
  end.

Definition path_index_iw_label {A B I i j} (l : I) (w : IW I A B i j l)
  : i (iw_label w) = l.
Proof.
  by destruct w.
Defined.

Definition iw_eta {A B I i j} (l : I) (w : IW I A B i j l)
  : path_index_iw_label l w # iw_sup I A B i j (iw_label w) (iw_arity l w) = w.
Proof.
  by destruct w.
Defined.

(** We have a canonical map from the IW-type to the fiber of the index map *)
Definition iw_to_hfiber_index {A B I i j} (l : I) : IW I A B i j l -> hfiber i l.
Proof.
  intros w.
  exists (iw_label w).
  apply path_index_iw_label.
Defined.

Definition pointwise_paths_ind `{Funext} {A : Type} {B : A -> Type}
  (a : forall x, B x)
  (P : forall b, a == b -> Type)
  (f : P a (fun _ => 1%path))
  {b : forall x, B x} (p : a == b)
  : P b p.
Proof.
  refine (equiv_ind apD10 (P b) _ p).
  intros [].
  exact f.
Defined.

(** * Reduction of indexed W-types to W-types *)

(** Jasper Hugunin found this construction (typecheck unindexed trees) in "Indexed Containers by Thorsten Altenkirch and Peter Morris". http://www.cs.nott.ac.uk/~psztxa/publ/ICont.pdf
This references the following:
  * M. Abbott, T. Altenkirch, and N. Ghani. Containers - constructing strictly positive types. Theoretical Computer Science, 342:327, September 2005. Applied Semantics: Selected Topics.
  * N. Gambino and M. Hyland. Wellfounded trees and dependent polynomial functors. In S. Berardi, M. Coppo, and F. Damiani, editors, types for Proofs and Programs (TYPES 2003), Lecture Notes in Computer Science, 2004
as previous examples of the technique. *)

Section Reduction.

  Context (I : Type) (A : Type) (B : A -> Type)
    (i : A -> I) (j : forall x, B x -> I).

  Fixpoint IsIndexedBy (x : I) (w : W A B) : Type :=
    match w with
    | w_sup a b => (i a = x) * (forall c, IsIndexedBy (j a c) (b c))
    end.

  Definition IW' (x : I) := sig (IsIndexedBy x).

  Definition iw_sup' (x : A) (y : forall z : B x, IW' (j x z)) : IW' (i x)
    := (w_sup A B x (fun a => pr1 (y a)); (idpath, (fun a => pr2 (y a)))).

  (** We can derive the induction principle for IW-types *)
  Definition IW'_ind (P : forall i, IW' i -> Type)
    (S : forall x y, (forall c, P _ (y c)) -> P _ (iw_sup' x y))
    : forall x w, P x w.
  Proof.
    intros x [w r].
    revert w x r.
    induction w as [a b k].
    intros x [p IH].
    destruct p.
    refine (S a (fun c => (b c; IH c)) _).
    intros c.
    apply k.
  Defined.

  (** We have definitional computation rules for this eliminator. *)
  Definition IW'_ind_beta_iw_sup' (P : forall i, IW' i -> Type)
    (S : forall x y, (forall c, P _ (y c)) -> P _ (iw_sup' x y)) x y
    : IW'_ind P S _ (iw_sup' x y) = S x y (fun c => IW'_ind P S _ (y c))
    := idpath.

  (** Showing that IW-types are equivalent to W-types requries funext. *)
  Definition equiv_wtype_iwtype `{Funext} (x : I)
    : IW' x <~> IW I A B i j x.
  Proof.
    snrapply equiv_adjointify.
    { rapply (IW'_ind (fun l _ => IW I A B i j l)).
      intros a b c.
      apply iw_sup.
      intros y.
      apply c. }
    { rapply (IW_rect I A B i j (fun l _ => IW' l)).
      intros a b c.
      apply iw_sup'.
      intros y.
      apply c. }
    { rapply (IW_rect I A B i j (fun x y => IW'_ind _ _ x _ = y)).
      cbn; intros a b c.
      apply ap.
      funext y.
      apply c. }
    simpl.
    intro y.
    rapply (IW'_ind (fun x y => IW_rect I A B i j _ _ x _ = y)).
    cbn; intros a b c.
    apply ap.
    funext d.
    apply c.
  Defined.

End Reduction.

(** * Characterization of path types of IW-types. Argument due to Jasper Hugunin. *)

Section Paths.

  Context `{Funext}
    (I : Type) (A : Type) (B : A -> Type)
    (i : A -> I) (j : forall x, B x -> I).

  (** We wish to show that path types of IW-types are IW-types themselves. We do this by showing the path type satisfies the same induction principle as the IW-type hence they are equivalent. *)

  Let I' : Type := {k : I & IW I A B i j k * IW I A B i j k}.
  Let A' : Type := {e : A & (forall c, IW I A B i j (j e c)) * (forall c, IW I A B i j (j e c))}.
  Let B' : A' -> Type := fun X => B X.1.
  Let i' : A' -> I' := functor_sigma i (fun a : A => functor_prod (iw_sup I A B i j a) (iw_sup I A B i j a)).
  Let j' : forall k, B' k -> I' := fun k c => (j k.1 c; (fst k.2 c, snd k.2 c)).

  Let IWPath : I' -> Type := fun x => fst (pr2 x) = snd (pr2 x).

  Definition iwpath_sup (x : A')
    : (forall y : B' x, IWPath (j' x y)) -> IWPath (i' x).
  Proof.
    destruct x as [x [c1 c2]].
    intros y.
    unfold IWPath.
    cbn; apply ap.
    funext l.
    apply y.
  Defined.

  Definition iwpath_sup_refl (x : A) (a : forall c : B x, IW I A B i j (j x c))
    : iwpath_sup (x; (a, a)) (apD10 1) = idpath.
  Proof.
    unfold iwpath_sup.
    rewrite path_forall_1.
    reflexivity.
  Defined.

  Section Ind.

    Context
      (P : forall xab, IWPath xab -> Type)
      (S : forall a b, (forall c, P _ (b c)) -> P (i' a) (iwpath_sup a b)).

    Definition IWPath_ind_refl : forall l a, P (l ; (a, a)) idpath.
    Proof.
      rapply (IW_rect I A B i j (fun l a => P (l; (a, a)) idpath)).
      intros x a q.
      pose (S (x; (a, a)) _ q) as p.
      unfold iwpath_sup in p.
      refine (transport (P (i x; (iw_sup I A B i j x a, iw_sup I A B i j x a))) _ p).
      change (ap (iw_sup I A B i j x) (path_forall a a (apD10 idpath))
        = ap (iw_sup I A B i j x) 1%path).
      refine (ap _ _).
      apply eissect.
    Defined.

    Definition IWPath_ind : forall x p, P x p.
    Proof.
      intros [x [a b]].
      unfold IWPath; cbn.
      destruct p.
      apply IWPath_ind_refl.
    Defined.

    (** The computation rule for the induction principle. *)
    Definition IWPath_ind_beta_iwpath_sup (x : A') (h : forall y : B' x, IWPath (j' x y))
      : IWPath_ind _ (iwpath_sup x h)
        = S x h (fun c => IWPath_ind _ (h c)).
    Proof.
      destruct x as [x [a b]].
      cbv in h.
      refine (_ @ _).
      { refine (_ @ ap _ (eisadj (path_forall _ _) h)).
        refine (paths_ind _
          (fun b p' =>
            paths_ind _ (fun r p'' => P (i x ; (iw_sup I A B i j x a , r)) p'')
              (IWPath_ind_refl (i x) (iw_sup I A B i j x a))
              _ (ap (iw_sup I A B i j x) p')
            = paths_rec (path_forall _ _ (apD10 p'))
                (fun p'' => P (_ ; (_, _)) (ap (iw_sup I A B i j x) p''))
                (S (x ; (a, b)) (apD10 p')
                (fun c => IWPath_ind (_ ; (_, _)) (apD10 p' c)))
                p' (eissect apD10 p'))
          _ _ _).
        exact (transport_compose _ _ _ _)^. }
      by cbn; destruct (eisretr apD10 h).
    Defined.

  End Ind.

  (** The path type of an IW-type is again an IW-type. *)
  Definition equiv_path_iwtype (x : I) (a b : IW I A B i j x)
    : IW I' A' B' i' j' (x; (a, b)) <~> a = b.
  Proof.
    change (IW I' A' B' i' j' (x; (a, b)) <~> IWPath (x; (a,b))).
    snrapply equiv_adjointify.
    { intros y.
      induction y as [e f g].
      apply iwpath_sup.
      intros y.
      apply g. }
    { intros y.
      induction y as [e f g] using IWPath_ind.
      apply iw_sup.
      intros y.
      apply g. }
    { intros y; cbn.
      induction y as [a' b' IH] using IWPath_ind.
      rewrite IWPath_ind_beta_iwpath_sup.
      simpl; f_ap.
      funext c.
      apply IH. }
    intros y; cbn.
    induction y as [e f IH].
    rewrite IWPath_ind_beta_iwpath_sup.
    f_ap; funext c.
    apply IH.
  Defined.

  (** ** Characterization of fiber *)

  (** We begin with two auxillary lemmas that will be explained shortly. *)
  Local Definition adjust_hfiber {X Y} {f : X -> Y} {y z}
    : hfiber f y -> y = z -> hfiber f z
    := fun '(x ; p) => match p with idpath => fun q => (x ; q) end.

  Local Definition adjust_hfiber_idpath {X Y} {f : X -> Y} {y xp}
    : adjust_hfiber (f:=f) xp (idpath : y = y) = xp.
  Proof.
    by destruct xp as [x []].
  Defined.

  (** We wish to show an induction principle coming from the path type of the fiber. However to do this we need to be a bit more general by allowing the elements of the IW-type to differ in label upto equality. This allows us to do prove this induction principle easily, and later we will derive the induction principle where the labels are the same. *)
  Local Definition path_iw_to_hfiber_ind'
    (P : forall (la lb : I) (le : lb = la) (a : IW I A B i j la) (b : IW I A B i j lb),
      iw_to_hfiber_index la a = adjust_hfiber (iw_to_hfiber_index lb b) le -> Type)
    (h : forall x a b,
      P (i x) (i x) idpath (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath)
    : forall la lb le a b p, P la lb le a b p.
  Proof.
    intros la lb le a b.
    destruct a as [xa cha], b as [xb chb].
    intros p.
    refine (paths_ind _
      (fun _ q => forall chb, P _ _ _ _ (iw_sup _ _ _ _ _ _ chb) q) _ _ p chb).
    intros x.
    apply h.
  Defined.

  (** Induction principle for paths in the fiber. *)
  Local Definition path_iw_to_hfiber_ind
    (P : forall (l : I) (a b : IW I A B i j l),
      iw_to_hfiber_index l a = iw_to_hfiber_index l b -> Type)
    (h : forall x a b,
      P (i x) (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath)
    : forall l a b p, P l a b p.
  Proof.
    intros l a b p.
    transparent assert (Q : (forall (la lb : I) (le : lb = la)
      (a : IW I A B i j la) (b : IW I A B i j lb),
      iw_to_hfiber_index la a = adjust_hfiber (iw_to_hfiber_index lb b) le -> Type)).
    { intros la lb le.
      destruct le.
      intros a' b' p'.
      refine (P lb _ _ _).
      exact (p' @ adjust_hfiber_idpath). }
    transparent assert (h' : ((forall (x : A) (a b : forall y : B x, IW I A B i j (j x y)),
        Q (i x) (i x) idpath (iw_sup I A B i j x a) (iw_sup I A B i j x b) idpath))).
    { intros x a' b'.
      apply h. }
    pose (path_iw_to_hfiber_ind' Q h' l l idpath a b (p @ adjust_hfiber_idpath^)) as q.
    refine (transport (P l a b) _ q).
    apply concat_pV_p.
  Defined.

  (** Induction principle for families over hfiber of i' *)
  Local Definition hfiber_ind
    (P : forall l a b, hfiber i' (l; (a, b)) -> Type)
    (h : forall x a b, P (i x) (iw_sup I A B i j x a)
      (iw_sup I A B i j x b) ((x; (a, b)); idpath))
    : forall l a b p, P l a b p.
  Proof.
    intros l a b [[x [y z]] p].
    unfold i', functor_sigma, functor_prod in p; simpl in p.
    revert p.
    refine (equiv_ind (equiv_path_sigma _ _ _) _ _).
    intros [p q]; simpl in p, q.
    destruct p.
    revert q; cbn.
    refine (equiv_ind (equiv_path_prod _ _) _ _).
    cbn; intros [p q].
    destruct p, q.
    apply h.
  Defined.

  Local Definition path_iw_to_hfiber l a b
    : iw_to_hfiber_index l a = iw_to_hfiber_index l b -> hfiber i' (l; (a, b))
    := path_iw_to_hfiber_ind (fun l a b _ => hfiber i' (l ; (a, b)))
        (fun x a b => ((x ; (a, b)); idpath)) l a b.

  Local Definition hfiber_to_path_iw l a b
    : hfiber i' (l; (a, b)) -> iw_to_hfiber_index l a = iw_to_hfiber_index l b
    := hfiber_ind
        (fun l a b _ => iw_to_hfiber_index l a = iw_to_hfiber_index l b)
        (fun x a b => idpath) l a b.

  Local Definition path_iw_to_hfiber_to_path_iw
    : forall l a b p, path_iw_to_hfiber l a b (hfiber_to_path_iw l a b p) = p.
  Proof.
    refine (hfiber_ind (fun l a b p
      => path_iw_to_hfiber l a b (hfiber_to_path_iw l a b p) = p) _).
    intros x a b.
    reflexivity.
  Defined.

  Local Definition hfiber_to_path_iw_to_hfiber
    : forall l a b p, hfiber_to_path_iw l a b (path_iw_to_hfiber l a b p) = p.
  Proof.
    rapply path_iw_to_hfiber_ind.
    intros x a b.
    reflexivity.
  Defined.

  (** The path type of the fibers of [i] is equivalent to the fibers of [i']. *)
  Definition equiv_path_hfiber_index (l : I) (a b : IW I A B i j l)
    : iw_to_hfiber_index l a = iw_to_hfiber_index l b <~> hfiber i' (l; (a, b)).
  Proof.
    srapply equiv_adjointify.
    + apply path_iw_to_hfiber.
    + apply hfiber_to_path_iw.
    + rapply path_iw_to_hfiber_to_path_iw.
    + rapply hfiber_to_path_iw_to_hfiber.
  Defined.

End Paths.

(** Some properties of the (fibers of the) index map [i] hold for the IW-type as well. For example, if [i] is an embedding then the corresponding IW-type is a hprop. *)

(** ** IW-types preserve truncation *)

(** We can show that if the index map is an embedding then the IW-type is a hprop. *)
Global Instance ishprop_iwtype `{Funext}
  (I : Type) (A : Type) (B : A -> Type)
  (i : A -> I) (j : forall x, B x -> I) {h : IsEmbedding i}
  : forall x, IsHProp (IW I A B i j x).
Proof.
  intros l.
  apply hprop_allpath.
  intros x.
  induction x as [x x' IHx].
  intros y.
  (** We need to induct on y and at the same time generalize the goal to become a dependent equality. This can be difficult to do with tactics so we just refine the corresponding match statement. All we have done is turn the RHS into a transport over an equality allowing the induction on y to go through. *)
  refine (
    match y in (IW _ _ _ _ _ l)
      return (forall q : l = i x,
        iw_sup I A B i j x x' = q # y)
    with iw_sup y y' => _ end idpath).
  intros q.
  pose (r := @path_ishprop _ (h (i x)) (x; idpath) (y; q)).
  set (r2 := r..2); cbn in r2.
  set (r1 := r..1) in r2; cbn in r1.
  clearbody r1 r2.
  destruct r1.
  simpl in r2.
  destruct r2.
  cbn; f_ap.
  funext a.
  apply IHx.
Defined.

(** Now by induction on truncation indices we show that IW-types are n.+1 truncated if the index maps are also n.+1 truncated. *)
Global Instance istrunc_iwtype `{Funext}
  (I : Type) (A : Type) (B : A -> Type) (i : A -> I)
  (j : forall x, B x -> I) (n : trunc_index) {h : IsTruncMap n.+1 i} (l : I)
  : IsTrunc n.+1 (IW I A B i j l).
Proof.
  (** We need a general induction hypothesis *)
  revert n I A B i j h l.
  induction n as [|n IHn].
  1: apply ishprop_iwtype.
  intros I A B i j h l.
  intros x y.
  refine (istrunc_equiv_istrunc _
    (equiv_path_iwtype I A B i j l x y) (n := n.+1)).
  apply IHn.
  intros [k [a b]].
  (** The crucial step is to characterize the fiber of [i'] which was done previously. *)
  apply (istrunc_equiv_istrunc _
    (equiv_path_hfiber_index I A B i j k a b)).
Defined.

(** ** Decidable equality for IW-types *)

(** If A has decidable paths then it is a hset and therefore equality of sigma types over it are determined by the second component. *)
Local Definition inj_right_pair_on
  {A : Type} {A_dec : DecidablePaths A}
  (P : A -> Type) (x : A) (y y' : P x)
    (H : (x; y) = (x; y')) : y = y'.
Proof.
  apply (equiv_path_sigma _ _ _)^-1%equiv in H.
  destruct H as [p q]; cbn in p, q.
  assert (r : idpath = p) by apply path_ishprop.
  destruct r.
  exact q.
Defined.

(** ** IW-types have decidable equality if liftP holds and the fibers of the indexing map have decidable paths. Notably, if B x is finitely enumerable, then liftP holds. *)
Section DecidablePaths.

  Context `{Funext}
    (I : Type) (A : Type) (B : A -> Type) (i : A -> I) (j : forall x, B x -> I)
    (liftP : forall (x : A) (P : B x -> Type),
     (forall c, Decidable (P c)) -> Decidable (forall c, P c))
    (fibers_dec : forall x, DecidablePaths (hfiber i x)).

  Let children_for (x : A) : Type := forall c, IW I A B i j (j x c).
  Let getfib {x} (a : IW I A B i j x) : hfiber i x
    := match a with iw_sup x _ => (x ; idpath) end.
  Let getfib_computes x y children p
    : getfib (paths_rec (i y) _ (iw_sup _ _ _ _ _ y children) (i x) p) = exist _ y p
    := match p
         return getfib (paths_rec _ _ (iw_sup _ _ _ _ _ y children) _ p) = exist _ y p
       with idpath => idpath end.
  Let getfib_plus {x} (a : IW I A B i j x)
    : {f : hfiber i x & children_for (pr1 f)}
    := match a with iw_sup x c => ((x; idpath); c) end.
  Let children_eq (x : A) (c1 c2 : forall c, IW I A B i j (j x c))
    : iw_sup I A B i j x c1 = iw_sup I A B i j x c2 -> c1 = c2
    := fun r => inj_right_pair_on (fun f => children_for (pr1 f))
         (x; idpath) _ _ (ap getfib_plus r).

  Fixpoint decide_eq l (a : IW I A B i j l) : forall b, Decidable (a = b).
  Proof.
    destruct a as [x c1].
    intro b.
    transparent assert (decide_children : (forall c2, Decidable (c1 = c2))).
    { intros c2.
      destruct (liftP x (fun c => c1 c = c2 c) (fun c => decide_eq _ (c1 c) (c2 c)))
        as [p|p].
      + left; by apply path_forall.
      + right; intro h; by apply p, apD10. }
    snrefine (
      match b in (IW _ _ _ _ _ l)
        return
          forall iy : l = i x,
            Decidable (iw_sup I A B i j x c1
              = paths_rec l (IW I A B i j) b (i x) iy)
      with iw_sup y c2 => fun iy : i y = i x => _ end idpath).
    destruct (fibers_dec (i x) (x ; idpath) (y ; iy)) as [feq|fneq].
    + refine (
        match feq in (_ = (y ; iy))
          return forall c2,
            Decidable (iw_sup _ _ _ _ _ x c1
              = paths_rec (i y) (IW I A B i j) (iw_sup _ _ _ _ _ y c2) (i x) iy)
          with idpath => _
        end c2).
      cbn; intros c3.
      destruct (decide_children c3) as [ceq | cneq].
      - left; exact (ap _ ceq).
      - right; intros r; apply cneq.
        exact (children_eq x c1 c3 r).
    + right; intros r; apply fneq.
      exact (ap getfib r @ getfib_computes x y c2 iy).
  Defined.

  Definition decidablepaths_iwtype
    : forall x, DecidablePaths (IW I A B i j x).
  Proof.
    intros x a b.
    apply decide_eq.
  Defined.

End DecidablePaths.


Require Import Tapl.Stlc.Base.
Require Import Tapl.Stlc.Exp.
Require Import Tapl.Stlc.Typing.

(* Lemmas *)

(* Lifting a wf term does nothing. *)
Lemma lift_wf_id : forall G t i,
  length G <= i
  -> wf G t
  -> lift i t = t.
Proof.
  intros.
  generalize dependent G.
  generalize dependent i.
  induction t; intros; simpl.
  - inversion H0; subst. destruct H3.
    assert (n < length G). apply get_length with (x := x); auto.
    assert (n < i). { apply Nat.le_trans with (m := length G); auto. }
    destruct (n ?= i) eqn:eqH.
    + apply Nat.compare_eq in eqH. apply Nat.lt_neq in H3. apply H3 in eqH. exfalso; assumption.
    + reflexivity.
    + apply Nat.compare_gt_iff in eqH. apply Nat.lt_asymm in eqH. apply eqH in H3; exfalso; assumption.
  - inversion H0; subst. pose proof IHt (S i) (t :: G).
    assert (lift (S i) t0 = t0).
    apply H1. simpl. apply Le.le_n_S; auto.
    apply H3.
    rewrite H2. reflexivity.
  - inversion H0; subst. apply IHt1 with (i := i) in H4. apply IHt2 with (i := i) in H5. simpl. rewrite -> H4. rewrite -> H5. reflexivity. auto. auto.
  - reflexivity.
Qed.
(* Corollary: lifting closed term does nothing. *)
Lemma lift_closed_id : forall t i,
  closed t -> lift i t = t.
Proof.
  intros. apply lift_wf_id with (G := nil); auto. apply le_0_n.
Qed.


(*****************************)
(*****************************)
(****                     ****)
(****   Typing contexts   ****)
(****                     ****)
(*****************************)
(*****************************)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Main.SystemF.FreeVar.
Require Import Main.SystemF.LocalClosure.
Require Import Main.SystemF.Name.
Require Import Main.SystemF.Substitution.
Require Import Main.SystemF.Syntax.
Require Import Main.Tactics.

Import Coq.Lists.List.ListNotations.

Inductive context :=
| cEmpty : context
| cEExtend : context -> name -> type -> context
| cTExtend : context -> name -> context.

(*******************)
(* Variable lookup *)
(*******************)

Fixpoint eLookup c1 x1 :=
  match c1 with
  | cEmpty => None
  | cEExtend c2 x2 t => if nameEq x1 x2 then Some t else eLookup c2 x1
  | cTExtend c2 _ => eLookup c2 x1
  end.

Fixpoint tLookup c1 x1 :=
  match c1 with
  | cEmpty => false
  | cEExtend c2 _ _ => tLookup c2 x1
  | cTExtend c2 x2 => if nameEq x1 x2 then true else tLookup c2 x1
  end.

(***********)
(* Domains *)
(***********)

Fixpoint eDomain c1 :=
  match c1 with
  | cEmpty => []
  | cEExtend c2 x t => x :: eDomain c2
  | cTExtend c2 _ => eDomain c2
  end.

Fixpoint tDomain c1 :=
  match c1 with
  | cEmpty => []
  | cEExtend c2 _ _ => tDomain c2
  | cTExtend c2 x => x :: tDomain c2
  end.

(************************)
(* Type well-formedness *)
(************************)

Definition tWellFormed c t :=
  tLocallyClosed t 0 /\
  incl (tFreeVars t) (tDomain c).

(***************************)
(* Context well-formedness *)
(***************************)

Inductive cWellFormed : context -> Prop :=
| cwfEmpty :
  cWellFormed cEmpty
| cwfEExtend :
  forall c t x,
  ~ In x (eDomain c) ->
  tWellFormed c t ->
  cWellFormed c ->
  cWellFormed (cEExtend c x t)
| cwfTExtend :
  forall c x,
  ~ In x (tDomain c) ->
  cWellFormed c ->
  cWellFormed (cTExtend c x).

#[export] Hint Constructors cWellFormed : main.

(*****************************)
(* Concatenation of contexts *)
(*****************************)

Fixpoint cConcat c1 c2 :=
  match c2 with
  | cEmpty => c1
  | cEExtend c3 x t2 => cEExtend (cConcat c1 c3) x t2
  | cTExtend c3 x => cTExtend (cConcat c1 c3) x
  end.

(****************************)
(* Substitution on contexts *)
(****************************)

Fixpoint cSub c1 x1 t1 :=
  match c1 with
  | cEmpty => cEmpty
  | cEExtend c2 x2 t2 => cEExtend (cSub c2 x1 t1) x2 (ttSub t2 x1 t1)
  | cTExtend c2 x2 => cTExtend (cSub c2 x1 t1) x2
  end.

(***********************************)
(* Facts about domains and lookups *)
(***********************************)

Theorem eDomainLookup :
  forall c x,
  In x (eDomain c) <-> exists t, eLookup c x = Some t.
Proof.
  clean. split; induction c; eSearch. clean. destruct H; eSearch.
Qed.

#[export] Hint Resolve -> eDomainLookup : main.
#[export] Hint Resolve <- eDomainLookup : main.

Theorem tDomainLookup :
  forall c x,
  In x (tDomain c) <-> tLookup c x = true.
Proof.
  clean. induction c; search.
Qed.

#[export] Hint Resolve -> tDomainLookup : main.
#[export] Hint Resolve <- tDomainLookup : main.

(************************************)
(* Facts about type well-formedness *)
(************************************)

Theorem tWellFormedClosed :
  forall c t x,
  tWellFormed c t ->
  In x (tFreeVars t) ->
  In x (tDomain c).
Proof.
  clean. apply tDomainLookup. invert H. search.
Qed.

#[export] Hint Resolve tWellFormedClosed : main.

Theorem tLookupWellFormed :
  forall c x t,
  cWellFormed c ->
  eLookup c x = Some t ->
  tWellFormed c t.
Proof.
  clean. unfold tWellFormed. induction H; search. clean.
  destruct (nameEq x x0); search. clean. invert H0. search.
Qed.

#[export] Hint Resolve tLookupWellFormed : main.

(****************************)
(* Facts about substitution *)
(****************************)

Theorem cSubEDomain :
  forall c x t,
  eDomain (cSub c x t) = eDomain c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cSubEDomain : main.

Theorem cSubTDomain :
  forall c x t,
  tDomain (cSub c x t) = tDomain c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cSubTDomain : main.

(*****************************************)
(* Facts about concatenation of contexts *)
(*****************************************)

Theorem cConcatEmpty : forall c, cConcat cEmpty c = c.
Proof.
  induction c; search.
Qed.

#[export] Hint Resolve cConcatEmpty : main.

Theorem cConcatAssoc :
  forall c1 c2 c3,
  cConcat (cConcat c1 c2) c3 = cConcat c1 (cConcat c2 c3).
Proof.
  induction c2; induction c3; search.
Qed.

#[export] Hint Resolve cConcatAssoc : main.

(*****************************************)
(* Facts about concatenation and domains *)
(*****************************************)

Theorem eDomainConcat :
  forall c1 c2,
  eDomain (cConcat c1 c2) = eDomain c2 ++ eDomain c1.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve eDomainConcat : main.

Theorem tDomainConcat :
  forall c1 c2,
  tDomain (cConcat c1 c2) = tDomain c2 ++ tDomain c1.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve tDomainConcat : main.

(****************************************)
(* Facts about concatenation and lookup *)
(****************************************)

Theorem cConcatELookup :
  forall c1 c2 t x,
  eLookup (cConcat c1 c2) x = Some t ->
  eLookup c1 x = Some t \/ eLookup c2 x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cConcatELookup : main.

Theorem cConcatTLookup :
  forall c1 c2 x,
  tLookup (cConcat c1 c2) x = true ->
  tLookup c1 x = true \/ tLookup c2 x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cConcatTLookup : main.

Theorem cELookupConcatRight :
  forall c1 c2 t x,
  eLookup c2 x = Some t ->
  eLookup (cConcat c1 c2) x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cELookupConcatRight : main.

Theorem cELookupConcatLeft :
  forall c1 c2 t x,
  eLookup c1 x = Some t ->
  eLookup c2 x = None ->
  eLookup (cConcat c1 c2) x = Some t.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cELookupConcatLeft : main.

Theorem cTLookupConcatRight :
  forall c1 c2 x,
  tLookup c2 x = true ->
  tLookup (cConcat c1 c2) x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cTLookupConcatRight : main.

Theorem cTLookupConcatLeft :
  forall c1 c2 x,
  tLookup c1 x = true ->
  tLookup (cConcat c1 c2) x = true.
Proof.
  induction c2; search.
Qed.

#[export] Hint Resolve cTLookupConcatLeft : main.

Theorem cELookupNone :
  forall c1 c2 t x,
  eLookup c1 x = Some t ->
  cWellFormed (cConcat c1 c2) ->
  eLookup c2 x = None.
Proof.
  clean. induction c2; search; invert H0; feed IHc2; clean.
  destruct (nameEq x n); search. clean.
  assert (In n (eDomain c1)); eSearch.
  rewrite eDomainConcat in H4.
  unfold not in H4. search.
Qed.

#[export] Hint Resolve cELookupNone : main.

Theorem cTLookupNone :
  forall c1 c2 x,
  tLookup c1 x = true ->
  cWellFormed (cConcat c1 c2) ->
  tLookup c2 x = false.
Proof.
  clean. induction c2; search; invert H0; feed IHc2; clean.
  destruct (nameEq x n); search. clean.
  assert (In n (tDomain c1)); [eSearch | idtac].
  rewrite tDomainConcat in H3.
  unfold not in H3. search.
Qed.

#[export] Hint Resolve cTLookupNone : main.

(***************************************)
(* Facts about context well-formedness *)
(***************************************)

Theorem cWellFormedESkip :
  forall c1 c2 t x,
  cWellFormed (cConcat (cEExtend c1 x t) c2) ->
  cWellFormed (cConcat c1 c2).
Proof.
  clean. induction c2; invert H; search; clean; constructor; search.
  - rewrite eDomainConcat in *. clean.
    unfold not in *. clean.
    pose proof (in_app_or (eDomain c2) (eDomain c1) n H).
    destruct H0; search.
  - unfold tWellFormed in *. split; search. clean.
    rewrite tDomainConcat in *. search.
  - rewrite tDomainConcat in *. search.
Qed.

#[export] Hint Resolve cWellFormedESkip : main.

Theorem cWellFormedTSkip :
  forall c1 c2 t x,
  cWellFormed (cConcat (cTExtend c1 x) c2) ->
  tWellFormed c1 t ->
  cWellFormed (cConcat c1 (cSub c2 x t)).
Proof.
  clean. induction c2; invert H; search; clean; constructor; search.
  - unfold tWellFormed in H5.
    rewrite eDomainConcat in *. rewrite cSubEDomain.
    unfold not in *. clean.
    assert (In n (eDomain c2) \/ In n (eDomain c1)); search.
  - unfold tWellFormed in *. split; search. clean.
    apply incl_tran with (
      m := tFreeVars t ++ remove nameEq x (tFreeVars t0)
    ); search.
    rewrite tDomainConcat. rewrite tDomainConcat in H1.
    assert (
      incl
        (remove nameEq x (tFreeVars t0))
        (tDomain (cSub c2 x t) ++ tDomain c1)
    ); search.
    rewrite cSubTDomain.
    unfold incl in *. clean.
    specialize (H1 a). feed H1.
    + pose proof (nameInRemove (tFreeVars t0) a x H3). search.
    + pose proof (remove_In nameEq (tFreeVars t0) x).
      assert (a <> x); search. clear H5.
      pose proof (in_app_or (tDomain c2) (x :: tDomain c1) a H1).
      destruct H5; search.
  - rewrite tDomainConcat in *.
    unfold not in *. clean.
    assert (In n (tDomain (cSub c2 x t)) \/ In n (tDomain c1)); search.
    destruct H1; search.
    rewrite cSubTDomain in H1. search.
Qed.

#[export] Hint Resolve cWellFormedTSkip : main.