From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a48_ : Universe.
Variable a47_ : Universe.
Variable a46_ : Universe.
Variable a45_ : Universe.
Variable a44_ : Universe.
Variable a43_ : Universe.
Variable a42_ : Universe.
Variable a41_ : Universe.
Variable a40_ : Universe.
Variable a4_ : Universe.
Variable a39_ : Universe.
Variable a38_ : Universe.
Variable a37_ : Universe.
Variable a36_ : Universe.
Variable a35_ : Universe.
Variable a34_ : Universe.
Variable a33_ : Universe.
Variable a32_ : Universe.
Variable a31_ : Universe.
Variable a30_ : Universe.
Variable a3_ : Universe.
Variable a29_ : Universe.
Variable a28_ : Universe.
Variable a27_ : Universe.
Variable a26_ : Universe.
Variable a25_ : Universe.
Variable a24_ : Universe.
Variable a23_ : Universe.
Variable a22_ : Universe.
Variable a21_ : Universe.
Variable a20_ : Universe.
Variable a2_ : Universe.
Variable a19_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ (dom_ a18_ /\ (dom_ a19_ /\ (dom_ a20_ /\ (dom_ a21_ /\ (dom_ a22_ /\ (dom_ a23_ /\ (dom_ a24_ /\ (dom_ a25_ /\ (dom_ a26_ /\ (dom_ a27_ /\ (dom_ a28_ /\ (dom_ a29_ /\ (dom_ a30_ /\ (dom_ a31_ /\ (dom_ a32_ /\ (dom_ a33_ /\ (dom_ a34_ /\ (dom_ a35_ /\ (dom_ a36_ /\ (dom_ a37_ /\ (dom_ a38_ /\ (dom_ a39_ /\ (dom_ a40_ /\ (dom_ a41_ /\ (dom_ a42_ /\ (dom_ a43_ /\ (dom_ a44_ /\ (dom_ a45_ /\ (dom_ a46_ /\ (dom_ a47_ /\ dom_ a48_))))))))))))))))))))))))))))))))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38 A39 A40 A41 A42 A43 A44 A45 A46 A47 A48 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ (dom_ A18 /\ (dom_ A19 /\ (dom_ A20 /\ (dom_ A21 /\ (dom_ A22 /\ (dom_ A23 /\ (dom_ A24 /\ (dom_ A25 /\ (dom_ A26 /\ (dom_ A27 /\ (dom_ A28 /\ (dom_ A29 /\ (dom_ A30 /\ (dom_ A31 /\ (dom_ A32 /\ (dom_ A33 /\ (dom_ A34 /\ (dom_ A35 /\ (dom_ A36 /\ (dom_ A37 /\ (dom_ A38 /\ (dom_ A39 /\ (dom_ A40 /\ (dom_ A41 /\ (dom_ A42 /\ (dom_ A43 /\ (dom_ A44 /\ (dom_ A45 /\ (dom_ A46 /\ (dom_ A47 /\ dom_ A48))))))))))))))))))))))))))))))))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 A22 A23 A24 A25 A26 A27 A28 A29 A30 A31 A32 A33 A34 A35 A36 A37 A38 A39 A40 A41 A42 A43 A44 A45 A46 A47 A48)).
Variable ax3_3 : (p_ a48_ a47_ a46_ a45_ a44_ a43_ a42_ a41_ a40_ a39_ a38_ a37_ a36_ a35_ a34_ a33_ a32_ a31_ a30_ a29_ a28_ a27_ a26_ a25_ a24_ a23_ a22_ a21_ a20_ a19_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma48_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import CSPEC.
Require Import MailServerAPI.
Require Import MailboxTmpAbsAPI.
Require Import DeliverListTidAPI.
Require Import MailFSAPI.

Module MailFSImpl' <:
  LayerImplMoversT
    MailboxTmpAbsState
    MailFSOp  MailFSAPI
    DeliverListTidOp DeliverListTidAPI.

  (* START CODE *)

  Definition same_tid (tid : nat) (fn : nat * nat) : bool :=
    if tid == fst fn then
      true
    else
      false.

  Definition listtid_core :=
    tid <- Call (MailFSOp.GetTID);
    l <- Call (MailFSOp.List);
    Ret (map snd (filter (same_tid tid) l)).

  Definition createwrite_core data :=
    ok1 <- Call (MailFSOp.CreateTmp);
    if (ok1 : bool) then Call (MailFSOp.WriteTmp data) else Ret ok1.

  Definition compile_op T (op : DeliverListTidOp.Op T) : proc _ T :=
    match op with
    | DeliverListTidOp.LinkMail m => Call (MailFSOp.LinkMail m)
    | DeliverListTidOp.List => Call (MailFSOp.List)
    | DeliverListTidOp.ListTid => listtid_core
    | DeliverListTidOp.Read fn => Call (MailFSOp.Read fn)
    | DeliverListTidOp.Delete fn => Call (MailFSOp.Delete fn)
    | DeliverListTidOp.CreateWriteTmp data => createwrite_core data
    | DeliverListTidOp.UnlinkTmp => Call (MailFSOp.UnlinkTmp)
    | DeliverListTidOp.Lock => Call (MailFSOp.Lock)
    | DeliverListTidOp.Unlock => Call (MailFSOp.Unlock)
    | DeliverListTidOp.Ext extop => Call (MailFSOp.Ext extop)
    end.

  (* END CODE *)

  Theorem compile_op_no_atomics :
    forall `(op : _ T),
      no_atomics (compile_op op).
  Proof.
    destruct op; compute; eauto.

    constructor; eauto.
    destruct x; eauto.
  Qed.

  Ltac step_inv :=
    match goal with
    | H : MailFSAPI.step _ _ _ _ _ _ |- _ =>
      inversion H; clear H; subst; repeat sigT_eq
    | H : MailFSAPI.xstep _ _ _ _ _ _ |- _ =>
      inversion H; clear H; subst; repeat sigT_eq
    | H : DeliverListTidAPI.step _ _ _ _ _ _ |- _ =>
      inversion H; clear H; subst; repeat sigT_eq
    end; intuition idtac.

  Hint Extern 1 (MailFSAPI.step _ _ _ _ _ _) => econstructor.
  Hint Extern 1 (DeliverListTidAPI.step _ _ _ _ _ _) => econstructor.
  Hint Constructors MailFSAPI.xstep.

  Lemma gettid_right_mover :
    right_mover
      MailFSAPI.step
      (MailFSOp.GetTID).
  Proof.
    unfold right_mover; intros.
    repeat step_inv; eauto 10.

    eexists; split; econstructor; eauto.
  Qed.

  Hint Resolve gettid_right_mover.

  Lemma fmap_mapsto_tid_ne :
    forall (tid0 tid1 : nat) (x y : nat) TV (v v0 : TV) m,
      tid0 <> tid1 ->
      FMap.MapsTo (tid0, x) v0 (FMap.add (tid1, y) v m) ->
      FMap.MapsTo (tid0, x) v0 m.
  Proof.
    intros.
    eapply FMap.mapsto_add_ne; eauto.
    congruence.
  Qed.

  Hint Resolve fmap_mapsto_tid_ne.

  Lemma createtmp_right_mover :
    right_mover
      MailFSAPI.step
      (MailFSOp.CreateTmp).
  Proof.
    unfold right_mover; intros.
    repeat step_inv; eauto 10.

    all: unfold MailFSAPI.step.
    all: try solve [ rewrite FMap.add_add_ne by congruence; eauto 10 ].

    rewrite FMap.add_add_ne by congruence.
      eexists. split. 2: eauto. eauto.

    rewrite <- FMap.add_remove_ne by congruence.
      eexists. split. 2: eauto. eauto.

    eexists. split. 2: eauto. eauto.
  Qed.

  Hint Resolve createtmp_right_mover.

  Theorem ysa_movers_listtid_core:
    ysa_movers MailFSAPI.step listtid_core.
  Proof.
    econstructor; eauto 20.
  Qed.

  Hint Resolve ysa_movers_listtid_core.

  Theorem ysa_movers_createwrite_core:
    forall data,
      ysa_movers MailFSAPI.step (createwrite_core data).
  Proof.
    econstructor; eauto 20.
    destruct r; eauto 20.
  Qed.

  Hint Resolve ysa_movers_createwrite_core.

  Theorem ysa_movers : forall `(op : _ T),
    ysa_movers MailFSAPI.step (compile_op op).
  Proof.
    destruct op; simpl; eauto 20.
  Qed.

  Theorem compile_correct :
    compile_correct compile_op MailFSAPI.step DeliverListTidAPI.step.
  Proof.
    unfold compile_correct; intros.
    destruct op.

    all: try solve [ repeat atomic_exec_inv; repeat step_inv; eauto ].

    - repeat atomic_exec_inv; repeat step_inv; eauto.
      rewrite FMap.add_add; eauto.
      rewrite FMap.add_add; eauto.

    - repeat atomic_exec_inv.
      repeat step_inv; eauto.
      econstructor; intros.

      eapply in_map_iff.
      exists (v1, fn); intuition eauto.
      eapply filter_In; intuition eauto.
      eapply FMap.is_permutation_in'; eauto.
      unfold same_tid; simpl.
      destruct (v1 == v1); congruence.
  Qed.

  Definition initP_compat : forall s, MailFSAPI.initP s ->
                                 DeliverListTidAPI.initP s :=
    ltac:(auto).

End MailFSImpl'.

Module MailFSImpl :=
  LayerImplMovers
    MailboxTmpAbsState
    MailFSOp MailFSAPI
    DeliverListTidOp DeliverListTidAPI
    MailFSImpl'.

Module MailFSImplH' :=
  LayerImplMoversHT
    MailboxTmpAbsState
    MailFSOp MailFSAPI
    DeliverListTidOp DeliverListTidAPI
    MailFSImpl'
    UserIdx.

Module MailFSImplH :=
  LayerImplMovers
    MailboxTmpAbsHState
    MailFSHOp MailFSHAPI
    DeliverListTidHOp DeliverListTidHAPI
    MailFSImplH'.


(**************************  uc/OS-II  ****************************)
(*************************** OS_SEM.C *****************************)
(******Proof of API Fucntion: int8u OSSemPost(OS_EVENT* pevent) ***)
(***************************** Code: ******************************)
(***
Definition OSSemPost_impl :=
Int8u ·OSSemPost·(⌞pevent @ OS_EVENT∗⌟)··{
       ⌞
         legal @ Int8u;
         x  @ Int8u
       ⌟;

 1        If (pevent′ ==ₑ NULL){
 2            RETURN (OSSemPost) ′OS_ERR_PEVENT_NULL
        };ₛ
 3        ENTER_CRITICAL;ₛ
 4        legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
 5       If (legal′ ==ₑ ′0){
 6           EXIT_CRITICAL;ₛ
 7           RETURN (OSSemPost) ′OS_ERR_PEVENT_NULL
        };ₛ
 8      If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_SEM){
 9           EXIT_CRITICAL;ₛ
10           RETURN (OSSemPost) ′OS_ERR_PEVENT_NULL
        };ₛ
11       If (pevent′→OSEventGrp !=ₑ ′0){
12           x′ =ₑ ′OS_STAT_SEM;ₛ
13           OS_EventTaskRdy(pevent′, (void * )NULL, x′);ₛ
14           EXIT_CRITICAL;ₛ
15           OS_Sched();ₛ
16           RETURN (OSSemPost) ′OS_NO_ERR
        };ₛ
17       If (pevent′→OSEventCnt <ₑ ′65535){
18           pevent′→OSEventCnt =ₑ pevent′→OSEventCnt +ₑ ′1;ₛ
19           EXIT_CRITICAL;ₛ
20           RETURN (OSSemPost) ′OS_NO_ERR
        };ₛ
21       EXIT_CRITICAL;ₛ
22       RETURN (OSSemPost) ′OS_SEM_OVF
}·.

***)
Require Import sem_common.
Require Import sempend_pure.
Require Import sempost_pure.
Open Scope code_scope.

(* use this old hoare_if to avoid large modification *)
Ltac lzh_find_ret_stmt stmts :=
  match stmts with
    | sseq ?s ?rs =>
      match s with
        | srete _ => constr:(some 1%nat)
        | _ => lzh_find_ret_stmt rs
      end
    | srete _ => constr:(some 1%nat)
    | _ => constr:(none 1%nat)
  end.

Ltac lzh_hoare_if :=
  lzh_hoare_unfold;
  hoare forward;
  match goal with
    | |- {|_, _, _, _, _, _|} |- ?ct {{?p ** [|?v <> Vint32 Int.zero /\
                                       ?v <> Vnull /\
                                       ?v <> Vundef|]}} ?stmts {{_}} =>
      (* ** ac: idtac "if block proof"; *)
      let x := lzh_find_ret_stmt stmts in
        match x with
          | some _ => instantiate (1:=Afalse)
          | none _ => idtac
        end;
      hoare_split_pure_all;
      lzh_val_inj_simpl; tryfalse

    | |- {|_, _, _, _, _, _|} |- ?ct {{_}} _ {{_}} =>
      (* ** ac: idtac "if all"; *)
      hoare forward;
      hoare_split_pure_all;
      lzh_val_inj_simpl; tryfalse
      (* first proof if-true condition, then proof if-false condition *)
    | _ => pauto
  end.

