From Formalisation Require Import String SizeNat Vector Span.
From stdpp Require Import numbers.

Open Scope N_scope.

Section Syntax.

  Inductive type : Type :=
  | Nat
  | NatN : N -> type
  | Bool
  | Vector : type -> type
  | String
  | Unit
  | Span
  | Unknown : string -> type
  | Option : type -> type
  | Pair : type -> type -> type
  | Sum : type -> type -> type.

  Fixpoint type_to_Type (ty : type) : Type :=
    match ty with
    | Nat => N
    | NatN n => natN n
    | Bool => bool
    | Vector ty => VECTOR (type_to_Type ty)
    | String => string
    | Unit => unit
    | Span => span
    | Option ty => option (type_to_Type ty)
    | Pair ty0 ty1 => type_to_Type ty0 * type_to_Type ty1
    | Sum ty0 ty1 => type_to_Type ty0 + type_to_Type ty1
    | Unknown s => True
    end.

  Fixpoint type_eq_dec (x y : type) : {x = y} + {x ≠ y}.
    Local Ltac type_eq_dec_tac :=
      match goal with
      | |- {?l = ?l} + {_ ≠ _} => eapply left; reflexivity
      | |- {?l = ?r} + {_ ≠ _} => eapply right; intro H; inversion H; done
      end.
    destruct x,y; try type_eq_dec_tac.
    destruct (N.eq_dec n n0).
    left. subst. reflexivity.
    right. intro. eapply n1. inversion H. reflexivity.
    destruct (type_eq_dec x y).
    left. subst. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    destruct (string_dec s s0).
    left. subst. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    destruct (type_eq_dec x y).
    left. subst. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    destruct (type_eq_dec x1 y1).
    destruct (type_eq_dec x2 y2).
    left. subst. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    destruct (type_eq_dec x1 y1).
    destruct (type_eq_dec x2 y2).
    left. subst. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
    right. intro. eapply n. inversion H. reflexivity.
  Defined.

  Context {var : type -> Type}.

  Inductive OpBin : type -> type -> type -> Type :=
  | EAdd : OpBin Nat Nat Nat
  | ESub : OpBin Nat Nat Nat
  | EMult : OpBin Nat Nat Nat
  | EDiv : OpBin Nat Nat Nat
  | EMod : OpBin Nat Nat Nat
  | EEq : OpBin Nat Nat Bool
  | ELe : OpBin Nat Nat Bool
  | ELt : OpBin Nat Nat Bool
  | EAnd : OpBin Bool Bool Bool
  | EOr : OpBin Bool Bool Bool
  | EStringGet : OpBin Nat String (NatN 8)
  | EPair : forall {X Y}, OpBin X Y (Pair X Y)
  | EpTo2p: forall {p: N}, OpBin (NatN p) (NatN p) (NatN (2 * p))
  | EGetVec : forall {X}, OpBin (Vector X) Nat (Option X)
  | EAddVec : forall {X}, OpBin (Vector X) X (Vector X).

  Inductive OpUna : type -> type -> Type :=
  | EVal : forall {len}, OpUna (NatN len) Nat
  | ENot : OpUna Bool Bool
  | EStringLen : OpUna String Nat
  | EFst : forall {X Y}, OpUna (Pair X Y) X
  | ESnd : forall {X Y}, OpUna (Pair X Y) Y
  | ESome : forall {X}, OpUna X (Option X)
  | EInl : forall {X Y}, OpUna X (Sum X Y)
  | EInr : forall {X Y}, OpUna Y (Sum X Y)
  | ELen : OpUna Span Nat
  | EMake : forall {X}, OpUna Nat (Vector X).

  Inductive Literal : type -> Type :=
  | ENat : N -> Literal Nat
  | ENatN : forall {len}, natN len -> Literal (NatN len)
  | EBool : bool -> Literal Bool
  | EString : string -> Literal String
  | ENone : forall {X}, Literal (Option X)
  | EUnit : Literal Unit.

  Inductive VAL : type -> Type :=
  | Var : forall {X}, var X -> VAL X
  | EBin : forall {X Y Z}, OpBin X Y Z -> VAL X -> VAL Y -> VAL Z
  | EUna : forall {X Y}, OpUna X Y -> VAL X -> VAL Y
  | Const : forall {X}, Literal X -> VAL X.

  Inductive LIST :=
  | NIL : LIST
  | CONS : forall {X}, VAL X -> LIST -> LIST.

  Inductive PHOAS : type -> Type :=
  | ExternStruct : forall (ty : string), string -> LIST -> PHOAS (Unknown ty)
  | Val : forall {X}, VAL X -> PHOAS X
  | LetIn : forall {X}, PHOAS X -> forall {Y}, (var X -> PHOAS Y) -> PHOAS Y

  | IfThenElse : VAL Bool -> forall {X}, PHOAS X -> PHOAS X -> PHOAS X
  | CaseOption : forall {X}, VAL (Option X)  -> forall {Y}, PHOAS Y -> (var X -> PHOAS Y) -> PHOAS Y
  | Switch : VAL Nat -> forall {X}, case_switch X -> PHOAS X

  | Fail : forall {X}, PHOAS X
  | Take : VAL Nat -> PHOAS Span
  | Length : PHOAS Nat
  | Read : VAL Span -> VAL Nat -> PHOAS (NatN 8)
  | Alt : forall {X}, PHOAS X -> PHOAS X -> PHOAS X
  | Local : VAL (Option Span) -> forall {X}, PHOAS X -> PHOAS X
  | Repeat  : VAL (Option Nat) -> forall {X}, (var X -> PHOAS X) -> VAL X -> PHOAS X

  with case_switch : type -> Type :=
  | LSnil : forall {X}, PHOAS X -> case_switch X
  | LScons : N -> forall {X}, PHOAS X -> case_switch X -> case_switch X.

End Syntax.

Notation "'let%' v ':=' e 'in' k" := (LetIn e (fun v => k))(at level 50).
Notation "'If' b 'Then' et 'Else' ef" := (IfThenElse b et ef)(at level 50).
Notation "b0 '<!' b1" := (EBin ELt b0 b1)(at level 30).
Notation "b0 '<=!' b1" := (EBin ELe b0 b1)(at level 30).
Notation "n0 '+!' n1" := (EBin EAdd n0 n1)(at level 25, left associativity).
Notation "n0 '-!' n1" := (EBin ESub n0 n1)(at level 25, left associativity).
Notation "'(!' a ',' b ')'" := (EBin EPair a b)(at level 25, left associativity).
Notation "↓ n" := (SizeNat.val n)(at level 20).

