Require Import Labels.
Require Import Events.
Require Import Execution.
Require Import List.
From hahn Require Import Hahn.
Require Import TraceWf.
Require Import IndefiniteDescription.
Require Import Lia.

Section TSO.

Definition shared_memory := Loc -> Val.
Definition buffer := list (Loc * Val).
Definition TSOMemory := (shared_memory * (Tid -> buffer))%type.

Definition TSO_label := sum Event Tid.

Inductive latest_buffered (buf: buffer) (loc: Loc) (opt_val: option Val) : Prop :=
  | no_loc_buffer
      (EMPTY_BUF: filter (fun loc_val: Loc * Val => Nat.eqb (fst loc_val) loc) buf = nil)
      (NO_LATEST: opt_val = None)
  | latest_loc
      val
      (LATEST_VALUE: opt_val = Some val)
      (LATEST_BUF:
         let buf_thread_loc := filter (fun loc_val: Loc * Val => Nat.eqb (fst loc_val) loc) buf in
         Some (loc, val) = nth_error buf_thread_loc (length buf_thread_loc - 1)).

Inductive TSO_step: TSOMemory -> TSO_label -> TSOMemory -> Prop :=
| tso_Read_buf sh_mem bufs loc val thread index
               (BUF: latest_buffered (bufs thread) loc (Some val)):
    TSO_step (sh_mem, bufs)
             (inl (ThreadEvent thread index (Aload loc val)))
             (sh_mem, bufs)
| tso_Read_mem sh_mem bufs loc val thread index
            (BUF: latest_buffered (bufs thread) loc None)
            (MEM: sh_mem loc = val):
    TSO_step (sh_mem, bufs)
             (inl (ThreadEvent thread index (Aload loc val)))
             (sh_mem, bufs)
| tso_Write sh_mem bufs loc (val: Val) thread index:
    TSO_step (sh_mem, bufs)
             (inl (ThreadEvent thread index (Astore loc val)))
             (sh_mem, upd bufs thread (bufs thread ++ cons (loc, val) nil))
| tso_RMW sh_mem bufs loc val_r val_w thread index
          (NO_BUF: bufs thread = nil)
          (MEM: sh_mem loc = val_r):
    TSO_step (sh_mem, bufs)
             (inl (ThreadEvent thread index (Armw loc val_r val_w)))
             (upd sh_mem loc val_w, bufs)