Hint Resolve noabs_oslinv.
Hint Extern 2 (_ <= _) => apply Z.leb_le; trivial.

Lemma sempost_part_0: forall
  (tid : tid)
  (v' : val)
  (v'0 : val)
  (v'1 : list vallist)
  (v'2 : list vallist)
  (v'3 : list vallist)
  (v'4 : list EventData)
  (v'5 : list os_inv.EventCtr)
  (v'6 : vallist)
  (v'7 : val)
  (v'8 : val)
  (v'9 : list vallist)
  (v'10 : vallist)
  (v'11 : list vallist)
  (v'12 : vallist)
  (v'13 : val)
  (v'14 : EcbMod.map)
  (v'15 : TcbMod.map)
  (v'16 : int32)
  (v'17 : addrval)
  (v'18 : val)
  (v'19 : list vallist)
  (H : RH_TCBList_ECBList_P v'14 v'15 tid)
  (H0 : RH_CurTCB tid v'15)
  (v'22 : list os_inv.EventCtr)
  (v'23 : list os_inv.EventCtr)
  (v'24 : list EventData)
  (v'25 : list EventData)
  (v'27 : vallist)
  (v'28 : val)
  (v'29 : val)
  (v'30 : list vallist)
  (v'31 : vallist)
  (v'32 : list vallist)
  (v'33 : vallist)
  (v'34 : val)
  (v'35 : EcbMod.map)
  (v'36 : TcbMod.map)
  (v'38 : val)
  (v'40 : vallist)
  (v'42 : val)
  (v'43 : EcbMod.map)
  (v'44 : EcbMod.map)
  (v'45 : EcbMod.map)
  (v'47 : addrval)
  (H4 : ECBList_P v'42 Vnull v'23 v'25 v'44 v'36)
  (H18 : EcbMod.join v'43 v'45 v'35)
  (H8 : RH_TCBList_ECBList_P v'35 v'36 tid)
  (H9 : RH_CurTCB tid v'36)
  (H13 : length v'22 = length v'24)
  (H17 : isptr v'42)
  (H10 : $ 1 <> $ 0)
  (v'20 : addrval)
  (v'26 : block)
  (H12 : array_type_vallist_match Int8u v'40)
  (H20 : length v'40 = ∘ OS_EVENT_TBL_SIZE)
  (x2 : val)
  (x3 : val)
  (i : int32)
  (H22 : Int.unsigned i <= 255)
  (i1 : int32)
  (H23 : Int.unsigned i1 <= 65535)
  (H24 : isptr x2)
  (H19 : RL_Tbl_Grp_P v'40 (Vint32 i))
  (H25 : isptr v'42)
  (H3 : ECBList_P v'38 (Vptr (v'26, Int.zero)) v'22 v'24 v'43
         v'36)
  (H1 : isptr (Vptr (v'26, Int.zero)))
  (H15 : id_addrval' (Vptr (v'26, Int.zero)) OSEventTbl OS_EVENT =
        Some v'20)
  (H21 : Int.unsigned ($ OS_EVENT_TYPE_SEM) <= 255)
  (H6 : R_ECB_ETbl_P (v'26, Int.zero)
         (V$ OS_EVENT_TYPE_SEM
          :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: v'42 :: nil,
         v'40) v'36)
  (x : waitset)
  (H7 : EcbMod.joinsig (v'26, Int.zero) (abssem i1, x) v'44 v'45)
  (Hget : EcbMod.get v'35 (v'26, Int.zero) = Some (abssem i1, x))
  (H2 : ECBList_P v'38 Vnull
         (v'22 ++
          ((V$ OS_EVENT_TYPE_SEM
            :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: v'42 :: nil,
           v'40) :: nil) ++ v'23)
         (v'24 ++ (DSem i1 :: nil) ++ v'25) v'35 v'36)
  (H5 : RLH_ECBData_P (DSem i1) (abssem i1, x))
  (H11 : Int.eq i ($ 0) = false)
(* ================================= *) ,
   {|OS_spec, GetHPrio, OSLInv, I,
   fun v : option val =>
   ( <|| END v ||>  **
    p_local OSLInv tid init_lg **
    ((EX v0 : val, LV pevent @ OS_EVENT ∗ |-> v0) **
     (EX v0 : val, LV legal @ Int8u |-> v0) **
     (EX v0 : val, LV os_code_defs.x @ Int8u |-> v0) ** Aemp) **
    Aie true ** Ais nil ** Acs nil ** Aisr empisr) **
   A_dom_lenv
     ((pevent, OS_EVENT ∗)
      :: (legal, Int8u) :: (os_code_defs.x, Int8u) :: nil),
   Afalse|}|- tid
   {{AEventData
       (V$ OS_EVENT_TYPE_SEM
        :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: v'42 :: nil)
       (DSem i1) **
     Astruct (v'26, Int.zero) OS_EVENT
       (V$ OS_EVENT_TYPE_SEM
        :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: v'42 :: nil) **
     Aarray v'20 (Tarray Int8u ∘ OS_EVENT_TBL_SIZE) v'40 **
     Aie false **
     Ais nil **
     Acs (true :: nil) **
     Aisr empisr **
     GV OSEventList @ OS_EVENT ∗ |-> v'38 **
     evsllseg v'38 (Vptr (v'26, Int.zero)) v'22 v'24 **
     evsllseg v'42 Vnull v'23 v'25 **
     A_isr_is_prop **
     AOSTCBList v'28 v'29 v'30 (v'31 :: v'32) v'33 tid v'36 **
     tcbdllflag v'28 (v'30 ++ v'31 :: v'32) **
     AOSRdyTblGrp v'33 v'34 **
     AOSTCBPrioTbl v'27 v'33 v'36 v'47 **
     HECBList v'35 **
     HTCBList v'36 **
     HCurTCB tid **
      <|| sem_post (Vptr (v'26, Int.zero) :: nil) ||>  **
     p_local OSLInv tid init_lg **
     LV legal @ Int8u |-> (V$ 1) **
     AOSEventFreeList v'1 **
     AOSQFreeList v'2 **
     AOSQFreeBlk v'3 **
     AOSMapTbl **
     AOSUnMapTbl **
     AOSIntNesting **
     AOSTCBFreeList v'18 v'19 **
     AOSTime (Vint32 v'16) **
     HTime v'16 **
     AGVars **
     atoy_inv' **
     LV os_code_defs.x @ Int8u |-> v'0 **
     LV pevent @ OS_EVENT ∗ |-> Vptr (v'26, Int.zero) **
     A_dom_lenv
       ((pevent, OS_EVENT ∗)
        :: (legal, Int8u) :: (os_code_defs.x, Int8u) :: nil)}}
   os_code_defs.x ′ =ₑ ′ OS_STAT_SEM;ₛ
   OS_EventTaskRdy (pevent ′, 〈 (Void) ∗ 〉 pevent ′,
   os_code_defs.x ′);ₛ
   EXIT_CRITICAL;ₛ
   OS_Sched ();ₛ
   RETURN ′ OS_NO_ERR {{Afalse}}
.
Proof.
  intros.
  hoare forward.

  hoare_unfold.
  unfold AOSTCBPrioTbl.
  unfold AOSTCBList.
  hoare_split_pure_all.
  destruct H14; subst v'29.

(****************************** L2: event_task_rdy ******************************)
  destruct H28.
  hoare forward.

  unfold_msg.
  sep cancel AEventData.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel Aie.
  sep cancel Ais.
  sep cancel Acs.
  sep cancel Aisr.
  sep cancel 1%nat 1%nat.
  sep cancel AOSRdyTblGrp.
  instantiate (2:= (v'30 ++ v'31 :: v'32)).
  eapply tcbdllseg_compose.
  sep cancel tcbdllseg.
  sep cancel tcbdllseg.
  sep pauto.

  eauto.
  unfold V_OSEventGrp; simpl.
  auto.
  pauto.
  pauto.
  split; auto.
  struct_type_match_solver.

  split.
  unfold V_OSEventGrp; simpl; eauto.
  lzh_simpl_int_eq. auto.
  simpl; eauto.
  simpl; eauto.
  pure_auto.

  Require Import tcblist_setnode_lemmas.

  (* ** ac: SearchAbout TCBList_P. *)
  Import OSQPostPure.
  (* ** ac: Locate tcbdllseg_get_last_tcb_ptr. *)
  (* ** ac: Check tcbdllseg_get_last_tcb_ptr. *)

  eapply TCBList_P_Combine.
  eapply tcbdllseg_get_last_tcb_ptr.
  instantiate (5:=s).
  sep cancel 3%nat 1%nat.
  sep pauto.
  2:eauto.
  2:eauto.
  eauto.

  eauto.
  eauto.
  eauto.

  eapply tcbdllseg_combine_ptr_in_tcblist.
  instantiate (7:=s).
  sep cancel tcbdllseg.
  sep cancel tcbdllseg.
  eauto.

  pure_auto.
  pure_auto.

  intros.
  sep auto.

  intros.
  sep auto.

  (** event task rdy precondition finished **)
  Set Printing Depth 500.
  hoare unfold.

  inverts H62.

  (** renameing **)
  rename v'26 into pevent_addr.
  rename tid into ctcb.
  rename v'90 into htcb_addr. (** highest tcb in pevent waitlist **)
  rename H35 into Hhtcb.
  rename H56 into Hctcb_in_tcblist.
  rename v'66 into tcblist_head.
  rename v'30 into tcblist_seg1.
  rename v'31 into ctcb_node.
  rename v'32 into tcblist_seg2.
  rename H39 into Hrel_et.

  (* ** ac: Print prio_in_tbl. *)
  rename v'53 into rtbl.
  (* ** ac: Print TCBList_P. *)

  rename v'49 into tcbls.
  rename v'39 into tcbls1.
  rename v'41 into tcbls2.
  (** tcbls = tcbls1 ++ tcbls2, tcbls2 = cur_node ++ tcbls2' **)

  remember (tcblist_seg1 ++ ctcb_node :: tcblist_seg2) as tcblist.

  (* ** ac: Check absimp_sem_post_ex_wt_succ_return. *)
  (* ** ac: Print GetHWait. *)

  (* ** ac: Locate post_exwt_succ_pre_sem. *)
  (* ** ac: Check post_exwt_succ_pre_sem. *)

  (* ** ac: Print priority. *)
  (* ** ac: Print rel_edata_tcbstat. *)
  (* ** ac: Print GetHWait. *)
  rename v'85 into hprio.
  assert (exists hprio', hprio = Vint32 hprio').
  {
    clear - H66. (** struct_type_vallist_match **)
    (* ** ac: SearchAbout struct_type_vallist_match. *)
    (* ** ac: Print struct_type_vallist_match. *)
    rename H66 into H.
    unfold struct_type_vallist_match in H.
    unfold OS_TCB_flag in H.
    unfold struct_type_vallist_match' in H.
    mytac.
    clear - H5.
    (* ** ac: SearchAbout (rule_type_val_match Int8u _). *)
    apply rule_type_val_match_int8u_elim in H5.
    mytac.
  }

  destruct H33.
  subst hprio.
  rename x0 into hprio.

  rename v'79 into hnext.
  rename v'86 into htcbx.
  rename v'87 into htcby.
  rename v'88 into hbitx.
  rename v'89 into hbity.

  (* ** ac: Check tcblist_get_TCBList_P_get. *)
  (* ** ac: Check sem_post_get_tcb_stat. *)
  (* ** ac: Check rh_tcblist_ecblist_p_post_exwt_aux_sem. *)
  (* ** ac: Check rh_tcblist_ecblist_p_post_exwt_sem. *)
  assert (Hhtcb_get: exists st m, get tcbls (htcb_addr, Int.zero) = Some (hprio, st, m)).
  {
    eapply tcblist_get_TCBList_P_get.
    eauto.
    pure_auto.
    eauto.
  }

  destruct Hhtcb_get as (st & msg & Hhtcb_get).

  assert (Hs1: Int.unsigned v'73 <= 7).
  {
    (* ** ac: Check osunmapvallist_prop. *)
    clear - H40 H22.
    apply osunmapvallist_prop in H22.
    mytac.
    rewrite H in H40.
    inverts H40.
    pure_auto.
  }

  assert (Hs2: Int.unsigned v'74 <= 255).
  {
    (* ** ac: Check array_int8u_nth_lt_len. *)
    clear - H41 Hs1 H52 H20.
    assert (Z.to_nat (Int.unsigned v'73) < length v'59)%nat.
    {
      rewrite H20; unfold OS_EVENT_TBL_SIZE.
      mauto.
    }
    lets Hx: array_int8u_nth_lt_len H52 H.
    mytac.
    rewrite H41 in H0.
    inverts H0.
    auto.
  }

  assert (Hs3: Int.unsigned v'72 <= 7).
  {
    clear - H42 Hs2.
    lets Hx: osunmapvallist_prop Hs2.
    mytac.
    rewrite H in H42; inverts H42.
    pure_auto.
  }

  rename x into pwls.
  (* ** ac: Check post_exwt_succ_pre_sem. *)
  generalize Hhtcb_get; intro Hhtcb_join.
  apply map_join_get_sig in Hhtcb_join.
  destruct Hhtcb_join as (tcbls' & Hhtcb_join).
  assert (Hpre: pwls <> nil /\ GetHWait tcbls pwls (htcb_addr, Int.zero) /\ TcbMod.get tcbls (htcb_addr, Int.zero) = Some (hprio, st, msg) /\ hprio = ((v'73<<ᵢ$ 3) +ᵢ  v'72)).
  {
    apply map_join_get_sig in Hhtcb_get.
    destruct Hhtcb_get.
    (* ** ac: Check post_exwt_succ_pre_sem. *)
    apply semacc_int_eq_false in H11.
    eapply post_exwt_succ_pre_sem; eauto.
  }

  (* ** ac: Print GetHWait. *)
  (* ** ac: Print PrioWaitInQ. *)
  (* ** ac: Check post_exwt_succ_pre_sem. *)
  (* ** ac: Locate post_exwt_succ_pre_sem. *)
  destruct Hpre as [ ? [? [? ?]]].
  subst hprio.

  hoare_abscsq.
  auto.

  eapply absimp_sem_post_ex_wt_succ_return.
  can_change_aop_solver.
  eauto.
  eauto.
  eauto.
  eauto.

  unfold AEventData.
  unfold_msg.
  hoare_split_pure_all.
  destruct H37.
  inverts H37.
  rename v'28 into pevent_addr.

  unfolds in H45; simpl in H45; inverts H45.
  (* ** ac: Check sem_post_get_tcb_stat. *)
  rename v'59 into etbl.

  rename H61 into Htcblist_p.
  lets Hhtcb_node: TCBList_P_tcblist_get_TCBNode_P Htcblist_p Hhtcb Hhtcb_get.
  generalize Hhtcb_node; intro Htmp.
  unfolds in Htmp.
  mytac.
  inverts H37; inverts H45.
  rename H53 into Hh_tcbblk.
  rename H54 into Hh_tcbstat.
  unfolds in Hh_tcbblk.
  mytac.
  inverts H37.
  inverts H56; inverts H72; inverts H53; inverts H55; inverts H45; inverts H54.

  rename v'73 into p1.
  rename v'72 into p2.
  remember ((p1<<ᵢ$ 3) +ᵢ  p2) as hprio.

  (* ** ac: Check sem_post_get_tcb_stat. *)

  assert (Hx: x6 = $ OS_STAT_SEM).
  {
    clear - Hrel_et.
    unfolds in Hrel_et.
    auto.
  }
  subst x6.

  assert (Hp1: (hprio >>ᵢ $ 3) =  p1).
  {
    subst hprio.
    clear - Hs1 Hs2 Hs3.
    clear Hs2.
    mauto.
  }

  assert (Hp2: hprio &ᵢ ($ 7) = p2).
  {
    subst hprio.
    clear - Hs1 Hs3.
    mauto.
  }

  assert (Hs4: Int.unsigned v'91 <= 255).
  {
    clear - Hs1 H32 H64 H49.
    assert (Z.to_nat (Int.unsigned p1) < length rtbl)%nat.
    {
      rewrite H64.
      unfold OS_RDY_TBL_SIZE.
      mauto.
    }
    lets Htmp: array_int8u_nth_lt_len H49 H.
    mytac.
      rewrite H32 in H0.
      inverts H0.
      auto.
  }

  (* ** ac: Check set_node_elim_hoare. *)

  assert (Htmp: v'75 = $ 1 <<ᵢ p2).
  {
    eapply math_mapval_core_prop.
    clear - Hs3.
    mauto.
    auto.
  }
  subst v'75.

  assert (Hno_dup: R_Prio_No_Dup tcbls).
  {
    clear - H30.
    unfolds in H30.
    mytac.
  }
  (** zhang hui's lemma **)
  hoare lift 19%nat pre.
  (* ** ac: Check set_node_elim_hoare. *)
  eapply set_node_elim_hoare with (tid:=ctcb) (tcbls:=tcbls); eauto.
  {
    eapply TCBNode_P_set_rdy; auto.
    3:eauto.

    rewrite Hp1.
    apply nth_val'2nth_val; eauto.

    auto.
  }
  {
    unfolds.
    rewrite Hp1.
    rewrite Hp2.
    do 2 eexists.
    splits; eauto.
  }
  {
    unfolds.
    unfold V_OSTCBNext , V_OSTCBPrev.
    simpl.
    auto.
  }

(************************* exit critical ***********************************)
  instantiate (1 := (pevent_addr, Int.zero)).
  hoare_split_pure_all.
  subst hprio.
  rewrite Hp1 in *.
  rewrite Hp2 in *.
  hoare forward prim.
  sep normal.
  sep eexists.
  sep cancel AOSEventFreeList.
  sep cancel AOSQFreeList.
  sep cancel AOSQFreeBlk.
  sep cancel AOSMapTbl.
  sep cancel AOSUnMapTbl.
  sep cancel AOSIntNesting.
  sep cancel AOSTCBFreeList.
  sep cancel AOSTime.
  sep cancel AGVars.
  sep cancel A_isr_is_prop.
  sep cancel 5%nat 5%nat.
  sep cancel 5%nat 5%nat.
  sep cancel 5%nat 5%nat.
  sep cancel 5%nat 5%nat.
  sep split; auto.
  sep cancel 5%nat 6%nat.
  sep cancel atoy_inv'.
  sep cancel AOSRdyTblGrp.

  (** AECBList **)
  unfold AECBList.
  sep normal.
  sep eexists.
  sep cancel 11%nat 1%nat.
  eapply lzh_evsllseg_compose.
  sep cancel evsllseg.
  sep cancel evsllseg.
  unfold AEventNode.
  unfold_msg.
  sep normal.
  sep eexists.
  sep split; auto.
  sep cancel Astruct.
  sep cancel Aarray.
  instantiate (13 := DSem i1).
  unfold AEventData.
  sep split; auto.

  (** AOSTCBPrioTbl **)
  unfold AOSTCBPrioTbl.
  sep normal.
  sep eexists.
  sep split; auto.
  sep cancel 5%nat 1%nat.
  sep cancel 4%nat 1%nat.
  sep cancel 8%nat 1%nat.

  (** AOSTCBList **)
  unfold AOSTCBList.
  sep normal.
  sep eexists.
  sep split; auto.
  sep cancel 4%nat 1%nat.
  sep cancel tcbdllseg.
  sep cancel 3%nat 1%nat.
  sep cancel tcbdllseg.

  (** tcbdllflag **)
  {
    sep lift 3%nat in H55.
    unfold AEventData in H55.
    eapply tcbdllflag_set_node in H55; eauto.
    unfolds; simpl; auto.
  }

  (** TCBList_P **)
  eauto.
  eauto.
  eauto.
  split; auto.

  (** R_PrioTbl_P **)
  eapply r_priotbl_p_set_hold; auto; eauto.
  eauto.
  split; auto.

  clear - H23.
  int auto.

  (** ecblist_p **)
  (* ** ac: Locate ecblist_p_post_exwt_hold_sem. *)
  (* ** ac: Check ecblist_p_post_exwt_hold_sem. *)
  (* ** ac: Print RL_RTbl_PrioTbl_P. *)

  eapply ecblist_p_post_exwt_hold_sem with (v'12:=v'57) (v'39:=p2) (v'69:=v'74) (v'38:=p1) (v'13:=etbl) (v'36:=v'52); eauto.

  eapply rl_etbl_ptbl_p; auto; eauto.

  lzh_simpl_int_eq; auto.

  clear - Hs3.
  mauto.

  (* ** ac: SearchAbout RL_Tbl_Grp_P. *)
  eauto.

  go.
  go.
  go.
  split;auto.
  go.
  simpl.
  eauto.
  go.

  assert (Htmp: ctcb = (htcb_addr, Int.zero) \/ ctcb <> (htcb_addr, Int.zero)) by tauto.
  destruct Htmp.
  subst ctcb.
  unfolds.
  unfold get; simpl.
  rewrite TcbMod.set_a_get_a.
  eauto.
  apply tidspec.eq_beq_true; auto.
  eapply rh_curtcb_set_nct; auto.

  assert (exists xl,st = wait (os_stat_sem (pevent_addr, Int.zero)) xl).
  {
    eapply rh_tcblist_ecblist_p_post_exwt_aux_sem ;eauto.
    clear -H35.
    unfolds in H35;mytac;auto.
  }
  destruct H56.
  subst st.

  eapply rh_tcblist_ecblist_p_post_exwt_sem;eauto.
  (* ** ac: Check rh_tcblist_ecblist_p_post_exwt_sem. *)
  clear -H35.
  unfolds in H35;mytac;auto.

  unfold AEventData.
  pure_auto.

  hoare_split_pure_all.
  hoare forward.
  sep normal.
  sep eexists.
  sep cancel Aie.
  sep cancel Ais.
  sep cancel Acs.
  sep cancel Aisr.
  sep cancel 1%nat 1%nat.
  sep cancel 1%nat 2%nat.
  sep split; auto.
  exact_s.
  unfold isflag.
  auto.
  pure_auto.
  intros.
  sep eexists.
  sep destruct H68.
  sep cancel 7%nat 1%nat.
  sep auto.

  intros.
  sep destruct H68.
  sep lift 7%nat in H68.
  sep eexists.
  sep cancel 1%nat 1%nat.
  sep auto.

  hoare unfold.
  inverts H68.
  hoare forward.
  sep cancel 5%nat 1%nat.
  sep cancel 5%nat 1%nat.
  sep normal.
  sep eexists.
  sep cancel Aie.
  sep cancel Ais.
  sep cancel Acs.
  sep cancel Aisr.
  exact_s.

  Grab Existential Variables.
  auto.
  auto.
  auto.
Qed.

Lemma OSSemPostProof:
  forall tid vl p r,
    Some p =
    BuildPreA' os_api OSSemPost
               sem_postapi vl OSLInv tid init_lg ->
    Some r =
    BuildRetA' os_api OSSemPost
               sem_postapi vl OSLInv tid init_lg ->
    exists t d1 d2 s,
      os_api OSSemPost = Some (t, d1, d2, s) /\
      {|OS_spec, GetHPrio, OSLInv, I, r, Afalse|} |- tid {{p}} s {{Afalse}}.
Proof.
  init_spec.

  (* L1 - L2 *)
  lzh_hoare_if.
  hoare abscsq.
  auto.
  eapply absimp_sem_post_null_return; pure_auto.
  hoare forward.

  (* L3 *)
  hoare forward prim.

  (* L4 *)
  hoare_unfold.
  hoare forward.

  sep cancel Aie.
  sep cancel Ais.
  sep cancel Aisr.
  sep cancel Acs.
  sep cancel tcbdllflag.
  sep cancel AECBList.
  sep cancel AOSRdyTblGrp.
  sep cancel AOSTCBList.
  sep cancel AOSTCBPrioTbl.
  sep pauto.
  pure_auto.
  pure_auto.

  apply retpost_osev.
  intros.
  sep pauto.
  sep destruct H2.
  (* ** ac: Check disj_star_elim. *)
  (* ** ac: SearchAbout (_ \\// _). *)
  apply adisj_elim in H2.
  destruct H2.
  sep auto.
  sep auto.

  intros.
  sep auto.

  hoare_split_pure_all.
  unfold OS_EventSearchPost.
  unfold OS_EventSearchPost'.
  unfold getasrt. (* getasrt is meaning of notation PRE *)
  eapply backward_rule1.
  intros.
  eapply disj_star_elim; eauto.

  (* 由于os_eventsearch(pevent)可能找到，也可能找不到，所以，这里就天然的要分成两种情况 *)
  hoare forward.
(************************************  legal == 0 **********************************)
  Focus 2. (* proof legal == 0 branch first *)
  lzh_hoare_if.
  pure_auto.
  inverts H6.
  hoare abscsq.
  auto.
  eapply absimp_sem_post_p_not_legal_return; pauto.

  hoare forward prim.
  sep pauto.
  pure_auto.
  hoare forward.
(**********************************************************************************)
(***********************************  legal == 1 **********************************)
  lzh_hoare_if.
  pure_auto.
  inverts H16.
  lets Hget: eventsearch_after_get_H H2 H7; eauto.

  lzh_hoare_if.
  pure_auto.
  pure_auto.
  pure_auto.

  transform_pre sem_eventtype_neq_sem ltac:(sep cancel AEventData).
  hoare_split_pure_all.
  hoare abscsq.
  auto.
  eapply absimp_sem_post_wrong_type_return; pauto.

  (*********  exit critical ***********)
  fold_AEventNode_r.
  compose_evsllseg.
  fold_AECBList.

  hoare forward prim.
  exact_s.
  pauto.
  hoare forward.
(*******************************  type != sem finished **********************)
(*******************************  type = sem ********************************)
  lzh_simpl_int_eq.
  subst.
  transform_pre semacc_triangle_sem ltac:(sep cancel AEventData).
  hoare_split_pure_all.
  destruct H11 as [? [? ?]]. subst.

  hoare_unfold.
  lzh_hoare_if.
  pure_auto.
  pure_auto.
  pure_auto.
(************************** Grp = 0, no task wait ************************)
  Focus 2.
  lzh_hoare_if.
  pure_auto.
  pure_auto.

  lzh_simpl_int_eq.
  unfold AOSTCBPrioTbl.
  hoare_split_pure_all.
  assert (Hnil : x = nil).
  {
    lets Fnil: sempost_grp_wls_nil' H11 H6; eauto.
  }
  subst x.
  hoare forward.
  (* pure_auto. *)
  struct_type_match_solver.
  (* pure_auto. *)

  hoare abscsq.
  auto.
  eapply absimp_sem_post_put_sem_return; pauto.

  transform_pre sempost_inc_cnt_prop ltac:(sep cancel AEventData).
  hoare_split_pure_all.
  clear H5 H6.

  hoare forward prim.
  unfold AECBList.
  sep pauto.
  eapply lzh_evsllseg_compose.
  sep cancel evsllseg.
  sep cancel evsllseg.
  unfold AEventNode.
  sep cancel AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto; eauto.
  sep cancel Astruct.
  sep cancel Aarray.
  unfold AOSTCBPrioTbl.
  sep pauto.
  sep cancel 2%nat 1%nat.
  sep pauto.
  auto.
  auto.

  split; [auto | apply sempost_struct_type_vallist_match_sem; auto (* struct_type_vallist_match *)].
  unfolds; simpl.
  auto.
  eauto.
  eauto.

  lets Hnewjoin: ecb_get_set_join_join Hget H7 H18.
  destruct Hnewjoin as [? [? ?]].
  eapply semacc_compose_EcbList_P; eauto.

  eapply sempost_inc_RH_TCBList_ECBList_P_hold; eauto.
  pauto.
  hoare forward.

(********************** cnt = 65535, overflow! ************************)
  lzh_simpl_int_eq.
  unfold AOSTCBPrioTbl.
  hoare_split_pure_all.
  assert (Hnil : x = nil).
  {
    lets Fnil: sempost_grp_wls_nil' H11 H6; eauto.
  }
  subst x.
  hoare abscsq.
  auto.
  eapply absimp_sem_post_ovf_err_return; pauto.

  fold_AEventNode_r.
  compose_evsllseg.
  fold_AECBList.

  hoare forward prim.
  unfold AOSTCBPrioTbl.
  sep pauto.
  pauto.
  hoare forward.
(**************** trivial cases are all finished! ***********************)
  eapply sempost_part_0; eauto.
Qed.


Require Export Coercion_Infrastructure.
Require Import Classical.
Set Undo 100000.

Definition WF_no_fun_pair r sigma := forall pi pi' t1 t2 s1 s2 a m1 m2,
  (In (typ_fun t1 t2) pi) ->
  (In (typ_pair s1 s2) pi') ->
  ((~ (coercion sigma pi a (typ_fun t1 t2) r (typ_pair s1 s2)) m1) /\
   (~ (coercion sigma pi' a (typ_pair s1 s2) r (typ_fun t1 t2)) m2)).

Definition no_unnecessary_fun_subtyping_path (sigma:Sigma) : Prop := forall t t' t1 t2 C C' theta a,
  In t theta ->
  (coercion sigma theta a t RelPrim t' C) ->
  (coercion sigma theta a t RelPrim (typ_fun t1 t2) C') ->
  (forall s1 s2,
    (typ_fun t1 t2) <> (typ_fun s1 s2) ->
    (not ((exists C1, coerciongen sigma (typ_fun s1 s2) RelPrim t' C1) /\
      (exists C2, coerciongen sigma (typ_fun t1 t2) RelSub (typ_fun s1 s2) C2)))).

Definition no_unnecessary_pair_subtyping_path (sigma:Sigma) : Prop := forall t t' t1 t2 C C' theta a,
  In t theta ->
  (coercion sigma theta a t RelPrim t' C) ->
  (coercion sigma theta a t RelPrim (typ_pair t1 t2) C') ->
  (forall s1 s2,
    (typ_pair t1 t2) <> (typ_pair s1 s2) ->
    (not ((exists C1, coerciongen sigma (typ_pair s1 s2) RelPrim t' C1) /\
      (exists C2, coerciongen sigma (typ_pair t1 t2) RelSub (typ_pair s1 s2) C2)))).

Definition no_multiple_fun_subtyping_paths (sigma:Sigma) : Prop := forall t t1 t2 s1 s2 s1' s2' C1 C2 C3 C4,
  (coerciongen sigma (typ_fun s1 s2) RelPrim t C1) ->
  (coerciongen sigma (typ_fun s1' s2') RelPrim t C2) ->
  (coerciongen sigma (typ_fun t1 t2) RelSub (typ_fun s1 s2) C3) ->
  (coerciongen sigma (typ_fun t1 t2) RelSub (typ_fun s1' s2') C4) ->
  (typ_fun s1 s2) = (typ_fun s1' s2').

Definition no_multiple_pair_subtyping_paths (sigma:Sigma) : Prop := forall t t1 t2 s1 s2 s1' s2' C1 C2 C3 C4,
  (coerciongen sigma (typ_pair s1 s2) RelPrim t C1) ->
  (coerciongen sigma (typ_pair s1' s2') RelPrim t C2) ->
  (coerciongen sigma (typ_pair t1 t2) RelSub (typ_pair s1 s2) C3) ->
  (coerciongen sigma (typ_pair t1 t2) RelSub (typ_pair s1' s2') C4) ->
  (typ_pair s1 s2) = (typ_pair s1' s2').

Definition no_fun_and_pair_subtyping_paths (sigma:Sigma) : Prop := forall t p1 p2 s1 s2 f1 f2 g1 g2 C1 C2 C3 C4,
  (coerciongen sigma (typ_pair p1 p2) RelPrim t C1) ->
  (coerciongen sigma (typ_fun f1 f2) RelPrim t C2) ->
  (coerciongen sigma (typ_pair s1 s2) RelSub (typ_pair p1 p2) C3) ->
  (coerciongen sigma (typ_fun g1 g2) RelSub (typ_fun f1 f2) C4) ->
  False.

(* Structural properties of coercion *)
Lemma coercion_sub_rel : forall sigma theta t t' C a,
  coercion sigma theta a t RelPrim t' C ->
  coercion sigma theta a t RelSub t' C.
Proof.
intros until 1. rename H into D_1.
induction D_1.
intros.
  eapply coercion_Id.
intros.
   eauto using coercion_PrimTrans.
intros.
   eauto using coercion_FunTrans.
intros.
   eauto using coercion_PairTrans.
Qed.

Lemma altnosub_to_altsub : forall sigma pi d t t' m a,
  coercion sigma pi a t d t' m ->
  coercion sigma pi AltSub t d t' m.
Proof.
intros. rename H into C_nosub.
induction C_nosub; eauto || discriminate.
Qed.

(* Cycle detection lemmas *)
Lemma cycles_are_identity : forall sigma theta t t' C a r,
  In t' theta ->
  coercion sigma theta a t r t' C ->
  (t = t' /\ C = (exp_lam t (exp_bvar 0))).
intros until 1. intro D.
induction D.
Case "Id".
  auto.
Case "PrimTrans".
destruct (IHD (in_cons _ _ _ H)) as [inTheta Ceq].
subst t2. contradiction.
Case "FunTrans".
destruct (IHD3 (in_cons _ _ _ H)) as [inTheta Ceq].
subst t'. contradiction.
Case "PairTrans".
destruct (IHD3 (in_cons _ _ _ H)) as [inTheta Ceq].
subst t'. contradiction.
Qed.

Hint Resolve in_eq in_cons in_inv in_nil insingleton.

Lemma coercion_between_distinct_types :
  forall sigma pi1 pi2 a a' t1 t2 s1 s2 m1 m2 d,
    (ok sigma) ->
    (coercion sigma pi1 a t1 d s1 m1) ->
    (In t1 pi1) ->
    (coercion sigma pi2 a' t2 d s2 m2) ->
    (In t2 pi2) ->
    ((t1 <> t2) \/ (s1 <> s2)) ->
    (m1 <> m2).
Proof.
intros until 1. rename H into ok_sigma. intros Cgen1 In_pi1 Cgen2 In_pi2 neq_disj.
generalize dependent pi2.
generalize dependent t2.
generalize dependent s2.
generalize dependent m2.
generalize dependent a'.
induction Cgen1.
Case "identity 1".
  intros. induction Cgen2; destruct neq_disj; try injection; eauto || discriminate.
Case "trans 1".
  intros.
  induction Cgen2; try solve [unfold compose; unfold funcompose; unfold paircompose; unfold not; intro; discriminate].
  SCase "trans 2".
    destruct neq_disj as [t1_neq_t0 | t3_neq_t5].
    SSCase "t1_neq_t0".
      assert (f <> f0). eauto.
      unfold compose. injection; intros; eauto.
    SSCase "t3 neq t5".
      assert (C<>C0).
        eapply IHCgen1; try apply (in_eq t4 pi0); eauto.
      unfold compose. injection; intros; eauto.
Case "funcompose". intros.
  induction Cgen2; try solve [unfold compose; unfold funcompose; unfold paircompose; unfold not; intro; discriminate].
    SSCase "funcompose".
    destruct neq_disj as [fneq | t'_neq_t'0].
       SSSCase "fneq".
         unfold compose; unfold not; intro. injection H1. intros. subst. eauto.
       SSSCase "t' <> t'0".
         clear IHCgen2_1 IHCgen2_2 IHCgen2_3.
         assert (C' <> C'0) as C'_neq.
             eapply IHCgen1_3. eauto. eauto. right. apply t'_neq_t'0. apply Cgen2_3. eauto.
         unfold compose; unfold not; intro. injection H1. intros. subst. eauto.
Case "pair". intros.
  induction Cgen2; try solve [unfold compose; unfold funcompose; unfold paircompose; unfold not; intro; discriminate].
    SSCase "funcompose".
    destruct neq_disj as [fneq | t'_neq_t'0].
       SSSCase "fneq".
         unfold compose; unfold not; intro. injection H1. intros. subst. eauto.
       SSSCase "t' <> t'0".
         clear IHCgen2_1 IHCgen2_2 IHCgen2_3.
         assert (C' <> C'0) as C'_neq.
             eapply IHCgen1_3. eauto. eauto. right. apply t'_neq_t'0. apply Cgen2_3. eauto.
         unfold compose; unfold not; intro. injection H1. intros. subst. eauto.
Qed.

Lemma identity_coercions_equate_types : forall sigma pi a d t1 t2 t3,
  coercion sigma pi a t1 d t2 (id t3) ->
  t1 = t2 /\ t2 = t3.
Proof.
  intros.
remember (id t3) as id_t3.
induction H; unfold id in Heqid_t3; try discriminate; injection Heqid_t3; intros; subst. eauto.
Qed.

Lemma identity_implies_equality : forall sigma pi a t d t' C,
  (In t pi) ->
  (coercion sigma pi a t d t' C) ->
  (C = id t) ->
  t = t'.
Proof.
intros. rename H into inPi. rename H0 into Cgen. rename H1 into Ceq.
induction Cgen; try solve [unfold id; unfold compose; unfold funcompose; unfold paircompose; simpl; eauto || discriminate].
Qed.

Lemma nonidentity_implies_inequality: forall sigma theta t t' C a d,
  (In t theta) ->
  (coercion sigma theta a t d t' C) ->
  C <> (id t) ->
  t <> t'.
Proof.
intros until 1. rename H into inTheta. intros D Cneq.
unfold id in Cneq.
induction D.
Case "coercion_Id".
destruct Cneq. auto.
Case "coercion_PrimTrans".
unfold not. intro t1eq.
subst t1.
destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ inTheta) D) as [t2Eqt3 CeqId].
subst t2. contradiction.
Case "funtrans".
destruct (classic (C1 = (id t1'))).
  SCase "C1 = id t1'".
    assert (t1' = t1). eauto using identity_implies_equality.
    subst.
    destruct (classic (C2 = (id t2))).
      SSCase "C2 = id t2".
        assert (t2=t2'). eauto using identity_implies_equality.
        subst. eauto. (* contradicts not in *)
      SSCase "C2 <> id".
        assert (t2 <> t2'). unfold id in *; eauto.
        unfold not. intro. subst.
        assert (In (typ_fun t1 t2) (typ_fun t1 t2'::pi)) as in_ext. eauto.
        destruct (cycles_are_identity _ _ _ _ _ _ _ in_ext D3) as [feq Ceq'].
        injection feq; intros. eauto.
   SCase "C2 <> id".
      assert (t1' <> t1). unfold id in *; eauto.
        unfold not. intro. subst.
        assert (In (typ_fun t1 t2) (typ_fun t1' t2'::pi)) as in_ext. eauto.
        destruct (cycles_are_identity _ _ _ _ _ _ _ in_ext D3) as [feq Ceq'].
        injection feq; intros. eauto.
Case "pairtrans".
destruct (classic (C1 = (id t1))).
  SCase "C1 = id t1'".
    assert (t1 = t1'). eauto using identity_implies_equality.
    subst.
    destruct (classic (C2 = (id t2))).
      SSCase "C2 = id t2".
        assert (t2=t2'). eauto using identity_implies_equality.
        subst. eauto. (* contradicts not in *)
      SSCase "C2 <> id".
        assert (t2 <> t2'). unfold id in *; eauto.
        unfold not. intro. subst.
        assert (In (typ_pair t1' t2) (typ_pair t1' t2'::pi)) as in_ext. eauto.
        destruct (cycles_are_identity _ _ _ _ _ _ _ in_ext D3) as [feq Ceq'].
        injection feq; intros. eauto.
   SCase "C2 <> id".
      assert (t1 <> t1'). unfold id in *; eauto.
        unfold not. intro. subst.
        assert (In (typ_pair t1 t2) (typ_pair t1' t2'::pi)) as in_ext. eauto.
        destruct (cycles_are_identity _ _ _ _ _ _ _ in_ext D3) as [feq Ceq'].
        injection feq; intros. eauto.
Qed.

Lemma inequality_implies_nonidentity: forall sigma theta t t' C a d,
  (In t theta) ->
  (t <> t') ->
  (coercion sigma theta a t d t' C) ->
  (forall s, C <> id s).
Proof.
intros until 1. rename H into inTheta. intros t_neq_t' Cgen.
induction Cgen; intros; try eauto; unfold compose; unfold id; discriminate.
Qed.

(* Other structural properties *)

Lemma relsub_derivations_use_subtyping_atmost_once:  forall sigma t t' C pi a,
  (WF_to_uniquefunc RelPrim sigma) ->
  (WF_to_uniquepair RelPrim sigma) ->
  (WF_no_fun_pair RelPrim sigma) ->
  (In t pi) ->
  (coercion sigma pi a t RelSub t' C) ->
  ((coercion sigma pi a t RelPrim t' C) \/
    (exists t1, exists t2, exists s1, exists s2, exists C1, exists C2, exists C3, exists pi',
      (typ_fun t1 t2) <> (typ_fun s1 s2) /\
      (In (typ_fun s1 s2) pi') /\
      (C1 = (id t) -> a = AltSub) /\ (* needed to strengthen IH *)
      (coercion sigma pi a t RelPrim (typ_fun t1 t2) C1) /\
      (coerciongen sigma (typ_fun t1 t2) RelSub (typ_fun s1 s2) C2) /\
      (coercion sigma pi' AltNoSub (typ_fun s1 s2) RelPrim t' C3)) \/
    (exists t1, exists t2, exists s1, exists s2, exists C1, exists C2, exists C3, exists pi',
      (typ_pair t1 t2) <> (typ_pair s1 s2) /\
      (In (typ_pair s1 s2) pi') /\
      (C1 = (id t) -> a = AltSub) /\ (* needed to strengthen IH *)
      (coercion sigma pi a t RelPrim (typ_pair t1 t2) C1) /\
      (coerciongen sigma (typ_pair t1 t2) RelSub (typ_pair s1 s2) C2) /\
      (coercion sigma pi' AltNoSub (typ_pair s1 s2) RelPrim t' C3))).
Proof.
intros until 1. rename H into WF_ufunc. intros WF_upair WF_no_fp tInPi cgenSub.
induction cgenSub.
Case "cgenSub is C-Id".
left. unfold coerciongen. eapply coercion_Id.
Case "cgenSub is C-PrimTrans".
assert (In t2 (t2::pi)) as inT2.  eapply in_eq.
pose proof (IHcgenSub WF_ufunc WF_upair WF_no_fp inT2) as fromIH.
clear IHcgenSub.
destruct fromIH as [relprim | [relsubFun | relsubPair]].
  SCase "relprim".
  left.
  eapply coercion_PrimTrans; eauto.
  SCase "relsub fun".
  right. left.
  destruct relsubFun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [aalt [Ineq [ inTheta [D2_2_1 [D2_2_2 D2_2_3]]]]]]]]]]]]].
  exists T1. exists T2. exists S1. exists S2.
  exists (compose t1 B1 (exp_base f)).
  exists B2.
  exists B3.
  exists theta'.
  split.
    SSCase "t1 -> t2 <> s1 -> s2".
    eauto.
  split.
    SSCase "s1 -> s2 in Theta'".
    eauto.
  split.
    SSCase "id t1 -> AltSub".
    intros. unfold compose in H1. discriminate.
  split.
    SSCase "prim".
    eapply coercion_PrimTrans; eauto.
    repeat (split; eauto).
  SCase "relsub pair (similar)".
  right. right.
  destruct relsubPair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [aalt [Ineq [ inTheta [D2_2_1 [D2_2_2 D2_2_3]]]]]]]]]]]]].
  exists T1. exists T2. exists S1. exists S2.
  exists (compose t1 B1 (exp_base f)).
  exists B2.
  exists B3.
  exists theta'.
  split.
    SSCase "t1 -> t2 <> s1 -> s2".
    eauto.
  split.
    SSCase "s1 -> s2 in Theta'".
    eauto.
  split.
    SSCase "id t1 -> AltSub".
    intros. unfold compose in H1. discriminate.
  split.
    eapply coercion_PrimTrans; eauto.
    repeat (split; eauto).
Case "D2 is C-FunTrans".
right. left.
clear IHcgenSub1 IHcgenSub2.
exists t1. exists t2.
exists t1'. exists t2'.
exists (id (typ_fun t1 t2)).
exists (compose (typ_fun t1 t2) (id (typ_fun t1' t2')) (funcompose (typ_fun t1 t2) t1' C1 C2)).
exists C'.
exists (typ_fun t1' t2'::pi).
split.
  SCase "t1 -> t2 <> t1' -> t2'".
     Lemma inequality_from_list_membership : forall T (a:T) (b:T) l,
         (In a l) -> (~In b l) -> a <> b.
       intros. unfold not. intros. subst b. contradiction.
     Qed.
  eapply inequality_from_list_membership; eauto.
  split.
  SCase "In theta".
    eapply in_eq.
  split.
  SCase "id t => AltSub".
    intro. auto.
  split.
  SCase "Left Streak 1".
  unfold id.
  eapply coercion_Id; eauto.
  split.
  SCase "Middle Fun Trans".
  unfold coerciongen.
  eapply coercion_FunTrans.
    SSCase "Premise NotIn singleton".
    pose proof (inequality_from_list_membership _ _ _ _ tInPi H) as ineq.
    unfold not. intros.
    destruct (in_inv H0) as [teq | innil].
    unfold not in ineq.
    apply ineq; apply teq.
    contradiction.
    SSCase "Premise D2_1".
    auto.
    SSCase "Premise D2_2".
    auto.
    SSCase "Premise Id tail".
    unfold id.
    eapply coercion_Id.
  SCase "Right Streak 1".
    destruct (IHcgenSub3 WF_ufunc WF_upair WF_no_fp (in_eq _ _)) as [relprim | [relsubfun | relsubpair]].
    SSCase "sfx is prim".
      assumption.
    SSCase "sfx is relsub fun (violates to_unique_func)".
      clear IHcgenSub3.
      destruct relsubfun as [s1 [s2 [u1 [u2 [D1 [D2 [D3 [pi' [tneq [in_pi [altsub_imp [pfx [sub sfx]]]]]]]]]]]]].
      clear - altsub_imp WF_ufunc pfx case subcase subsubcase.
      assert (typ_fun t1' t2' = typ_fun s1 s2) as teq.
        pose proof (coercion_Id sigma (typ_fun t1' t2'::pi) AltNoSub RelPrim (typ_fun t1' t2')) as tfun_id.
        unfold WF_to_uniquefunc in WF_ufunc.
        destruct (WF_ufunc _ _ _ _ _ _ _ _ (typ_fun t1' t2'::pi) (in_eq _ _) tfun_id pfx) as [AA [BB CC]].
        subst. auto.
      rewrite <- teq in pfx.
      destruct (cycles_are_identity _ _ _ _ _ _ _ (in_eq _ _) pfx).
      subst D1.
      unfold id in altsub_imp.
      pose proof (altsub_imp (refl_equal _)). discriminate.
    SSCase "sfx is relsub pair (violates no_func_pair)".
      clear IHcgenSub3.
      destruct relsubpair as [s1 [s2 [u1 [u2 [D1 [D2 [D3 [pi' [tneq [in_pi [altsub_imp [pfx [sub sfx]]]]]]]]]]]]].
      clear - WF_no_fp pfx case subcase subsubcase.
      unfold WF_no_fun_pair in WF_no_fp.
      destruct (WF_no_fp  (typ_fun t1' t2'::pi) (typ_pair s1 s2::pi) t1' t2' s1 s2 AltNoSub D1 D1 (in_eq _ _) (in_eq _ _)).
      contradiction.

Case "D2 is C-PairTrans (similar)".
right. right.
clear IHcgenSub1 IHcgenSub2.
exists t1. exists t2.
exists t1'. exists t2'.
exists (id (typ_pair t1 t2)).
exists (compose (typ_pair t1 t2) (id (typ_pair t1' t2')) (paircompose t1 t2 C1 C2)).
exists C'.
exists (typ_pair t1' t2'::pi).
split.
  SCase "t1 * t2 <> t1' * t2'".
  eapply inequality_from_list_membership; eauto.
  split.
  SCase "In theta".
    eapply in_eq.
  split.
  SCase "id t => AltSub".
    intro. auto.
  split.
  SCase "Left Streak 1".
  unfold id.
  eapply coercion_Id; eauto.
  split.
  SCase "Middle Pair Trans".
  unfold coerciongen.
  eapply coercion_PairTrans.
    SSCase "Premise NotIn singleton".
    pose proof (inequality_from_list_membership _ _ _ _ tInPi H) as ineq.
    unfold not. intros.
    destruct (in_inv H0) as [teq | innil].
    unfold not in ineq.
    apply ineq; apply teq.
    contradiction.
    SSCase "Premise D2_1".
    auto.
    SSCase "Premise D2_2".
    auto.
    SSCase "Premise Id tail".
    unfold id.
    eapply coercion_Id.
  SCase "Right Streak 1".
    destruct (IHcgenSub3 WF_ufunc WF_upair WF_no_fp (in_eq _ _)) as [relprim | [relsubfun | relsubpair]].
    SSCase "sfx is prim".
      assumption.
    SSCase "sfx is relsub fun (violates no_pair_func)".
      clear IHcgenSub3.
      destruct relsubfun as [s1 [s2 [u1 [u2 [D1 [D2 [D3 [pi' [tneq [in_pi [altsub_imp [pfx [sub sfx]]]]]]]]]]]]].
      clear - WF_no_fp pfx case subcase subsubcase.
      unfold WF_no_fun_pair in WF_no_fp.
      destruct (WF_no_fp  (typ_fun s1 s2::pi) (typ_pair t1' t2'::pi) s1 s2 t1' t2' AltNoSub D1 D1 (in_eq _ _) (in_eq _ _)).
      contradiction.
    SSCase "sfx is relsub pair (violates to_unique_pair)".
      clear IHcgenSub3.
      destruct relsubpair as [s1 [s2 [u1 [u2 [D1 [D2 [D3 [pi' [tneq [in_pi [altsub_imp [pfx [sub sfx]]]]]]]]]]]]].
      clear - altsub_imp WF_upair pfx case subcase subsubcase.
      assert (typ_pair t1' t2' = typ_pair s1 s2) as teq.
        pose proof (coercion_Id sigma (typ_pair t1' t2'::pi) AltNoSub RelPrim (typ_pair t1' t2')) as tpair_id.
        unfold WF_to_uniquepair in WF_upair.
        destruct (WF_upair _ _ _ _ _ _ _ _ (typ_pair t1' t2'::pi) (in_eq _ _) tpair_id pfx) as [AA [BB CC]].
        subst. auto.
      rewrite <- teq in pfx.
      destruct (cycles_are_identity _ _ _ _ _ _ _ (in_eq _ _) pfx).
      subst D1.
      unfold id in altsub_imp.
      pose proof (altsub_imp (refl_equal _)). discriminate.
Qed.

Lemma from_uniquefunc_implies_nomul : forall sigma,
  WF_from_uniquefunc RelPrim sigma ->
  no_multiple_fun_subtyping_paths sigma.
Proof.
intros.
unfold WF_from_uniquefunc in H.
unfold no_multiple_fun_subtyping_paths; intros.
assert (C1 = C2 /\ s1 = s1' /\ s2 = s2').
  eapply H; eauto.
destruct H4 as [A [B C]]; subst; auto.
Qed.

Lemma relprim_sub_alt_ix : forall sigma pi a a' t t' m,
  (coercion sigma pi a t RelPrim t' m) ->
  (coercion sigma pi a' t RelPrim t' m).
Proof.
  intros.
  remember RelPrim as rp.
  induction H.
  eapply coercion_Id; eauto.
  eapply coercion_PrimTrans; eauto.
  discriminate. discriminate.
Qed.

Lemma wf_uniquepath_2 : forall sigma,
  (ok sigma) ->
  (WF_to_uniquefunc RelPrim sigma) ->
  (WF_to_uniquepair RelPrim sigma) ->
  (WF_uniquepath RelPrim sigma) ->
  (WF_no_fun_pair RelPrim sigma) ->
  (no_unnecessary_fun_subtyping_path sigma) ->
  (no_unnecessary_pair_subtyping_path sigma) ->
  (no_multiple_fun_subtyping_paths sigma) ->
  (no_multiple_pair_subtyping_paths sigma) ->
  (no_fun_and_pair_subtyping_paths sigma) ->
  (forall t t' theta C C' a a', In t theta ->
    coercion sigma theta a t RelSub t' C ->
    coercion sigma theta a' t RelSub t' C' ->
    C = C').
intros sigma okSigma WF_f_1 WF_p_1 WF_up_1 WF_no_fp No_un_f No_un_p No_mul_f No_mul_p No_f_and_p.
intros until 1. intros D1 D2.
remember RelSub as rs.
generalize dependent C'.
generalize dependent a'.
induction D1.
Case "D1 is C-Id".
intros a' C' D2.
induction D2.
 SCase "D2 is C-Id".
  auto.
 SCase "D2 is C-PrimTrans".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D2) as [C1 C2].
   subst t2. contradiction.
 SCase "D2 is FunTrans".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D2_3) as [Eq1 Eq2].
  subst t'. contradiction.
 SCase "D2 is PairTrans".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D2_3) as [Eq1 Eq2].
  subst t'. contradiction.
Case "D1 is C-PrimTrans".
intros.
induction D2.
 SCase "Symmetric D2 is C-Id".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D1) as [C1 C2].
   subst t2. contradiction.
 SCase "D2 is C-PrimTrans".
  subst r.
  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1) as D1_LR.
  destruct D1_LR as [D1prim | [D1_fun | D1_pair]].
  SSCase "D1 is a level 1 derivation".
  assert (coercion sigma pi a t1 RelPrim t3 (compose t1 C (exp_base f))) as D1_L1.
    eapply coercion_PrimTrans; eauto.

  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2) as D2_LR.
  destruct D2_LR as [D2prim | [D2_fun | D2_pair]].
  SSSCase "D2 is a level 1 derivation".
  unfold WF_uniquepath, coerciongen in WF_p_1.
  assert (coercion sigma pi a t1 RelPrim t3 (compose t1 C0 (exp_base f0))) as D2_L1.
    eauto using coercion_PrimTrans.
  eapply WF_up_1; eauto using in_eq.
  SSSCase "D2 uses fun subtyping".
    destruct D2_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D2_Ineq [InTheta' [altsub_imp [D2_R_Pfx [D2_R_FunSub D2_R_Sfx]]]]]]]]]]]]].
    unfold no_unnecessary_fun_subtyping_path, coerciongen in No_un_f.
    rename f0 into g.
    assert (coercion sigma pi a t1 RelPrim (typ_fun T1 T2) (compose t1 B1 (exp_base g))) as D2_R_Pfx_g.
      eapply coercion_PrimTrans; eauto.
    pose proof (No_un_f _ _ _ _ _ _ _ _ H D1_L1 D2_R_Pfx_g S1 S2 D2_Ineq) as from_No_Un.
    unfold not in from_No_Un.
    assert ((exists C1, coercion sigma [typ_fun S1 S2] AltSub  (typ_fun S1 S2) RelPrim t3 C1) /\
            (exists C2, coercion sigma [typ_fun T1 T2] AltSub
                       (typ_fun T1 T2) RelSub (typ_fun S1 S2) C2)) as forContra.
    split.
    SSSSCase "Assertion Left".
      exists B3.
      eapply coercion_pi_strengthening.
      eauto using D2_R_Sfx, relprim_sub_alt_ix.
      apply (insingleton typ (typ_fun S1 S2) theta' InTheta').
    SSSSCase "Assertion Right".
      exists B2.
      unfold coerciongen in D2_R_FunSub; eauto.
    destruct (from_No_Un forContra).
  SSSCase "D2 uses pair subtyping".
    destruct D2_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D2_Ineq [InTheta' [altsub_imp [D2_R_Pfx [D2_R_PairSub D2_R_Sfx]]]]]]]]]]]]].
    unfold no_unnecessary_pair_subtyping_path, coerciongen in No_un_p.
    rename f0 into g.
    assert (coercion sigma pi a t1 RelPrim (typ_pair T1 T2) (compose t1 B1 (exp_base g))) as D2_R_Pfx_g.
      eapply coercion_PrimTrans; eauto.
    pose proof (No_un_p _ _ _ _ _ _ _ _ H D1_L1 D2_R_Pfx_g S1 S2 D2_Ineq) as from_No_Un.
    unfold not in from_No_Un.
    assert ((exists C1, coercion sigma [typ_pair S1 S2] AltSub  (typ_pair S1 S2) RelPrim t3 C1) /\
            (exists C2, coercion sigma [typ_pair T1 T2] AltSub
                       (typ_pair T1 T2) RelSub (typ_pair S1 S2) C2)) as forContra.
    split.
    SSSSCase "Assertion Left".
      exists B3.
      eapply coercion_pi_strengthening.
      eauto using D2_R_Sfx, relprim_sub_alt_ix.
      apply (insingleton typ (typ_pair S1 S2) theta' InTheta').
    SSSSCase "Assertion Right".
      exists B2.
      unfold coerciongen in D2_R_PairSub; eauto.
    destruct (from_No_Un forContra).
 SSCase "D1 uses fun subtyping".
  destruct D1_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_Ineq [InTheta' [altsub_imp [D1_R_Pfx [D1_R_FunSub D1_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a t1 RelPrim (typ_fun T1 T2) (compose t1 B1 (exp_base f))) as D1_R_Pfx_f.
    eapply coercion_PrimTrans; eauto.
  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2) as D2_LR.
  destruct D2_LR as [D2_prim | [D2_fun | D2_pair]].
 SSSCase "D2 is a level 1 derivation (Symmetric)".
    unfold no_unnecessary_fun_subtyping_path, coerciongen in No_un_f.
    rename f0 into g.
    assert (coercion sigma pi a t1 RelPrim t3 (compose t1 C0 (exp_base g))) as D2_L1.
      eapply coercion_PrimTrans; eauto.
    pose proof (No_un_f _ _ _ _ _ _ _ _ H D2_L1 D1_R_Pfx_f S1 S2 D1_Ineq) as from_No_Un.
    unfold not in from_No_Un.
    assert ((exists C1, coercion sigma [typ_fun S1 S2] AltSub (typ_fun S1 S2) RelPrim t3 C1) /\
           (exists C2, coercion sigma [typ_fun T1 T2] AltSub
                       (typ_fun T1 T2) RelSub (typ_fun S1 S2) C2)) as forContra.
      split.
      SSSSCase "Assertion Left".
        exists B3.
        eapply coercion_pi_strengthening.
        eauto using D1_R_Sfx, relprim_sub_alt_ix.
        apply (insingleton typ (typ_fun S1 S2) theta' InTheta').
      SSSSCase "Assertion Right".
        exists B2.
        unfold coerciongen in D1_R_FunSub; eauto.
        destruct (from_No_Un forContra).
      SSSCase "D2 is a fun sub".
        destruct D2_fun as [T1' [T2' [S1' [S2' [B1' [B2' [B3' [theta'' [D2_Ineq [InTheta'' [altsub_imp' [D2_R_Pfx [D2_R_FunSub D2_R_Sfx]]]]]]]]]]]]].
        unfold WF_to_uniquefunc in WF_f_1.
        rename f0 into g.
        assert (coercion sigma pi a t1 RelPrim (typ_fun T1' T2') (compose t1 B1' (exp_base g))) as D2_R_Pfx_g.
          eauto using coercion_PrimTrans.
        pose proof (WF_f_1  _ _ _ _ _ _ _ _ _ H D1_R_Pfx_f D2_R_Pfx_g) as eq.
        destruct eq as [e1 [e2 e3]]. subst T1'. subst T2'. unfold compose in e1. injection e1. intros. subst g. subst B1'.
        assert (t0 = t2) as t0eqt2.
         assert ((typ_fun t1 t0) = (typ_fun t1 t2)) as inj.
          eapply binds_id; eauto.
          injection inj; intros; auto.
        subst t2.
        assert (C=C0) as Ceq.
         eapply IHD1; eauto using in_eq, relprim_sub_alt_ix.
        subst. auto.
      SSSCase "D2 is a pair sub (violates no fun and pair subtyping paths)".
        destruct D2_pair as [T1' [T2' [S1' [S2' [B1' [B2' [B3' [theta'' [D2_Ineq [InTheta'' [altsub_imp' [D2_R_Pfx [D2_R_PairSub D2_R_Sfx]]]]]]]]]]]]].
        unfold no_fun_and_pair_subtyping_paths, coerciongen in No_f_and_p.
        unfold coerciongen in D2_R_PairSub, D1_R_FunSub.
        assert False as ff.
          eapply (No_f_and_p t3 S1' S2' T1' T2' S1 S2 T1 T2 B3' B3 B2' B2).
            eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply D2_R_Sfx. eauto using insingleton.
            eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply D1_R_Sfx. eauto using insingleton.
            apply D2_R_PairSub.
            apply D1_R_FunSub.
        destruct ff.
 SSCase "D1 is pair sub".
  destruct D1_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_Ineq [InTheta' [altsub_imp [D1_R_Pfx [D1_R_PairSub D1_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a t1 RelPrim (typ_pair T1 T2) (compose t1 B1 (exp_base f))) as D1_R_Pfx_f.
    eapply coercion_PrimTrans; eauto.
  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2) as D2_LR.
  destruct D2_LR as [D2_prim | [D2_fun | D2_pair]].
  SSSCase "D2 is a level 1 derivation (Symmetric)".
    unfold no_unnecessary_pair_subtyping_path, coerciongen in No_un_p.
    rename f0 into g.
    assert (coercion sigma pi a t1 RelPrim t3 (compose t1 C0 (exp_base g))) as D2_L1.
      eapply coercion_PrimTrans; eauto.
    pose proof (No_un_p _ _ _ _ _ _ _ _ H D2_L1 D1_R_Pfx_f S1 S2 D1_Ineq) as from_No_Un.
    unfold not in from_No_Un.
    assert ((exists C1, coercion sigma [typ_pair S1 S2] AltSub (typ_pair S1 S2) RelPrim t3 C1) /\
           (exists C2, coercion sigma [typ_pair T1 T2] AltSub
                       (typ_pair T1 T2) RelSub (typ_pair S1 S2) C2)) as forContra.
      split.
      SSSSCase "Assertion Left".
        exists B3.
        eapply coercion_pi_strengthening.
        eauto using D1_R_Sfx, relprim_sub_alt_ix.
        apply (insingleton typ (typ_pair S1 S2) theta' InTheta').
      SSSSCase "Assertion Right".
        exists B2.
        unfold coerciongen in D1_R_PairSub; eauto.
    destruct (from_No_Un forContra).
  SSSCase "D2 is a fun sub (violates no fun and pair subtyping paths)".
        destruct D2_fun as [T1' [T2' [S1' [S2' [B1' [B2' [B3' [theta'' [D2_Ineq [InTheta'' [altsub_imp' [D2_R_Pfx [D2_R_FunSub D2_R_Sfx]]]]]]]]]]]]].
        unfold no_fun_and_pair_subtyping_paths, coerciongen in No_f_and_p.
        unfold coerciongen in D2_R_FunSub, D1_R_PairSub.
        assert False as ff.
          eapply (No_f_and_p t3 S1 S2 T1 T2 S1' S2' T1' T2').
            eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply D1_R_Sfx. eauto using insingleton.
            eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply D2_R_Sfx. eauto using insingleton.
            apply D1_R_PairSub.
            apply D2_R_FunSub.
        destruct ff.
  SSSCase "D2 is a pair sub(violates no fun and pair subtyping paths)".
    destruct D2_pair as [T1' [T2' [S1' [S2' [B1' [B2' [B3' [theta'' [D2_Ineq [InTheta'' [altsub_imp' [D2_R_Pfx [D2_R_PairSub D2_R_Sfx]]]]]]]]]]]]].
    unfold WF_to_uniquepair in WF_p_1.
    rename f0 into g.
    assert (coercion sigma pi a t1 RelPrim (typ_pair T1' T2') (compose t1 B1' (exp_base g))) as D2_R_Pfx_g.
      eauto using coercion_PrimTrans.
    pose proof (WF_p_1  _ _ _ _ _ _ _ _ _ H D1_R_Pfx_f D2_R_Pfx_g) as eq.
    destruct eq as [e1 [e2 e3]]. subst T1'. subst T2'. unfold compose in e1. injection e1. intros. subst g. subst B1'.
    assert (t0 = t2) as t0eqt2.
      assert ((typ_fun t1 t0) = (typ_fun t1 t2)) as inj.
        eapply binds_id; eauto.
    injection inj; intros; auto.
    subst t2.
    assert (C=C0) as Ceq.
      eapply IHD1; eauto using in_eq, relprim_sub_alt_ix.
    subst. auto.
  SCase "D2 is C-FunTrans".
  clear IHD2_1 IHD2_2 IHD2_3 IHD1.
  rename D1 into D1_2.
  rename t' into t_final.
  rename t2 into t_mid_1.
  rename t1' into t2.
  rename t0 into t1'.
  assert (typ_fun t1 t1' <> typ_fun t2 t2') as fneq.
  unfold not; intro feq. rewrite <- feq in H2. contradiction.
(*   pose proof (coercion_FunTrans _ _ _ _ _ _ _ _ _ _ H2 D2_1 D2_2 D2_3) as D2. *)
  assert (coercion sigma (typ_fun t2 t2'::pi) AltNoSub (typ_fun t2 t2') RelPrim t_final C') as alreadyUsedSubtyping.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates to_uniquefunc)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_fun t2 t2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_fun t2 t2' <> typ_fun T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_fun t2 t2'::pi) AltNoSub RelPrim (typ_fun t2 t2')) as forcontra.
          destruct (WF_f_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates no_fun_pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun t2 t2'::pi) (typ_pair T1 T3::pi) t2 t2' T1 T3 AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
  destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_2) as [D1_prim | [D1_fun | D1_pair]].
  SSCase "D1_prim ... D1 is level1".
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim  t_final (compose (typ_fun t1 t1') C (exp_base f))) as D1_Contra.
    eapply coercion_PrimTrans; eauto.
  unfold no_unnecessary_fun_subtyping_path, coerciongen in No_un_f.
    pose proof (No_un_f _ _ _ _ _ _ _ _ H D1_Contra (coercion_Id _ _ _ _ _) t2 t2' fneq) as from_Noun.
    assert ((exists C1, coercion sigma [typ_fun t2 t2'] AltSub (typ_fun t2 t2') RelPrim t_final C1) /\
            (exists C2 : exp,  coercion sigma [typ_fun t1 t1'] AltSub
                    (typ_fun t1 t1') RelSub (typ_fun t2 t2') C2)) as forContra.
  split.
     SSSCase "Assertion Conj left".
     exists C'.
         eapply coercion_pi_strengthening.
         eapply relprim_sub_alt_ix.
         eapply alreadyUsedSubtyping.
         eauto using insingleton, in_eq.
     SSSCase "Assertion Conj right".
     exists (compose (typ_fun t1 t1') (id (typ_fun t2 t2')) (funcompose (typ_fun t1 t1') t2 C1 C2)).
     eapply coercion_FunTrans.
     SSSSCase "Premise not in".
     unfold not. intros.
       destruct (in_inv H3) as [fEq | inNil].
       rewrite fEq in fneq. eapply fneq. reflexivity.
       contradiction.
     SSSSCase "Premise Farg".
       auto.
     SSSSCase "Premise Fret".
       auto.
     SSSSCase "Streak right".
       unfold id. eapply coercion_Id.
  contradiction.
  SSCase "D1_2_R ... D1 is fun sub".
  destruct D1_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_Pfx [D1_2_R_FunSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_fun T1 T2) (compose (typ_fun t1 t1') B1 (exp_base f))) as D1_Contra.
   SSSCase "Assertion D1_Contra".
    eapply coercion_PrimTrans; eauto.
   assert (typ_fun t1 t1' <> typ_fun T1 T2) as Tfun_ineq.
    SSSCase "Assertion Tfun_ineq".
     eapply nonidentity_implies_inequality; eauto.
       unfold compose, id. discriminate.
   assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_fun t1 t1') (exp_lam (typ_fun t1 t1') (exp_bvar 0))) as D1_Contra_2.
     eapply coercion_Id;eauto.
  unfold WF_to_uniquefunc in WF_f_1.
  assert (typ_fun t1 t1' = typ_fun T1 T2) as Contra.
    destruct (WF_f_1 _ _ _ _ _ _ _ _ _ H D1_Contra_2 D1_Contra) as [A1 [A2 A3]].
    subst. auto.
  contradiction.
  SSCase "D1_2_R ... D1 is pair sub".
  destruct D1_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_fun_to_pair [D1_2_R_PairSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_pair T1 T2) (compose (typ_fun t1 t1') B1 (exp_base f))) as fun_to_pair.
    eauto using coercion_PrimTrans, in_eq.
  unfold WF_no_fun_pair in WF_no_fp.
  destruct (WF_no_fp  pi [typ_pair T1 T2] t1 t1' T1 T2 a (compose (typ_fun t1 t1') B1 (exp_base f)) B1 H (in_eq _ _)).
  contradiction.

  SCase "D2 is C-PairTrans".
  clear IHD2_1 IHD2_2 IHD2_3 IHD1.
  rename D1 into D1_2.
  rename t' into t_final.
  rename t2 into t_mid_1.
  rename t1' into t2.
  rename t0 into t1'.
  assert (typ_pair t1 t1' <> typ_pair t2 t2') as fneq.
  unfold not; intro feq. rewrite <- feq in H2. contradiction.
(*   pose proof (coercion_FunTrans _ _ _ _ _ _ _ _ _ _ H2 D2_1 D2_2 D2_3) as D2. *)
  assert (coercion sigma (typ_pair t2 t2'::pi) AltNoSub (typ_pair t2 t2') RelPrim t_final C') as alreadyUsedSubtyping.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates no_pair_fun)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_pair_to_fun XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun T1 T3::pi) (typ_pair t2 t2'::pi) T1 T3 t2 t2' AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates to_uniquepair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cpair_to_pair XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_pair t2 t2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_pair t2 t2' <> typ_pair T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_pair t2 t2'::pi) AltNoSub RelPrim (typ_pair t2 t2')) as forcontra.
          destruct (WF_p_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cpair_to_pair forcontra).
          unfold id in E1_neq. contradiction.
  destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_2) as [D1_prim | [D1_fun | D1_pair]].
  SSCase "D1_prim ... D1 is level1".
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim  t_final (compose (typ_pair t1 t1') C (exp_base f))) as D1_Contra.
    eapply coercion_PrimTrans; eauto.
  unfold no_unnecessary_pair_subtyping_path, coerciongen in No_un_f.
    pose proof (No_un_p _ _ _ _ _ _ _ _ H D1_Contra (coercion_Id _ _ _ _ _) t2 t2' fneq) as from_Noun.
    assert ((exists C1, coercion sigma [typ_pair t2 t2'] AltSub (typ_pair t2 t2') RelPrim t_final C1) /\
            (exists C2 : exp,  coercion sigma [typ_pair t1 t1'] AltSub
                    (typ_pair t1 t1') RelSub (typ_pair t2 t2') C2)) as forContra.
  split.
     SSSCase "Assertion Conj left".
     exists C'.
         eapply coercion_pi_strengthening.
         eapply relprim_sub_alt_ix.
         eapply alreadyUsedSubtyping.
         eauto using insingleton, in_eq.
     SSSCase "Assertion Conj right".
     exists (compose (typ_pair t1 t1') (id (typ_pair t2 t2')) (paircompose t1 t1' C1 C2)).
     eapply coercion_PairTrans.
     SSSSCase "Premise not in".
     unfold not. intros.
       destruct (in_inv H3) as [fEq | inNil].
       rewrite fEq in fneq. eapply fneq. reflexivity.
       contradiction.
     SSSSCase "Premise Farg".
       auto.
     SSSSCase "Premise Fret".
       auto.
     SSSSCase "Streak right".
       unfold id. eapply coercion_Id.
  contradiction.
  SSCase "D1_2_R ... D1 is fun sub".
  destruct D1_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_pair_to_fun [D1_2_R_PairSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_fun T1 T2) (compose (typ_pair t1 t1') B1 (exp_base f))) as pair_to_fun.
    eauto using coercion_PrimTrans, in_eq.
  unfold WF_no_fun_pair in WF_no_fp.
  destruct (WF_no_fp [typ_fun T1 T2] pi T1 T2 t1 t1' a B1 (compose (typ_pair t1 t1') B1 (exp_base f)) (in_eq _ _) H).
  contradiction.
  SSCase "D1_2_R ... D1 is pair sub".
  destruct D1_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_Pfx [D1_2_R_PairSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_pair T1 T2) (compose (typ_pair t1 t1') B1 (exp_base f))) as D1_Contra.
   SSSCase "Assertion D1_Contra".
    eapply coercion_PrimTrans; eauto.
   assert (typ_pair t1 t1' <> typ_pair T1 T2) as Tpair_ineq.
    SSSCase "Assertion Tpair_ineq".
     eapply nonidentity_implies_inequality; eauto.
       unfold compose, id. discriminate.
   assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_pair t1 t1') (exp_lam (typ_pair t1 t1') (exp_bvar 0))) as D1_Contra_2.
     eapply coercion_Id;eauto.
  unfold WF_to_uniquepair in WF_p_1.
  assert (typ_pair t1 t1' = typ_pair T1 T2) as Contra.
    destruct (WF_p_1 _ _ _ _ _ _ _ _ _ H D1_Contra_2 D1_Contra) as [A1 [A2 A3]].
    subst. auto.
  contradiction.
Case "D1 is FunTrans".
intros.
remember (typ_fun t1 t2) as tinitial.
remember RelSub as rs.
induction D2.
 SCase "D2 is C-Id (Symmetric)".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D1_3) as [Eq1 Eq2].
  rewrite <- Eq1 in H.
  contradiction.
 SCase "D2 is PrimTrans (Symmetric)".
  rename D2 into D2_2.
  clear IHD1_1 IHD1_2 IHD1_3 IHD2.
  rename t4 into t_final.
  rename t3 into t_mid_2.
  rename t1' into temp.
  rename t2 into t1'.
  rename temp into t2.
  subst t0.
  subst r.
  assert (typ_fun t1 t1' <> typ_fun t2 t2') as fneq.
  unfold not; intro feq. rewrite <- feq in H0. contradiction.
  assert (coercion sigma (typ_fun t2 t2'::pi) AltNoSub (typ_fun t2 t2') RelPrim t_final C') as alreadyUsedSubtyping.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates to_uniquefunc)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_fun t2 t2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_fun t2 t2' <> typ_fun T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_fun t2 t2'::pi) AltNoSub RelPrim (typ_fun t2 t2')) as forcontra.
          destruct (WF_f_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates no_fun_pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun t2 t2'::pi) (typ_pair T1 T3::pi) t2 t2' T1 T3 AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_2) as D2_2_LR.
  destruct D2_2_LR as [D2_2_prim | [D2_2_fun | D2_2_pair]].
  SSCase "D2_2_prim ... D2 is level1".
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim t_final (compose (typ_fun t1 t1') C (exp_base f))) as D2_Contra.
    eapply coercion_PrimTrans; eauto.
  unfold no_unnecessary_fun_subtyping_path, coerciongen in No_un_f.
    pose proof (No_un_f _ _ _ _ _ _ _ _ H D2_Contra (coercion_Id _ _ _ _ _) t2 t2' fneq) as from_Noun.
    assert ((exists C1, coercion sigma [typ_fun t2 t2'] AltSub (typ_fun t2 t2') RelPrim t_final C1) /\
            (exists C2 : exp,  coercion sigma [typ_fun t1 t1'] AltSub
                    (typ_fun t1 t1') RelSub (typ_fun t2 t2') C2)) as forContra.
  split.
     SSSCase "Assertion Conj left".
     exists C'.
        eapply coercion_pi_strengthening.
        eapply relprim_sub_alt_ix.
        apply alreadyUsedSubtyping.
        eauto using insingleton, in_eq.
     SSSCase "Assertion Conj right".
     exists (compose (typ_fun t1 t1') (id (typ_fun t2 t2')) (funcompose (typ_fun t1 t1') t2 C1 C2)).
     eapply coercion_FunTrans.
       SSSSCase "Premise not in".
       unfold not. intros.
         destruct (in_inv H3) as [fEq | inNil].
         rewrite fEq in fneq. eapply fneq. reflexivity.
         contradiction.
       SSSSCase "Premise Farg".
         auto.
       SSSSCase "Premise Fret".
         auto.
       SSSSCase "Streak right".
         unfold id. eapply coercion_Id.
  contradiction.
  SSCase "D1_2_fun ... D2 is level 2".
  destruct D2_2_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D2_2_R_Pfx [D2_2_R_FunSub D2_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_fun T1 T2) (compose (typ_fun t1 t1') B1 (exp_base f))) as D2_Contra.
   SSSCase "Assertion D1_Contra".
    eapply coercion_PrimTrans; eauto.
  assert (typ_fun t1 t1' <> typ_fun T1 T2) as Tfun_ineq.
   SSSCase "Assertion Tfun_ineq".
   eapply nonidentity_implies_inequality; eauto.
     unfold compose, id. discriminate.
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_fun t1 t1') (exp_lam (typ_fun t1 t1') (exp_bvar 0))) as D2_Contra_2.
    eapply coercion_Id;eauto.
  unfold WF_to_uniquefunc in WF_f_1.
  assert (typ_fun t1 t1' = typ_fun T1 T2) as Contra.
    destruct (WF_f_1 _ _ _ _ _ _ _ _ _ H D2_Contra_2 D2_Contra) as [A1 [A2 A3]].
    subst. auto.
  contradiction.

  SSCase "D2_2_R ... D2 is pair sub".
  destruct D2_2_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_fun_to_pair [D1_2_R_PairSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_fun t1 t1') RelPrim (typ_pair T1 T2) (compose (typ_fun t1 t1') B1 (exp_base f))) as fun_to_pair.
    eauto using coercion_PrimTrans, in_eq.
  unfold WF_no_fun_pair in WF_no_fp.
  destruct (WF_no_fp  pi [typ_pair T1 T2] t1 t1' T1 T2 a (compose (typ_fun t1 t1') B1 (exp_base f)) B1 H (in_eq _ _)).
  contradiction.

 SCase "D2 is FunTrans".
  rename t' into t_final.
  injection Heqtinitial. intros. subst t0. subst t3. clear Heqtinitial.
  rename t1' into s1.
  rename t2' into s1'.
  rename t1'0 into s2.
  rename t2'0 into s2'.
  rename t2 into t1'.
  rename C' into C_Sfx_1.
  rename C'0 into C_Sfx_2.

  assert (coercion sigma (typ_fun s1 s1'::pi) AltNoSub (typ_fun s1 s1') RelPrim t_final C_Sfx_1) as alreadyUsedSubtyping1.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates to_uniquefunc)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_fun s1 s1'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_fun s1 s1' <> typ_fun T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_fun s1 s1'::pi) AltNoSub RelPrim (typ_fun s1 s1')) as forcontra.
          destruct (WF_f_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates no_fun_pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun s1 s1'::pi) (typ_pair T1 T3::pi) s1 s1' T1 T3 AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.

  assert (coercion sigma (typ_fun s2 s2'::pi) AltNoSub (typ_fun s2 s2') RelPrim t_final C_Sfx_2) as alreadyUsedSubtyping2.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates to_uniquefunc)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_fun s2 s2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_fun s2 s2' <> typ_fun T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_fun s2 s2'::pi) AltNoSub RelPrim (typ_fun s2 s2')) as forcontra.
          destruct (WF_f_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates no_fun_pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun s2 s2'::pi) (typ_pair T1 T3::pi) s2 s2' T1 T3 AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.

  assert (typ_fun s1 s1' = typ_fun s2 s2') as fun_eq.
    unfold no_multiple_fun_subtyping_paths, coerciongen in No_mul_f.
    eapply (No_mul_f t_final).
      eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply alreadyUsedSubtyping1. eauto using insingleton, in_eq.
      eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply alreadyUsedSubtyping2. eauto using insingleton, in_eq.
    eapply coercion_pi_strengthening.
      eapply coercion_FunTrans.
        apply H0.
        apply D1_1. apply D1_2. eapply coercion_Id. eauto using insingleton, in_eq.
    eapply coercion_pi_strengthening.
      eapply coercion_FunTrans.
        apply H1.
        apply D2_1. apply D2_2. eapply coercion_Id. eauto using insingleton, in_eq.
  injection fun_eq; intros; subst s2; subst s2'. clear fun_eq.
  assert (C_Sfx_1 = C_Sfx_2) as sfx_eq.
    unfold WF_uniquepath in WF_up_1.
    eapply (WF_up_1 _ _ _ _ _ (typ_fun s1 s1'::pi) (in_eq _ _) alreadyUsedSubtyping1 alreadyUsedSubtyping2).
  subst C_Sfx_2.
  clear IHD2_1 IHD2_2 IHD2_3 IHD1_3.
  assert (C1 = C0) as eq_10.
    eapply IHD1_1; eauto using in_eq.
  assert (C2 = C3) as eq_23.
    eapply IHD1_2; eauto using in_eq.
  subst C0. subst C3. auto.

 SCase "D2 is PairTrans".
 subst. discriminate.

Case "D1 is PairTrans".
intros.
remember (typ_pair t1 t2) as tinitial.
remember RelSub as rs.
induction D2.
 SCase "D2 is C-Id (Symmetric)".
  destruct (cycles_are_identity _ _ _ _ _ _ _ (in_cons _ _ _ H) D1_3) as [Eq1 Eq2].
  rewrite <- Eq1 in H.
  contradiction.
 SCase "D2 is PrimTrans (Symmetric)".
  rename D2 into D2_2.
  clear IHD1_1 IHD1_2 IHD1_3 IHD2.
  rename t4 into t_final.
  rename t3 into t_mid_2.
  rename t1' into temp.
  rename t2 into t1'.
  rename temp into t2.
  subst t0.
  subst r.
  assert (typ_pair t1 t1' <> typ_pair t2 t2') as fneq.
  unfold not; intro feq. rewrite <- feq in H0. contradiction.
  assert (coercion sigma (typ_pair t2 t2'::pi) AltNoSub (typ_pair t2 t2') RelPrim t_final C') as alreadyUsedSubtyping.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates no fun pair)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun T1 T3::pi) (typ_pair t2 t2'::pi) T1 T3 t2 t2' AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates unique_pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_pair t2 t2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_pair t2 t2' <> typ_pair T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_pair t2 t2'::pi) AltNoSub RelPrim (typ_pair t2 t2')) as forcontra.
          destruct (WF_p_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
  pose proof (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_2) as D2_2_LR.
  destruct D2_2_LR as [D2_2_prim | [D2_2_fun | D2_2_pair]].
  SSCase "D2_2_prim ... D2 is level1".
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim t_final (compose (typ_pair t1 t1') C (exp_base f))) as D2_Contra.
    eapply coercion_PrimTrans; eauto.
  unfold no_unnecessary_pair_subtyping_path, coerciongen in No_un_p.
    pose proof (No_un_p _ _ _ _ _ _ _ _ H D2_Contra (coercion_Id _ _ _ _ _) t2 t2' fneq) as from_Noun.
    assert ((exists C1, coercion sigma [typ_pair t2 t2'] AltSub (typ_pair t2 t2') RelPrim t_final C1) /\
            (exists C2 : exp,  coercion sigma [typ_pair t1 t1'] AltSub
                    (typ_pair t1 t1') RelSub (typ_pair t2 t2') C2)) as forContra.
  split.
     SSSCase "Assertion Conj left".
     exists C'.
         eapply coercion_pi_strengthening. eapply relprim_sub_alt_ix. apply alreadyUsedSubtyping. eauto using insingleton, in_eq.
     SSSCase "Assertion Conj right".
     exists (compose (typ_pair t1 t1') (id (typ_pair t2 t2')) (paircompose  t1 t1' C1 C2)).
     eapply coercion_PairTrans.
       SSSSCase "Premise not in".
       unfold not. intros.
         destruct (in_inv H3) as [fEq | inNil].
         rewrite fEq in fneq. eapply fneq. reflexivity.
         contradiction.
       SSSSCase "Premise Farg".
         auto.
       SSSSCase "Premise Fret".
         auto.
       SSSSCase "Streak right".
         unfold id. eapply coercion_Id.
  contradiction.
  SSCase "D1_2_fun ... D2 is level 2".
  destruct D2_2_fun as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D1_2_R_fun_to_pair [D1_2_R_PairSub D1_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_fun T1 T2) (compose (typ_pair t1 t1') B1 (exp_base f))) as fun_to_pair.
    eauto using coercion_PrimTrans, in_eq.
  unfold WF_no_fun_pair in WF_no_fp.
  destruct (WF_no_fp [typ_fun T1 T2] pi T1 T2 t1 t1'  a B1 (compose (typ_pair t1 t1') B1 (exp_base f)) (in_eq _ _) H).
  contradiction.
  SSCase "D2_2_R ... D2 is pair sub".
  destruct D2_2_pair as [T1 [T2 [S1 [S2 [B1 [B2 [B3 [theta' [D1_2_Ineq [InTheta' [alt_imp [D2_2_R_Pfx [D2_2_R_PairSub D2_2_R_Sfx]]]]]]]]]]]]].
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_pair T1 T2) (compose (typ_pair t1 t1') B1 (exp_base f))) as D2_Contra.
   SSSCase "Assertion D1_Contra".
    eapply coercion_PrimTrans; eauto.
  assert (typ_pair t1 t1' <> typ_pair T1 T2) as Tfun_ineq.
   SSSCase "Assertion Tfun_ineq".
   eapply nonidentity_implies_inequality; eauto.
     unfold compose, id. discriminate.
  assert (coercion sigma pi a (typ_pair t1 t1') RelPrim (typ_pair t1 t1') (exp_lam (typ_pair t1 t1') (exp_bvar 0))) as D2_Contra_2.
    eapply coercion_Id;eauto.
  unfold WF_to_uniquepair in WF_p_1.
  assert (typ_pair t1 t1' = typ_pair T1 T2) as Contra.
    destruct (WF_p_1 _ _ _ _ _ _ _ _ _ H D2_Contra_2 D2_Contra) as [A1 [A2 A3]].
    subst. auto.
  contradiction.

 SCase "D2 is FunTrans".
subst. discriminate.

SCase "D2 is PairTrans".
  rename t' into t_final.
  injection Heqtinitial. intros. subst t0. subst t3. clear Heqtinitial.
  rename t1' into s1.
  rename t2' into s1'.
  rename t1'0 into s2.
  rename t2'0 into s2'.
  rename t2 into t1'.
  rename C' into C_Sfx_1.
  rename C'0 into C_Sfx_2.

  assert (coercion sigma (typ_pair s1 s1'::pi) AltNoSub (typ_pair s1 s1') RelPrim t_final C_Sfx_1) as alreadyUsedSubtyping1.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D1_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
        auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates no_fp)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun T1 T3::pi) (typ_pair s1 s1'::pi) T1 T3 s1 s1' AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates to unique pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_pair s1 s1'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_pair s1 s1' <> typ_pair T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_pair s1 s1'::pi) AltNoSub RelPrim (typ_pair s1 s1')) as forcontra.
          destruct (WF_p_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
  assert (coercion sigma (typ_pair s2 s2'::pi) AltNoSub (typ_pair s2 s2') RelPrim t_final C_Sfx_2) as alreadyUsedSubtyping2.
    destruct (relsub_derivations_use_subtyping_atmost_once _ _ _ _ _ _ WF_f_1 WF_p_1 WF_no_fp (in_eq _ _) D2_3) as [D2_3_prim | [D2_3_fun | D2_3_pair]].
      SSCase "Assertion: D2_3 prim".
       auto.
      SSCase "Assertoin: D2_3 is funsub (impos violates no_fp)".
        destruct D2_3_fun as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_fun_to_pair XX]]]]]]]]]]]].
        unfold WF_no_fun_pair in WF_no_fp.
        destruct (WF_no_fp  (typ_fun T1 T3::pi) (typ_pair s2 s2'::pi) T1 T3 s2 s2' AltNoSub E1 E1 (in_eq _ _) (in_eq _ _)).
        contradiction.
      SSCase "Assertion: D2_3 is pair sub (violates to unique pair)".
        destruct D2_3_pair as [T1 [T3 [S1 [S2 [E1 [E2 [E3 [theta'' [tneq [notintheta'' [alt_imp [cfun_to_fun XX]]]]]]]]]]]].
        assert (E1 <> (id (typ_pair s2 s2'))) as E1_neq.
          unfold not; intro. subst E1. pose proof (alt_imp (refl_equal _)). discriminate.
          assert (typ_pair s2 s2' <> typ_pair T1 T3).
            eauto using nonidentity_implies_inequality, in_eq.
          pose proof (coercion_Id sigma (typ_pair s2 s2'::pi) AltNoSub RelPrim (typ_pair s2 s2')) as forcontra.
          destruct (WF_p_1  _ _ _ _ _ _ _ _ _ (in_eq _ _) cfun_to_fun forcontra).
          unfold id in E1_neq. contradiction.
  assert (typ_pair s1 s1' = typ_pair s2 s2') as fun_eq.
    unfold no_multiple_pair_subtyping_paths, coerciongen in No_mul_p.
    eapply (No_mul_p t_final t1 t1' s1 s1' s2 s2' C_Sfx_1 C_Sfx_2).
     eapply coercion_pi_strengthening.
        eapply relprim_sub_alt_ix. apply alreadyUsedSubtyping1. eauto using insingleton, in_eq.
     eapply coercion_pi_strengthening.
        eapply relprim_sub_alt_ix. apply alreadyUsedSubtyping2. eauto using insingleton, in_eq.
    eapply coercion_pi_strengthening.
      eapply coercion_PairTrans.
        apply H0.
        apply D1_1. apply D1_2. eapply coercion_Id. eauto using insingleton, in_eq.
    eapply coercion_pi_strengthening.
      eapply coercion_PairTrans.
        apply H1.
        apply D2_1. apply D2_2. eapply coercion_Id. eauto using insingleton, in_eq.
  injection fun_eq; intros; subst s2; subst s2'. clear fun_eq.
  assert (C_Sfx_1 = C_Sfx_2) as sfx_eq.
    unfold WF_uniquepath in WF_up_1.
    eapply (WF_up_1 _ _ _ _ _ (typ_pair s1 s1'::pi) (in_eq _ _) alreadyUsedSubtyping1 alreadyUsedSubtyping2).
  subst C_Sfx_2.
  clear IHD2_1 IHD2_2 IHD2_3 IHD1_3.
  assert (C1 = C0) as eq_10.
    eapply IHD1_1; eauto using in_eq.
  assert (C2 = C3) as eq_23.
    eapply IHD1_2; eauto using in_eq.
  subst C0. subst C3. auto.
Qed.