Section sem_PHOAS.

  Fixpoint lengthN {X} (l : list X) : N :=
    match l with
    | [] => 0
    | _ :: t => N.succ (lengthN t)
    end.

  Definition val := type_to_Type.

  Definition PHOASV : type -> Type := @PHOAS val.

  Lemma zero_is_u8 : 0 < 2 ^ 8. simpl. lia. Qed.

  Lemma sub_natN : forall len (n0 n1 : natN len), ↓ n0 - ↓ n1 < 2 ^ len.
  Proof. intros len [v0 P0] [v1 P1]. simpl. lia. Qed.

  Lemma div_natN : forall len (n0 n1 : natN len), ↓ n1 > 0 -> ↓ n0 / ↓ n1 < 2 ^ len.
  Proof.
    intros len [v0 P0] [v1 P1] LT. simpl in *. eapply (N.le_lt_trans _ v0); auto.
    transitivity (v1 * v0 `div` v1). 2 : eapply N.mul_div_le; lia.
    rewrite <- (N.mul_1_l (v0 `div` v1)) at 1. eapply N.mul_le_mono_r. lia.
  Qed.

  Lemma mod_natN : forall len (n0 n1 : natN len), ↓ n1 > 0 -> ↓ n0 `mod` ↓ n1 < 2 ^ len.
  Proof.
    intros len [v0 P0] [v1 P1] LT. simpl in *. transitivity v1; auto.
    eapply N.mod_lt. lia.
  Qed.

  (* 12 rules *)
  Inductive sem_bin : forall {X Y} Z, OpBin X Y Z -> val X -> val Y -> val Z -> Prop :=
  | SAdd : forall n0 n1,
      (* sem_val vn0 = n0 -> *)
      (* sem_val vn1 = n1 -> *)
      sem_bin Nat EAdd n0 n1 (n0 + n1)
  | SSub : forall n0 n1,
      sem_bin Nat ESub n0 n1 (n0 - n1)
  | SMult :  forall n0 n1,
      sem_bin Nat EMult n0 n1 (n0 * n1)
  | SDiv : forall n0 n1,
      sem_bin Nat EDiv n0 n1 (n0 / n1)
  | SMod : forall n0 n1,
      sem_bin Nat EMod n0 n1 (n0 `mod` n1)
  | SEq : forall n0 n1,
      sem_bin Bool EEq n0 n1 (n0 =? n1)
  | SLe : forall n0 n1,
      sem_bin Bool ELe n0 n1 (n0 <=? n1)
  | SLt : forall n0 n1,
      sem_bin Bool ELt n0 n1 (n0 <? n1)
  | SAnd : forall b0 b1,
      sem_bin Bool EAnd b0 b1 (b0 && b1)
  | SOr :forall b0 b1,
      sem_bin Bool EOr b0 b1 (b0 || b1)
  | SStringGet : forall s n r,
      string_get n s = Some r ->
      sem_bin (NatN 8) EStringGet n s r
  | SPair : forall X Y n0 n1,
      sem_bin (Pair X Y) EPair n0 n1 (n0, n1)
  | SpTo2p: forall len n0 n1,
      sem_bin (NatN (2 * len)) EpTo2p n0 n1 (n0 ↑ n1)
  | SGetVec : forall X vec n,
      sem_bin (Option X) EGetVec vec n (get vec n)
  | SAddVec : forall ty (vec : VECTOR (type_to_Type ty)) x,
      sem_bin (Vector ty) EAddVec vec x (Vector.add vec x).

  (* 10 rules *)
  Inductive sem_unary : forall {X} Y, OpUna X Y -> val X -> val Y -> Prop :=
  | SEVal : forall len (n : val (NatN len)),
      sem_unary Nat EVal n (↓ n)
  | SNot : forall b,
      sem_unary Bool ENot b (negb b)
  | SStringLenOK : forall s,
      sem_unary Nat EStringLen s (string_length s)
  | SFst : forall X Y (v : val (Pair X Y)),
      sem_unary X EFst v (v.1)
  | SSnd : forall X Y (v : val (Pair X Y)),
      sem_unary Y ESnd v (v.2)
  | SSome : forall X n,
      sem_unary (Option X) ESome n (Some n)
  | SInl : forall X Y v,
      sem_unary (Sum X Y) EInl v (inl v)
  | SInr : forall X Y v,
      sem_unary (Sum X Y) EInr v (inr v)
  | SLen : forall s,
      sem_unary Nat ELen s (len s)
  | SMake : forall ty n,
      sem_unary (Vector ty) EMake n (Vector.make (type_to_Type ty) n).

  (* 4 rules *)
  Inductive sem_literal : forall {X : type}, Literal X -> val X -> Prop :=
  | SNat : forall n,
        sem_literal (ENat n) n
  | SNatN : forall len (n : natN len),
      sem_literal (ENatN n) n
  | SBool : forall b,
      sem_literal (EBool b) b
  | SString : forall s,
      sem_literal (EString s) s
  | SNone : forall X,
      sem_literal (ENone : Literal (Option X)) None
  | SUnit : sem_literal EUnit tt.

  (* 4 rules *)
  Inductive sem_VAL: forall {X}, @VAL val X -> val X -> Prop :=
  | SVar : forall X (v : val X), sem_VAL (Var v) v
  | SBin : forall X Y Z (ob : OpBin X Y Z) (vv0 : VAL X) (vv1 : VAL Y) v0 v1 res,
      sem_VAL vv0 v0 ->
      sem_VAL vv1 v1 ->
      sem_bin Z ob v0 v1 res ->
      sem_VAL (EBin ob vv0 vv1) res
  | SUna : forall X Y (ou : OpUna X Y) (vv0 : VAL X) v0 res,
      sem_VAL vv0 v0 ->
      sem_unary Y ou v0 res ->
      sem_VAL (EUna ou vv0) res
  | SConst : forall X (lit : Literal X) v,
      sem_literal lit v ->
      sem_VAL (Const lit) v.

  (* 20 rules *)
  Inductive sem_PHOAS (data : list nat8):
      forall {X : type}, span -> PHOASV X  -> option (val X * span) -> Prop :=
  | SExternStruct : forall ty f l v s,
      sem_PHOAS data s (ExternStruct ty f l) (Some (v, s))

  | SVal : forall X (vv : VAL X) v s,
      sem_VAL vv v ->
      sem_PHOAS data s (Val vv) (Some (v,s))

  | SLetInS : forall (X Y : type) (e : PHOASV X) (f : val X -> PHOASV Y)  v res p0 p1,
      sem_PHOAS data p0 e (Some (v,p1)) ->
      sem_PHOAS data p1 (f v) res ->
      sem_PHOAS data p0 (LetIn e f) res
  | SLetInF : forall (X Y : type) (e : PHOASV X) (f : val X -> PHOASV Y) p0,
      sem_PHOAS data p0 e None ->
      sem_PHOAS data p0 (LetIn e f) None

  | sem_IfThenElseT : forall vb X (et ee : PHOASV X) res s (b : val Bool),
      b = true ->
      sem_VAL vb b ->
      sem_PHOAS data s et res ->
      sem_PHOAS data s (IfThenElse vb et ee) res

  | sem_IfThenElseF : forall vb X (et ee : PHOASV X) res s (b : val Bool),
      b = false ->
      sem_VAL vb b ->
      sem_PHOAS data s ee res ->
      sem_PHOAS data s (IfThenElse vb et ee) res

  | SCaseOptionNone : forall X (vo : VAL (Option X)) Y (eN : PHOASV Y) eOpt res p,
      sem_VAL vo None ->
      sem_PHOAS data p eN res ->
      sem_PHOAS data p (CaseOption vo eN eOpt) res
  | SCaseOptionSome : forall X (vo : VAL (Option X)) Y (eN : PHOASV Y) eOpt v res p,
      sem_VAL vo (Some v) ->
      sem_PHOAS data p (eOpt v) res ->
      sem_PHOAS data p (CaseOption vo eN eOpt) res

  | sem_Switch : forall vn p (n : val Nat) X (cases : case_switch X) res,
      sem_VAL vn n ->
      sem_switch_cases data p n cases res ->
      sem_PHOAS data p (Switch vn cases) res

  | SFail : forall p0 X, sem_PHOAS data p0 (Fail : PHOAS X) None

  | STake : forall (hn : VAL Nat) s n,
      sem_VAL hn n ->
      sem_PHOAS data s (Take hn)
        (Some (mk_span (pos s) n, mk_span (pos s + n) (len s - n)))

  | SLength: forall s,
      sem_PHOAS data s Length (Some ((len s : val Nat), s))

  | SRead : forall s hs hn (range : val Span) (n : val Nat) v default,
      sem_VAL hs range ->
      sem_VAL hn n ->
      nth (N.to_nat (pos range + n)) data default = v ->
      sem_PHOAS data s (Read hs hn) (Some (v,s))

  | SAlt1 : forall p0 X (e0 e1 : PHOASV X) v0 p1,
      sem_PHOAS data p0 e0 (Some (v0, p1)) ->
      sem_PHOAS data p0 (Alt e0 e1) (Some (v0, p1))
  | SAlt2 : forall p0 X (e0 e1 : PHOAS X) res,
      sem_PHOAS data p0 e0 None ->
      sem_PHOAS data p0 e1 res ->
      sem_PHOAS data p0 (Alt e0 e1) res

  | SScopeF : forall hs X (ex : PHOAS X) p s (res : val (Option Span)),
      res = Some s ->
      sem_VAL hs res ->
      sem_PHOAS data s ex None ->
      sem_PHOAS data p (Local hs ex) None
  | SScopeS : forall hs X (ex : PHOAS X) p s v p0 (res : val (Option Span)),
      res = Some s ->
      sem_VAL hs res ->
      sem_PHOAS data s ex (Some (v, p0)) ->
      sem_PHOAS data p (Local hs ex) (Some (v, p))

  | SPeekF : forall hs X (ex : PHOAS X) p (res : val (Option Span)),
      res = None ->
      sem_VAL hs res ->
      sem_PHOAS data p ex None ->
      sem_PHOAS data p (Local hs ex) None
  | SPeekS : forall hs X (ex : PHOAS X) p v p0 (res : val (Option Span)),
      res = None ->
      sem_VAL hs res ->
      sem_PHOAS data p ex (Some (v, p0)) ->
      sem_PHOAS data p (Local hs ex) (Some (v, p))

  | SRepeatN : forall von X (vb : VAL X) p ex base res,
      sem_VAL von (None : val (Option Nat)) ->
      sem_VAL vb base ->
      sem_repeat_None data p ex base res ->
      sem_PHOAS data p (Repeat von ex vb) res

  | SRepeatS : forall p von n X ex (vb : VAL X) base res,
      sem_VAL von (Some n : val (Option Nat)) ->
      sem_VAL vb base ->
      sem_repeat_Some data p n ex base res ->
      sem_PHOAS data p (Repeat von ex vb) res

  (* 2 rules *)
  with sem_repeat_None (data : list nat8) :
    forall {X}, span -> (val X -> PHOAS X) -> val X -> option (val X * span) -> Prop :=
  | SRepeatNF : forall X p e (base : val X),
    sem_PHOAS data p (e base) None ->
    sem_repeat_None data p e base (Some (base, p))
  | SRepeatNS : forall X p0 p1 e ve (base : val X) res,
      sem_PHOAS data p0 (e base) (Some (ve, p1)) ->
      sem_repeat_None data p1 e ve res ->
      sem_repeat_None data p0 e base res

  (* 3 rules *)
  with sem_repeat_Some (data : list nat8) :
    forall {X}, span -> N -> (val X -> PHOAS X) -> val X -> option (val X * span) -> Prop :=
  | SRepeatSO : forall X p e (base : val X),
      sem_repeat_Some data p 0 e base (Some (base, p))
  | SRepeatSS : forall X p0 p1 n e ve (base : val X) res,
      sem_PHOAS data p0 (e base) (Some (ve, p1)) ->
      sem_repeat_Some data p1 n e ve res ->
      sem_repeat_Some data p0 (N.succ n) e base res
  | SRepeatSF : forall X p n e (base : val X),
      sem_PHOAS data p (e base) None ->
      sem_repeat_Some data p (N.succ n) e base None

  (* 3 règles *)
  with sem_switch_cases (data : list nat8) : forall {X},
      span -> N -> case_switch X -> option (val X * span) -> Prop :=
  | SLSnil : forall (X : type) (e : PHOAS X) res n p0,
      sem_PHOAS data p0 e res ->
      sem_switch_cases data p0 n (LSnil e) res
  | SLSconsEq : forall (X : type) val (e : PHOAS X) n cases res p0,
      val = n ->
      sem_PHOAS data p0 e res ->
      sem_switch_cases data p0 val (LScons n e cases) res
  | SLSconsNEq : forall (X : type) val n (e : PHOAS X) cases res p0,
      val <> n ->
      sem_switch_cases data p0 val cases res ->
      sem_switch_cases data p0 val (LScons n e cases) res.

  Ltac simpl_existT :=
    repeat match goal with
      | H : existT _ _ = existT _ _ |- _ =>
          eapply Eqdep_dec.inj_pair2_eq_dec in H; [idtac | intros; eapply type_eq_dec]
      | H : existT _ _ = existT _ _ |- _ =>
          eapply Eqdep_dec.inj_pair2_eq_dec in H; [idtac | intros; eapply N.eq_dec]
      end.

  Ltac next_step H := inversion H; subst; simpl_existT; subst; clear H.

  Ltac head t :=
    match t with
    | ?t' _ => head t'
    | _ => t
    end.

  Ltac head_constructor t :=
    let t' := head t in is_constructor t'.

  (* Lemma sem_val_inj : forall X (v : val X) res0 res1, *)
  (*     sem_val v = res0 -> *)
  (*     sem_val v = res1 -> *)
  (*     res0 = res1. *)
  (* Proof. *)
  (*   Local Ltac ind_val_inj IH := *)
  (*   match goal with *)
  (*   | H : sem_val ?t _ |- _ => *)
  (*       head_constructor t(* ; next_step H *) *)
  (*   | H0 : sem_val ?t _, H1 : sem_val ?t _ |- _ => *)
  (*       injection (IH _ t _ _ H0 H1); clear H0; clear H1 *)
  (*   | H0 : sem_val ?t _, H1 : sem_val ?t _ |- _ => *)
  (*       eapply (IH _ t _ _ H0) in H1 *)
  (*   end. *)
  (*   fix IH 2. *)
  (*   destruct v; intros; repeat ind_val_inj IH; subst; try reflexivity. *)
  (* Qed. *)

  Lemma sem_bin_inj : forall X (v0 : val X) Y (v1 : val Y) Z o res1 res2,
      sem_bin Z o v0 v1 res1 ->
      sem_bin Z o v0 v1 res2 ->
      res1 = res2.
  Proof.
    Local Ltac ind_bin_inj IH :=
    match goal with
    | H : sem_bin _ ?t _ _ _ |- _ =>
        head_constructor t; next_step H
    | H0 : sem_bin _ ?t _ _ _, H1 : sem_bin _ ?t _ _ _ |- _ =>
        injection (IH _ t _ _ H0 H1); clear H0; clear H1
    | H0 : sem_bin _ ?t _ _ _, H1 : sem_bin _ ?t _ _ _ |- _ =>
        eapply (IH _ _ _ _ _ t _ _ H0) in H1
    end.
    fix IH 6.
    destruct o; intros; repeat ind_bin_inj IH; try reflexivity.
    match goal with
    | H0 : string_get v0 v1 = _,
        H1 : string_get v0 v1 = _ |- _ => rewrite H0 in H1; injection H1
    end. intro. auto.
  Qed.

  Lemma sem_unary_inj : forall X (v0 : val X) Y o res1 res2,
      sem_unary Y o v0 res1 ->
      sem_unary Y o v0 res2 ->
      res1 = res2.
  Proof.
    Local Ltac ind_unary_inj IH :=
    match goal with
    | H : sem_unary _ ?t _ _ |- _ =>
        head_constructor t; next_step H
    | H0 : sem_unary _ ?t _ _, H1 : sem_unary _ ?t _ _ |- _ =>
        injection (IH _ t _ _ H0 H1); clear H0; clear H1
    | H0 : sem_unary _ ?t _ _, H1 : sem_unary _ ?t _ _ |- _ =>
        eapply (IH _ t _ _ H0) in H1
    end.
    fix IH 4.
    destruct o; intros; repeat ind_unary_inj IH; auto.
  Qed.

  Lemma sem_literal_inj : forall X (v : Literal X) res1 res2,
      sem_literal v res1 ->
      sem_literal v res2 ->
      res1 = res2.
  Proof.
    Local Ltac ind_lit_inj IH :=
    match goal with
    | H : sem_literal ?t _ |- _ =>
        head_constructor t; next_step H
    | H0 : sem_literal ?t _, H1 : sem_literal ?t _ |- _ =>
        injection (IH _ t _ _ H0 H1); clear H0; clear H1
    | H0 : sem_literal ?t _, H1 : sem_literal ?t _ |- _ =>
        eapply (IH _ t _ _ H0) in H1
    end.
    fix IH 2.
    destruct v; intros; repeat ind_lit_inj IH; intros; simpl_existT; subst; try reflexivity.
  Qed.

  Lemma sem_VAL_inj : forall X (v : VAL X) res1 res2,
      sem_VAL v res1 ->
      sem_VAL v res2 ->
      res1 = res2.
  Proof.
    Local Ltac ind_inj IH :=
    match goal with
    | H : sem_VAL ?t _ |- _ =>
        head_constructor t; next_step H
    | H0 : sem_VAL ?t _, H1 : sem_VAL ?t _ |- _ =>
        injection (IH _ t _ _ H0 H1); clear H0; clear H1
    | H0 : sem_VAL ?t _, H1 : sem_VAL ?t _ |- _ =>
        eapply (IH _ t _ _ H0) in H1
    end.
    fix IH 2.
    destruct v; intros; repeat ind_inj IH; intros; simpl_existT; subst.
    - reflexivity.
    - eapply sem_bin_inj; eauto.
    - eapply sem_unary_inj; eauto.
    - eapply sem_literal_inj; eauto.
  Qed.

End sem_PHOAS.

Section PHOAS_equiv.

  Context {var1 var2 : type -> Type}.

  Inductive Env :=
  | Nil : Env
  | Cons : forall {X}, var1 X -> var2 X -> Env -> Env.

  Inductive In {X} (v1 : var1 X) (v2 : var2 X) : Env -> Prop :=
  | Here : forall env, In v1 v2 (Cons v1 v2 env)
  | Later : forall X (t1 : var1 X) (t2 : var2 X) env,
      In v1 v2 env ->
      In v1 v2 (Cons t1 t2 env).

  Inductive equiv_VAL : Env -> forall X, @VAL var1 X -> @VAL var2 X -> Prop :=
  | EquivVar : forall X env v1 v2,
      In v1 v2 env ->
      equiv_VAL env X (Var v1) (Var v2)
  | EquivBin : forall X Y Z env o v1 v2 v3 v4,
      equiv_VAL env X v1 v3 ->
      equiv_VAL env Y v2 v4 ->
      equiv_VAL env Z (EBin o v1 v2) (EBin o v3 v4)
  | EquivUna : forall X Y env o v1 v3,
      equiv_VAL env X v1 v3 ->
      equiv_VAL env Y (EUna o v1) (EUna o v3)
  | EquivConst : forall X env c,
      equiv_VAL env X (Const c) (Const c).

  Inductive equiv_LIST : Env -> @LIST var1 -> @LIST var2 -> Prop :=
  | EquivNIL : forall env,
      equiv_LIST env NIL NIL
  | EquivCONS : forall env X v1 v2 l1 l2,
      equiv_VAL env X v1 v2 ->
      equiv_LIST env l1 l2 ->
      equiv_LIST env (CONS v1 l1) (CONS v2 l2).

  Inductive equiv_prog : Env -> forall X, @PHOAS var1 X -> @PHOAS var2 X -> Prop :=
  | EquivCstruct : forall env ty constr l1 l2,
    equiv_LIST env l1 l2 ->
    equiv_prog env (Unknown ty) (ExternStruct ty constr l1) (ExternStruct ty constr l2)
  | EquivVal : forall X env v1 v2,
      equiv_VAL env X v1 v2 ->
      equiv_prog env X (Val v1) (Val v2)
  | EquivLetIn : forall X Y env e0 e1 k0 k1,
      equiv_prog env X e0 e1 ->
      (forall v0 v1, equiv_prog (Cons v0 v1 env) Y (k0 v0) (k1 v1)) ->
      equiv_prog env Y (LetIn e0 k0) (LetIn e1 k1)
  | EquivIfThenElse : forall X env vb1 vb2 et1 et2 ef1 ef2,
      equiv_VAL env Bool vb1 vb2 ->
      equiv_prog env X et1 et2 ->
      equiv_prog env X ef1 ef2 ->
      equiv_prog env X (IfThenElse vb1 et1 ef1) (IfThenElse vb2 et2 ef2)
  | EquivCaseOption : forall X Y env vo1 vo2 en1 en2 es1 es2,
      equiv_VAL env (Option X) vo1 vo2 ->
      equiv_prog env Y en1 en2 ->
      (forall v0 v1, equiv_prog (Cons v0 v1 env) Y (es1 v0) (es2 v1)) ->
      equiv_prog env Y (CaseOption vo1 en1 es1) (CaseOption vo2 en2 es2)
  | EquivSwitch : forall Y env vn1 vn2 c1 c2,
      equiv_VAL env Nat vn1 vn2 ->
      equiv_branch env Y c1 c2 ->
      equiv_prog env Y (Switch vn1 c1) (Switch vn2 c2)
  | EquivFail : forall Y env,
      equiv_prog env Y Fail Fail
  | EquivTake : forall env vn1 vn2,
      equiv_VAL env Nat vn1 vn2 ->
      equiv_prog env Span (Take vn1) (Take vn2)
  | EquivLength : forall env,
      equiv_prog env Nat Length Length
  | EquivRead : forall env vs1 vs2 vn1 vn2,
      equiv_VAL env Span vs1 vs2 ->
      equiv_VAL env Nat vn1 vn2 ->
      equiv_prog env (NatN 8) (Read vs1 vn1) (Read vs2 vn2)
  | EquivAlt : forall X env e1 e2 e3 e4,
      equiv_prog env X e1 e3 ->
      equiv_prog env X e2 e4 ->
      equiv_prog env X (Alt e1 e2) (Alt e3 e4)
  | EquivLocal : forall X env vo1 vo2 e1 e2,
      equiv_VAL env (Option Span) vo1 vo2 ->
      equiv_prog env X e1 e2 ->
      equiv_prog env X (Local vo1 e1) (Local vo2 e2)
  | EquivRepeat : forall X env on1 on2 k1 k2 b1 b2,
      equiv_VAL env (Option Nat) on1 on2 ->
      (forall v1 v2, equiv_prog (Cons v1 v2 env) X (k1 v1) (k2 v2)) ->
      equiv_VAL env X b1 b2 ->
      equiv_prog env X (Repeat on1 k1 b1) (Repeat on2 k2 b2)

  with equiv_branch : Env -> forall X, @case_switch var1 X -> @case_switch var2 X -> Prop :=
  | EquivLSNil : forall X env e1 e2,
      equiv_prog env X e1 e2 ->
      equiv_branch env X (LSnil e1) (LSnil e2)
  | EquivLSCons : forall X env n e1 e2 cs1 cs2,
      equiv_prog env X e1 e2 ->
      equiv_branch env X cs1 cs2 ->
      equiv_branch env X (LScons n e1 cs1) (LScons n e2 cs2).