| tso_prop sh_mem bufs buf' loc val thread
           (BUF: bufs thread = cons (loc, val) buf'):
    TSO_step (sh_mem, bufs)
             (inr thread)
             (upd sh_mem loc val, upd bufs thread buf').

Definition empty_buffer : buffer := nil.
Definition Minit : TSOMemory := (fun _ => 0, fun _ => empty_buffer).

Definition TSO_lts :=
  {| LTS_init := eq Minit ;
     LTS_step := TSO_step ;
     LTS_final := ∅ |}.

Definition ppo G := sb G \ (is_w × is_r).
Definition implied_fence G := sb G ⨾ ⦗is_rmw⦘ ∪ ⦗is_rmw⦘ ⨾ sb G.
Definition TSO_hb G := (ppo G ∪ implied_fence G ∪ rfe G ∪ co G ∪ fr G)^+.

Definition TSO_consistent G := acyclic (TSO_hb G) /\ SCpL G.

Definition def_lbl: TSO_label := inl (InitEvent 0).

Definition enabled st tid := exists st', TSO_step st (inr tid) st'.
Definition TSO_fair tr st :=
  forall i tid
    (DOM_EXT: NOmega.le (NOnum i) (trace_length tr)) (* le accounts for the final state if any*)
    (ENABLED: enabled (st i) tid),
  exists j, i <= j /\ (NOmega.lt_nat_l j (trace_length tr)) /\
       trace_nth j tr def_lbl = inr tid.

Definition TSO_trace_wf (t: trace TSO_label) :=
  forall i j d thread index1 index2 lbl1 lbl2
    (LTij: i < j)
    (LTj : NOmega.lt_nat_l j (trace_length t))
    (TR_I: trace_nth i t d = inl (ThreadEvent thread index1 lbl1))
    (TR_J: trace_nth j t d = inl (ThreadEvent thread index2 lbl2)),
    index1 < index2.

Definition is_regular_write' := (is_w \₁(is_rmw ∪₁ is_init)).
Definition regular_write' :=
fun lbl : TSO_label =>
match lbl with
| inl e => is_regular_write' e
| inr _ => False
end.

Definition is_prop (lbl: TSO_label) := match lbl with | inr _ => True | _ => False end.

Definition lbl_thread_opt (lbl: TSO_label) :=
  match lbl with
  | inl (ThreadEvent thread _ _)
  | inr thread => Some thread
  | _ => None
  end.

Definition in_thread thread := fun lbl => lbl_thread_opt lbl = Some thread.

Definition is_external (x: TSO_label) := match x with | inl _ => True | inr _ => False end.

End TSO.

Ltac unfolder' := unfold set_compl, cross_rel, regular_write', is_regular_write', set_minus, set_inter, set_union, is_r, is_r_l, is_w, is_w_l, is_rmw, is_rmw_l, is_init, is_prop, def_lbl, in_thread, lbl_thread_opt, same_loc, loc, loc_l, valr, valw, lab, tid in *.

Section TSO_facts.

(* Lemma TS0 {State Label: Type} {lts: LTS State Label} t st (TRACE: LTS_trace_param lts st t): *)
(*   LTS_init lts (st 0). *)
(* Proof. *)
(*   unfold trace_states.  *)
(*   destruct (constructive_indefinite_description _ _). by desc.  *)
(* Qed. *)

(* Lemma TSi {st lb: Type} {lts: LTS st lb} t (TRACE: LTS_trace lts t): *)
(*   forall i (LT: NOmega.lt_nat_l i (trace_length t)), *)
(*     let fl' := trace_states t TRACE in *)
(*     forall d, LTS_step lts (fl' i) (trace_nth i t d) (fl' (S i)). *)
(* Proof. *)
(*   unfold trace_states.  *)
(*   destruct (constructive_indefinite_description _ _). by desc.  *)
(* Qed.    *)

Lemma init_non_r r (Rr: is_r r) (INIT: is_init r): False.
Proof. generalize Rr, INIT. unfolder'. by destruct r. Qed.

Lemma init_non_rw': forall l, ~ is_regular_write' (InitEvent l).
Proof.
  ins. red. ins. do 2 red in H. desc.
  apply H0. vauto.
Qed.

Lemma reg_write_structure tlab (W: regular_write' tlab):
  exists thread index loc val, tlab = inl (ThreadEvent thread index (Astore loc val)).
Proof.
  unfolder'.
  unfold regular_write', is_regular_write' in W.
  destruct tlab eqn:WW.
  2: { simpl in W. vauto. }
  destruct e.
  { destruct (init_non_rw' x). intuition. }
  generalize W. unfolder'. destruct l; vauto; intuition.
  repeat eexists.
Qed.

End TSO_facts.

(* Lemma opt_val {A: Type} (ov: option A): ov <> None <-> exists v, ov = Some v. *)
(* Proof. destruct ov; split; ins; desc; vauto. Qed.  *)

(* Lemma set_equiv_exp_iff (A : Type) (s s' : A -> Prop): *)
(*   s ≡₁ s' <-> (forall x, s x <-> s' x). *)
(* Proof. *)
(*   split; [apply set_equiv_exp| ]. *)
(*   intros EQ. red. split; red; ins; apply EQ; auto.  *)
(* Qed. *)


Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.TypesI.

Require Import ExtLib.Core.RelDec.

Require Import MirrorCharge.SetoidRewrite.Base.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.AutoSetoidRewrite.

Require Import Charge.Logics.ILogic.

Section ILPullQuant.
  Context {typ func : Type} {HIL : ILogicFunc typ func}.
  Context {RType_typ : RType typ}.
  Context {RelDec_func : RelDec (@eq (expr typ func))}.

  Let Rbase := expr typ func.

  Variable inhabited : typ -> bool.
  Variable inhabited_sound : forall t, inhabited t = true -> Inhabited (typD t).

  Variable rg_eq : typ -> expr typ func.

  Definition rw_under_exists (t : typ) (l : typ) (rw : rewriter _) :=
    rw_under (RGinj (rg_eq t))
             (fun e rvars rg => rg_fmap (mkExists t l) (rw e rvars rg)).

  Definition il_match_plus_l (rw : @rw_type typ func) (e : expr typ func)
             (rvars : list (RG (expr typ func))) (rg : RG Rbase) : m (expr typ func) :=
  match e with
    | App (App a (App b (Abs _ P))) Q =>
      let Q' := lift 0 1 Q in
      match ilogicS (typ := typ) (func := expr typ func) a, ilogicS b with
      	| Some (ilf_and _), Some (ilf_exists t l) =>
	  rg_plus
	    (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
	             (fun _ => rw_under_exists t l rw (mkAnd l P Q') rvars rg))
	    (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
	             (fun _ => rw_under_exists t l rw (mkAnd l P Q') rvars rg))

(*(fun _ => rg_ret (mkExists t l (mkAnd l P Q)))) *)
      	| Some (ilf_or _), Some (ilf_exists t l) =>
      	  let rewrite_rl :=
	      rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
		      (fun _ => rw_under_exists t l rw (mkOr l P Q') rvars rg)
(* (fun _ => rg_ret (mkExists t l (mkOr l P Q))) *)in
	  if inhabited t then
	    rg_plus
	      rewrite_rl
	      (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
		       (fun _ => rw_under_exists t l rw (mkOr l P Q') rvars rg))
(* (fun _ => rg_ret (mkExists t l (mkOr l P Q)))) *)
	  else
	    rewrite_rl
	| _, _ => rg_fail
      end
    | _ => rg_fail
  end.

Definition il_match_plus_r (rw : @rw_type typ func)
           (e : expr typ func) (rvars : list (RG (expr typ func))) (rg : RG Rbase) : m (expr typ func) :=
  match e with
   | App (App a P) (App b (Abs _ Q)) =>
   	 let P' := lift 0 1 P in
     match ilogicS a, ilogicS b with
       | Some (ilf_and _), Some (ilf_exists t l) =>
	      rg_plus
	        (rg_bind
	          (unifyRG (@rel_dec (expr typ func) _ _ ) rg (RGinj (fEntails l)))
	            (fun _ => rw_under_exists t l rw (mkAnd l P' Q) rvars rg))
  	        (rg_bind
	          (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
	            (fun _ => rw_under_exists t l rw (mkAnd l P' Q) rvars rg))
       | Some (ilf_or _), Some (ilf_exists t l) =>
         let rewrite_rl :=
		   rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
		     (fun _ => rw_under_exists t l rw (mkOr l P' Q) rvars rg) in
		   if inhabited t then
		     rg_plus
		       rewrite_rl
		       (rg_bind (unifyRG (@rel_dec (expr typ func) _ _ ) rg (RGinj (fEntails l)))
		         (fun _ => rw_under_exists t l rw (mkOr t P' Q) rvars rg))
		   else
		     rewrite_rl
	   | _, _ => rg_fail
	 end
   | _ => rg_fail
 end.

Definition il_match_plus := sr_combineK il_match_plus_l il_match_plus_r.

End ILPullQuant.

Implicit Arguments il_match_plus [[typ] [func] [HIL] [RelDec_func]].


Require Import FcEtt.fc_invert.
Require Import Omega.
Require Import Coq.Arith.Wf_nat.
Require Import FcEtt.toplevel.

Require Import FcEtt.erase_syntax.
Require Import FcEtt.sigs.
Require Import FcEtt.fc_unique.
Require Import FcEtt.fc_invert.
Require Import FcEtt.fc_context_fv.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Module fc_get (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig) (unique: fc_unique_sig).
Import wf weak subst.

Module invert := fc_invert wf weak subst.
Import invert.

(* -------------------------------------------------------------------------------------- *)

(* This function looks at an annotated term and returns its type.
*)

Fixpoint get_tpg_n (n : nat) (G : context) (a : tm) { struct n } : tm :=
match n with
| 0 => a_Star
| S m =>
  match a with
  | a_Star => a_Star
  | a_Var_f x =>
    match binds_lookup _ x G with
    | inl (exist (Tm A) _) => A
    | _ => a_Star
    end
  | a_Pi  rho A B => a_Star
  | a_Abs rho A a =>
    let (x,_) := atom_fresh (dom G) in
    a_Pi rho A (close_tm_wrt_tm x (get_tpg_n m ((x,Tm A)::G) (open_tm_wrt_tm a (a_Var_f x))))
  | a_App a1 rho a2 =>
    match get_tpg_n m G a1 with
      | a_Pi rho A B => open_tm_wrt_tm B a2
      | _ => a_Star
    end
  | a_Conv a g => let (_,b) := get_deq_n m G g in b
  | a_CPi phi B => a_Star
  | a_CAbs phi a => let (x,_) := atom_fresh (dom G) in
                   a_CPi phi (close_tm_wrt_co x (get_tpg_n m ((x,Co phi)::G) (open_tm_wrt_co a (g_Var_f x))))
  | a_Fam F =>
    match binds_lookup _ F an_toplevel with
    | inl (exist (Ax a A) _) => A
    | _ => a_Star
    end
  | a_CApp a1 g2 =>
    match get_tpg_n m G a1 with
      | a_CPi phi B => open_tm_wrt_co B g2
      | _ => a_Star
    end
  | a_Const T =>
     match binds_lookup _ T an_toplevel with
    | inl (exist (Cs A) _) => A
    | _ => a_Star
    end
  | _ => a_Star
  end
end
with
get_iso_n (n : nat) (G : context) (g : co) : (constraint * constraint) :=
  match n with
  | 0 => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
  | S m =>
    match g with
    | (g_EqCong g1 A g2) =>
      let (A1, A2) := get_deq_n m G g1 in
      let (B1, B2) := get_deq_n m G g2 in
      (Eq A1 B1 A, Eq A2 B2 A)
    | g_CPiFst g =>
      let (T1,T2) := get_deq_n m G g in
      match (T1, T2) with
      | (a_CPi phi1 A2, a_CPi phi2 B2) => (phi1, phi2)
      | _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
      end
    | g_Sym g =>
      let (phi2, phi1) := get_iso_n m G g in
      (phi1, phi2)
    | g_IsoConv (Eq a1 a2 A) (Eq a1' a2' B) g =>
      (Eq a1 a2 A, Eq a1' a2' B)
    | _ => (Eq a_Star a_Star a_Star,Eq a_Star a_Star a_Star)
    end
  end
with
get_deq_n (n : nat) (G : context) (g : co) : (tm * tm) :=
  match n with
  | 0 => (a_Star, a_Star)
  | S m =>
    match g with
    | g_Var_f c => match binds_lookup _ c G with
                  | inl (exist (Co (Eq a b A)) _) => (a,b)
                  | _ => (a_Star, a_Star)
                  end
    | g_Refl a => (a,a)
    | g_Refl2 a b g => (a,b)
    | g_Beta a b => (a,b)
    | g_Sym g => let (a,b) := get_deq_n m G g in
                (b,a)
    | g_Trans g1 g2 =>
      let (a,c1) := get_deq_n m G g1 in
      let (c2, b) := get_deq_n m G g2 in
      (a,b)
    | g_PiCong rho g1 g2 =>
      let (x,_) := atom_fresh (dom G) in
      let (A1,A2) := get_deq_n m G g1 in
      let (B1,B2) := get_deq_n m ([(x, Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
      let B3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2 in
      (a_Pi rho A1 (close_tm_wrt_tm x B1), a_Pi rho A2 (close_tm_wrt_tm x B3))
    | g_AbsCong rho g1 g2 =>
      let (x,_) := atom_fresh (dom G) in
      let (A1,A2) := get_deq_n m G g1 in
      let (b1,b2) := get_deq_n m ([(x,Tm A1)] ++ G) (open_co_wrt_tm g2 (a_Var_f x)) in
      let b3 := tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x b2 in
      (a_Abs rho A1 (close_tm_wrt_tm x b1), a_Abs rho A2 (close_tm_wrt_tm x b3))
    | g_AppCong g1 rho g2 =>
      let (a1, b1) := get_deq_n m G g1 in
      let (a2, b2) := get_deq_n m G g2 in
      (a_App a1 rho a2, a_App b1 rho b2)
    | g_PiFst g =>
      let (a,b) := get_deq_n m G g in
      match (a,b) with
      | (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) => (A1, A2)
      | (_,_) => (a_Star, a_Star)
      end
    | g_PiSnd g1 g2 =>
      let (T1,T2) := get_deq_n m G g1 in
      let (a1,a2) := get_deq_n m G g2 in
      match (T1,T2) with
      | (a_Pi rho1 A1 B1, a_Pi rho2 A2 B2) =>
        (open_tm_wrt_tm B1 a1, open_tm_wrt_tm B2 a2)
      | (_,_) => (a_Star, a_Star)
      end
    | g_CPiCong g1 g3 =>
      let (phi1,phi2) := get_iso_n m G g1 in
      let (x,_) := atom_fresh (dom G) in
      let (B1,B2) := get_deq_n m ([(x,Co phi1)] ++ G)
                               (open_co_wrt_co g3 (g_Var_f x)) in
      let B3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x B2 in
      (a_CPi phi1 (close_tm_wrt_co x B1), a_CPi phi2 (close_tm_wrt_co x B3))
    | g_CAbsCong g1 g2 g3 =>
      let (phi1,phi2) := get_iso_n m G g1 in
      let (x,_) := atom_fresh (dom G) in
      let (b1,b2) := get_deq_n m ([(x,Co phi1)] ++ G)
                               (open_co_wrt_co g2 (g_Var_f x)) in
      let b3 := co_subst_co_tm (g_Cast (g_Var_f x) (g_Sym g1)) x b2 in
      (a_CAbs phi1 (close_tm_wrt_co x b1), a_CAbs phi2 (close_tm_wrt_co x b3))

    | (g_CAppCong g1 g2 g3) =>
      let (a1, b1) := get_deq_n m G g1 in
      (a_CApp a1 g2,a_CApp b1 g3)
    | (g_CPiSnd g1 g2 g3) =>
      match get_deq_n m G g1 with
      | (a_CPi (Eq a a' A) B1, a_CPi (Eq b b' B) B2) =>
         (open_tm_wrt_co  B1   g2, open_tm_wrt_co  B2   g3 )
      | (_,_) => (a_Star, a_Star)
      end
    | (g_Cast g1 g2) =>
      match get_iso_n m G g2 with
      | (Eq a a' A, Eq b b' B) => (b,b')
      end
    |  (g_IsoSnd g) =>
       match get_iso_n m G g with
       | (Eq a a' A, Eq b b' B) => (A, B)
       end
    | (g_Eta b) =>
      let (x,_) := atom_fresh (dom G) in
      match get_tpg_n m G b with
      | (a_Pi rho A B) => (a_Abs rho A (close_tm_wrt_tm x (a_App b rho (a_Var_f x))), b)
      | (a_CPi phi _) =>  (a_CAbs phi (close_tm_wrt_co x (a_CApp b (g_Var_f x))), b)
      | _ => (a_Star, a_Star)
      end
     (* Left/Right
    | (g_Left g1 g2) =>
      match get_deq_n m G g1 with
      | (a_App a _ _, a_App a' _ _) => (a,a')
      | (a_CApp a _, a_CApp a' _) => (a,a')
      | (_,_) => (a_Star, a_Star)
      end
    | (g_Right g1 g2) =>
      match get_deq_n m G g1 with
      | (a_App _ _ a, a_App _ _ a') => (a,a')
      | (_,_) => (a_Star, a_Star)
      end
     *)
    | _ => (a_Star, a_Star)
    end
  end.

Definition get_tpg (G : context) (a:tm) : tm :=
  get_tpg_n (size_tm a) G a.
Definition get_deq (G : context) (g:co) : (tm*tm) :=
  get_deq_n (size_co g) G g.
Definition get_iso (G : context) (g:co) : (constraint*constraint) :=
  get_iso_n (size_co g) G g.

Lemma get_n_correct : forall n,
    (forall G a A B, size_tm a <= n -> AnnTyping G a A -> get_tpg_n n G a = B -> A = B) /\
    (forall G D g A B A' B', size_co g <= n -> AnnDefEq G D g A B ->
                        get_deq_n n G g = (A',B') -> A = A' /\ B = B') /\
    (forall G D g A B A' B', size_co g <= n -> AnnIso G D g A B ->
                        get_iso_n n G g = (A',B') -> A = A' /\ B = B').

Proof.
  intro n.
  eapply (lt_wf_ind n). clear n. intros.
  split.
  { intros G a A B HS HT GT.
    destruct a; simpl in *; try  (destruct n; [inversion HS | try solve [inversion HT; subst;  auto]]).
    - inversion HT. subst. simpl.
      assert (U : uniq G). { eapply AnnCtx_uniq. eauto. }
      destruct (binds_lookup _ x G) as [ [ [A0 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H3 P U) => h0. inversion h0. auto.
      move: (binds_unique _ _ _ _ _ H3 P U) => h0. inversion h0.
      eapply NB in H3. done.
    - destruct (An_Abs_inversion HT) as (B1 & EQ & T1 & HB1). subst.
      simpl.
      destruct (atom_fresh (dom G)).
      f_equal.
      move: (HB1 x n0) => [R1 TB1]. clear HB1.
      move: (H n ltac:(omega)) => [h0 _].
      assert (size_tm (open_tm_wrt_tm a2 (a_Var_f x)) = size_tm a2). eauto with lngen.
      move: (h0 ((x, Tm a1) :: G) (open_tm_wrt_tm a2 (a_Var_f x)) (open_tm_wrt_tm B1 (a_Var_f x))
                (get_tpg_n n ((x, Tm a1) :: G) (open_tm_wrt_tm a2 (a_Var_f x)))
            ltac:(omega) TB1 ltac:(auto))
      => h1.
      rewrite <- h1.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm; eauto.
      move: (AnnTyping_context_fv HT) => [_ [_ [f1 _]]]. simpl in f1.
      fsetdec.
    - inversion HT. subst. simpl.
      move: (H n ltac:(omega)) => [h0 _].
      move: (@h0 G a1 (a_Pi rho A0 B0) (get_tpg_n n G a1) ltac:(omega) H5 eq_refl) => h1.
      rewrite <- h1.
      auto.
    - inversion HT. subst.
      Opaque an_toplevel.
      simpl.
      destruct (binds_lookup _ F an_toplevel) as [[ [A0 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0.
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0. auto.
      eapply NB in H2. done.
    - inversion HT. subst. Opaque an_toplevel.
      simpl.
      destruct (binds_lookup _ T an_toplevel) as [ [ [A0 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0. auto.
      move: (binds_unique _ _ _ _ _ H2 P uniq_an_toplevel) => h0. inversion h0.
      eapply NB in H2. done.
    - inversion HT. subst. simpl.
      remember (get_deq_n n G g) as GD. destruct GD as [A' B'].
      move: (H n ltac:(omega)) => [_ [h0 _]].
      destruct (h0 _ _ g _ _ A' B' ltac:(omega) H4).
      auto. subst. auto.
    - destruct (An_CAbs_inversion HT) as (B1 & EQ & HT1). subst. simpl.
      destruct (atom_fresh (dom G)). f_equal. simpl_env.
      move: (HT1 x n0) => [R1 TB1]. clear HT1.
      move: (H n ltac:(omega)) => [h0 _].
      assert (size_tm (open_tm_wrt_co a (g_Var_f x)) = size_tm a). eauto with lngen.
      move: (h0 _ (open_tm_wrt_co a (g_Var_f x)) _ _  ltac:(omega) TB1 eq_refl) => h1.
      rewrite <- h1.
      rewrite close_tm_wrt_co_open_tm_wrt_co; eauto.
      move: (AnnTyping_context_fv HT) => [_ [_ [_ f1]]]. simpl in f1.
      fsetdec.
   - inversion HT. subst. simpl.
     move: (H n ltac:(omega)) => [h0 _].
     move: (@h0 G a (a_CPi (Eq a0 b A1) B0) (get_tpg_n n G a)
                 ltac:(omega) H3 eq_refl) => h1.
     rewrite <- h1.
     auto.
  } split. {
    intros G D g A B A' B' SZ DE GET.
    destruct g; simpl in *; (destruct n; [inversion SZ| try solve [inversion DE; subst; simpl;  auto]]).
    - inversion DE. subst. simpl in GET.
      assert (U : uniq G). { eapply AnnCtx_uniq. eauto. }
      destruct (binds_lookup _ c G) as [[ [ A1 | phi] P] | NB].
      move: (binds_unique _ _ _ _ _ H2 P U) => h0. inversion h0. destruct phi. inversion GET. subst.
      move: (binds_unique _ _ _ _ _ H2 P U) => h0. inversion h0. auto.
      eapply NB in H2. done.
    - inversion DE. subst.  simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET. inversion GET. auto.
    - inversion DE. subst. simpl in GET.
      remember (get_deq_n n G g) as GG.
      destruct GG. inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 G D g _ _ B' A' ltac:(omega) H6 ltac:(auto)) => [h1 h2]. subst.
      auto.
    - inversion DE. subst. simpl in GET.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      inversion GET. subst.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 G D g1 _ _ A' t0 ltac:(omega) H2 ltac:(auto)) => [h1 h2]. subst.
      move: (h0 G D g2 _ _ t1 B' ltac:(omega) H3 ltac:(auto)) => [h1 h2]. subst.
      auto.
    - destruct (An_PiCong_inversion DE) as (A1 & B1 & A2 & B2 & B3 &
                                             E1 & E2 & T1 & T2 & T3 & DE1 & DE2).
      simpl in GET.
      destruct (atom_fresh (dom G)).
      remember (get_deq_n n G g1) as GET1.
      destruct GET1 as [A1' A2'].
      remember (get_deq_n n ((x, Tm A1') :: G) (open_co_wrt_tm g2 (a_Var_f x))) as GET2.
      destruct GET2 as [B1' B2'].
      inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h1 _]].
      move: (h1 G D g1 A1 A2 A1' A2' ltac:(omega) DE1 ltac:(auto)) => [E1 E2].
      subst.
      assert (SS : size_co (open_co_wrt_tm g2 (a_Var_f x)) = size_co g2).
      auto with lngen.
      move: (DE2 x ltac:(auto)) => [DEx E3].
      move: (h1 ([(x, Tm A1')] ++ G) D
                (open_co_wrt_tm g2 (a_Var_f x))
                (open_tm_wrt_tm B1 (a_Var_f x))
                (open_tm_wrt_tm B2 (a_Var_f x))
                B1' B2' ltac:(omega) ltac:(auto) ltac:(auto)) => [E1 E2].
      subst.
      move: (AnnTyping_context_fv T1) => [f1 [_ _]]. simpl in f1.
      move: (AnnTyping_context_fv T2) => [f2 [_ _]]. simpl in f2.
      move: (AnnTyping_context_fv T3) => [f3 [_ _]]. simpl in f3.
      assert (x `notin` fv_tm_tm_tm B2 \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B3). fsetdec.
      split. f_equal. rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto. auto.
      f_equal.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm.
      rewrite tm_subst_tm_tm_var.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      rewrite <- E3.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto.
      auto.
      econstructor; eauto.
      econstructor. eapply AnnDefEq_lc; eauto.
    - destruct (An_AbsCong_inversion DE) as (A1 & A2 & b1 & b2 & b3 & C2 &
                                             E1 & E2 & T1 & T2 & DE1 & T3 & DE2).
      simpl in GET.
      destruct (atom_fresh (dom G)).
      remember (get_deq_n n G g1) as GET1.
      destruct GET1 as [A1' A2'].
      remember (get_deq_n n ((x, Tm A1') :: G) (open_co_wrt_tm g2 (a_Var_f x))) as GET2.
      destruct GET2 as [b1' b2'].
      inversion GET. subst. clear GET.
      move: (H n ltac:(omega)) => [_ [h1 _]].
      move: (h1 G D g1 A1 A2 A1' A2' ltac:(omega) DE1 ltac:(auto)) => [E1 E2]. subst.
      assert (SS : size_co (open_co_wrt_tm g2 (a_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x ltac:(auto)) => [DEx [E3 [RC1 RC2]]].
      move: (h1 ([(x, Tm A1')] ++ G) D
                (open_co_wrt_tm g2 (a_Var_f x))
                (open_tm_wrt_tm b1 (a_Var_f x))
                (open_tm_wrt_tm b2 (a_Var_f x))
                b1' b2' ltac:(omega) ltac:(auto) ltac:(auto)) => [E1 E2].
      subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1 [_ [f2 _]]]]]. simpl in f1. simpl in f2.
      move: (AnnTyping_context_fv T3) => [f3 [_ _]]. simpl in f3.
      assert (x `notin` fv_tm_tm_tm b2 \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b3). fsetdec.
      split. f_equal.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto. auto.
      f_equal.
      rewrite tm_subst_tm_tm_open_tm_wrt_tm.
      rewrite tm_subst_tm_tm_var.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      rewrite <- E3.
      rewrite close_tm_wrt_tm_open_tm_wrt_tm. auto.
      auto.
      econstructor; eauto.
      econstructor. eapply AnnDefEq_lc; eauto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      inversion GET.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
      auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g) as GG. destruct GG.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_iso_n n G g) as GG. destruct GG.
      move: (H n ltac:(omega)) => [_ [_ h0]].
      move: (h0 _ _ g _ _ c c0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H2 ltac:(auto)) => [E1 E2]. subst.
      move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - destruct (An_CPiCong_inversion DE) as (phi1 & phi2 & b1 & b2 & b3 &
                                             E1 & E2 & I1 & T1 & T2 & T3 & DE2).
      simpl in *.
      remember (get_iso_n n G g1) as GG1. destruct GG1 as [phi1' phi2'].
      destruct (atom_fresh (dom G)) as [x Fr].
      remember (get_deq_n n ((x, Co phi1') :: G) (open_co_wrt_co g2 (g_Var_f x))) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h1 _ _ g1 _ _ phi1' phi2' ltac:(omega) I1 ltac:(auto)) => [E1' E2']. subst.
      assert (SS : size_co (open_co_wrt_co g2 (g_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x Fr) => [DE2' EQ].
      inversion GET. clear GET.
      move: (h0 _ _ (open_co_wrt_co g2 (g_Var_f x)) _ _ t t0 ltac:(omega) DE2' ltac:(auto)) => [E1' E2']. subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1' [f1 [f2' f2]]]]]. simpl in *.
      move: (AnnTyping_context_fv T3) => [f3' [f3 _]]. simpl in *.
      split.
      + f_equal. rewrite close_tm_wrt_co_open_tm_wrt_co. auto. auto.
      + f_equal.
        rewrite co_subst_co_tm_open_tm_wrt_co.
        rewrite co_subst_co_co_var.
        rewrite co_subst_co_tm_fresh_eq; auto.
        rewrite <- EQ.
        rewrite close_tm_wrt_co_open_tm_wrt_co. auto.
        auto.
        econstructor; eauto.
        econstructor. eapply AnnIso_lc; eauto.
    - destruct (An_CAbsCong_inversion DE) as (phi1 & phi2 & b1 & b2 & b3
                                              & B1 & B2 & B3 &
                                              E1 & E2 & I1 & T1 & T2 & T3
                                              & DE1 & DE2).
      simpl in *.

            remember (get_iso_n n G g1) as GG1. destruct GG1 as [phi1' phi2'].
      destruct (atom_fresh (dom G)) as [x Fr].
      remember (get_deq_n n ((x, Co phi1') :: G) (open_co_wrt_co g2 (g_Var_f x))) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h1 _ _ g1 _ _ phi1' phi2' ltac:(omega) I1 ltac:(auto)) => [E1' E2']. subst.
      assert (SS : size_co (open_co_wrt_co g2 (g_Var_f x)) = size_co g2). auto with lngen.
      move: (DE2 x Fr) => [DE2' EQ].
      inversion GET. clear GET.
      move: (h0 _ _ (open_co_wrt_co g2 (g_Var_f x)) _ _ t t0 ltac:(omega) DE2' ltac:(auto)) => [E1' E2']. subst.
      move: (AnnDefEq_context_fv DE) => [_ [_ [f1' [f1 [f2' f2]]]]]. simpl in *.
      move: (AnnTyping_context_fv T3) => [f3' [f3 _]]. simpl in *.
      split.
      + f_equal. rewrite close_tm_wrt_co_open_tm_wrt_co. auto. auto.
      + f_equal.
        rewrite co_subst_co_tm_open_tm_wrt_co.
        rewrite co_subst_co_co_var.
        rewrite co_subst_co_tm_fresh_eq; auto.
        rewrite <- EQ.
        rewrite close_tm_wrt_co_open_tm_wrt_co. auto.
        auto.
        econstructor; eauto.
        econstructor. eapply AnnIso_lc; eauto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_deq_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H3 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      move: (H n ltac:(omega)) => [_ [h0 _]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H5 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      remember (get_iso_n n G g2) as GG2. destruct GG2.
      move: (H n ltac:(omega)) => [_ [h0 h1]].
      move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
      move: (h1 _ _ g2 _ _ c c0 ltac:(omega) H7 ltac:(auto)) => [E1 E2]. subst.
      inversion GET. auto.
    - inversion DE. simpl in *. subst.
      move: (H n ltac:(omega)) => [h0 _].
      move: (h0  _ B _ _ ltac:(omega) H1 eq_refl) => EQ.
      remember (get_tpg_n n G B) as pi. destruct pi; inversion EQ. subst.
      destruct (atom_fresh (dom G)) as [x Fr].
      inversion GET. subst.
      split; auto.
      f_equal.
      pick fresh y.
      rewrite -(@close_tm_wrt_tm_open_tm_wrt_tm a0 y); auto.
      rewrite H4; auto.
      unfold close_tm_wrt_tm. simpl.
      edestruct eq_dec; try done.
      edestruct eq_dec; try done.
      f_equal.
      replace (close_tm_wrt_tm_rec 0 y B') with (close_tm_wrt_tm y B'); simpl; auto.
      replace (close_tm_wrt_tm_rec 0 x B') with (close_tm_wrt_tm x B'); simpl; auto.
      pick fresh z for (fv_tm_tm_tm (close_tm_wrt_tm y B') \u fv_tm_tm_tm (close_tm_wrt_tm x B')).
      eapply open_tm_wrt_tm_inj with (x1 := z); auto.
      rewrite -tm_subst_tm_tm_spec.
      rewrite -tm_subst_tm_tm_spec.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      rewrite tm_subst_tm_tm_fresh_eq; auto.
      destruct (AnnDefEq_context_fv DE) as (_ & _ & _ & _ & h4 & _).
      fsetdec.
      assert (K: (if y == y then a_Var_b 0 else a_Var_f y) = a_Var_b 0).
      destruct (y == y); auto. contradiction.
      assert (K': (if x == x then a_Var_b 0 else a_Var_f x) = a_Var_b 0).
      destruct (x == x); auto. contradiction. rewrite K. rewrite K'. auto.

      simpl in *. subst.
      move: (H n ltac:(omega)) => [h0 _].
      assert (EQ: size_tm B <= n). omega.
      eapply h0 with (G:= G) (A:= (a_CPi phi B0)) in EQ; auto.
      remember (get_tpg_n n G B) as pi. destruct pi; inversion EQ. subst.
      destruct (atom_fresh (dom G)) as [x Fr].
      inversion GET. subst.
      split; auto.
      f_equal.
      pick fresh y.
      rewrite -(@close_tm_wrt_co_open_tm_wrt_co a0 y); auto.
      rewrite H4; auto.
      unfold close_tm_wrt_co. simpl.
      edestruct eq_dec; try done.
      edestruct eq_dec; try done.
      f_equal.
      replace (close_tm_wrt_co_rec 0 y B') with (close_tm_wrt_co y B'); simpl; auto.
      pick fresh z for (fv_co_co_tm (close_tm_wrt_co y B') \u fv_co_co_tm (close_tm_wrt_co_rec 0 x B')).
      eapply open_tm_wrt_co_inj with (c1 := z); auto.
      rewrite -co_subst_co_tm_spec.
      rewrite -co_subst_co_tm_spec.
      rewrite co_subst_co_tm_fresh_eq; auto.
      rewrite co_subst_co_tm_fresh_eq; auto.
      destruct (AnnDefEq_context_fv DE) as (_ & _ & _ & _ & _ & h4).
      fsetdec.
      assert (K: (if y == y then g_Var_b 0 else g_Var_f y) = g_Var_b 0).
      destruct (y == y); auto. contradiction.
      assert (K': (if x == x then g_Var_b 0 else g_Var_f x) = g_Var_b 0).
      destruct (x == x); auto. contradiction. rewrite K. rewrite K'. auto.
   (* - inversion DE; simpl in *; subst.
      + move: (H n ltac:(omega)) => [h0 [h1 h2]].
        remember (get_deq_n n G g1) as GG1. destruct GG1.
        move: (h1  _ _ g1 _ _ _ _ ltac:(omega) H8 ltac:(eauto)) => [ EQ1 EQ2 ].
        subst.
        inversion GET. auto.
      + move: (H n ltac:(omega)) => [h0 [h1 h2]].
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      move: (h1  _ _ g1 _ _ _ _ ltac:(omega) H8 ltac:(eauto)) => [ EQ1 EQ2 ].
      subst.
      inversion GET. auto.
    - inversion DE; simpl in *; subst.
      move: (H n ltac:(omega)) => [h0 [h1 h2]].
      remember (get_deq_n n G g1) as GG1. destruct GG1.
      move: (h1  _ _ g1 _ _ _ _ ltac:(omega) H8 ltac:(eauto)) => [ EQ1 EQ2 ].
      subst.
      inversion GET. auto. *)
     }
      { intros G D g A B A' B' SZ H1 GET.
      destruct g; (destruct n; [inversion SZ|idtac]); inversion H1;
        simpl in *; subst.
      -  remember (get_iso_n n G g) as GG. destruct GG.
         move: (H n ltac:(omega)) => [_ [h0 h1]].
         move: (h1 _ _ g _ _ c c0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
         inversion GET. subst. auto.
      -  remember (get_deq_n n G g) as GG. destruct GG.
         move: (H n ltac:(omega)) => [_ [h0 h1]].
         move: (h0 _ _ g _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.
         inversion GET. subst. auto.
      - remember (get_deq_n n G g1) as GG. destruct GG.
        remember (get_deq_n n G g2) as GG. destruct GG.
        move: (H n ltac:(omega)) => [_ [h0 h1]].
        move: (h0 _ _ g1 _ _ t t0 ltac:(omega) H4 ltac:(auto)) => [E1 E2]. subst.              move: (h0 _ _ g2 _ _ t1 t2 ltac:(omega) H7 ltac:(auto)) => [E1 E2]. subst.             inversion GET. auto.
      - inversion GET. auto.
    } Unshelve. auto. auto. auto. auto.
Qed.

Lemma get_tpg_correct : (forall G a A B, AnnTyping G a A -> get_tpg G a = B -> A = B).
Proof.
  intros. unfold get_tpg in *.
  move: (get_n_correct (size_tm a)) => [h0 _].
  eapply h0; eauto.
Qed.

Lemma get_deq_correct: (forall G D g A B A' B',  AnnDefEq G D g A B ->
                                            get_deq G g = (A',B') -> A = A' /\ B = B').
Proof.
  intros. unfold get_deq in *.
  move: (get_n_correct (size_co g)) => [_ [h0 _]
                                       ].
  eapply h0; eauto.
Qed.

Lemma get_iso_correct: (forall G D g A B A' B',  AnnIso G D g A B ->
                                            get_iso G g = (A',B') -> A = A' /\ B = B').
Proof.
  intros. unfold get_deq in *.
  move: (get_n_correct (size_co g)) => [_ [_ h0]].
  eapply h0; eauto.
Qed.

Lemma An_PiCong_exists2: forall x1 x2 (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
    x1 `notin` (dom G \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B2 \u  fv_tm_tm_co g2)
    -> x2 `notin` (dom G \u singleton x1 \u fv_tm_tm_tm B2 \u fv_tm_tm_tm B3 \u  fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x1, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
               (open_tm_wrt_tm B1 (a_Var_f x1)) (open_tm_wrt_tm B2 (a_Var_f x1))
    → (open_tm_wrt_tm B3 (a_Var_f x2) =
       open_tm_wrt_tm B2 (a_Conv (a_Var_f x2) (g_Sym g1)))
    → get_tpg G A1 = a_Star
    → get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B1 (a_Var_f x1)) = a_Star
    → get_tpg ([(x1,Tm A1)] ++ G) (open_tm_wrt_tm B2 (a_Var_f x1)) = a_Star
    → get_tpg G A2 = a_Star
    → get_tpg ([(x1,Tm A2)] ++ G) (open_tm_wrt_tm B3 (a_Var_f x1)) = a_Star
    → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 B1) (a_Pi rho A2 B3).
Proof.
intros.
destruct (AnnDefEq_regularity H1) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H2) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H5) => EQ. subst.
move: (get_tpg_correct T4 H6) => EQ. subst.
move: (get_tpg_correct T1 H4) => EQ. subst.
move: (get_tpg_correct T2 H7) => EQ. subst.
eapply (@An_PiCong_exists x1 x2); eauto.
+ eapply (@An_Pi_exists2 x1); eauto.
+ eapply (@An_Pi_exists2 x2); eauto.
rewrite H3.
rewrite (tm_subst_tm_tm_intro x1); eauto.
replace a_Star with  (tm_subst_tm_tm (a_Conv (a_Var_f x2) (g_Sym g1)) x1 a_Star); auto.
have t1: AnnCtx G by eauto with ctx_wff.
move: (AnnTyping_weakening T2 [(x1,Tm A1)] nil G eq_refl) => t2. simpl_env in t2.
move: (AnnTyping_weakening T1 [(x2,Tm A2)] nil G eq_refl) => t3. simpl_env in t3.
eapply AnnTyping_tm_subst with (A:= A1).
eapply AnnTyping_weakening with (F:=[(x1,Tm A1)]); eauto 4.
econstructor; eauto.
econstructor; eauto.
econstructor; eauto.
eapply AnnTyping_weakening with (F:=nil) (E:=[(x2,Tm A2)]); eauto.
simpl_env. eauto.
eapply AnnDefEq_weakening with (F:=nil) (E:=[(x2,Tm A2)]); simpl_env; eauto.
simpl_env.
eapply (fourth ann_weaken_available_mutual) with (D := dom G).
eapply AnnDefEq_weaken_available. eauto. simpl. fsetdec.
+ eapply (@An_Pi_exists2 x1); eauto.
Qed.

Lemma An_PiCong_exists3: forall x (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
    x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
    → B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
    → get_tpg G A1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B2 = a_Star
    → get_tpg G A2 = a_Star
    → get_tpg ([(x,Tm A2)] ++ G) B3 = a_Star
    → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 (close_tm_wrt_tm x B1)) (a_Pi rho A2 (close_tm_wrt_tm x B3)).
Proof.
intros.
destruct (AnnDefEq_regularity H0) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H4) => EQ. subst.
move: (get_tpg_correct T4 H5) => EQ. subst.
move: (get_tpg_correct T1 H3) => EQ. subst.
move: (get_tpg_correct T2 H6) => EQ. subst.
eapply (@An_PiCong_exists x x) with (B2 := close_tm_wrt_tm x B2); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@tm_subst_tm_tm_intro x).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_Pi_exists2 x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ pick fresh y.
  rewrite (tm_subst_tm_tm_spec _ _ x); auto.
  rewrite (tm_subst_tm_tm_intro y); auto.
  eapply (@An_Pi_exists2 x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
  replace a_Star with
     (tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) y a_Star); auto.

  replace B2 with (open_tm_wrt_tm (close_tm_wrt_tm x B2) (a_Var_f x)) in T4; autorewrite with lngen; auto.
  replace a_Star with (open_tm_wrt_tm a_Star (a_Var_f x)) in T4; auto.
  apply (@AnnTyping_tm_swap x y) in T4; autorewrite with lngen; eauto.
  replace (open_tm_wrt_tm a_Star (a_Var_f y)) with a_Star in T4; auto.

  have t1: AnnCtx G by eauto with ctx_wff.
  move: (AnnTyping_weakening T2 [(x,Tm A1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnTyping_weakening T1 [(x,Tm A2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnTyping_weakening T1 [(x,Tm A1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnTyping_weakening T2 [(x,Tm A2)] nil G eq_refl) => t5. simpl_env in t5.

  eapply AnnTyping_tm_subst with (A:= A1).
  eapply AnnTyping_weakening with (F:=[(y,Tm A1)]); eauto 4.
  econstructor; eauto.
  econstructor; eauto.
  eapply AnnDefEq_weakening with (F:=nil) (E:=[(x,Tm A2)]); simpl_env; eauto.
  simpl_env.
  eapply (fourth ann_weaken_available_mutual) with (D := dom G).
  eapply AnnDefEq_weaken_available. eauto. simpl. fsetdec.

  autorewrite with lngen. fsetdec.

+ eapply (@An_Pi_exists2 x); eauto.
   autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

Lemma An_AbsCong_exists3: forall x (G:context) D rho
                           (g1 g2 : co) (A1 B1 A2 B3 B2 B: tm),
    x `notin` (dom G \u fv_tm_tm_co g2 \u fv_tm_tm_co g1)
    -> AnnDefEq G D g1 A1 A2
    → AnnDefEq ([(x, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) B1 B2
    → B3 = tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2
    → get_tpg G A1 = a_Star
    → get_tpg ([(x,Tm A1)] ++ G) B2 = B (* FIXME: isn't this assumption useless? (B seems to only occur here) *)
    → get_tpg G A2 = a_Star
    → RhoCheck rho x (erase_tm B1)
    → RhoCheck rho x (erase_tm B3)
    → AnnDefEq G D (g_AbsCong rho g1 g2)
               (a_Abs rho A1 (close_tm_wrt_tm x B1))
               (a_Abs rho A2 (close_tm_wrt_tm x B3)).
Proof.
intros.
destruct (AnnDefEq_regularity H0) as (C1 & C2 & g' & T1 & T2 & _).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T4 H4) => EQ. subst.
move: (get_tpg_correct T1 H3) => EQ. subst.
move: (get_tpg_correct T2 H5) => EQ. subst.
eapply (@An_AbsCong_exists x x) with (b2 := close_tm_wrt_tm x B2)
(b1 := close_tm_wrt_tm x B1)
(b3 := close_tm_wrt_tm x (tm_subst_tm_tm (a_Conv (a_Var_f x) (g_Sym g1)) x B2))
(B := a_Pi rho A1 (close_tm_wrt_tm x (get_tpg ([(x, Tm A1)] ++ G) B2)));
  eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@tm_subst_tm_tm_intro x).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ autorewrite with lngen. auto.
+ autorewrite with lngen. auto.
+ eapply (@An_Abs_exists x); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
  autorewrite with lngen.
  rewrite <- subst_tm_erase_tm in H7.
  simpl in H7.
  rewrite tm_subst_tm_tm_spec in H7.
  autorewrite with lngen in H7. auto.
Qed.

Lemma An_CPiCong_exists_3 :  ∀ c (G : context) D (g1 g3 : co) (phi1 : constraint)
       (B1 : tm) (phi2 : constraint) (B3 B2 : tm),
     c `notin` dom G \u D \u fv_co_co_co g3 \u fv_co_co_co g1
    -> AnnIso G D g1 phi1 phi2
    → AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) B1 B2
    → B3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c B2
    -> get_tpg ([(c,Co phi1)] ++ G) B1 = a_Star
    -> get_tpg ([(c,Co phi2)] ++ G) B3 = a_Star
    -> get_tpg ([(c,Co phi1)] ++ G) B2 = a_Star
    → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 (close_tm_wrt_co c B1))
               (a_CPi phi2 (close_tm_wrt_co c B3)).
Proof.
intros.
destruct (AnnIso_regularity H0).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H3) => EQ. subst.
move: (get_tpg_correct T4 H5) => EQ. subst.
eapply (@An_CPiCong_exists c c) with
(B2 := close_tm_wrt_co c B2); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@co_subst_co_tm_intro c).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_CPi_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ pick fresh y.
  rewrite (co_subst_co_tm_spec _ _ c); auto.
  rewrite (co_subst_co_tm_intro y); auto.
  eapply (@An_CPi_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen.
  replace a_Star with
     (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) y a_Star); auto.
  replace B2 with
    (open_tm_wrt_co (close_tm_wrt_co c B2) (g_Var_f c)) in T4; autorewrite with lngen; auto.
  replace a_Star with (open_tm_wrt_co a_Star (g_Var_f c)) in T4; auto.
  apply (@AnnTyping_co_swap c y) in T4; autorewrite with lngen; eauto.
  replace (open_tm_wrt_co a_Star (g_Var_f y)) with a_Star in T4; auto.
  have t1: AnnCtx G by eauto with ctx_wff.
  move: (AnnPropWff_weakening H6 [(c,Co phi1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnPropWff_weakening H7 [(c,Co phi2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnPropWff_weakening H6 [(c,Co phi1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnPropWff_weakening H7 [(c,Co phi2)] nil G eq_refl) => t5. simpl_env in t5.
  destruct phi1 as [a b A].
  inversion H6. subst.
  eapply AnnTyping_co_subst with (A1 := a) (A2:=b) (A3:=A)
              (D := dom ([(c,Co phi2)] ++ G)).
  { eapply AnnTyping_weakening with (F:=[(y,Co (Eq a b A))]); eauto.
    econstructor; eauto.
    econstructor; eauto.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
  }
  {
    destruct phi2.
    eapply An_Cast.
    eapply An_Assn.
    econstructor.  eauto.
    eauto. eauto.
    eauto.
    rewrite dom_app. simpl. auto.
    econstructor.
    eapply AnnIso_weakening with (F:=nil) (E:=[(c,Co (Eq a0 b0 A0))]) (G:=G);
      simpl_env; eauto.
  simpl_env.
  eapply (third ann_weaken_available_mutual) with (D := dom G).
  eapply AnnIso_weaken_available. eauto. simpl. fsetdec.
  }
  autorewrite with lngen. fsetdec.
+ eapply (@An_CPi_exists c); eauto.
   autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

Lemma An_CAbsCong_exists3 :
        ∀ (c : atom) (G : context) (D : available_props)
           (g1 g3 g4 : co) (phi1 : constraint) (a1 : tm)
           (phi2 : constraint) (a3 a2 B1 B3 : tm),
    AnnIso G D g1 phi1 phi2
    → c `notin` dom G \u D \u (fv_co_co_co g3) \u (fv_co_co_co g1)
        \u fv_co_co_co g4
    → AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c)) a1 a2
    → a3 = co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c a2
    → get_tpg ([(c, Co phi1)] ++ G) a1 = B1
    -> get_tpg ([(c, Co phi2)] ++ G) a3 = B3
    → AnnDefEq G (dom G) g4 (a_CPi phi1 (close_tm_wrt_co c B1))
               (a_CPi phi2 (close_tm_wrt_co c B3))
    → AnnDefEq G D (g_CAbsCong g1 g3 g4)
               (a_CAbs phi1 (close_tm_wrt_co c a1))
               (a_CAbs phi2 (close_tm_wrt_co c a3))
                             .
Proof.
intros.
destruct (AnnIso_regularity H) as (T1 & T2).
destruct (AnnDefEq_regularity H1) as (C3 & C4 & g'' & T3 & T4 & _).
move: (get_tpg_correct T3 H3) => EQ2. subst C3.
assert (AnnTyping ([(c,Co phi2)] ++ G)
                  (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c a2)
                  (co_subst_co_tm (g_Cast (g_Var_f c) (g_Sym g1)) c C4)).
{
  pick fresh y.
  replace C4 with
  (open_tm_wrt_co (close_tm_wrt_co c C4) (g_Var_f c)) in T4;
    autorewrite with lngen; auto.
  replace a2 with
  (open_tm_wrt_co (close_tm_wrt_co c a2) (g_Var_f c)) in T4;
    autorewrite with lngen; auto.
  apply (@AnnTyping_co_swap c y) in T4; autorewrite with lngen; eauto.

  (*
  rewrite (co_subst_co_tm_spec _ _ c); auto.
  rewrite (co_subst_co_tm_intro y); auto. *)

  (* move: (ann_ctx_wff_PropWff T1) => t1. *)
  move: (AnnPropWff_weakening T1 [(c,Co phi1)] nil G eq_refl) => t2. simpl_env in t2.
  move: (AnnPropWff_weakening T2 [(c,Co phi2)] nil G eq_refl) => t3. simpl_env in t3.
  move: (AnnPropWff_weakening T1 [(c,Co phi1)] nil G eq_refl) => t4. simpl_env in t4.
  move: (AnnPropWff_weakening T2 [(c,Co phi2)] nil G eq_refl) => t5. simpl_env in t5.
  destruct phi1 as [a b A].
  inversion T1. subst.

  rewrite (co_subst_co_tm_spec a2 _ c); auto.
  rewrite (co_subst_co_tm_intro y); auto.

  rewrite (co_subst_co_tm_spec C4 _ c); auto.
  rewrite (co_subst_co_tm_intro y (close_tm_wrt_co c C4) ); auto.

  eapply AnnTyping_co_subst with (A1 := a) (A2:=b) (A3:=A)
              (D := dom ([(c,Co phi2)] ++ G)).
  { eapply AnnTyping_weakening with (F:=[(y,Co (Eq a b A))]); eauto 3 with ctx_wff.
    econstructor; eauto with ctx_wff.
    econstructor; eauto.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
    eapply AnnTyping_weakening with (F:=nil)(E:=[(c,Co phi2)]); eauto with ctx_wff.
  }
  {
    destruct phi2.
    eapply An_Cast.
    eapply An_Assn.
    econstructor.  eauto with ctx_wff.
    eauto. eauto.
    eauto.
    rewrite dom_app. simpl. auto.
    econstructor.
    eapply AnnIso_weakening with (F:=nil) (E:=[(c,Co (Eq a0 b0 A0))]) (G:=G);
      simpl_env; eauto with ctx_wff.
  simpl_env.
  eapply (third ann_weaken_available_mutual) with (D := dom G).
  eapply AnnIso_weaken_available. eauto. simpl. clear Fr. fsetdec.
  }
  autorewrite with lngen. fsetdec.
  autorewrite with lngen. fsetdec.
}
rewrite H2 in H4.
move: (get_tpg_correct H6 H4) => EQ3.
eapply (@An_CAbsCong_exists c c) with
(a2 := close_tm_wrt_co c a2)
  (B := a_CPi phi1 (close_tm_wrt_co c C4)); eauto.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. fsetdec.
+ autorewrite with lngen. eauto.
+ autorewrite with lngen. rewrite (@co_subst_co_tm_intro c).
  autorewrite with lngen. auto. autorewrite with lngen. auto.
+ eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ rewrite <- EQ3.
  rewrite H2.
  eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
+ eapply (@An_CAbs_exists c); eauto.
  autorewrite with lngen. auto.
  autorewrite with lngen. auto.
Qed.

End fc_get.


Require Export Coq.Program.Tactics.
Require Export LibTactics.
(** printing × $\times$ #×# *)
(** printing :> $:$ #:># *)
(** printing ≡ $\equiv$ #≡# *)
(** printing [*] $*$ #*# *)
(** printing ∧ $\wedge$ #∧# *)
(** printing ∀ $\forall$ #∀# *)
(** printing → $\rightarrow$ #→# *)
(** printing ∃ $\exists$ #∃# *)
(** printing ≤ $\le$ #≤# *)
(** printing θ $\theta$ #θ# *)
(** printing eeev $\epsilon_v$ #∊ᵥ# *)
(** printing eeew $\epsilon_w$ #∊w# *)
(** printing tm $t_m$ #tm# *)
(** printing IR $\mathbb{R}$ #IR# *)
(** printing CR $\mathbb{R}$ #CR# *)
(** printing tr $t_r$ #tr# *)
(** remove printing * *)

(** printing ' $ $ #'# *)

Require Import Vector.
Require Import CPS.
Require Import CPSUtils.

Require Import MathClasses.interfaces.canonical_names.
Require Import MCInstances.
Require Import CartCR.

Definition initialVel : (Polar2D Q) := {|rad:=0; θ:=0|}.

Require Export CartIR.

Notation FConst := ConstTContR.
Notation FSin:= CFSine.
Notation FCos:= CFCos.

(**
* Specifying robots.
*)

(**
A cyber-physical system (CpS) typicall consistes of one or more robots (broadly interpreted), and
one or more software agents (controllers).

We want to be able to specify a CpS by composing the specifications
of its robots and other software components.
As explained in the
#ROSCoq paper#,
a specification CpS involved a specification of its physical
specification of its physical model and mutually independent specifications of each of its agents.
Our goal here is to specify the physical model of the robot and its hardware agents which represent
its device-drivers. We do this in a general way so that it can be instantiated in the specification
of various CpSes.
*)

(**
* The physical model of iRobot Create
*)

(**
As described in Sec. 2 of the
#ROSCoq paper#,
a physical model is a type that specifies how each relevant physical
quantities evolved over time, and the physical laws governing that evolution.
Hence, a physical model of a CpS would typically be a product of the physical models
of each component robots.

Below is the specification of the physical model of the iCreate robot.
This specification is explained as an example in
Sec. 2 of the
#ROSCoq paper#

*)

(** [TContR] is a type of continuous functions from [Time] to reals ([R])
It denotes how a physical quantity evolved over time *)
Local Notation "Time -c-> R" := TContR (at level 100).

Record iCreate : Type := {
(** x, y co-ordinates  of the center of the robot *)

  position :> Cart2D (Time -c-> R);

(** the angle with X axis made by the line joining the center of the robot to the front tip *)

  theta : Time -c-> R;

(** velocity of the center of the robot *)

  linVel : Time -c-> R;

(** angular velocity (rate of turn) of the robot, in radians per unit time *)

  omega : Time -c-> R;

(** differential equations *)

  derivRot : isDerivativeOf omega theta;
  derivX : isDerivativeOf (linVel * (FCos theta)) (X position);
  derivY : isDerivativeOf (linVel * (FSin theta)) (Y position);

(** Initial (at time:=0) Conditions *)
(* Todo: generalize over 0 *)

  initPos:  ({X position} 0) ≡ 0 ∧ ({Y position} 0) ≡ 0;
  initTheta:  ({theta} 0) ≡ 0;
  initTransVel : ({linVel} 0) ≡ (rad initialVel);
  initOmega : ({omega} 0) ≡ (θ initialVel)
}.

Section HardwareAgents.

(**
* Specifying the hardware agents (device-drivers)
*)

(**
The Robot Operating System (ROS) typically provides drivers
for robots. These are typically represented as agents (nodes) of a distributed system.
These nodes communicate on designated topics,
e.g. to subscribe to actuation commands, or to publish sensed values.
To reason about such robots, one can specify them as ROSCoq hardware agents.
We want the specification to be general enough so that these agents can be used
in a wide range of CpSes. So we parametrize the specification with an arbitrary
type for topics, and arbitrary members denoting the designated topics.

Below, we illustrate this method with a specification of the driver of an iCreate robot,
as explained in Sec. 4.1 of the
#ROSCoq paper#

We assume an arbitrary type for topics.
*)

Context
  `{rtopic : TopicClass RosTopic}
  `{dteq : Deq RosTopic}.

(**
We assume a designated topic which the driver subscribes to, to receive velocity commands
*)

Variable VELOCITY : RosTopic.

(**
We assume that the payload type of the above topic is [Polar2D Q].
Members of [Polar2D Q] are pairs of rationals. For example, for rationals
[a] and [b], [{| rad :=a ; θ :=b |}] is a member of [Polar2D Q].
The [rad] component denotes the requested linear velocity, and the
[θ] component denotes the requested angular velocity.
*)

Hypothesis VelTOPICType : (topicType VELOCITY ≡ Polar2D Q).

(**
A bound on the time the robot takes to nearly achieve a requested velocity.
This can be understood as a bound on the width of the vertical green
rectangle below.
*)

Variable reacTime : QTime.

(* It is more sensible to change the type to [QNonNeg]
    as the value certainly does not represent time.
    However, the coercion QT2Q does not work then *)

Local Notation QNonNegative := QTime.

(**
Bound on actuation error for given liner and angular velocities.
This is related to the height of the horizontal rectangle in the figure below.
*)

Variable motorPrec : Polar2D Q → Polar2D QNonNegative.

(**
The robot eventually comes to a complete stop when requested to do so.
*)

Hypothesis motorPrec0 : motorPrec {| rad :=0 ; θ :=0 |} ≡ {| rad :=0 ; θ :=0 |}.

Close Scope Q_scope.

(**
The definition below is the key ingredient of the specification of the device driver.
Suppose the driver receives a payload [cmd] of type [Polar2D Q] at time [tm].
Consider some later time instant [t] such that no other messages were received between
[tm] and [t].
[correctVelDuring] specified how the robot's linear and angular velocity must have
evolved from time [tm] to [t].
The first conjunct specifies the evolution of the linear velocity, and the second one
which is similar,  specifies the evolution of the angular velocity.
To understand a conjunct, we hanve to understand the definition of [changesTo]
(click it to jump to its definition).

The figure below illustrates it pictorially.
There must exist a time instant [tr] by which
the linear velocity of the robot becomes close to [rad cmd], which is the requested linear velocity.
As explained above, the parameter [reacTime] is
an upper bound on [tr - tm].
After [tr], the linear velocity remains close enough (as specified by [motorPrec]) to [rad cmd].

##

*)

Definition correctVelDuring
  (cmd : (Polar2D Q))
  (tm: QTime)
  (t : QTime)
  (ic: iCreate) :=

  changesTo
    (linVel ic)
    tm
    t
    (rad cmd)
    reacTime
    (rad  (motorPrec cmd))
  ∧
  changesTo
    (omega ic)
    tm
    t
    (θ cmd)
    reacTime
    (θ (motorPrec cmd)).

Section LastVelocityMessage.

Context `{etype : @EventType _ _ _ Event  tdeq}.

Typeclasses eauto :=2.

(**
Given [evs], the  sequence of events that happened at the hardware agent,
and any time [t],
the function below computes the latest velocity message received before time [t],
and the time when it was received.
*)

Definition latestVelPayloadAndTime
  (evs : nat -> option Event) (t : QTime) : ((Polar2D Q) × QTime) :=
(@transport _ _ _ (λ t, t -> t ** QTime) VelTOPICType
   (lastPayloadAndTime VELOCITY evs t)) initialVel.

(**
Now we just consider any time instant [t] and enforce that the velocity
evolved correctly, as explained above, from the time instant the latest message
before [t] was received and till [t].
*)

Definition corrSinceLastVel
  (evs : nat -> option Event)
  (t : QTime)
  (ic: iCreate) :=
let (cmd, tm) := latestVelPayloadAndTime evs t in
correctVelDuring cmd tm t ic.

End LastVelocityMessage.

(**
The final specification of the hardware agent just enforces the above for all
(rational) time instants. Ideally, one might want to enforce it for even the irrational
time instants. However, because velocity is assumed to be a continuous function,
the specification at rational time instants is sufficient.
*)

Definition HwAgent  : Device iCreate :=
λ (Event:Type)
(tdeq : DecEq Event) (_ : EventType Event) (robot: iCreate) (evs : nat -> option Event) ,
  (∀ t: QTime, corrSinceLastVel evs t robot)
  ∧ ∀ n:nat, isDeqEvtOp (evs n).

(**
See #examples/icreateMoveToLoc/spec.v#
for an example of using  the definitions
in this file while specifiying a CpS.
*)

(* partial simplified definition shown in the paper :
Definition eeev  a b : Q  :=
 (rad (motorPrec {|rad:= a; θ:= b|})).

Definition eeew  a b : Q :=
 (θ (motorPrec {|rad:= a; θ:= b|})).

Definition HwAgentP (ic: iCreate) (evs : nat -> option Event): Prop :=
onlyRecvEvts evs ∧ ∀ t: QTime,
  let (lastCmd, tm ) := latestVelPayloadAndTime evs t in
  let a : Q := rad (lastCmd) in
  let b : Q := θ (lastCmd) in
  ∃ tr : QTime, (tm ≤ tr ≤ tm + reacTime)
    ∧ (∀ t' : QTime, (tm ≤ t' ≤ tr)
        → (Min ({linVel ic} tm) (a - eeev a b)
            ≤ {linVel ic} t' ≤ Max ({linVel ic} tm) (a+ eeev a b)))
    ∧ (∀ t' : QTime, (tr ≤ t' ≤ t) → |{linVel ic} t' - a | ≤ Q2R (eeev a b)).

Lemma HwAgentPCorr1 :
  ∀ icr evs,
  HwAgent icr evs ->  HwAgentP icr evs.
Proof.
  intros ? ? H.
  destruct H as [Hr H].
  split; [assumption|]. clear H.
  intros t.
  specialize (Hr t).
  unfold corrSinceLastVel in Hr.
  destruct (latestVelPayloadAndTime evs t) as [lc lt].
  apply proj1 in Hr.
  destruct Hr as [qtrans Hr].
  exists qtrans.
  unfold le, Le_instance_QTime.
  autounfold with IRMC. unfold Plus_instance_QTime.
  unfoldMC. repnd.
  split; auto.
  unfold eeev.
  destruct lc.
  simpl Vector.rad.
  simpl Vector.rad in Hrrl, Hrrr.
  unfold Q2R. setoid_rewrite inj_Q_inv.
  split; auto.
  unfold between, Q2R in Hrrr.
  intros ? H.
  apply Hrrr in H.
  autorewrite with QSimpl in H.
  exact H.
Qed.
*)

End HardwareAgents.


Add LoadPath "..".
Require Export Hyb_Syntax.
Require Export LibTactics. (* case_if *)
Require Import Gt.
Require Import Arith.

(* Notation for term substitution *)
Global Reserved Notation " [ M // v ] N " (at level 5).

(* Notation for world substitution *)
Global Reserved Notation " {{ w1 // w2 }} N " (at level 5).

(*** Definitions ***)

(*
Term substitution
  Simple term substitution, very similar to the one in simple lambda calculus.
  We assume here that the term M0 is locally closed, that is it does not
  require any shifts.
*)
Fixpoint subst_t_Hyb (M0: te_Hyb) (v0: vte) (N0: te_Hyb) :=
match N0 with
| hyp_Hyb v =>
    if (eq_vte_dec v v0) then M0 else N0
| lam_Hyb A M =>
    lam_Hyb A ([M0 // shift_vte v0] M)
| appl_Hyb M N =>
    appl_Hyb ([M0//v0]M) ([M0//v0]N)
| box_Hyb M =>
    box_Hyb ([M0//v0]M)
| unbox_fetch_Hyb w M =>
    unbox_fetch_Hyb w ([M0//v0]M)
| get_here_Hyb w M =>
    get_here_Hyb w ([M0//v0]M)
| letdia_get_Hyb w M N =>
    letdia_get_Hyb w ([M0//v0]M) ([M0//shift_vte v0]N)
end
where " [ M // v ] N " := (subst_t_Hyb M v N) : hybrid_is5_scope.

(*
World substitution
  Replaces one world with another. Since both of the worlds can be free or
  bound, we need to use shift operation on both sides for box and letdia cases.
*)
Fixpoint subst_w_Hyb (w1: vwo) (w2: vwo) (M0: te_Hyb) :=
match M0 with
| hyp_Hyb n => hyp_Hyb n
| lam_Hyb A M => lam_Hyb A ({{w1//w2}}M)
| appl_Hyb M N => appl_Hyb ({{w1//w2}}M) ({{w1//w2}}N)
| box_Hyb M =>
  box_Hyb ({{ shift_vwo w1 // shift_vwo w2 }} M)
| unbox_fetch_Hyb w M =>
  let w' := if (eq_vwo_dec w w2) then w1 else w in
    unbox_fetch_Hyb w' ({{w1//w2}} M)
| get_here_Hyb w M =>
  let w' := if (eq_vwo_dec w w2) then w1 else w in
    get_here_Hyb w' ({{w1//w2}}M)
| letdia_get_Hyb w M N =>
  let w' := if (eq_vwo_dec w w2) then w1 else w in
    letdia_get_Hyb w' ({{w1//w2}} M) ({{shift_vwo w1 // shift_vwo w2}} N)
end
where " {{ w1 // w2 }} M " := (subst_w_Hyb w1 w2 M) : hybrid_is5_scope.

(* Opening is defined in terms of substitution *)

Definition open_t_Hyb (M: te_Hyb) (t: te_Hyb) := subst_t_Hyb t (bte 0) M.

Definition open_w_Hyb M w := subst_w_Hyb w (bwo 0) M.

Notation " M '^t^' t " := (open_t_Hyb M t) (at level 67) : hybrid_is5_scope.
Notation " M ^w^ w  " := (open_w_Hyb M w) (at level 67) : hybrid_is5_scope.

Open Scope hybrid_is5_scope.

(*
List substitution
  Substituting a list of terms for bound variables in term, starting
  from a given index.
*)
Fixpoint list_t_subst_Hyb (L: list te_Hyb) (n: nat) (M: te_Hyb) :=
match L with
| nil => M
| t :: L' => [t // bte n] (list_t_subst_Hyb L' (S n) M)
end.

(*** Properties ***)

(*
Simplify substitution in special cases
  * when substitution is identity substitution
  * when the variable for which we try to substitute does not occur in the term
  * when term is closed and we try to substitute for bound variable
*)

Lemma subst_w_Hyb_id:
forall M w,
  {{w // w}} M = M.
induction M; intros; simpl in *;
repeat case_if; subst; auto;
rewrite IHM || (rewrite IHM1; try rewrite IHM2);
auto.
Qed.

Lemma subst_w_Hyb_2_step_id:
forall M w n
  (HT: w \notin free_worlds_Hyb M),
  {{bwo n//fwo w}}({{fwo w//bwo n}}M) = M.
induction M; intros; simpl in *;
repeat case_if; subst; auto;
rewrite IHM || (rewrite IHM1; try rewrite IHM2);
try destruct v; auto;
assert (w <> w) as Neq by eauto; elim Neq; auto.
Qed.

(* Free variable for which we substitute does not occur in the term *)

Lemma closed_subst_w_Hyb_free:
forall M w0 w
  (H_lc: w0 \notin free_worlds_Hyb M),
  {{ w // fwo w0}} M  = M.
induction M; intros; simpl in *;
repeat case_if; auto;
rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto;
(rewrite notin_union in H_lc; rewrite notin_singleton in H_lc;
destruct H_lc as (Neq, H_lc); elim Neq) || destruct v; auto.
Qed.

Lemma closed_subst_t_Hyb_free:
forall M v0 N
  (H_lc: v0 \notin free_vars_Hyb N),
  [M // fte v0] N = N.
induction N; intros; simpl in *;
repeat case_if;
try (rewrite IHN || (rewrite IHN1; try rewrite IHN2); auto);
[ rewrite notin_singleton in H_lc; elim H_lc |
  destruct v]; auto.
Qed.

(* Term is closed and we try to substitute for bound variable *)

Lemma closed_subst_w_Hyb_bound:
forall M w0 w n
  (H_lc: lc_w_n_Hyb n M)
  (Gt: w0 >= n),
  {{ w // bwo w0}} M  = M.
induction M; intros; simpl in *;
repeat case_if; auto;
inversion H_lc; subst;
erewrite IHM || (erewrite IHM1; try erewrite IHM2); eauto;
omega.
Qed.

Lemma closed_subst_t_Hyb_bound:
forall N M v0 n
  (H_lc: lc_t_n_Hyb n N),
  v0 >= n -> [M // bte v0] N = N.
induction N; intros; simpl in *;
repeat case_if; inversion H_lc; subst;
try (erewrite IHN || (erewrite IHN1; try erewrite IHN2)); eauto.
assert (~(n = v0)) by omega;
apply gt_asym in H2; elim H2; omega.
omega. omega.
Qed.

(* Properties of substitution: commutativity *)

Lemma subst_w_Hyb_comm:
forall M w w' w'' n
  (Neq: w'' <> w),
  {{fwo w'//fwo w''}}({{fwo w//bwo n}}M) =
  {{fwo w//bwo n}}({{fwo w'//fwo w''}}M).
induction M; intros; simpl;
repeat case_if; subst; simpl; auto;
rewrite IHM || (rewrite IHM1; try rewrite IHM2);
auto.
Qed.

Lemma subst_t_Hyb_comm:
forall M v v' n N
  (Lc: lc_t_Hyb N),
  v <> v' ->
  [ N // fte v] ([ hyp_Hyb (fte v') // bte n] M) =
  [hyp_Hyb (fte v') // bte n] ([N // fte v] M).
induction M; intros; simpl;
[ repeat (case_if; simpl); auto;
  erewrite closed_subst_t_Hyb_bound; eauto; omega | | | | | |];
try (rewrite IHM; auto);
try (rewrite IHM1; try rewrite IHM2; auto);
repeat (case_if; simpl); subst; simpl;
auto;
erewrite closed_subst_t_Hyb_bound;
eauto;
replace n with (0+n) by omega;
apply closed_t_addition; auto.
Qed.

(* Properties of substitution: expansion with neutral element *)

Lemma subst_w_Hyb_neutral_free:
forall M w w' w0
  (HT: w0 \notin free_worlds_Hyb M),
  {{w//fwo w0}}({{fwo w0// w'}}M) = {{w//w'}}M.
induction M; intros; simpl in *;
repeat case_if; subst; simpl; auto;
try destruct w; try destruct w'; try destruct v; subst;
rewrite IHM || (rewrite IHM1; try rewrite IHM2);
auto;
assert (w0 <> w0) as Neq by eauto; elim Neq; auto.
Qed.

Lemma subst_t_Hyb_neutral_free:
forall M v n N
  (HT: v \notin free_vars_Hyb M),
  [ N // bte n] M = [N // fte v] [hyp_Hyb (fte v) // bte n] M.
induction M; intros; simpl in *;
try (erewrite IHM || (erewrite IHM1; try erewrite IHM2); eauto);
repeat (case_if; simpl); subst; auto;
assert (v0 <> v0) as Neq by eauto; elim Neq; auto.
Qed.

Lemma subst_w_Hyb_neutral_bound:
forall M n
  (HT: lc_w_n_Hyb n M),
  forall m w w',
    m >= n -> {{w//bwo m}}({{bwo m// w'}}M) = {{w//w'}}M.
intros M n HT; induction HT; intros; simpl in *; auto.
rewrite IHHT; auto.
rewrite IHHT1; try rewrite IHHT2; auto.
destruct w; destruct w'; simpl; try rewrite IHHT; auto; omega.
repeat case_if; rewrite IHHT; auto.
repeat case_if; rewrite IHHT; auto; inversion H1; subst; omega.
repeat case_if; rewrite IHHT; auto.
repeat case_if; rewrite IHHT; auto; inversion H1; subst; omega.
repeat case_if; rewrite IHHT1; try rewrite IHHT2; auto; omega.
repeat case_if; rewrite IHHT1; try rewrite IHHT2; auto; try omega;
inversion H1; subst; omega.
Qed.

(* With two different types of substitution, the order does not matter *)

Lemma subst_Hyb_order_irrelevant_bound:
forall N w M v m
  (HT_M: lc_w_Hyb M),
    [M // v ] ({{w // bwo m}} N)  =
    {{w // bwo m}} ([M // v ] N).
induction N; intros; simpl in *;
repeat case_if; simpl;
unfold shift_vte in *; unfold shift_vwo in *;
try destruct v; try destruct w; auto;
try rewrite IHN; try (rewrite IHN1; try rewrite IHN2);
auto; erewrite closed_subst_w_Hyb_bound; eauto; omega.
Qed.

Lemma subst_Hyb_order_irrelevant_free:
forall N w w' M v
  (HT_M: w' \notin (free_worlds_Hyb M)),
    [M // v ] ({{w // fwo w'}} N)  =
    {{w // fwo w'}} ([M // v ] N).
induction N; intros; simpl in *;
repeat case_if; simpl;
unfold shift_vwo in *;
try destruct c; try destruct v; auto;
try rewrite IHN; try (rewrite IHN1; try rewrite IHN2);
auto; rewrite closed_subst_w_Hyb_free; auto.
Qed.

(*
   Substitution of one type does not change the set of free variables
   of the other type.
*)

Lemma subst_t_Hyb_preserv_free_worlds:
forall N v k w,
  w \notin free_worlds_Hyb N ->
  w \notin free_worlds_Hyb [ hyp_Hyb (fte v) // bte k ] N.
induction N; intros; simpl in *;
repeat case_if;try destruct v;
simpl; auto.
Qed.

Lemma subst_w_Hyb_preserv_free_vars:
forall N w w' v,
  v \notin free_vars_Hyb N ->
  v \notin free_vars_Hyb {{w // w'}} N.
induction N; intros; simpl in *;
repeat case_if; try destruct c;
simpl; auto.
Qed.

(*
   Other lemmas that proved to be needed in the development.
   Warning: May contain repetitions.
*)

Lemma lc_w_subst_t_Hyb:
forall N M v n,
  lc_w_n_Hyb n M ->
  lc_w_n_Hyb n N ->
  lc_w_n_Hyb n (subst_t_Hyb M v N).
induction N; intros; inversion H0; subst; simpl in *; try case_if;
auto; constructor; try eapply IHN; eauto. apply closed_w_succ; auto.
eapply IHN2; [apply closed_w_succ | ]; auto.
eapply IHN2; [apply closed_w_succ | ]; auto.
Qed.

Lemma lc_w_subst_Hyb:
forall M w k,
  lc_w_n_Hyb (S k) M ->
  lc_w_n_Hyb k {{fwo w // bwo k}} M.
induction M; intros; simpl in *; repeat case_if;
inversion H; subst; try destruct w;
constructor; eauto.
destruct (eq_nat_dec m k); subst; [elim H0 |]; auto; omega.
destruct (eq_nat_dec m k); subst; [elim H0 |]; auto; omega.
destruct (eq_nat_dec m k); subst; [elim H0 |]; auto; omega.
Qed.

Lemma lc_w_subst_Hyb_same_n_fwo:
forall M w w' n,
  lc_w_n_Hyb n M ->
  lc_w_n_Hyb n {{fwo w // w'}} M.
induction M; intros; simpl in *; repeat case_if;
inversion H; subst; try destruct w;
constructor; eauto.
Qed.

Lemma lc_w_subst_Hyb_same_n_bwo:
forall M w' k n,
  lc_w_n_Hyb n M ->
  k < n ->
  lc_w_n_Hyb n {{bwo k // w'}} M.
induction M; intros; simpl in *; repeat case_if;
inversion H; subst; try destruct w'; simpl;
constructor; try (eapply IHM || eapply IHM2); try omega; auto.
Qed.

Lemma lc_w_n_Hyb_subst_t:
forall N M v n,
lc_w_n_Hyb n (subst_t_Hyb M v N) ->
lc_w_n_Hyb n N.
induction N; intros; simpl in *; try destruct v; constructor;
inversion H; subst; try eapply IHN; eauto.
Qed.

Lemma lc_w_n_Hyb_subst_w:
forall N w n,
lc_w_n_Hyb n (subst_w_Hyb (fwo w) (bwo n) N) ->
lc_w_n_Hyb (S n) N.
induction N; intros; simpl in *; try destruct v; constructor;
inversion H; subst; try eapply IHN; eauto;
repeat case_if; try inversion H0; subst; try inversion H1; subst;
try omega.
Qed.

Lemma subst_w_Hyb_comm2:
forall M w w' m n
  (Neq: m <> n)
  (Neq': w <> bwo m),
  {{fwo w'//bwo m }}({{w//bwo n}}M) =
  {{w//bwo n}}({{fwo w'//bwo m}}M).
induction M; intros; simpl; destruct w;
repeat case_if; subst; simpl; auto;
rewrite IHM || (rewrite IHM1; try rewrite IHM2);
auto; intro nn; elim Neq'; inversion nn; subst; auto.
Qed.

Lemma lc_t_subst_w_Hyb:
forall N w w' n,
  lc_t_n_Hyb n N ->
  lc_t_n_Hyb n (subst_w_Hyb w w' N).
induction N; intros; inversion H; subst; simpl in *; try case_if;
auto; constructor; try eapply IHN; eauto.
Qed.

Lemma lc_t_subst_Hyb:
forall M N k,
  lc_t_n_Hyb (S k) M ->
  lc_t_n_Hyb k N ->
  lc_t_n_Hyb k [N // bte k] M.
induction M; intros; simpl in *; repeat case_if;
inversion H; subst; try constructor; eauto.
assert (v0 <> k) by (intro; elim H1; subst; auto); omega.
eapply IHM; eauto; apply closed_t_succ; auto.
eapply IHM2; eauto; apply closed_t_succ; auto.
Qed.

Lemma lc_t_n_Hyb_subst_w:
forall N w w' n,
lc_t_n_Hyb n (subst_w_Hyb w w' N) ->
lc_t_n_Hyb n N.
induction N; intros; simpl in *; try destruct v; constructor;
inversion H; subst; try eapply IHN; eauto.
Qed.

Lemma lc_t_n_Hyb_subst_t:
forall N M n,
lc_t_n_Hyb n M ->
lc_t_n_Hyb n (subst_t_Hyb M (bte n) N) ->
lc_t_n_Hyb (S n) N.
induction N; intros; simpl in *; try destruct v; constructor;
repeat case_if; try inversion H1; subst; try omega;
inversion H0; subst; eauto.
apply IHN with (M:=M); eauto; apply closed_t_succ; auto.
apply IHN2 with (M:=M); eauto; apply closed_t_succ; auto.
apply IHN2 with (M:=M); eauto; apply closed_t_succ; auto.
Qed.

Lemma double_subst_w_Hyb_bwo:
forall N w w' n,
 w' <> bwo n ->
 {{w // bwo n}}({{w' // bwo n}}N) = {{w' // bwo n}}N.
induction N; destruct w'; simpl in *; intros; repeat case_if;
try rewrite IHN;
try (rewrite IHN1; try rewrite IHN2); auto; intro nn; inversion nn;
subst; elim H; auto.
Qed.

Lemma subst_t_comm2_Hyb:
forall M v' m n N
  (Neq: m <> n)
  (Lc: lc_t_Hyb N),
  subst_t_Hyb N (bte m) (subst_t_Hyb (hyp_Hyb (fte v')) (bte n) M) =
  subst_t_Hyb (hyp_Hyb (fte v')) (bte n) (subst_t_Hyb N (bte m) M).
induction M; intros; subst; simpl;
repeat (case_if; subst; simpl); auto;
try rewrite IHM; eauto; try omega.
rewrite closed_subst_t_Hyb_bound with (n:=0); auto; omega.
rewrite IHM1; eauto; rewrite IHM2; eauto; omega.
rewrite IHM1; eauto; rewrite IHM2; eauto; omega.
Qed.

Lemma reorder_subst_w_Hyb_eq:
forall M w w' w'',
  subst_w_Hyb w w' (subst_w_Hyb w w'' M) =
  subst_w_Hyb w w'' (subst_w_Hyb w w' M).
induction M; intros; simpl; repeat case_if;
try rewrite IHM;
try rewrite IHM1; try rewrite IHM2; eauto.
Qed.

Hint Resolve lc_t_n_Hyb_subst_t lc_t_n_Hyb_subst_w lc_t_subst_Hyb
     lc_t_subst_w_Hyb lc_w_n_Hyb_subst_w lc_w_n_Hyb_subst_t
     lc_w_subst_Hyb_same_n_bwo lc_w_subst_Hyb_same_n_fwo
     lc_w_subst_Hyb lc_t_subst_Hyb.

Close Scope hybrid_is5_scope.


(* Calls to external decision procedures *)

Require Export ZArith.
Require Export Classical.

(* Zenon *)

(*  Copyright 2004 INRIA  *)
Lemma zenon_nottrue :
  (~True -> False).
Proof. tauto. Qed.

Lemma zenon_noteq : forall (T : Type) (t : T),
  ((t <> t) -> False).
Proof. tauto. Qed.

Lemma zenon_and : forall P Q : Prop,
  (P -> Q -> False) -> (P /\ Q -> False).
Proof. tauto. Qed.

Lemma zenon_or : forall P Q : Prop,
  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
Proof. tauto. Qed.

Lemma zenon_imply : forall P Q : Prop,
  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_equiv : forall P Q : Prop,
  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notand : forall P Q : Prop,
  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notor : forall P Q : Prop,
  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notimply : forall P Q : Prop,
  (P -> ~Q -> False) -> (~(P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notequiv : forall P Q : Prop,
  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.

Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
Proof. auto. Qed.

Lemma zenon_equal_step :
  forall (S T : Type) (fa fb : S -> T) (a b : S),
  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.

Lemma zenon_pnotp : forall P Q : Prop,
  (P = Q) -> (P -> ~Q -> False).
Proof. intros P Q Ha. rewrite Ha. auto. Qed.

Lemma zenon_notequal : forall (T : Type) (a b : T),
  (a = b) -> (a <> b -> False).
Proof. auto. Qed.

Ltac zenon_intro id :=
  intro id || let nid := fresh in (intro nid; clear nid)
.

Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.

Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.

(* Ergo *)

Set Implicit Arguments.
Section congr.
  Variable t:Type.
Lemma ergo_eq_concat_1 :
  forall (P:t -> Prop) (x y:t),
    P x -> x = y -> P y.
Proof.
  intros; subst; auto.
Qed.

Lemma ergo_eq_concat_2 :
  forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
    P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
Proof.
  intros; subst; auto.
Qed.

End congr.


Require Import Hask.Ltac.
(* Require Import Hask.Control.Iso. *)

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(*
#[export]
Instance LTuple_Isomorphism {A} : (unit * A) ≅ A :=
{ iso_to   := @snd unit A
; iso_from := pair tt
}.
(* jww (2015-06-17): NYI
Obligation 1. (* iso_to *)
  intros. extensionality x. destruct x. compute. destruct u. reflexivity.
Defined.
*)

#[export]
Instance RTuple_Isomorphism {A} : (A * unit) ≅ A :=
{ iso_to   := @fst A unit
; iso_from := fun x => (x, tt)
}.
(* jww (2015-06-17): NYI
Obligation 1. (* iso_to *)
  intros. extensionality x. destruct x. compute. destruct u. reflexivity.
Defined.
*)
*)

Definition tuple_swap_a_bc_to_ab_c {A B C} (x : A * (B * C)) : A * B * C :=
  match x with (a, (b, c)) => ((a, b), c) end.

Definition tuple_swap_ab_c_to_a_bc {A B C} (x : A * B * C) : A * (B * C) :=
  match x with ((a, b), c) => (a, (b, c)) end.

Definition left_triple {A B C} (x : A) (y : B) (z : C) : A * B * C :=
  ((x, y), z).

Definition right_triple {A B C} (x : A) (y : B) (z : C) : A * (B * C) :=
  (x, (y, z)).

(*
#[export]
Instance Tuple_Assoc {A B C} : (A * B * C) ≅ (A * (B * C)) :=
{ iso_to   := tuple_swap_ab_c_to_a_bc
; iso_from := tuple_swap_a_bc_to_ab_c
}.
(* jww (2015-06-17): NYI
Obligation 1. (* iso_to *)
  intros.
  extensionality x.
  unfold compose.
  destruct x.
  destruct p.
  unfold id.
  unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc.
  reflexivity.
Defined.
Obligation 2. (* iso_from *)
  intros.
  extensionality x.
  unfold compose.
  destruct x.
  destruct p.
  unfold id.
  unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc.
  reflexivity.
Defined.
*)
*)

Definition first `(f : a -> b) `(x : a * z) : b * z :=
  match x with (a, z) => (f a, z) end.

Definition second `(f : a -> b) `(x : z * a) : z * b :=
  match x with (z, b) => (z, f b) end.

Definition curry `(f : a -> b -> c) (x : (a * b)) : c :=
  match x with (a, b) => f a b end.

Definition uncurry {X Y Z} (f : X -> Y -> Z) (xy : X * Y) : Z :=
  match xy with (x, y) => f x y end.

Theorem uncurry_works : forall {X Y Z} (x : X) (y : Y) (f : X -> Y -> Z),
  uncurry f (x, y) = f x y.
Proof. reflexivity. Qed.

Lemma fst_snd : forall a b (z : a * b),
  (let '(x, y) := z in (x, y)) = (fst z, snd z).
Proof. intros ? ? [?]; auto. Qed.

Require Import Coq.Lists.List.

Lemma unsplit : forall a b (xs : list (a * b)),
  map (fun x => (fst x, snd x)) xs = xs.
Proof.
  intros.
  induction xs as [|x xs IHxs]; auto; simpl.
  rewrite IHxs.
  destruct x; auto.
Qed.

Definition prod_map {A B C : Type} (f : A -> B) (x : C * A) : C * B :=
  match x with (a, b) => (a, f b) end.

Require Import FunctionalExtensionality.

Module TupleLaws.

Theorem prod_map_id {E A} : @prod_map A A E id = id.
Proof.
  extensionality x.
  destruct x; auto.
Qed.

Theorem prod_map_comp {E A B C} (f : B -> C) (g : A -> B) :
  @prod_map B C E f \o @prod_map A B E g = @prod_map A C E (f \o g).
Proof.
  extensionality x.
  destruct x; auto.
Qed.

Corollary prod_map_comp_x {E A B C} (f : B -> C) (g : A -> B) (x : E * A) :
  prod_map f (prod_map g x) = prod_map (fun x => f (g x)) x.
Proof. destruct x; auto. Qed.

End TupleLaws.