End PHOAS_equiv.

Definition exotic_term : @PHOAS val Unit :=
  let% v := Val (Const (EBool true)) in
  if (v : bool)
  then Val (Const EUnit)
  else Fail.

Definition equiv_exotic :
  {code : @PHOAS (fun _ => string) Unit | equiv_prog Nil Unit exotic_term code}.
  eapply exist. repeat econstructor. intros. Abort.

Definition Expr X := forall (var : type -> Type), @PHOAS var X.

Close Scope N_scope.


(*
Proof that function composition is associative,
even without assuming functional extensionality.
 *)

Require Import Basics.

Open Scope program_scope.

Theorem compose_assoc : forall (A : Set) (f g h : A -> A),
    f ∘ (g ∘ h) = (f ∘ g) ∘ h.
Proof.
  reflexivity.
Qed.


Require Import List.

Require Import SimpSyntax.
Require Import TreeSyntax.

Require Import Le Lt.
Require Import Plus Minus.
Require Import Compare_dec.

Require Import Utils.
Require Import Substitutions.

Import VarBump.
Import TreeTermBump.
Import TreeVarSubst.
Import TreeVarOKBump.
Import TreeVarOKSubst.

Fixpoint laTree l f la := match la with
	nil => var (l + f) |
	a :: la => apl (laTree l f la) (var a)
end.

Definition spTree l (p:_ * _) := let (f,la) := p in El (laTree l f la).

Fixpoint sfTree l (F:simpFam) := match F with
	nil => Uv |
	p :: F => Pi (spTree l p) (sfTree (S l) F)
end.

Definition sfcTree := map (sfTree O).

Fixpoint spcTree G := match G with
	nil => nil |
	p :: G => spTree (length G) p :: spcTree G
end.

Lemma laTreeChLvl l f la : laTree l f la = laTree O (l + f) la.
	induction la;simpl.

	reflexivity.

	rewrite <- IHla.
	reflexivity.
Qed.

Lemma spcTree_length G : length (spcTree G) = length G.
	induction G;simpl.

	reflexivity.

	rewrite IHG.
	reflexivity.
Qed.

Lemma spcTree_nth a : forall G,(a < length G)->
(nth a (spcTree G) Uv = spTree (length G - S a) (nth a G (O,nil))).
	induction a;intro;(destruct G;intro;[destruct lt_n_O with (1 := H) |]);simpl.

	rewrite <- minus_n_O.
	reflexivity.

	exact (IHa _ (lt_S_n _ _ H)).
Qed.

Lemma laTree_BumpG n l1 l2 f la : (l1 <= l2)->(laTree (l2 + n) f (laBump n l1 la) = ttBump n l1 (laTree l2 f la)).
	intro.
	induction la;simpl.

	rewrite varBumpHi;[| apply le_not_lt;apply le_plus_trans with (1 := H)].
	rewrite plus_assoc.
	rewrite <- (plus_comm n).
	reflexivity.

	rewrite IHla.
	reflexivity.
Qed.

Lemma spTree_BumpG n l1 l2 p : (l1 <= l2)->(spTree (l2 + n) (pBumpG n l1 p) = tpBump n l1 (spTree l2 p)).
	intro.
	destruct p as (f,la).
	simpl.
	rewrite laTree_BumpG with (1 := H).
	reflexivity.
Qed.

Lemma sfTree_BumpG n F : forall l1 l2,(l1 <= l2)->(sfTree (l2 + n) (fBumpG n l1 F) = tpBump n l1 (sfTree l2 F)).
	induction F;intros;simpl.

	reflexivity.

	rewrite spTree_BumpG with (1 := H).
	change (S (l2 + n)) with (S l2 + n).
	rewrite (IHF _ _ (le_n_S _ _ H)).
	reflexivity.
Qed.

Lemma sfTree_BumpDG a b F : forall l,(fBumpG 1 l F = F)->
(sfTree (l + a) (fBumpD b F) = tpBump (a + b) l (sfTree l F)).
	induction F as [| p].

	simpl.
	intros.
	reflexivity.

	intro.
	destruct p as (f,la).
	simpl.
	intro.
	rewrite <- laTree_BumpG with (1 := le_n _).
	rewrite (laTreeChLvl _ f).
	rewrite plus_assoc.
	rewrite <- plus_assoc.
	rewrite <- laTreeChLvl.
	pose proof (ap (fun F=>snd (hd (f,la) F)) H).
	pose proof (ap (@tl _) H).
	simpl in H0,H1.
	clear H.
	rewrite laFreeBump with (1 := H0).
	rewrite <- (IHF _ H1).
	reflexivity.
Qed.

Lemma var_simpVarSubst l b i : var (SimpSubst.varSubst l b i) = varSubst l (var b) i.
	unfold SimpSubst.varSubst.
	unfold varSubst.
	destruct (nat_compare i l);[simpl;rewrite varBumpHi with (1 := lt_n_O _) | |];reflexivity.
Qed.

Lemma laTree_SubstG f la l1 l2 b : (l1 <= l2)->(laTree l2 f (laSubst la l1 b) = ttSubst l1 (var b) (laTree (S l2) f la)).
	intro.
	induction la;simpl.

	rewrite varSubstGt;[| apply le_n_S;apply le_plus_trans with (1 := H)].
	exact (eq_refl (var (l2 + f))).

	rewrite <- IHla.
	rewrite var_simpVarSubst.
	reflexivity.
Qed.

Lemma spTree_SubstG p l1 l2 b : (l1 <= l2)->(spTree l2 (pSubstG p l1 b) = tpSubst l1 (var b) (spTree (S l2) p)).
	intro.
	destruct p as (f,la).
	simpl.
	rewrite <- laTree_SubstG with (1 := H).
	reflexivity.
Qed.

Lemma sfTree_SubstG F b : forall l1 l2,(l1 <= l2)->(sfTree l2 (fSubstG F l1 b) = tpSubst l1 (var b) (sfTree (S l2) F)).
	induction F;intros;simpl.

	reflexivity.

	rewrite <- spTree_SubstG with (1 := H).
	rewrite <- (IHF _ _ (le_n_S _ _ H)).
	reflexivity.
Qed.

Lemma spOKTree D G F f la T : SimpParamOK G F la T->let G' := spcTree G ++ sfcTree D in
VarOK G' (length G + f) (sfTree (length G) F)->TreeTermOK G' (laTree (length G) f la) (sfTree (length G) T).
	simpl.
	intros Hla Hf.
	induction Hla;simpl.

	apply ttOKVar with (1 := Hf).

	rewrite sfTree_SubstG with (1 := le_O_n _).
	apply ttOKApl with (1 := IHHla).
	apply ttOKVar.
	rewrite le_plus_minus with (1 := l).
	rewrite <- plus_comm.
	rewrite spTree_BumpG with (1 := le_O_n _).
	rewrite <- spcTree_nth with (1 := l).
	assert (a < length (spcTree G)).
		rewrite spcTree_length.
		exact l.
	rewrite <- app_nth1 with (l' := sfcTree D) (1 := H).
	apply mkVarOK.
	rewrite app_length.
	apply le_plus_trans with (1 := H).
Qed.

Lemma sfOKTree D G T : SimpFCtxOK D->SimpFamOK D G T->let G' := spcTree G ++ sfcTree D in
CtxOK G'->TreeTypeOK G' (sfTree (length G) T).
	intros HD ?.
	simpl.
	induction H;intro.

	simpl.
	apply tpOKUv.

	simpl in IHSimpFamOK |- *.
	assert (TreeTypeOK (spcTree G ++ sfcTree D) (El (laTree (length G) f la))).
		apply tpOKEl.
		apply spOKTree with (1 := s).
		change (length G) with (O + length G) at 2.
		rewrite sfTree_BumpDG with (1 := sfOKFree _ _ _ (fctxProjOK _ _ HD l)).
		simpl.
		rewrite <- plus_n_Sm.
		rewrite <- map_nth.
		fold sfcTree.
		simpl.
		set (f' := f) at 3.
		replace f' with (length G + f - length (spcTree G));subst f';[| rewrite spcTree_length;apply minus_plus].
		rewrite <- app_nth2 with (l := spcTree G);[| rewrite spcTree_length;apply le_plus_l].
		apply mkVarOK.
		rewrite app_length.
		rewrite spcTree_length.
		apply plus_lt_compat_l.
		unfold sfcTree.
		rewrite map_length.
		exact l.
	refine (let H := IHSimpFamOK _ in _).
		apply ctxOKCons with (1 := X) (2 := H0).
	apply tpOKPi with (1 := H0) (2 := H1).
Qed.


Require Export CatSem.CAT.prods.
Require Export CatSem.CAT.CatFunct.
Require Export CatSem.CAT.horcomp.
Require Export CatSem.CAT.functor_leibniz_eq.
(*Require Export CatSem.CAT.setoid_lemmata.*)

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

Unset Automatic Introduction.

(** for a cat C and e:C, we want the functor c -> (c, e) *)

Section erightleft.

Variable obC: Type.
Variable morC : obC -> obC -> Type.
Variable C: Cat_struct morC.

Variable e:obC.

(** this functor C -> C x C  is constant on the right *)

Program Definition eright : Functor C (PROD C C) := Build_Functor
  (Fobj := fun c: obC => (c, e))
  (Fmor := fun a b f => (f, id e)) _ .
Next Obligation.
Proof.
  apply Build_Functor_struct;
  try red;
  try red; cat.
Qed.

(** and this one constant on the left *)

Program Definition eleft : Functor C (PROD C C) := Build_Functor
  (Fobj := fun c: obC => (e, c))
  (Fmor := fun a b f => (id e, f)) _.
Next Obligation.
Proof.
  apply Build_Functor_struct;
  try red;
  try red; cat.
Qed.

End erightleft.

(** there is a functor (A x B) x C ---> A x (B x C) *)

Section PROD_almost_assoc.

Variables obA obB obC:Type.
Variable morA: obA -> obA -> Type.
Variable morB: obB -> obB -> Type.
Variable morC: obC -> obC -> Type.
Variables (A: Cat_struct morA) (B: Cat_struct morB) (C:Cat_struct morC).

Program Definition iso: Functor (PROD (PROD A B) C) (PROD A (PROD B C)) :=
         Build_Functor
  (Fobj := fun a => (fst (fst a), (snd (fst a), snd a)))
  (Fmor := fun a b f => (fst (fst f), (snd (fst f), snd f))) _ .
Next Obligation.
Proof.
  apply Build_Functor_struct;
  intros;
  try red;
  try red;
  cat.
  elim_conjs; cat.
Qed.

End PROD_almost_assoc.

(** strict monoidal cat *)
Section smon_cat.

Variable obC: Type.
Variable morC : obC -> obC -> Type.

Section smon_cat_.
Variable C: Cat_struct morC.

(** a category C is strict monoidal if there is a tensor
    which is associative and has a unit *)

Class smon_cat := {
  tensor : Functor (PROD C C) C;
  e: obC;
  tensor_assoc : CompF (Prod_functor tensor (Id C)) tensor ==
                  CompF (iso C C C) (CompF (Prod_functor (Id C) tensor)
                                         tensor);
  eleft_unit:  CompF (eleft C e) tensor == Id C;
  eright_unit: CompF (eright C e) tensor == Id C
}.

End smon_cat_.

Record SMON := {
   cat:> Cat_struct morC;
   smon_struct:> smon_cat cat
}.

End smon_cat.

(** The category of endofunctors End(C) over a category C
    is a strict monoidal category with composition as tensor *)

Section monads.
Variable obC: Type.
Variable morC : obC -> obC -> Type.
Variable C: Cat_struct morC.

(** composition is a functor PROD (FunctCat C C) (FunctCat C C) *)

Program Definition comp_tensor :
  Functor (PROD ([C, C]) ([C, C])) ([C, C]) := Build_Functor
    (Fobj := fun a => CompF (fst a) (snd a))
    (Fmor := fun a b f => hcompNT (fst f) (snd f)) _ .
Next Obligation.
Proof.
  apply Build_Functor_struct.

  intros a b; simpl.
  red. red.
  intros x y H.
  unfold hcompNT.
  simpl.
  intro c.
  unfold hcompNT1.
(*  destruct x as [x1 x2].
  destruct y as [y1 y2].*)
  destruct H as [H1 H2].
  rewrite H1 .
  rewrite H2.
  cat.

  intro a;
  simpl.
  unfold hcompNT1.
  intro c; simpl.
  cat.

  intros a b c f g;
  simpl.
  destruct f as [alpha beta].
  destruct g as [gamma delta].
  simpl.
(*  unfold eq_NT1.*)
  intro c0.
  unfold vcompNT.
  unfold hcompNT.
  unfold hcompNT1.
  unfold vcompNT1.
  simpl.
  destruct a as [F1 F2].
  destruct b as [G1 G2].
  destruct c as [H1 H2].
  simpl in *|-*.
  rewrite <- assoc.
  rewrite <- assoc.
  rewrite <- (NTcomm beta).
  rewrite <- (NTcomm beta).
  rewrite (FComp G2).
  repeat rewrite assoc.
  apply hom_refl.
Qed.

End monads.

Section endo_monad.

Notation "a 'OO' b" := (hcompNT  a b)(at level 60).

Variable obC: Type.
Variable morC : obC -> obC -> Type.
Variable C: Cat_struct morC.

Local Obligation Tactic := idtac.

Program Instance monads : smon_cat (FunctCat C C) := {
  tensor := comp_tensor C;
  e := Id C
}.
Obligation 2.
Proof.
  simpl.
  intros a b f.
  assert (H:= NT_Extensionality
        (alpha := vidNT (Id C) OO f) (beta := f)
            (IdFl _ ) (IdFl _ ) ).
  apply H.
  intro x.
  simpl.
  unfold hcompNT1.
  simpl.
  apply Build_Equal_hom.
  cat.
Qed.
Next Obligation.
Proof.
  simpl.
  intros a b f.
  destruct a as [[F1 F2] F3].
  destruct b as [[G1 G2] G3].
  destruct f as [[alpha beta] gamma].
  simpl in *|-*.
  assert (H:= NT_Extensionality
         (alpha := (alpha OO beta) OO gamma)
         (beta := (alpha OO (beta OO gamma))) ).
  apply H.

  apply CompFassoc.

  apply CompFassoc.

  intro x.
  simpl.
  unfold hcompNT.
  unfold hcompNT1.
  simpl.
  apply Build_Equal_hom.
  rewrite (FComp F3).
  rewrite <- assoc.
  apply hom_refl.
Qed.
Next Obligation.
Proof.
  simpl.
  intros F G alpha.
  set (H:= NT_Extensionality
        (alpha := alpha OO vidNT (Id C)) (beta := alpha)
            (IdFr _ ) (IdFr _ ) ).
  apply H.
  intro x.
  simpl.
  unfold hcompNT1.
  simpl.
  apply Build_Equal_hom.
  cat.
Qed.

End endo_monad.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import classical funlib category functor.

Open Scope category_scope.

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

(* A category with products *)
Module ProdCategory.
  Structure mixin_of (C : category) : Type := Mixin {
    prod : C -> C -> C ;
    proj1 : forall {X1 X2 : C}, prod X1 X2 ~> X1 ;
    proj2 : forall {X1 X2 : C}, prod X1 X2 ~> X2 ;
    (* the universal property of products *)
    _ : forall (X1 X2 Y : C) (f1 : Y ~> X1) (f2 : Y ~> X2),
        exists! (f : Y ~> prod X1 X2), proj1 \\o f = f1 /\ proj2 \\o f = f2
  }.

  Section ClassDef.
    Record class_of (obj : Type) : Type := Class {
      base : Category.class_of obj ;
      mixin : mixin_of (Category.Pack base)
    }.

    Record type : Type := Pack { obj ; class : class_of obj }.
    Definition category (C : type) := Category.Pack (base (class C)).
  End ClassDef.

  Module Exports.
    Coercion base : class_of >-> Category.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion obj : type >-> Sortclass.
    Coercion category : type >-> Category.type.
    Canonical category.

    Notation prodCategory := type.
    Notation ProdCatMixin := Mixin.
    Notation ProdCategory T m := (@Pack T (@Class _ _ m)).

    Definition Prod (C : type) : C -> C -> C :=
      let: Pack _ (Class _ (Mixin prod _ _ _)) := C in prod.

    Notation "A * B" := (Prod A B) : category_scope.
  End Exports.
End ProdCategory.
Import ProdCategory.Exports.

(* The category Type has products, which is just the type-theoretic product *)
Section type_prod.
Lemma type_prod_universal (T1 T2 S : Type) (f1 : S -> T1) (f2 : S -> T2) :
  exists! f : S -> (T1 * T2), fst \o f = f1 /\ snd \o f = f2.
Proof.
  exists (fun x => (f1 x, f2 x)). rewrite /unique; split => //=.
  move=> f [<- <-]. apply: functional_extensionality => x //=.
  by move: (f x) => [].
Qed.

Definition type_ProdCatMixin := ProdCatMixin type_prod_universal.
Definition type_ProdCategory := ProdCategory Type type_ProdCatMixin.
Canonical type_ProdCategory.
End type_prod.

Export ProdCategory.Exports.


Require Export StlcEqui.Inst.
Require Export StlcEqui.SpecSyntax.
Require Export StlcEqui.SpecTyping.
Require Export StlcEqui.LemmasTyping.

(* a fully annotated version of iso-recursive terms. *)
Inductive TmA : Set :=
  | ea_var (i: Ix)
  | ea_abs (τ1 τ2 : Ty) (t: TmA)
  | ea_app (τ1 τ2 : Ty) (t₁ t₂ : TmA)
  | ea_unit
  | ea_true
  | ea_false
  | ea_ite (τ : Ty) (t₁ t₂ t₃: TmA)
  | ea_pair (τ1 τ2 : Ty) (t₁ t₂: TmA)
  | ea_proj₁ (τ1 τ2 : Ty) (t: TmA)
  | ea_proj₂ (τ1 τ2 : Ty) (t: TmA)
  | ea_inl (τ1 τ2 : Ty) (t: TmA)
  | ea_inr (τ1 τ2 : Ty) (t: TmA)
  | ea_caseof (τ1 τ2 τ : Ty) (t₁ t₂ t₃: TmA)
  | ea_seq (τ : Ty) (t₁ t₂: TmA)
  | ea_coerce (τ : Ty) (t : TmA).

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.
  Context {vrTm: Vr TmA}.
  Context {liftYTm: Lift Y TmA}.

  Context {vrTy: Vr Ty}.
  Context {liftYTy: Lift Y Ty}.

  Fixpoint apTmA (ζ: Sub Y) (t: TmA) {struct t} : TmA :=
    match t with
      | ea_var x                   => lift (ζ x)
      | ea_abs τ₁ τ₂ t             => ea_abs τ₁ τ₂ (apTmA (ζ↑) t)
      | ea_app τ₁ τ₂ t₁ t₂         => ea_app τ₁ τ₂ (apTmA ζ t₁) (apTmA ζ t₂)
      | ea_unit                    => ea_unit
      | ea_true                    => ea_true
      | ea_false                   => ea_false
      | ea_ite τ t₁ t₂ t₃          => ea_ite τ (apTmA ζ t₁) (apTmA ζ t₂) (apTmA ζ t₃)
      | ea_pair τ₁ τ₂ t₁ t₂        => ea_pair τ₁ τ₂ (apTmA ζ t₁) (apTmA ζ t₂)
      | ea_proj₁ τ₁ τ₂ t           => ea_proj₁ τ₁ τ₂ (apTmA ζ t)
      | ea_proj₂ τ₁ τ₂ t           => ea_proj₂ τ₁ τ₂ (apTmA ζ t)
      | ea_inl τ₁ τ₂ t             => ea_inl τ₁ τ₂ (apTmA ζ t)
      | ea_inr τ₁ τ₂ t             => ea_inr τ₁ τ₂ (apTmA ζ t)
      | ea_caseof τ₁ τ₂ τ t₁ t₂ t₃ => ea_caseof τ₁ τ₂ τ (apTmA ζ t₁) (apTmA (ζ↑) t₂) (apTmA (ζ↑) t₃)
      | ea_seq τ t₁ t₂             => ea_seq τ (apTmA ζ t₁) (apTmA ζ t₂)
      | ea_coerce τ t              => ea_coerce τ (apTmA ζ t)
    end.

  Global Arguments apTmA ζ !t /.

End Application.

Reserved Notation "⟪  Γ ea⊢ t : T  ⟫"
  (at level 0, Γ at level 98, t at level 98, T at level 98 ).
Inductive AnnotTyping (Γ : Env) : TmA -> Ty -> Prop :=
  | ea_WtVar {i T} :
      ⟪ i : T r∈ Γ ⟫ →
      ⟪ Γ ea⊢ ea_var i : T ⟫
  | ea_WtAbs {t τ₁ τ₂} :
    ValidTy τ₁ ->
      ⟪ Γ r▻ τ₁ ea⊢ t : τ₂ ⟫ →
      ⟪ Γ ea⊢ ea_abs τ₁ τ₂ t : tarr τ₁ τ₂ ⟫
  | ea_WtApp {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ea⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ea⊢ t₂ : τ₁ ⟫ →
      ⟪ Γ ea⊢ ea_app τ₁ τ₂ t₁ t₂ : τ₂ ⟫
  | ea_WtUnit :
      ⟪ Γ ea⊢ ea_unit : tunit ⟫
  | ea_WtTrue :
      ⟪ Γ ea⊢ ea_true : tbool ⟫
  | ea_WtFalse :
      ⟪ Γ ea⊢ ea_false : tbool ⟫
  | ea_WtIte {t₁ t₂ t₃ T} :
      ⟪ Γ ea⊢ t₁ : tbool ⟫ →
      ⟪ Γ ea⊢ t₂ : T ⟫ →
      ⟪ Γ ea⊢ t₃ : T ⟫ →
      ⟪ Γ ea⊢ ea_ite T t₁ t₂ t₃ : T ⟫
  | ea_WtPair {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ea⊢ t₁ : τ₁ ⟫ →
      ⟪ Γ ea⊢ t₂ : τ₂ ⟫ →
      ⟪ Γ ea⊢ ea_pair τ₁ τ₂ t₁ t₂ : tprod τ₁ τ₂ ⟫
  | ea_WtProj1 {t τ₁ τ₂} :
      ⟪ Γ ea⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ea⊢ ea_proj₁ τ₁ τ₂ t : τ₁ ⟫
  | ea_WtProj2 {t τ₁ τ₂} :
      ⟪ Γ ea⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ea⊢ ea_proj₂ τ₁ τ₂ t : τ₂ ⟫
  | ea_WtInl {t τ₁ τ₂} :
      ValidTy τ₂ ->
      ⟪ Γ ea⊢ t : τ₁ ⟫ →
      ⟪ Γ ea⊢ ea_inl τ₁ τ₂ t : tsum τ₁ τ₂ ⟫
  | ea_WtInr {t τ₁ τ₂} :
      ValidTy τ₁ ->
      ⟪ Γ ea⊢ t : τ₂ ⟫ →
      ⟪ Γ ea⊢ ea_inr τ₁ τ₂ t : tsum τ₁ τ₂ ⟫
  | ea_WtCaseof {t₁ t₂ t₃ τ₁ τ₂ τ} :
      ⟪ Γ ea⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ea⊢ t₂ : τ ⟫ →
      ⟪ Γ r▻ τ₂ ea⊢ t₃ : τ ⟫ →
      ValidTy τ₁ -> ValidTy τ₂ ->
      ⟪ Γ ea⊢ ea_caseof τ₁ τ₂ τ t₁ t₂ t₃ : τ ⟫
  | ea_WtSeq {t₁ t₂ T} :
      ⟪ Γ ea⊢ t₁ : tunit ⟫ →
      ⟪ Γ ea⊢ t₂ : T ⟫ →
      ⟪ Γ ea⊢ ea_seq T t₁ t₂ : T ⟫
  | ea_WtCoerce {t T U} :
      ⟪ T ≗ U ⟫ ->
      ValidTy T ->
      ValidTy U ->
      ⟪ Γ ea⊢ t : T ⟫ ->
      ⟪ Γ ea⊢ ea_coerce T t : U ⟫
where "⟪  Γ ea⊢ t : T  ⟫" := (AnnotTyping Γ t T).

Inductive PCtxA : Set :=
  | ea_phole
  | ea_pabs (τ₁ τ₂ : Ty) (C: PCtxA)
  | ea_papp₁ (τ₁ τ₂ : Ty) (C: PCtxA) (t: TmA)
  | ea_papp₂ (τ₁ τ₂ : Ty) (t: TmA) (C: PCtxA)
  | ea_pite₁ (τ : Ty) (C: PCtxA) (t₂ t₃: TmA)
  | ea_pite₂ (τ : Ty) (t₁: TmA) (C: PCtxA) (t₃: TmA)
  | ea_pite₃ (τ : Ty) (t₁ t₂: TmA) (C: PCtxA)
  | ea_ppair₁ (τ₁ τ₂ : Ty) (C: PCtxA) (t: TmA)
  | ea_ppair₂ (τ₁ τ₂ : Ty) (t: TmA) (C: PCtxA)
  | ea_pproj₁ (τ₁ τ₂ : Ty) (C: PCtxA)
  | ea_pproj₂ (τ₁ τ₂ : Ty) (C: PCtxA)
  | ea_pinl (τ₁ τ₂ : Ty) (C: PCtxA)
  | ea_pinr (τ₁ τ₂ : Ty) (C: PCtxA)
  | ea_pcaseof₁ (τ₁ τ₂ τ : Ty) (C: PCtxA) (t₂ t₃: TmA)
  | ea_pcaseof₂ (τ₁ τ₂ τ : Ty) (t₁: TmA) (C: PCtxA) (t₃: TmA)
  | ea_pcaseof₃ (τ₁ τ₂ τ : Ty) (t₁ t₂: TmA) (C: PCtxA)
  | ea_pseq₁ (τ : Ty) (C: PCtxA) (t: TmA)
  | ea_pseq₂ (τ : Ty) (t: TmA) (C: PCtxA)
  | ea_pcoerce (τ : Ty) (C: PCtxA).

Reserved Notation "⟪ ea⊢ C : Γ₀ , τ₀ → Γ , τ ⟫"
  (at level 0, C at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ea⊢  C  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").
Inductive PCtxTypingAnnot (Γ₀: Env) (τ₀: Ty) : Env → PCtxA → Ty → Prop :=
  | ea_WtPHole :
      ⟪ ea⊢ ea_phole : Γ₀, τ₀ → Γ₀, τ₀ ⟫
  | ea_WtPAbs {Γ C τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ r▻ τ₁, τ₂ ⟫ →
      ValidTy τ₁ ->
      ⟪ ea⊢ ea_pabs τ₁ τ₂ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
  | ea_WtPAppl {Γ C t₂ τ₁ τ₂} :
    ValidTy τ₂ ->
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ea⊢ t₂ : τ₁ ⟫ →
      ⟪ ea⊢ ea_papp₁ τ₁ τ₂ C t₂ : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ea_WtPAppr {Γ t₁ C τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
      ⟪ Γ ea⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ea⊢ ea_papp₂ τ₁ τ₂ t₁ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ea_WtPIteI {Γ C t₂ t₃ T} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ , tbool ⟫ →
      ⟪ Γ ea⊢ t₂ : T ⟫ →
      ⟪ Γ ea⊢ t₃ : T ⟫ →
      ⟪ ea⊢ ea_pite₁ T C t₂ t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | ea_WtPIteT {Γ t₁ C t₃ T} :
      ⟪ Γ ea⊢ t₁ : tbool ⟫ →
      ⟪ ea⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ Γ ea⊢ t₃ : T ⟫ →
      ⟪ ea⊢ ea_pite₂ T t₁ C t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | ea_WtPIteE {Γ t₁ t₂ C T} :
      ⟪ Γ ea⊢ t₁ : tbool ⟫ →
      ⟪ Γ ea⊢ t₂ : T ⟫ →
      ⟪ ea⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ ea⊢ ea_pite₃ T t₁ t₂ C : Γ₀ , τ₀ → Γ , T ⟫
  | ea_WtPPair₁ {Γ C t₂ τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ Γ ea⊢ t₂ : τ₂ ⟫ →
      ⟪ ea⊢ ea_ppair₁ τ₁ τ₂ C t₂ : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | ea_WtPPair₂ {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ea⊢ t₁ : τ₁ ⟫ →
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ea⊢ ea_ppair₂ τ₁ τ₂ t₁ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | ea_WtPProj₁ {Γ C τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ValidTy (tprod τ₁ τ₂) ->
      ⟪ ea⊢ ea_pproj₁ τ₁ τ₂ C : Γ₀, τ₀ → Γ, τ₁ ⟫
  | ea_WtPProj₂ {Γ C τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ValidTy (tprod τ₁ τ₂) ->
      ⟪ ea⊢ ea_pproj₂ τ₁ τ₂ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | ea_WtPInl {Γ C τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ValidTy τ₂ ->
      ⟪ ea⊢ ea_pinl τ₁ τ₂ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | ea_WtPInr {Γ C τ₁ τ₂} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ValidTy τ₁ ->
      ⟪ ea⊢ ea_pinr τ₁ τ₂ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | ea_WtPCaseof₁ {Γ C t₂ t₃ τ₁ τ₂ τ} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ea⊢ t₂ : τ ⟫ →
      ⟪ Γ r▻ τ₂ ea⊢ t₃ : τ ⟫ →
      ValidTy τ₁ -> ValidTy τ₂ ->
      ⟪ ea⊢ ea_pcaseof₁ τ₁ τ₂ τ C t₂ t₃ : Γ₀, τ₀ → Γ, τ ⟫
  | ea_WtPCaseof₂ {Γ t₁ C t₃ τ₁ τ₂ τ} :
      ⟪ Γ ea⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ r▻ τ₁, τ ⟫ →
      ⟪ Γ r▻ τ₂ ea⊢ t₃ : τ ⟫ →
      ValidTy τ₁ -> ValidTy τ₂ ->
      ⟪ ea⊢ ea_pcaseof₂ τ₁ τ₂ τ t₁ C t₃ : Γ₀, τ₀ → Γ, τ ⟫
  | ea_WtPCaseof₃ {Γ t₁ t₂ C τ₁ τ₂ τ} :
      ⟪ Γ ea⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ r▻ τ₁ ea⊢ t₂ : τ ⟫ →
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ r▻ τ₂, τ ⟫ →
      ValidTy τ₁ -> ValidTy τ₂ ->
      ⟪ ea⊢ ea_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C : Γ₀, τ₀ → Γ, τ ⟫
  | ea_WtPSeq₁ {Γ C t₂ T} :
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, tunit ⟫ →
      ⟪ Γ ea⊢ t₂ : T ⟫ →
      ⟪ ea⊢ ea_pseq₁ T C t₂ : Γ₀, τ₀ → Γ, T ⟫
  | ea_WtPSeq₂ {Γ C t₁ T} :
      ⟪ Γ ea⊢ t₁ : tunit ⟫ →
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, T ⟫ →
      ⟪ ea⊢ ea_pseq₂ T t₁ C : Γ₀, τ₀ → Γ, T ⟫
  | ea_WtPCoerce {Γ C T U} :
      ⟪ T ≗ U ⟫ ->
      ⟪ ea⊢ C : Γ₀, τ₀ → Γ, T ⟫ →
      ValidTy T -> ValidTy U ->
      ⟪ ea⊢ ea_pcoerce T C : Γ₀, τ₀ → Γ, U ⟫
where "⟪ ea⊢ C : Γ₀ , τ₀ → Γ , τ ⟫" := (PCtxTypingAnnot Γ₀ τ₀ Γ C τ).

Ltac crushTypingMatchEAH :=
  match goal with
    | [ H: ⟪ _ : _ r∈ empty ⟫         |- _ ] =>
      inversion H
    | [ H: ⟪ 0 : _ r∈ _ ⟫         |- _ ] =>
      apply getEvarInvHere in H; repeat subst
    | [ H: ⟪ (S _) : _ r∈ (_ r▻ _) ⟫ |- _ ] =>
      apply getEvarInvThere in H
    | H: ⟪ _ ea⊢ ea_var _        : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_abs _ _ _      : _ ⟫ |- _     => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_app _ _ _ _      : _ ⟫ |- _   => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_unit         : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_true         : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_false        : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_ite _ _ _    : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_pair _ _     : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_proj₁ _      : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_proj₂ _      : _ ⟫ |- _       => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_inl _ _ _        : _ ⟫ |- _   => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_inr _ _ _        : _ ⟫ |- _   => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_caseof _ _ _ _ _ _ : _ ⟫ |- _ => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_seq _ _        : _ ⟫ |- _     => inversion H; clear H
    | H: ⟪ _ ea⊢ ea_coerce _ _        : _ ⟫ |- _  => inversion H; clear H
    (* | H: ⟪ _ ⊢ seq _ _      : _ ⟫ |- _ => inversion H; clear H *)
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [match ?i with _ => _ end]
      ] => destruct i
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [(_ · _) ?i]
      ] => destruct i
    | [ |- ⟪ _ ea⊢ ea_var _ : _ ⟫              ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_abs _ _ _ : _ ⟫          ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_app _ _ _ _ : _ ⟫        ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_unit : _ ⟫               ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_true : _ ⟫               ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_false : _ ⟫              ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_ite _ _ _ : _ ⟫          ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_pair _ _ : _ ⟫           ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_proj₁ _ : _ ⟫            ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_proj₂ _ : _ ⟫            ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_inl _ _ _ : _ ⟫          ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_inr _ _ _ : _ ⟫          ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_caseof _ _ _ _ _ _ : _ ⟫ ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_seq _ _ : _ ⟫            ] => econstructor
    | [ |- ⟪ _ ea⊢ ea_coerce _ _ : _ ⟫         ] => econstructor
    | [ |- ⟪ ea⊢ ea_phole : _ , _ → _ , _ ⟫                ] => econstructor
    | [ |- ⟪ ea⊢ ea_pabs _ _ _ : _ , _ → _ , _ ⟫           ] => econstructor
    | [ |- ⟪ ea⊢ ea_papp₁ _ _ _ _ : _ , _ → _ , _ ⟫        ] => econstructor
    | [ |- ⟪ ea⊢ ea_papp₂ _ _ _ _ : _ , _ → _ , _ ⟫        ] => econstructor
    | [ |- ⟪ ea⊢ ea_pite₁ _ _ _ : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ea⊢ ea_pite₂ _ _ _ : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ea⊢ ea_pite₃ _ _ _ : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ea⊢ ea_ppair₁ _ _ : _ , _ → _ , _ ⟫           ] => econstructor
    | [ |- ⟪ ea⊢ ea_ppair₂ _ _ : _ , _ → _ , _ ⟫           ] => econstructor
    | [ |- ⟪ ea⊢ ea_pproj₁ _ : _ , _ → _ , _ ⟫             ] => econstructor
    | [ |- ⟪ ea⊢ ea_pproj₂ _ : _ , _ → _ , _ ⟫             ] => econstructor
    | [ |- ⟪ ea⊢ ea_pinl _ _ _ : _ , _ → _ , _ ⟫           ] => econstructor
    | [ |- ⟪ ea⊢ ea_pinr _ _ _ : _ , _ → _ , _ ⟫           ] => econstructor
    | [ |- ⟪ ea⊢ ea_pcaseof₁ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ea⊢ ea_pcaseof₂ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ea⊢ ea_pcaseof₃ _ _ _ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ ea⊢ ea_pseq₁ _ _ _ : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ea⊢ ea_pseq₂ _ _ _ : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ ea⊢ ea_pcoerce _ _ : _ , _ → _ , _ ⟫          ] => econstructor
  end.

Fixpoint eraseAnnot (t : TmA) : Tm :=
  match t with
  | ea_var i                   => var i
  | ea_abs τ₁ τ₂ t             => abs τ₁ (eraseAnnot t)
  | ea_app τ₁ τ₂ t₁ t₂         => app (eraseAnnot t₁) (eraseAnnot t₂)
  | ea_unit                    => unit
  | ea_true                    => true
  | ea_false                   => false
  | ea_ite τ t₁ t₂ t₃          => ite (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot t₃)
  | ea_pair τ₁ τ₂ t₁ t₂        => pair (eraseAnnot t₁) (eraseAnnot t₂)
  | ea_proj₁ τ₁ τ₂ t           => proj₁ (eraseAnnot t)
  | ea_proj₂ τ₁ τ₂ t           => proj₂ (eraseAnnot t)
  | ea_inl τ₁ τ₂ t             => inl (eraseAnnot t)
  | ea_inr τ₁ τ₂ t             => inr (eraseAnnot t)
  | ea_caseof τ₁ τ₂ τ t₁ t₂ t₃ => caseof (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot t₃)
  | ea_seq τ t₁ t₂             => seq (eraseAnnot t₁) (eraseAnnot t₂)
  | ea_coerce τ t              => eraseAnnot t
  end.

Fixpoint eraseAnnot_pctx (C : PCtxA) : PCtx :=
  match C with
  | ea_phole                    => phole
  | ea_pabs τ₁ τ₂ t             => pabs τ₁ (eraseAnnot_pctx t)
  | ea_papp₁ τ₁ τ₂ C t₂         => papp₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ea_papp₂ τ₁ τ₂ t₁ C         => papp₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ea_pite₁ τ C t₂ t₃          => pite₁ (eraseAnnot_pctx C) (eraseAnnot t₂) (eraseAnnot t₃)
  | ea_pite₂ τ t₁ C t₃          => pite₂ (eraseAnnot t₁) (eraseAnnot_pctx C) (eraseAnnot t₃)
  | ea_pite₃ τ t₁ t₂ C          => pite₃ (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot_pctx C)
  | ea_ppair₁ τ₁ τ₂ C t₂        => ppair₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ea_ppair₂ τ₁ τ₂ t₁ C        => ppair₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ea_pproj₁ τ₁ τ₂ C           => pproj₁ (eraseAnnot_pctx C)
  | ea_pproj₂ τ₁ τ₂ C           => pproj₂ (eraseAnnot_pctx C)
  | ea_pinl τ₁ τ₂ C             => pinl (eraseAnnot_pctx C)
  | ea_pinr τ₁ τ₂ C             => pinr (eraseAnnot_pctx C)
  | ea_pcaseof₁ τ₁ τ₂ τ C t₂ t₃ => pcaseof₁ (eraseAnnot_pctx C) (eraseAnnot t₂) (eraseAnnot t₃)
  | ea_pcaseof₂ τ₁ τ₂ τ t₁ C t₃ => pcaseof₂ (eraseAnnot t₁) (eraseAnnot_pctx C) (eraseAnnot t₃)
  | ea_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C => pcaseof₃ (eraseAnnot t₁) (eraseAnnot t₂) (eraseAnnot_pctx C)
  | ea_pseq₁ τ C t₂             => pseq₁ (eraseAnnot_pctx C) (eraseAnnot t₂)
  | ea_pseq₂ τ t₁ C             => pseq₂ (eraseAnnot t₁) (eraseAnnot_pctx C)
  | ea_pcoerce τ C              => eraseAnnot_pctx C
  end.

Lemma eraseAnnotT {Γ t τ} : ⟪  Γ ea⊢ t : τ  ⟫ ->
                            ⟪  Γ e⊢ (eraseAnnot t) : τ  ⟫.
Proof.
  induction 1; cbn; eauto using Typing.
Qed.

Lemma eraseAnnot_pctxT {Γₒ τₒ Γ C τ} : ⟪ ea⊢ C : Γₒ , τₒ → Γ , τ ⟫ ->
                            ⟪  e⊢ eraseAnnot_pctx C : Γₒ , τₒ → Γ , τ  ⟫.
Proof.
  induction 1; cbn; eauto using Typing, PCtxTyping, eraseAnnotT.
Qed.

(* #[export]
Hint Resolve pctxtyping_app_annot : typing. *)
(* #[export]
Hint Resolve pctxtyping_cat_annot : typing. *)

(* Ltac crushTypingMatchEAH2 := *)
(*   match goal with *)
(*     | [ |- ⟪ _ ea⊢ pctxA_app _ _ : _ ⟫          ] => apply pctxtyping_app_annot *)
(*     | [ |- ⟪ ea⊢ pctxA_cat _ _ : _ , _ → _ , _ ⟫          ] => eapply pctxtyping_cat_annot *)
(*   end. *)

Ltac crushTypingEA :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     repeat crushTypingMatchEAH;
     eauto with ws
    ).

#[export]
Hint Extern 20 (⟪ _ ea⊢ _ : _ ⟫) =>
  crushTypingEA : typing.

#[export]
Hint Extern 20 (⟪ ea⊢ _ : _ , _ → _ , _ ⟫) =>
  crushTypingEA : typing.


Require Import PL.Imp.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Import Assertion_D.

Definition concat'(d1 d2 d3:state->exit_kind->state->Prop):
state->exit_kind->state->Prop:=
fun st1 ek st2=>
 exists (st3:state) (ek':exit_kind),  d1 st1 ek' st3/\
  ((ek'=EK_Break /\ d3 st3 ek st2)\/
  (ek'<>EK_Break /\ exists st4, d2 st3 EK_Normal st4/\
  d3 st4 ek st2)).

Fixpoint ceval_Normal(c:com)(s:cstack): state->exit_kind->state->Prop:=
  match s with
  |nil=> ceval c
  |cons (b,c1,c2) s'=> concat'(ceval c)(ceval (CWhile b c1))(ceval_Normal c2 s')
  end.
Definition concat_loop(b:bexp)(d1 d2 d3:state->exit_kind->state->Prop):
state->exit_kind->state->Prop:=
fun st1 ek st2=>
 (beval b st1 /\ concat' d1 d2 d3 st1 ek st2)\/
 (~beval b st1/\ d3 st1 ek st2).

Definition ceval_LoopCond(b:bexp)(s:cstack):state->exit_kind->state->Prop:=
  match s with
  |nil=>ceval CSkip
  |cons(b',c1,c2) s'=>concat_loop b (ceval c1)  (ceval (CWhile b' c1)) (ceval_Normal c2 s')
  end.

Fixpoint ceval'(c:com'):state->exit_kind->state->Prop:=
  match c with
  |CNormal s c => ceval_Normal c s
  |CLoopCond s b=> ceval_LoopCond b s
  end.

Lemma aeval_preserve: forall st a1 a2,
  astep st a1 a2 ->
  aeval a1 st  = aeval a2 st.
Proof.
  intros.
  induction H.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    rewrite IHastep.
    reflexivity.
  + simpl.
    reflexivity.
Qed.

Lemma beval_preserve: forall st b1 b2,
  bstep st b1 b2 ->
  (beval b1 st  <-> beval b2 st).
Proof.
  intros.
  induction H.
  + apply aeval_preserve in H.
    simpl.
    rewrite H.
    tauto.
  + apply aeval_preserve in H0.
    simpl.
    rewrite H0.
    tauto.
  + simpl.
    tauto.
  + simpl.
    tauto.
  + apply aeval_preserve in H.
    simpl.
    rewrite H.
    tauto.
  + apply aeval_preserve in H0.
    simpl.
    rewrite H0.
    tauto.
  + simpl.
    tauto.
  + simpl.
    omega.
  + simpl.
    tauto.
  + simpl.
    tauto.
  + simpl.
    tauto.
  + simpl.
    tauto.
  + simpl.
    tauto.
  + simpl.
    tauto.
Qed.

Lemma Break_Condition:forall c st,
start_with_break c->
ceval c st EK_Break st.
Proof.
  intros.
  induction H.
  +  simpl.
      unfold break_sem.
      split.
      -  reflexivity.
      -  reflexivity.
  +  simpl.
      unfold seq_sem.
      right.
      split.
      -  tauto.
      -  discriminate.
Qed.

Theorem Cont_Condition:forall c st,
start_with_cont c->
ceval c st EK_Cont st.
Proof.
  intros.
  induction H.
  +  simpl.
      unfold break_sem.
      split.
      -  reflexivity.
      -  reflexivity.
  +  simpl.
      unfold seq_sem.
      right.
      split.
      -  tauto.
      -  discriminate.
Qed.

Lemma ceval_Normal_CSAssStep:  forall st s X a a' ,
      astep st a a' ->
        forall st' ek, ceval' (CNormal s (CAss X a'))  st ek st' -> ceval'  (CNormal s (CAss X a))  st ek st'.
Proof.
      intros.
      apply aeval_preserve in H.
      subst.
      induction s.
      +  simpl.
         simpl in H0.
         unfold asgn_sem.
         unfold asgn_sem in H0.
         rewrite H.
         tauto.
      +  destruct a0 as [p c2].
         destruct p as [b c1].
         simpl.
         simpl in  H0.
         unfold concat' in H0.
         unfold concat'.
         destruct H0 as [st4 [ek' [? ?]]].
         unfold asgn_sem in H0.
         destruct H0 as [? [? ?]].
         destruct H1.
         -  destruct H1 as [? ?].
             subst.
             discriminate.
         -  destruct H1 as [? [st5 [? ?]]].
            exists st4.
            exists ek'.
            split.
            *  unfold asgn_sem.
               rewrite H.
                tauto.
            *  right.
                split.
                tauto.
                exists st5.
                tauto.
Qed.

Lemma ceval_Normal_CSAss:
     forall st1 st2 s X ,
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
     forall st3 ek, ceval' (CNormal s CSkip) st2 ek st3->ceval' (CNormal s (CAss X (st2 X))) st1 ek st3.
Proof.
  intros.
   induction s.
   +   simpl.
         simpl in H0.
         unfold skip_sem in H0.
         destruct H0.
         unfold asgn_sem.
         subst.
         unfold aeval.
         split.
         { reflexivity. }
         split.
         {  reflexivity.  }
         { tauto. }
     + destruct a as [[b c1] c2].
         simpl.
         simpl in  H0.
         unfold concat' in H0.
         unfold concat'.
         destruct H0 as [st5 [ek' [? ?]]].
         unfold skip_sem in H0.
         destruct H1.
         -  destruct H1 as [? ?].
             destruct H0 as [? ?].
             subst.
             discriminate.
         -  destruct H1 as [? [st4 [? ?]]].
             destruct H0.
             exists st5.
             exists ek'.
             subst.
            split.
            *  unfold asgn_sem.
               simpl.
               split.
                {  tauto. }
                split.
                {  reflexivity. }
                tauto.
            *  right.
               split.
               tauto.
               exists st4.
               tauto.
Qed.

Lemma ceval_Normal_Seq:
forall c s ek st st',  ceval' (CNormal s c) st ek st'->
ceval' (CNormal s (Skip;; c)) st ek st'.
Proof.
  intros.
  induction s.
  +  simpl.
       simpl in H.
       unfold seq_sem,skip_sem.
       left.
       exists st.
       split.
       split.
       -  reflexivity.
       -  reflexivity.
        - tauto.
   +  destruct a as [[b c1'] c2'].
        simpl.
        simpl in  H.
        unfold concat' in H.
        unfold concat'.
        destruct H as [st4 [ek' [? ?]]].
        destruct H0.
         -  destruct H0 as [? ?].
             exists st4.
             exists ek'.
             split.
             * unfold seq_sem,skip_sem.
                left.
                exists st.
                split.
                split.
                { reflexivity. }
                { reflexivity. }
                { tauto. }
            *  left.
                tauto.
        -  destruct H0 as [? [st5 [? ?]]].
            exists st4.
            exists ek'.
            split.
            *  unfold seq_sem,skip_sem.
                left.
                exists st.
                split.
                split.
                {  reflexivity. }
                { reflexivity. }
                { tauto.  }
            *  right.
               split.
               tauto.
               exists st5.
               tauto.
Qed.

Lemma Loop_Condition:
forall b st1 st2 st3 c ek,
beval b st1->
ek<> EK_Break->
loop_sem b (ceval c) st2 EK_Normal st3->ceval c st1 ek st2->loop_sem b (ceval c) st1 EK_Normal st3.
Proof.
  intros.
  assert(ek=EK_Normal \/ ek=EK_Cont).
  {  induction ek;tauto. }
  unfold loop_sem.
  unfold loop_sem in H1.
  destruct H3.
  +  destruct H1 as [n [? ?]].
      exists (S n).
      simpl.
      split.
      split.
      -  left.
        exists st2.
        subst.
        tauto.
     -  tauto.
     -  reflexivity.
  +  destruct H1 as [n [? ?]].
       exists (S n).
       simpl.
       split.
       split.
       -  right.
          right.
          subst.
          exists st2.
          tauto.
        - tauto.
        - tauto.
Qed.

Theorem  ceval'_preserve: forall c1 c2 st1 st2,
cstep (c1, st1) (c2, st2) ->
  forall st3 ek, ceval' c2  st2 ek st3 -> ceval'  c1 st1 ek st3.
Proof.
  intros.
  revert H0.
  remember (c1, st1) as cst1 eqn:H0.
  remember (c2, st2) as cst2 eqn:H1.
  revert c1 c2 st1 st2 st3 H0 H1.
  induction H; simpl; intros.
  +  injection H0 as ? ?.
      injection H1 as ? ?.
      subst.
      pose proof (ceval_Normal_CSAssStep _ _ _ _ _ H _ _ H2).
      tauto.
  +  injection H1 as ? ?.
      injection H2 as ? ?.
      subst.
      pose proof (ceval_Normal_CSAss _ _ _ _   H0 _ _ H3).
      tauto.
  +  injection H0 as ? ?.
       injection H1 as ? ?.
       subst.
       induction s.
       -   simpl in H2.
           simpl.
           unfold seq_sem in H2.
           unfold seq_sem.
           assert ((CNormal nil c1, st1) =(CNormal nil c1, st1)). { reflexivity. }
            assert  ( (CNormal nil c1', st2) =(CNormal nil c1', st2) ).  { reflexivity. }
           destruct H2.
           *  destruct H2 as [st4 [? ?]].
               pose proof (classic (ek=EK_Normal)).
               left.
               exists st4.
               specialize (IHcstep _ _ _ _ st4 H0 H1).
               simpl in IHcstep.
               destruct H4.
               {  subst.
                   specialize (IHcstep H2).
                   tauto. }
               {  split.
                   admit.
                   tauto. }
           *  destruct H2.
               right.
               specialize (IHcstep _ _ _ _ st3 H0 H1).
               simpl in IHcstep.
               specialize (IHcstep H2).
               tauto.
      -    destruct a as [p c4].
           destruct p as [b c3].
           simpl.
           simpl in  H2.
           unfold concat' in H2.
           unfold concat'.
           destruct H2 as [st4 [ek' [? ?]]].
           unfold seq_sem in H0.
           admit.
  +  injection H0 as ? ?.
       injection H1 as ? ?.
       subst.
       pose proof (ceval_Normal_Seq _ _ _ _ _ H2).
       tauto.
  +   injection H0 as ? ?.
        injection H1 as ? ?.
        subst.
        simpl.
        simpl in H2.
        induction s.
        -   unfold if_sem.
            pose proof (beval_preserve _ _ _ H ).
            destruct H0.
            pose proof (classic (beval b' st2)).
            destruct H3.
            *  simpl.
                unfold if_sem.
                left.
                specialize(H1 H3).
                simpl in H2.
               unfold if_sem in H2.
               tauto.
            *  simpl.
                simpl in H2.
                unfold if_sem.
                unfold if_sem in H2.
                assert(~ beval b' st2).
                { tauto. }
                tauto.
        -   destruct a as [p c4].
            destruct p as [b0 c3].
            pose proof (beval_preserve _ _ _ H ).
            destruct H0 as [? ?].
            simpl.
            simpl in  H2.
            unfold concat' in H2.
            unfold concat'.
            destruct H2 as [st4 [ek' [? ?]]].
            unfold if_sem in H2.
            destruct H2.
            destruct H3.
         *  destruct H2 as [? ?].
             exists st4.
             exists ek'.
             split.
             { unfold if_sem.
                pose proof (H1 H4).
                tauto.  }
             left.
             tauto.
         *  destruct H3 as [? [st5 [? ?]]].
             destruct H2 as [? ?].
             exists st4.
             exists ek'.
             split.
             { unfold if_sem.
                pose proof (H1 H6).
                tauto.  }
             right.
             split.
             { tauto. }
             { exists st5.
               tauto.  }
         *  destruct H3.
             {
             destruct H3.
             destruct H2.
             exists st4.
             exists ek'.
             split.
             {  unfold if_sem.
                 assert(~beval b st2).
                 {  tauto. }
                 tauto. }
             left.
             tauto.
            }
            {  destruct H3 as [? [st5 [? ?]]].
                destruct H2.
                exists st4.
                exists ek'.
                split.
                {  unfold if_sem.
                    assert(~beval b st2).
                 {  tauto. }
                 tauto. }
                right.
                split.
                tauto.
                exists st5.
                tauto.
                }
  +    injection H0 as ? ?.
         injection H1 as ? ?.
         subst.
         simpl.
         simpl in H2.
         induction s.
         -  simpl.
            unfold if_sem.
            left.
            split.
           {tauto. }
           { simpl.
              tauto. }
        -  destruct a as [p c5].
           destruct p as [b0 c4].
           simpl.
           simpl in H2.
           unfold concat'.
           unfold concat' in H2.
           destruct H2 as [st4 [ek' [? ?]]].
           destruct H0.
           *  exists st4.
               exists ek'.
              split.
              {  unfold if_sem.
                 left.
                 simpl.
                 tauto.
              }
              tauto.
          *   exists st4.
               exists ek'.
              split.
              {  unfold if_sem.
                 left.
                 simpl.
                 tauto.
              }
             right.
             split.
             tauto.
             destruct H0 as [? [st5 ?]].
             exists st5.
             tauto.
  + injection H0 as ? ?.
    injection H1 as ? ?.
    subst.
    simpl.
    simpl in H2.
    induction s.
    -   simpl.
        unfold if_sem.
        right.
        split.
        {  tauto. }
        {  simpl.
            tauto. }
     -     destruct a as [p c5].
           destruct p as [b0 c4].
           simpl.
           simpl in H2.
           unfold concat'.
           unfold concat' in H2.
           destruct H2 as [st4 [ek' [? ?]]].
           destruct H0.
           *  exists st4.
               exists ek'.
              split.
              {  unfold if_sem.
                 right.
                 simpl.
                 tauto.
              }
              tauto.
          *   exists st4.
               exists ek'.
              split.
              {  unfold if_sem.
                 right.
                 simpl.
                 tauto.
              }
             right.
             split.
             tauto.
             destruct H0 as [? [st5 ?]].
             exists st5.
             tauto.
  +  injection H0 as ? ?.
      injection H1 as ? ?.
      subst.
      simpl.
      simpl in H2.
      unfold ceval_LoopCond in H2.
      unfold concat_loop in H2.
      destruct H2.
      { destruct H0.
         induction H.
         +  induction s.
             -  simpl.
                simpl in H1.
                unfold concat' in H1.
                destruct H1 as [st4 [ek' [? ?]]].
                destruct H1.
                *  unfold skip_sem in H1.
                   unfold loop_sem.
                   exists (S O).
                   simpl.
                   destruct H1 as [? [? ?]].
                   subst.
                   tauto.
              *   assert (ek'=EK_Normal \/ ek'=EK_Cont).
                 { induction ek';tauto. }
                 destruct H1 as [? [st5 [? ?]]].
                 destruct H2.
                 ++  subst.
                        unfold skip_sem in H4.
                        destruct H4.
                        unfold loop_sem.
                        unfold loop_sem in H3.
                        destruct H3 as [n [? ?]].
                        exists (S n).
                        subst.
                        simpl.
                        split.
                        split.
                        left.
                        exists st4.
                        tauto.
                        tauto.
                        tauto.
                  ++ unfold loop_sem.
                        unfold loop_sem in H3.
                        destruct H3 as [n [? ?]].
                        exists (S n).
                        simpl.
                        unfold skip_sem in H4.
                        destruct H4.
                        subst.
                        split.
                        split.
                        right.
                        right.
                        exists st4.
                        tauto.
                        tauto.
                        reflexivity.
             -   destruct a as [[b' c1] c2].
                 simpl.
                 simpl in H1.
                 unfold concat' at 1 in H1.
                 destruct H1 as [st4 [ek' [? ?]]].
                 destruct H1.
                 *  destruct H1.
                    unfold concat',skip_sem in H2.
                    destruct H2 as [st5 [ek'' [[? ?] ?]]].
                    destruct H4.
                    ++  destruct H4.
                           subst.
                           discriminate.
                    ++  destruct H4 as [? [st1 [? ?]]].
                           unfold concat'.
                           subst.
                           exists st5.
                           exists EK_Normal.
                           split.
                           {
                           unfold loop_sem.
                           exists (S O).
                           simpl.
                           tauto.
                           }
                      right.
                      split.
                      discriminate.
                      exists st1.
                      tauto.
                *  destruct H1 as [? [st1 [? ?]]].
                    unfold concat',skip_sem in H3.
                    destruct H3 as [st5 [ek'' [[? ?] ?]]].
                    destruct H5.
                    ++  destruct H5.
                           subst.
                           discriminate.
                    ++  subst.
                           destruct H5 as [? [st1 [? ?]]].
                           unfold concat'.
                           unfold loop_sem in H4.
                           destruct H4 as [n [? ?]].
                           clear H3 H6.
                           exists st5.
                           exists EK_Normal.
                           split.
                           {  pose proof (Loop_Condition _ _ _ _ _ _ H0 H1  H2 H).
                          tauto.
                          }
                          right.
                          split.
                          discriminate.
                          exists st1.
                          unfold loop_sem.
                          split.
                          exists n.
                          tauto.
                          tauto.
         +  unfold concat' in H1.
             destruct H1 as [st1 [ek' [? ?]]].
             admit.
                   }
      destruct H0.
      induction H.
      -  simpl.
      induction s.
      *  simpl.
         simpl in H1.
         unfold skip_sem in H1.
         unfold loop_sem.
         exists O.
         simpl.
         tauto.
      *  destruct a as [[st' c1 ]c2].
         simpl.
         simpl in H1.
         unfold concat',skip_sem in H1.
         unfold concat'.
         unfold loop_sem at 1.
         destruct H1 as [st4 [ek' [? ?]]].
         destruct H1.
         {  destruct H.
             destruct H1.
             subst.
             discriminate.  }
         {  destruct H.
             subst.
             destruct H1 as [? [st2 [? ?]]].
             exists st4.
             exists EK_Normal.
             split.
             {  exists O.
                simpl.
                tauto. }
             {  right.
                split.
                tauto.
                exists st2.
                tauto.
                }
             }
      -  admit.
  + injection H0 as ? ?.
      injection H1 as ? ?.
      subst.
      simpl.
      simpl in H2.
      pose proof (beval_preserve _ _ _  H).
      unfold ceval_LoopCond.
      simpl.
      pose proof (classic (beval b'' st2)).
      unfold ceval_LoopCond in H2.
      unfold concat_loop in H2.
       unfold concat_loop.
      destruct H1.
      -  assert(beval b' st2).
         { tauto. }
         destruct H2.
         *  destruct H2.
            left.
            split.
            tauto.
            simpl in H4.
            tauto.
          *  tauto.
      -  assert (~beval b' st2).
        {  tauto. }
        tauto.
  +   injection H0 as ? ?.
     injection H1 as ? ?.
     subst.
     simpl.
     simpl in H2.
     unfold concat_loop.
     simpl.
     tauto.
  + injection H0 as ? ?.
     injection H1 as ? ?.
     subst.
     simpl.
     unfold concat_loop.
     simpl.
     tauto.
  +  injection H0 as ? ?.
       injection H1 as ? ?.
       subst.
       simpl.
      unfold concat',skip_sem.
      exists st2.
      exists EK_Normal.
      split.
      split.
      reflexivity.
      reflexivity.
      right.
      unfold ceval_LoopCond in H2.
      unfold concat_loop in H2.
      destruct H2.
      -  destruct H as [? ?].
         split.
         discriminate.
         unfold concat' in H0.
         destruct H0 as [st4 [ek' [? ?]]].
         destruct H1.
         *  destruct H1.
            exists st4.
            unfold loop_sem.
            split.
            exists (S O).
            simpl.
            subst.
            tauto.
            tauto.
        *  destruct H1 as [? [st5 [? ?]]].
            exists st5.
            unfold loop_sem.
            assert(ek'=EK_Normal \/ ek'=EK_Cont).
            { induction ek';tauto. }
            split.
            destruct H4.
            { simpl in H2.
              unfold loop_sem in H2.
              destruct H2 as [n [? ?]].
              exists (S n).
              simpl.
              split.
              split.
              left.
              exists st4.
              subst.
              tauto.
              tauto.
              tauto.
              }
            { simpl in H2.
              unfold loop_sem in H2.
              destruct H2 as [n [? ?]].
              exists (S n).
              simpl.
              split.
              split.
              right.
              right.
              exists st4.
              subst.
              tauto.
              tauto.
              tauto.
            }
         tauto.
      -  simpl.
         destruct H as [? ?].
         split.
         discriminate.
         exists st2.
        unfold loop_sem.
        split.
        exists O.
        simpl.
        split.
        split.
        { reflexivity. }
        { tauto. }
        { reflexivity. }
        { tauto. }
  +   injection H0 as ? ?.
       injection H1 as ? ?.
       subst.
       induction s.
      -   simpl.
          simpl in H2.
          unfold concat'.
          exists st2.
          exists EK_Break.
          split.
          *  apply Break_Condition.
              tauto.
          *  left.
              split.
              reflexivity.
              tauto.
       -   destruct a as [p c5].
           destruct p as [b0 c4].
           simpl.
           simpl in H2.
           unfold concat' at 1.
           exists st2.
           exists EK_Break.
           split.
           *  apply Break_Condition.
               tauto.
           *  left.
               split.
               { reflexivity. }
               {  tauto. }
  +  injection H1 as ? ?.
      injection H0 as ? ?.
      subst.
      unfold ceval_LoopCond in H2.
      simpl.
      unfold concat_loop in H2.
      destruct H2.
      -  destruct H0.
         unfold concat'.
         unfold concat' in H1.
         destruct H1 as [st4 [ek' [? ?]]].
         destruct H2.
         *  destruct H2.
             subst.
             exists st2.
             exists EK_Cont.
             pose proof (Cont_Condition _ st2 H).
             split.
             tauto.
             right.
             split.
            discriminate.
             exists st4.
             unfold loop_sem.
             split.
             exists (S O).
             simpl.
             simpl in H1.
             split.
             tauto.
             reflexivity.
             tauto.
         *  destruct H2 as [? [st5 [? ?]]].
              pose proof (Cont_Condition _ st2 H).
              exists st2.
              exists EK_Cont.
              split.
              tauto.
              right.
              split.
              discriminate.
              exists st5.
              simpl in H3.
              assert(ek'=EK_Normal\/ ek'=EK_Cont).
              { induction ek';tauto. }
              split.
              unfold loop_sem in H3.
              destruct H3 as [n [? ?]].
              exists (S n).
              destruct H6.
              {  simpl.
                  split.
                  split.
                  left.
                  subst.
                  exists st4.
                  tauto.
                  tauto.
                  reflexivity.  }
              {  simpl.
                  split.
                  split.
                  right.
                  right.
                  subst.
                  exists st4.
                  tauto.
                  tauto.
                  reflexivity.
                }
                tauto.
       -  unfold concat'.
          destruct H0.
          exists st2.
          pose proof (Cont_Condition _ st2 H).
          exists EK_Cont.
          split.
          tauto.
          right.
          split.
          discriminate.
          exists st2.
          split.
          unfold loop_sem.
          exists O.
          simpl.
          split.
          split.
          reflexivity.
          tauto.
          reflexivity.
          tauto.
  Admitted.

Theorem semantic_equiv_normal2: forall (c:com')  st1 st2,
multi_cstep (c ,st1) (CNormal nil CSkip ,st2)->(ceval' c st1 EK_Normal st2) .
Proof.
  intros.
  remember (CNormal nil Skip) as c' eqn:H0.
  revert H0.  induction_1n H.  simpl; intros; subst.
  + simpl.
    unfold skip_sem.
    split.
    -  reflexivity.
    -  reflexivity.
  + pose proof ceval'_preserve _ _ _ _ H st2.
     intros.
     pose proof (IH H2).
     specialize (H1 EK_Normal H3).
     tauto.
Qed.

Theorem semantic_equiv_break2: forall (c:com')  st1 st2,
(exists c', multi_cstep (c ,st1) (CNormal nil c' ,st2)/\start_with_break c')->(ceval' c st1 EK_Break  st2) .
Proof.
  intros.
  destruct H as [c' [?  ?]].
  remember (CNormal nil c') as c1 eqn:H1.
  revert H1.  induction_1n H.  simpl; intros; subst.
  + simpl.
     pose proof (Break_Condition _ st1 H0).
     tauto.
  +  pose proof ceval'_preserve _ _ _ _ H st2.
      intros.
      pose proof (IH H3).
     specialize (H2 EK_Break H4).
     tauto.
Qed.

Theorem semantic_equiv_cont2: forall (c:com')  st1 st2,
(exists c', multi_cstep (c ,st1) (CNormal nil c' ,st2)/\start_with_cont c')->(ceval' c st1 EK_Cont  st2) .
Proof.
  intros.
  destruct H as [c' [?  ?]].
  remember (CNormal nil c') as c1 eqn:H1.
  revert H1.  induction_1n H.  simpl; intros; subst.
  + simpl.
     pose proof (Cont_Condition _ st1 H0).
     tauto.
  +  pose proof ceval'_preserve _ _ _ _ H st2.
      intros.
      pose proof (IH H3).
     specialize (H2 EK_Cont H4).
     tauto.
Qed.


Set Implicit Arguments.

Require Import Coq.Classes.Equivalence.
Require Import WordInterface.
Require Import Network.NetworkPacket.
Require Import OpenFlow.OpenFlow0x01Types.

Local Open Scope equiv_scope.

Module Type PATTERN.

  Parameter t : Type.

  Parameter inter : t -> t -> t.

  Parameter all : t.

  Parameter empty : t.

  Parameter exact_pattern : packet -> portId -> t.

  Parameter is_empty : t -> bool.

  Parameter match_packet : portId -> packet -> t -> bool.

  Parameter is_exact : t -> bool.

  Parameter to_match : forall x, is_empty x = false -> of_match.

  Parameter beq : t -> t -> bool.

  (** Constructors that produce valid patterns. *)

  Parameter dlSrc : dlAddr -> t.

  Parameter dlDst : dlAddr -> t.

  Parameter dlTyp : dlTyp -> t.

  (** TODO(arjun): Only the 12 lower bits matter. If higher-order bits are
      non-zero, we might calculate incorrect intersections here too. *)
  Parameter dlVlan : dlVlan -> t.

  (** TODO(arjun): only lower 3 bits matter, similar to above. *)
  Parameter dlVlanPcp : dlVlanPcp -> t.

  Parameter ipSrc : nwAddr -> t.

  Parameter ipDst : nwAddr -> t.

  Parameter ipProto : nwProto -> t.

  Parameter inPort : portId -> t.

  Parameter tcpSrcPort : tpPort -> t.

  Parameter tcpDstPort : tpPort -> t.

  Parameter udpSrcPort : tpPort -> t.

  Parameter udpDstPort : tpPort -> t.

  (** Pattern equivalence *)

  Definition equiv (pat1 pat2 : t) : Prop :=
    forall pt pk,
      match_packet pt pk pat1 = match_packet pt pk pat2.

  Parameter equiv_is_Equivalence : Equivalence equiv.

  Instance Pattern_Equivalence : Equivalence equiv.
    apply equiv_is_Equivalence.
  Qed.

  Parameter beq_true_spec : forall p p',
    beq p p' = true ->
    p === p'.

  Parameter inter_comm : forall p p', inter p p' === inter p' p.

  Parameter inter_assoc : forall p p' p'',
    inter p (inter p' p'') === inter (inter p p') p''.

  Parameter is_empty_false_distr_l : forall x y,
    is_empty (inter x y) = false ->
    is_empty x = false .

  Parameter is_empty_false_distr_r : forall x y,
    is_empty (inter x y) = false ->
    is_empty y = false .

  Parameter is_empty_true_l : forall x y,
    is_empty x = true ->
    is_empty (inter x y) = true.

  Parameter is_empty_true_r : forall x y,
    is_empty y = true ->
    is_empty (inter x y) = true.

  Parameter is_match_false_inter_l :
    forall (pt : portId) (pkt : packet) pat1 pat2,
      match_packet pt pkt pat1 = false ->
      match_packet pt pkt (inter pat1 pat2) = false.

  Parameter no_match_subset_r : forall k n t t',
    match_packet n k t' = false ->
    match_packet n k (inter t t') = false.

  Parameter exact_match_inter : forall x y,
    is_exact x = true ->
    is_empty (inter x y) = false ->
    inter x y === x.

  Parameter all_spec : forall pt pk,
    match_packet pt pk all = true.

  Parameter exact_match_is_exact : forall pk pt,
    is_exact (exact_pattern pk pt) = true.

  Parameter exact_intersect : forall k n t,
    match_packet k n t = true ->
    inter (exact_pattern n k) t === exact_pattern n k.

  Parameter is_match_true_inter : forall pat1 pat2 pt pk,
    match_packet pt pk pat1 = true ->
    match_packet pt pk pat2 = true ->
    match_packet pt pk (inter pat1 pat2) = true.

  Parameter match_packet_spec : forall pt pk pat,
    match_packet pt pk pat =
    negb (is_empty (inter (exact_pattern pk pt) pat)).

  Parameter all_is_not_empty : is_empty all = false.

End PATTERN.


From NP Require Export Defs.

Implicit Types P Q R S : CCS.
Implicit Types a : action.

Definition kvstore (X:Type) (Y:X->Type) := list {x:X & Y x}.
Definition keys {X:Type} {Y:X->Type} : kvstore X Y -> list X := map sigLeft.
Definition proj1 {X:Type} {Y:X->Type} : {x:X & Y x} -> X := fun k => match k with existT _ x _ => x end.
Definition elemType {X:Type} {Y:X->Type} (k:kvstore X Y) := {x:X & Y x}.
Lemma find {X:Type} {Y:X->Type} (A:kvstore X Y) (x:X) : x cel keys A -> Y x.
intros H. destruct (elMapS sigLeft A x) as [[x' yx] [x'el xx']]. exact H.
rewrite xx'. exact yx. Defined.

Definition syntactic (p:CCS -> Prop) : Prop := (forall P Q, p(Par P Q) -> p P * p Q) * (forall P Q, p(Choice P Q) -> p P * p Q) * (forall P (H:actionFilter), p (Restrict P H) -> p P).

Fixpoint guarded S :Prop := match S with Prefix a P => True | Choice P Q => guarded P * guarded Q | Par P Q => guarded P * guarded Q | Restrict P _ => guarded P | Var _ => False | Stop => True end.

Lemma guardedSyntactic : syntactic guarded.
split. 1:split; easy. easy. Defined.

Lemma trueSyntactic : syntactic (fun _ => True).
split. 1:split; easy. easy. Defined.

Definition varHelper (G:nat->CCS) (p:CCS -> Prop) := forall n:nat, p (Var n) -> {A:kvstore (action*CCS) (fun '(a,t) => trans G (Var n) a t) & forall a R, trans G (Var n) a R -> (a,R) cel keys A}.

Fact helpSync1 (n:nat) : Snd n <> Tau. congruence. Defined.
Fact helpSync2 (n:nat) : Rcv n <> Tau. congruence. Defined.
Fact helpSyncInvert1 {G:nat->CCS} {s:CCS} {t:CCS} (n n':nat) : n=n' -> trans G s (Rcv n') t -> trans G s (invAction (Snd n)) t. intros H. rewrite H. cbn. easy. Defined.
Fact helpSyncInvert2 {G:nat->CCS} {s:CCS} {t:CCS} (n n':nat) : n=n' -> trans G s (Snd n') t -> trans G s (invAction (Rcv n)) t. intros H. rewrite H. cbn. easy. Defined.

Definition syncHelp {G:nat->CCS} {P Q:CCS} (A' : kvstore (action * CCS) (fun '(a, T) => trans G Q a T)) (k : {'(a,T):action*CCS & trans G P a T}) : kvstore (action * CCS) (fun '(a, T) => trans G (Par P Q) a T).
destruct k as [[[|n|n] T] trns].
* exact [].
* refine (flatmap _ A'). intros [[b T'] trns']. destruct b as [| |n']. 1,2: exact []. destruct (natDec n n') as [eq|neq].
  + refine [ _ ]. exists (Tau, Par T T'). apply tSync with (Snd n). apply helpSync1. easy. apply helpSyncInvert1 with n'. easy. easy.
  + exact [].
* refine (flatmap _ A'). intros [[b T'] trns']. destruct b as [|n'|]. 1,3: exact []. destruct (natDec n n') as [eq|neq].
  + refine [ _ ]. exists (Tau, Par T T'). apply tSync with (Rcv n). apply helpSync2. easy. apply helpSyncInvert2 with n'. easy. easy.
  + exact [].
Defined.

Lemma transDeriv (G:nat->CCS) S (p:CCS -> Prop) : syntactic p -> varHelper G p -> p S -> {A:kvstore (action*CCS) (fun '(a,T) => trans G S a T) & forall a T, trans G S a T -> (a,T) cel keys A}.
intros [[pPar pChoice] pRes] vH.
induction S as [a P IH|P IHP Q IHQ|P IHP Q IHQ|P IH H|n|].
* intros _. exists [existT _ (a, P) (tPrefix G a P)].
  intros a' P' taP. inversion taP. left. easy.
* intros [pP pQ]%pChoice. destruct (IHP pP) as [PA cPA], (IHQ pQ) as [QA cQA].
  pose (fun '((existT _ (a,T) tT):elemType PA) => existT (fun '(a,T) => trans G (Choice P Q) a T) (a,T) (tChoiceL G a P Q T tT)) as extendL.
  pose (fun '((existT _ (a,T) tT):elemType QA) => existT (fun '(a,T) => trans G (Choice P Q) a T) (a,T) (tChoiceR G a P Q T tT)) as extendR.
  exists (map extendL PA
       ++ map extendR QA).
  intros a T H. unfold keys. rewrite mapAppend. apply elAppend. inversion H.
  + left. pose proof (cPA a T X) as HH. apply elMapS in HH. destruct HH as [[[a' T'] taT'] [elPA eq]]. rewrite eq.
    cbn. change (a', T') with (sigLeft (existT (fun '(a, T) => trans G (Choice P Q) a T) (a',T') (tChoiceL G a' P Q T' taT'))). apply elMap.
    change (existT (fun '(a1, T0) => trans G (Choice P Q) a1 T0) (a', T') (tChoiceL G a' P Q T' taT'))
    with (extendL (existT (fun '(a, T) => trans G P a T) (a', T') taT')).
    apply elMap. easy.
  + right. pose proof (cQA a T X) as HH. apply elMapS in HH. destruct HH as [[[a' T'] taT'] [elQA eq]]. rewrite eq.
    cbn. change (a', T') with (sigLeft (existT (fun '(a, T) => trans G (Choice P Q) a T) (a',T') (tChoiceR G a' P Q T' taT'))). apply elMap.
    change (existT (fun '(a1, T0) => trans G (Choice P Q) a1 T0) (a', T') (tChoiceR G a' P Q T' taT'))
    with (extendR (existT (fun '(a, T) => trans G Q a T) (a', T') taT')).
    apply elMap. easy.
* intros [pP pQ]%pPar. destruct (IHP pP) as [PA cPA], (IHQ pQ) as [QA cQA].
  pose (fun '((existT _ (a,T) tT):elemType PA) => existT (fun '(a,T) => trans G (Par P Q) a T) (a,(Par T Q)) (tParL G a P Q T tT)) as extendL.
  pose (fun '((existT _ (a,T) tT):elemType QA) => existT (fun '(a,T) => trans G (Par P Q) a T) (a,(Par P T)) (tParR G a P Q T tT)) as extendR.
  exists (map extendL PA ++ map extendR QA ++ flatmap (syncHelp QA) PA).
  intros a T H. unfold keys. rewrite !mapAppend. apply elAppend. inversion H.
  + left. pose proof (cPA a P' X) as HH. apply elMapS in HH. destruct HH as [[[a' T'] taT'] [elPA eq]]. cbn in eq. enough (a=a' /\ P'=T') as [Hl Hr]. 2:split;congruence. rewrite Hl, Hr.
    change (a', Par T' Q) with (sigLeft (existT (fun '(a,T) => trans G (Par P Q) a T) (a',(Par T' Q)) (tParL G a' P Q T' taT'))). apply elMap.
    change (existT (fun '(a1, T0) => trans G (Par P Q) a1 T0) (a', Par T' Q) (tParL G a' P Q T' taT'))
    with (extendL (existT (fun '(a', T') => trans G P a' T') (a', T') taT')). apply elMap. easy.
  + right. apply elAppend. left.
    pose proof (cQA a Q' X) as HH. apply elMapS in HH. destruct HH as [[[a' T'] taT'] [elQA eq]]. cbn in eq. enough (a=a' /\ Q'=T') as [Hl Hr]. 2:split;congruence. rewrite Hl, Hr.
    change (a', Par P T') with (sigLeft (existT (fun '(a,T) => trans G (Par P Q) a T) (a',(Par P T')) (tParR G a' P Q T' taT'))). apply elMap.
    change (existT (fun '(a', T') => trans G (Par P Q) a' T') (a', Par P T') (tParR G a' P Q T' taT'))
    with (extendR (existT (fun '(a', T') => trans G Q a' T') (a', T') taT')). apply elMap. easy.
  + right. apply elAppend. right.
    pose proof (cPA a0 P' X) as HHP. apply elMapS in HHP. destruct HHP as [[[Pa' PT'] PtaT'] [elPA eqP]]. cbn in eqP.
    pose proof (cQA (invAction a0) Q' X0) as HHQ. apply elMapS in HHQ. destruct HHQ as [[[Qa' QT'] QtaT'] [elQa eqQ]]. cbn in eqQ.
    destruct Pa'.
    - exfalso. apply H4. congruence.
    - enough (Qa' = Rcv n) as HQa'. destruct Qa'.
      ++ exfalso. congruence.
      ++ exfalso. congruence.
      ++ destruct (natDec n n0) as [Heq|Hneq] eqn:Hndr.
       -- enough (PT' = P' /\ QT'=Q') as [HL HR]. 2: split; congruence. rewrite <- HL, <- HR.
          change ((Tau, Par PT' QT')) with (sigLeft (existT (fun '(a,T) => trans G (Par P Q) a T) (Tau, Par PT' QT')
                      ((tSync G (Snd n) P Q PT' QT' (helpSync1 n) PtaT' (helpSyncInvert1 n n0 Heq QtaT'))))). apply elMap.
          apply elFlatmap with (existT (fun '(a, T) => trans G P a T) (Snd n, PT') PtaT'). easy. unfold syncHelp.
          apply elFlatmap with (existT (fun '(a, T) => trans G Q a T) (Rcv n0, QT') QtaT'). easy. rewrite Hndr. left. easy.
       -- exfalso. congruence.
      ++ enough (Qa' = invAction a0). 2: congruence. enough (a0 = Snd n). 2: congruence. rewrite H5, H6. easy.
    - enough (Qa' = Snd n) as HQa'. destruct Qa'.
      ++ exfalso. congruence.
      ++ destruct (natDec n n0) as [Heq|Hneq] eqn:Hndr.
       -- enough (PT' = P' /\ QT'=Q') as [HL HR]. 2: split; congruence. rewrite <- HL, <- HR.
          change ((Tau, Par PT' QT')) with (sigLeft (existT (fun '(a,T) => trans G (Par P Q) a T) (Tau, Par PT' QT')
                      ((tSync G (Rcv n) P Q PT' QT' (helpSync2 n) PtaT' (helpSyncInvert2 n n0 Heq QtaT'))))). apply elMap.
          apply elFlatmap with (existT (fun '(a, T) => trans G P a T) (Rcv n, PT') PtaT'). easy. unfold syncHelp.
          apply elFlatmap with (existT (fun '(a, T) => trans G Q a T) (Snd n0, QT') QtaT'). easy. rewrite Hndr. left. easy.
       -- exfalso. congruence.
      ++ exfalso. congruence.
      ++ enough (Qa' = invAction a0). 2: congruence. enough (a0 = Rcv n). 2: congruence. rewrite H5, H6. easy.
* intros pP%pRes. destruct (IH pP) as [PA cPA].
  pose (fun '((existT _ (a,T) tT):elemType PA) => match (cAdmits H a) with inl Hadm => [existT (fun '(a,T) => trans G (Restrict P H) a T) (a,(Restrict T H)) (tRes G a P T H Hadm tT)] | inr Hn => [] end) as extend.
  exists (flatmap extend PA).
  intros a T trns. unfold keys. inversion trns.
  pose proof (cPA a P' X0) as HH. apply elMapS in HH. destruct HH as [[[a' T'] taT'] [elPA eq]]. cbn in eq. enough (a=a' /\ P'=T') as [Hrl Hrr]. 2: split; congruence.
  destruct (cAdmits H a') as [admt|nadmt] eqn:Headmt. 2: exfalso; apply nadmt; congruence. rewrite Hrr, Hrl.
  change (a', Restrict T' H) with (sigLeft (existT (fun '(a,T) => trans G (Restrict P H) a T) (a',(Restrict T' H)) (tRes G a' P T' H admt taT'))). apply elMap.
  apply elFlatmap with (existT (fun '(a, T) => trans G P a T) (a', T') taT'). easy. cbn. rewrite Headmt. left. easy.
* intros pVar. apply vH. easy.
* intros _. exists nil. intros a T H. inversion H.
Defined.

Lemma guardedDeriv (G:nat->CCS) S : guarded S -> {A:kvstore (action*CCS) (fun '(a,T) => trans G S a T) & forall a T, trans G S a T -> (a,T) cel keys A}.
intros H. apply transDeriv with guarded. apply guardedSyntactic. intros n []. easy.
Defined.

Definition recHelp {G:nat->CCS} {n:nat} (A' : {'(a,T) : (action * CCS) & trans G (G n) a T}) : {'(a,T) : action*CCS & trans G (Var n) a T}.
destruct A' as [[a T] taT]. exists (a,T). apply tRec with (G n). apply eq_refl. easy. Defined.

Lemma guardedGammaDeriv (G:nat->CCS) S : (forall n, guarded (G n)) -> {A:kvstore (action*CCS) (fun '(a,T) => trans G S a T) & forall a T, trans G S a T -> (a,T) cel keys A}.
intros gN. apply transDeriv with (fun _ => True). 3:easy. apply trueSyntactic.
intros n []. destruct (guardedDeriv G (G n)) as [A cA]. easy.
exists (map recHelp A).
intros a R H. inversion H. unfold keys. rewrite <- H1 in X.
pose proof (cA a R X) as HHA. apply elMapS in HHA. destruct HHA as [[[a' T'] taT'] [pA eqa]]. cbn in eqa. enough (a=a' /\ R=T') as [Hel Her]. rewrite Hel, Her.
change (a',T') with (sigLeft (existT (fun '(a0, T0) => trans G (Var n) a0 T0) (a', T') (tRec G n a' (G n) T' eq_refl taT'))). apply elMap.
change (existT (fun '(a1, T0) => trans G (Var n) a1 T0) (a', T') (tRec G n a' (G n) T' eq_refl taT'))
  with (recHelp (existT (fun '(a, T) => trans G (G n) a T) (a', T') taT')). apply elMap. easy. split; congruence.
Defined.

Definition exampleCCS := (Par (Var 0) (Var 1)).
Definition exampleGamma := fun k => match k with 0 => Prefix (Snd 0) (Var 1)
                                               | 1 => Prefix (Rcv 0) (Var 0)
                                               | _ => Stop end.
Fact gg : (forall n:nat, guarded(exampleGamma n)).
now intros [|[|n]].
Defined.

Definition CCSTransDecider {G:nat->CCS} {S:CCS} {a:action} {T:CCS} : (forall n, guarded (G n)) -> dec(trans G S a T).
intros H. destruct (guardedGammaDeriv G S H) as [A cA].
destruct (elDec (keys A) (a,T)). apply pairEqDec. apply eqAction. apply eqCCS.
* left. apply (find A (a,T)). easy.
* right. intros Tr. apply f. apply cA. exact Tr.
Defined.

Definition cLTSTransDecider (S:LTS) : cLTS S -> forall (s:states S) (a:action) (t:states S) , dec(istrans S s a t).
intros [[[A cA] edS] [B cB]].
intros s a t. destruct (elDec B (s,a,t)) as [Hin|Hn]. apply pairEqDec. apply pairEqDec. easy. apply eqAction. easy.
* left. apply cB. easy.
* right. intros H. apply Hn. apply cB. easy.
Defined.

Definition transLister (S:LTS) (s:states S):= {A:list (action*states S) & forall a (t:states S), (a,t) cel A <=> istrans S s a t}.

Definition CCSTransLister (G:nat->CCS) (s0:CCS) (S:CCS) : (forall n, guarded (G n)) -> transLister (CCSLTS G s0) S.
intros gg. destruct (guardedGammaDeriv G S gg) as [A pA].
exists (keys A). intros a T. split.
* apply (find A).
* apply pA.
Defined.

Definition cLTSTransLister (S:LTS) (s:states S): cLTS S -> transLister S s.
intros [[[A cA] edS] [B pB]].
exists (flatmap (fun '(s',a,t) => if edS s s' then [(a,t)] else []) B). intros a t. split.
* intros [[[s' a']t'] [psat qsat]]%elFlatmapS. apply pB. destruct (edS s s') as [Heq|Hneq]. destruct qsat as [qsat|[]]. enough (a=a' /\ t=t') by congruence. split; congruence. exfalso. easy.
* intros H. apply elFlatmap with ((s,a,t)). apply pB. easy. destruct (edS s s) as [Heq|[]]. now left. easy.
Defined.


From Equations Require Import Equations.
From Coq Require Import Bool.
Inductive depInd : Type -> Type :=
| A : depInd bool
| B : depInd unit.
Derive Signature for depInd.

Equations bar {a} (d : depInd (id a)) : a -> bool :=
 | A => fun x => eqb x true
 | B => fun x => true.

About bar_elim.