Load metaproperties.

(*
Credit default swap

Assume that Alice holds a financial obligation from
a company called B whose price is P = 1000 dollars.
The maturity of the obligation is M = 3 years:
B pays a fee per year of FY = 100 dollars to Alice,
and at the end of the 3 years (maturity reached)
it pays back to Alice P, that is, 1000 dollars.
Therefore, Alice should receive

  P + M * FY = 1000 + (3 * 100)

dollars at the end of the 3 years.

Since Alice knows that B has financial issues and it is
possible that C may not be able to pay the yearly fees
(i.e., C defaults), Alice buys a Credit Swap Derivative
(CDS) from a bank C.
A CDS acts as an insurance: Alice pays a fee of F = 20
dollars per year to C, and in exchange, C will pay
1000 + (YL * 100) dollars if B defaults. That is, C pays to Alice
P + YL * 100, where YL is the number of years left until
the obligation reaches its maturity.
For instance, if B defaults in the first year, YL = M - 1
and C pays P + YL * 100 = 1000 + 200 = 1200 dollars to Alice.

Here we prove that:
1.  Alice recovers P + M * FY
2. The bank C receives a total fee F = k * 20 from Alice, where
k = M - YL.
3. Other contracts that are generated by CDS are consistent:
no accidental transaction happens s.t. parties are paying
extra money other than those specified above.
*)

(**************************************************************)
(* A credit default swap - CDS - in Findel.                   *)
(*                                                            *)
(* We use the compositionality of Findel to describe CDS.     *)
(* For this we use two (sub)contracts:                        *)
(* 1. pay_at_t which pays a sum at time t if B has defaulted  *)
(* 2. yearly_check which specifies that Alice should pay C an *)
(*    yearly fee, and C should pay P + M * FY if B defaulted. *)
(**************************************************************)

Definition pay_at_t (t : Time)
           (addr : Address)
           (sum : nat) :=
  (At t
      (If addr
          (Scale sum (One USD))
          Zero)
  ).

Definition yearly_check (t t' : Time)
           (addr : Address)
           (price B2AliceFee Alice2CFee i : nat)
  :=
    At t (If addr Zero
             (And (Give (Scale Alice2CFee (One USD)))
                  (pay_at_t t' addr (price + i * B2AliceFee)))).

(****************************************************************************)
(* Finally, the description of CDS in Findel simply executes a              *)
(* sequence of three contracts:                                             *)
(* 1. first, Alice pays C a fee F and C pays at now + 1 year if B defaulted *)
(* 2. second, perform an yearly check at now + 2 years                      *)
(* 3. third, perform an yearly check at now + 3 years                       *)
(****************************************************************************)

Definition CDS (Alice C : Address)
           (defaulted_addr : Address)
           (price FY F : nat) (now : Time)
           (Y1 Y2 Y3 : nat)
  :=
  (
    And
      (* first year *)
      (And (Give (Scale F (One USD)))
           (pay_at_t (now + Y1) defaulted_addr (price + (2 * FY)))
      )

      (
        And
          (* second year *)
          (yearly_check (now + Y1) (now + Y2) defaulted_addr price FY F 1)
          (* third year *)
          (yearly_check (now + Y2) (now + Y3) defaulted_addr price FY F 0)
      )
  ).

(*******************************************)
(* Helper definitions, tactics, and lemmas *)
(*******************************************)

Definition is_executed (c : FinContract)
           (state1 state2 : State)
           (time : Time) :=
    step state1 state2 /\
    In c (m_contracts state1) /\
    In (Executed (ctr_id c)) (m_events state2) /\
    time = (m_global_time state1).

Ltac destruct_exec H :=
  let Step := fresh "Step" in
  let InCtr := fresh "InCtr" in
  let InEv := fresh "InEv" in
  let T := fresh "T" in
  destruct H as [Step [InCtr [InEv T]]].

Definition generates_new_ctr_when_executed_at (c c': FinContract)
           (proposed_owner : Address)
           (state1 state2 : State)
           (time : Time) :=
    (* is_executed_at *)
    step state1 state2 /\
    In c (m_contracts state1) /\
    In (Executed (ctr_id c)) (m_events state2) /\
    time = (m_global_time state1) /\
    (* generates new ctr with proposed_owner *)
    ~ In c' (m_contracts state1) /\
    In c' (m_contracts state2) /\
    (ctr_proposed_owner c' = proposed_owner).

Ltac destruct_gen_new_ctr H :=
  let Step := fresh "Step" in
  let InCtr := fresh "InCtr" in
  let InEv := fresh "InEv" in
  let T := fresh "T" in
  let InCtr' := fresh "InCtr" in
  let NInCtr := fresh "NInCtr" in
  let SamePrim := fresh "SamePrim" in
  destruct H as [Step [inCtr [InEv [T [NInCtr [InCtr' SamePrim]]]]]].

(* This is not a real restriction since the current unix time is > 30 *)
Axiom global_time_is_bigger_than_delta:
  forall s,
    m_global_time s > Δ.

Create HintDb cds.
Hint Resolve global_time_is_bigger_than_delta : cds.
Hint Constructors steps : cds.
Hint Constructors step : cds.

Lemma helper_1 :
  forall t y d, t > d -> d > 0 -> (t + y + d <? t) = false.
Proof.
  intros.
  case_eq (t + y + d <? t); intros * H'; trivial.
  apply leb_sound_true in H'.
  omega.
Qed.

Lemma helper_2 :
  forall t y d,  y > d -> (t + y - d <=? t) = false.
Proof.
  intros.
  case_eq (t + y - d <=? t); intros * H'; trivial.
  apply leb_sound_true in H'.
  omega.
Qed.

Lemma in_smaller_list :
  forall l x x', In x (rm x' l) -> In x l.
Proof.
  induction l; intros; simpl in *; trivial.
  case_eq (ctr_eq_dec x' a); intros * H'; rewrite H' in H.
  - subst. right. eapply IHl. eauto.
  - destruct H as [H | H]; auto.
    right. eapply IHl; eauto.
Qed.

Lemma h1 :
  forall a b c d,
    a + b - c >= d ->
    a + b + c >= d.
Proof.
  intros.
  omega.
Qed.

Lemma h2 :
  forall a b b' c d,
    a + b - c >= d ->
    b' > b ->
    a + b' - c >= d.
Proof.
  intros.
  omega.
Qed.

Lemma exec_later_no_effect :
  forall s1 s2 c T t t' primitive,
    consistent_state s1 ->
    is_executed c s1 s2 (T + t) ->
    ctr_primitive c = At (T + t') primitive ->
    t - t' > Δ ->
    m_ledger s1 = m_ledger s2.
Proof.
  intros * CS Exec Prim C.
  destruct_exec Exec.
  induction Step; subst s2; try auto.
  - same_ctr InEv.
    subst ctr. destruct c. simpl in *. subst.
    unfold exec_ctr_in_state_with_owner, execute in H5; simpl in *.
    case_if H5. apply ltb_sound_false in H6. omega.
  - same_ctr InEv. subst ctr. rewrite Prim in H2. inversion H2.
  - same_ctr InEv. subst ctr. rewrite Prim in H2. inversion H2.
Qed.

(***********************)
(* Proofs for pay_at_t *)
(***********************)
Proposition pay_at_t_O_rights:
  forall s1 s2 c t I O addr sum c_id dsc_id response,
    c = finctr c_id dsc_id (pay_at_t t addr sum) I O O 1 ->
    is_executed c s1 s2 t ->
    query (m_gateway s1) addr t = Some response ->
    response <> 0 ->
    O <> 0 ->
    consistent_state s1 ->
    (exists tr,
        In tr (m_ledger s2) /\
        tr_ctr_id tr = (ctr_id c) /\
        tr_from tr = I /\
        tr_to tr = O /\
        tr_amount tr = sum
    ).
Proof.
  intros * Ctr Exec Q Hr Ho C.
  destruct_exec Exec.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv. subst ctr.
    execute_own c H5.
    case_if H5.
    case_if H9; simpl.
    + subst t.
      rewrite Q in H9.
      destruct response; simpl in *; try contradiction.
      inversion H9. subst.
      eexists.
      split.
      * simpl. left. eauto.
      * repeat split; simpl; trivial.
        resolve_owner H0. omega.
    + subst t. apply leb_sound_false in H5. contradict H5.
      assert (H' : m_global_time s1 > Δ).
      apply global_time_is_bigger_than_delta.
      unfold Δ. omega.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - inversion_event InEv. find_contradiction InEv.
  - find_contradiction InEv.
Qed.

Proposition pay_at_t_not_defaulted:
  forall s1 s2 c t I O addr sum c_id dsc_id,
    c = finctr c_id dsc_id (pay_at_t t addr sum) I O O 1 ->
    is_executed c s1 s2 t ->
    query (m_gateway s1) addr t = Some 0 ->
    O <> 0 ->
    consistent_state s1 ->
    m_ledger s1 = m_ledger s2.
Proof.
  intros * Ctr Exec Q Ho C.
  destruct_exec Exec.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv. subst ctr.
    execute_own c H5.
    case_if H5.
    case_if H9; simpl.
    + subst t.
      rewrite Q in H9. simpl in *.
      inversion H9. trivial.
    + subst t. apply leb_sound_false in H5. contradict H5.
      assert (H' : m_global_time s1 > Δ).
      apply global_time_is_bigger_than_delta.
      unfold Δ. omega.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - inversion_event InEv. find_contradiction InEv.
  - find_contradiction InEv.
Qed.
Print pay_at_t_O_rights.
Print pay_at_t_not_defaulted.

(****************************)
(* Proofs for yearly_checks *)
(****************************)

(* If defaulted then yearly_checks does not change the ledger *)
Proposition yearly_checks_already_defaulted:
  forall s1 s2 c t t' I O addr sum c_id dsc_id response a2cfee b2afee i,
    c = finctr c_id dsc_id (yearly_check t t' addr sum b2afee a2cfee i) I O O 1 ->
    is_executed c s1 s2 t ->
    (* B defaults *)
    query (m_gateway s1) addr t = Some response ->
    response <> 0 ->
    O <> 0 ->
    consistent_state s1 ->
    m_ledger s1 = m_ledger s2.
Proof.
  intros * C Exec Q1 R Hy1 Hc.
  destruct_exec Exec.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv. subst ctr.
    execute_own c H5.
    subst t. simpl.
    case_if H5.
    case_if H9; simpl.
    + rewrite Q1 in H9. simpl in H9.
      destruct response; try contradiction. simpl in H9.
      inversion H9. clear H9. subst. trivial.
    + trivial.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - inversion_event InEv. find_contradiction InEv.
  - find_contradiction InEv.
Qed.

Proposition yearly_checks_not_defaulted:
  forall s1 s2 c t t' I O addr sum c_id dsc_id a2cfee b2afee i,
    c = finctr c_id dsc_id (yearly_check t t' addr sum b2afee a2cfee i) I O O 1 ->
    is_executed c s1 s2 t ->
    (* B defaults *)
    query (m_gateway s1) addr t = Some 0 ->
    O <> 0 ->
    consistent_state s1 ->
    t > Δ ->
    t' - Δ > t  ->
    (exists ctr,
        In ctr (m_contracts s2) /\
        ctr_issuer ctr = I /\
        ctr_owner ctr = O /\
        ctr_primitive ctr = pay_at_t t' addr (sum + i * b2afee)).
Proof.
  intros * C Exec Q1 Hy1 Hc Hy2 Hy3.
  destruct_exec Exec.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv. subst ctr.
    execute_own c H5.
    subst t. simpl.
    case_if H5.
    case_if H9; simpl.
    + subst. rewrite Q1 in H9. simpl in H9.
      case_match H9.
      case_if H7.
      case_if H11.
      * apply leb_sound_true in H7. contradict H7. omega.
      * destruct r. inversion H12. clear H12. subst.
        inversion H10. clear H10.
        eexists. split.
        apply in_app_iff. right. simpl. left. trivial.
        repeat split; trivial. resolve_owner H0.
    + apply leb_sound_false in H5. contradict H5. unfold Δ. omega.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - inversion_event InEv. find_contradiction InEv.
  - find_contradiction InEv.
Qed.

Proposition yearly_checks_not_defaulted_C_rights:
  forall s1 s2 c t t' I O addr sum c_id dsc_id a2cfee b2afee i,
    c = finctr c_id dsc_id (yearly_check t t' addr sum b2afee a2cfee i) I O O 1 ->
    is_executed c s1 s2 t ->
    (* B defaults *)
    query (m_gateway s1) addr t = Some 0 ->
    O <> 0 ->
    consistent_state s1 ->
    t > Δ ->
    t' - Δ > t  ->
    (exists tr,
        In tr (m_ledger s2) /\
        tr_ctr_id tr = (ctr_id c) /\
        tr_from tr = O /\
        tr_to tr = I /\
        tr_amount tr = a2cfee).
Proof.
  intros * C Exec Q1 Hy1 Hc Hy2 Hy3.
  destruct_exec Exec.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv.  subst ctr.
    execute_own c H5.
    subst t. simpl.
    case_if H5.
    case_if H9; simpl.
    + subst. rewrite Q1 in H9. simpl in H9.
      case_match H9.
      case_if H7.
      case_if H11.
      * destruct r. inversion H12. clear H12. subst.
        inversion H10. clear H10.
        eexists.  simpl. split. left. trivial.
        repeat split; auto.
        simpl. resolve_owner H0.
        simpl. omega.
      * destruct r. inversion H12. clear H12. subst.
        inversion H10. clear H10.
        eexists.  simpl. split. left. trivial.
        repeat split; auto.
        simpl. resolve_owner H0.
        simpl. omega.
    + apply leb_sound_false in H5. contradict H5. unfold Δ. omega.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - same_ctr InEv. subst ctr. not_or' c H2.
  - inversion_event InEv. find_contradiction InEv.
  - find_contradiction InEv.
Qed.
Print yearly_checks_already_defaulted.
Print yearly_checks_not_defaulted.
Print yearly_checks_not_defaulted_C_rights.

(**********************************)
(* Proofs for Credit Default Swap *)
(**********************************)

(************************************************************)
(* General info:                                            *)
(* CDS generates three subcontracts C1 C2 C3, as follows:   *)
(*                                                          *)
(*   -> C1 - where Alice can request price + 2 * B2AliceFee *)
(*                 from C if B defaults in the first year   *)
(*   -> C2 - where Alice can request price + 1 * B2AliceFee *)
(*                 from C if B defaults in the second year  *)
(*   -> C3 - where Alice can request price + 0 * B2AliceFee *)
(*           from C if B defaults in the third year         *)
(************************************************************)

(*************************************************************************)
(* Scenario 1: B defaults in the first year.                             *)
(* Facts proved below:                                                   *)
(* 1. CDS_Y1_C1: Alice receives price + 2 * B2AliceFee if Alice joins C1 *)
(* 2. CDS_Y1_C2: ledger remains unchanged if Alice joins C2              *)
(* 3. CDS_Y1_C3: ledger remains unchanged if Alice joins C3              *)
(* 4. CDS_Y1_C: C receives the yealy fee from Alice if Alice joins CDS   *)
(*************************************************************************)

Proposition CDS_Y1_C1:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y1) ->
    (* default after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = pay_at_t (now + Y1) defaulted_addr (price + (2 * b2afee)) ->
      exists tr,
        In tr (m_ledger s4) /\
        tr_ctr_id tr = (ctr_id c') /\
        tr_from tr = C /\
        tr_to tr = Alice /\
        tr_amount tr = price + (2 * b2afee)
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * resolve_owner H2.
        eapply pay_at_t_O_rights; eauto. unfold pay_at_t, At. eauto.
      * subst c'. simpl in Prim. unfold pay_at_t, At in Prim. inversion Prim.
      * subst c'. simpl in Prim. unfold pay_at_t, At in Prim. inversion Prim.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y1_C2:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y1) ->
    (* default after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y2 > Y1 ->
    consistent_state s1 ->

    (* conclusion *)
    ( ctr_primitive c' = yearly_check (now + Y1) (now + Y2) defaulted_addr price b2afee a2cfee 1 ->
      m_ledger s3 = m_ledger s4
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Hy3 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * resolve_owner H2.
        eapply yearly_checks_already_defaulted; eauto.
        unfold yearly_check, At.
        instantiate (2 := b2afee). instantiate (2 := 1).
        exact Exec2.
      * subst c'. inversion Prim.
        contradict H9. omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y1_C3:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y2) ->
    (* default after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y3 > Y2 ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y2) (now + Y3) defaulted_addr price b2afee a2cfee 0 ->
      m_ledger s3 = m_ledger s4
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Hy3 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
        contradict H9. omega.
      * resolve_owner H2.
        eapply yearly_checks_already_defaulted; eauto.
        unfold yearly_check, At.
        instantiate (2 := b2afee). instantiate (2 := 0).
        exact Exec2.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent  Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y1_C :
  forall CDSctr CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (exists tr,
        In tr (m_ledger s2) /\
        tr_ctr_id tr = (ctr_id CDSctr) /\
        tr_from tr = Alice /\
        tr_to tr = C /\
        tr_amount tr = a2cfee
    ).
Proof.
  intros * CDS Exec Ho Hy1 Hy2 Hy3 Cst.
  destruct_exec Exec.
  insert_consistent s2 Step.
  induction Step; subst s2.
  - inversion_event InEv. find_contradiction InEv.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H6. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H6; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H6; unfold Δ; try auto; try omega.
    inversion H6. clear H6. subst.
    eexists. split. simpl. left. trivial.
    repeat split; trivial. simpl. resolve_owner H1.
    simpl. auto.
  - same_ctr InEv. subst ctr. not_or' CDSctr H3.
  - same_ctr InEv. subst ctr. not_or' CDSctr H3.
  - inversion_event InEv. inconsistent Cst InEv.
  - find_contradiction InEv.
Qed.
Print CDS_Y1_C1.
Print CDS_Y1_C2.
Print CDS_Y1_C3.
Print CDS_Y1_C.

(**************************************************************************)
(* Scenario 2: B defaults in the second year.                             *)
(* Facts proved below:                                                    *)
(* 1. CDS_Y2_C1: ledger remains unchanged if Alice joins C1               *)
(* 2. CDS_Y2_C2: if Alice joins C2 a new contract is generated, where:    *)
(*                  i) Alice is the owner                                 *)
(*                  ii) C is the issuer                                   *)
(*                  iii) the primitive is pay_at_t                        *)
(*                  iv) the value is price + b2afee                       *)
(*       CDS_Y2_C2 and pay_at_t_O_rights ensure that Alice receives       *)
(*       the payment price + b2afee from C, when B defaults after 2 years *)
(* 3. CDS_Y2_C3: ledger remains unchanged if Alice joins C3               *)
(* 4. CDS_Y2_C: C receives the yearly fee from Alice if Alice joins CDS   *)
(*    Note: the yearly fee is generated by C2                             *)
(**************************************************************************)

Proposition CDS_Y2_C1 :
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    (forall t, t >= now + Y1 -> is_executed c' s3 s4 t) ->
    (* not defaulted after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = pay_at_t (now + Y1) defaulted_addr (price + (2 * b2afee)) ->
     m_ledger s3 = m_ledger s4).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Q3 Ho Hn Hy1 Hy2 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * resolve_owner H2.
        eapply pay_at_t_not_defaulted; eauto.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y2_C2:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y1) ->
    (* not defaulted after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y2 -Y1 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y1) (now + Y2)
                                     defaulted_addr price b2afee a2cfee 1  ->
     (exists ctr,
         In ctr (m_contracts s4) /\
         ctr_issuer ctr = C /\
         ctr_owner ctr = Alice /\
         (ctr_primitive ctr = pay_at_t (now + Y2) defaulted_addr (price + 1 * b2afee)))
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Hy3 Hy4 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * eapply yearly_checks_not_defaulted in Exec2; try destruct Exec2 as [cpay [In [Is [Ow CPrim]]]]; eauto; try omega.
        ** exists cpay. repeat split; eauto.
           assert (H' : price + (b2afee + 0) = price + (1 * b2afee)); try omega.
           rewrite H'. exact CPrim.
        ** resolve_owner H2. unfold yearly_check, At. eauto.
        ** omega.
      * subst c'. inversion Prim.
        contradict H9. omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y2_C3:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y2) ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y3 - Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y2) (now + Y3)
                                     defaulted_addr price b2afee a2cfee 1  ->
      m_ledger s3 = m_ledger s4
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Hy3 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
        contradict H9. omega.
      * resolve_owner H2.
        eapply yearly_checks_already_defaulted; eauto.
        unfold yearly_check, At.
        instantiate (2 := b2afee). instantiate (2 := 0).
        exact Exec2.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y2_C :
  forall CDSctr CDSctr_id dsc_id Alice C defaulted_addr
         price c' b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y1) ->
    (* not defaulted after 1 year *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y2 - Y1 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y1) (now + Y2)
                                     defaulted_addr price b2afee a2cfee 1  ->
     (exists tr,
         In tr (m_ledger s4) /\
         tr_ctr_id tr = (ctr_id c') /\
         tr_from tr = Alice /\
         tr_to tr = C /\
         tr_amount tr = a2cfee
     )).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Ho Hn Hy1 Hy2 Hy3 Hy4 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * resolve_owner H2.
        eapply yearly_checks_not_defaulted_C_rights; eauto. unfold yearly_check, At; try omega.
        assert (H' : (price + (b2afee + 0)) = price + 1 * b2afee); try omega.
        rewrite H'. eauto.
        repeat try omega.
        omega.
      * subst c'. inversion Prim.
        contradict H9. omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - apply consistent_impl_exec in InCtr0; auto. contradiction.
Qed.
Print CDS_Y2_C1.
Print CDS_Y2_C2.
Print CDS_Y2_C3.
Print CDS_Y2_C.

(************************************************************************)
(* Scenario 3: B defaults in the third year.                            *)
(* Facts proved below:                                                  *)
(* 1. CDS_Y3_C1: ledger remains unchanged if Alice joins C1             *)
(* 2. CDS_Y3_C2: ledger remains unchanged if Alice joins C3             *)
(* 3. CDS_Y3_C3: if Alice joins C3 a new contract is generated, where:  *)
(*                  i) Alice is the owner                               *)
(*                  ii) C is the issuer                                 *)
(*                  iii) the primitive is pay_at_t                      *)
(*                  iv) the value is price                              *)
(*       CDS_Y3_C3 and pay_at_t_O_rights ensure that Alice receives     *)
(*       the payment price from C, when B defaults after 3 years        *)
(* 4. CDS_Y3_C: C receives the yearly fee from Alice if Alice joins CDS *)
(*    Note: the yearly fee is generated by C3                           *)
(************************************************************************)

Proposition CDS_Y3_C1 :
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    (forall t, t >= now + Y1 -> is_executed c' s3 s4 t) ->
    (* not defaulted in the first 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y3) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y3 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = pay_at_t (now + Y1) defaulted_addr (price + (2 * b2afee)) ->
     m_ledger s3 = m_ledger s4).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Q3 Q4 Ho Hn Hy1 Hy2 Hy3 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * resolve_owner H2.
        eapply pay_at_t_not_defaulted; eauto.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv.  inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y3_C2:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    (* if c' is executed at t < now + Y2 then c' execution will be postponed
       if c' is executed at t >= now + Y2 it will have no effect on the ledger *)
    is_executed c' s3 s4 (now + Y2) ->
    (* not defaulted in the first 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y3) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y2 - Y1 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y1) (now + Y2)
                                     defaulted_addr price b2afee a2cfee 1  ->
      m_ledger s3 = m_ledger s4
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Q3 Ho Hn Hy1 Hy2 Hy3 Hy4 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * eapply exec_later_no_effect; eauto.
      * subst c'. inversion Prim.
        contradict H9. omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y3_C3:
  forall CDSctr c' CDSctr_id dsc_id Alice C defaulted_addr
         price b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y2) ->
    (* not defaulted in the first 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y3) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y3 - Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y2) (now + Y3)
                                     defaulted_addr price b2afee a2cfee 1  ->
     (exists ctr,
         In ctr (m_contracts s4) /\
         ctr_issuer ctr = C /\
         ctr_owner ctr = Alice /\
         (ctr_primitive ctr = pay_at_t (now + Y3) defaulted_addr price))
    ).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Q3 Ho Hn Hy1 Hy2 Hy3 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr. destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]]; try contradiction.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
        contradict H9. omega.
      * resolve_owner H2.
        assert (H' : price = price + 0 * b2afee); try omega.
        rewrite H'.
        eapply yearly_checks_not_defaulted; eauto; try omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - simpl in InCtr. contradiction.
Qed.

Proposition CDS_Y3_C :
  forall CDSctr CDSctr_id dsc_id Alice C defaulted_addr
         price c' b2afee a2cfee s1 s2 s3 s4 now Y1 Y2 Y3,
    (* the execution of CDS generates 3 new contracts *)
    CDSctr = finctr CDSctr_id dsc_id
                    (CDS Alice C defaulted_addr price
                         b2afee a2cfee now Y1 Y2 Y3)
                    C Alice Alice 1 ->
    is_executed CDSctr s1 s2 now ->
    query (m_gateway s1) defaulted_addr now = Some 0 ->

    (* new contracts are joined by Alice *)
    ~ In c' (m_contracts s1) ->
    In c' (m_contracts s2) ->
    s2 ~~> s3 ->
    is_executed c' s3 s4 (now + Y2) ->
    (* not defaulted in the first 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y1) = Some 0 ->
    query (m_gateway s3) defaulted_addr (now + Y2) = Some 0 ->
    (* default after 2 years *)
    query (m_gateway s3) defaulted_addr (now + Y3) = Some 1 ->

    (* technical details *)
    Alice <> 0 ->
    now > Δ ->
    Y1 > Δ ->
    Y2 > Δ ->
    Y2 - Y1 > Δ ->
    Y3 - Y2 > Δ ->
    consistent_state s1 ->

    (* conclusion *)
    (ctr_primitive c' = yearly_check (now + Y2) (now + Y3)
                                     defaulted_addr price b2afee a2cfee 1  ->
     (exists tr,
         In tr (m_ledger s4) /\
         tr_ctr_id tr = (ctr_id c') /\
         tr_from tr = Alice /\
         tr_to tr = C /\
         tr_amount tr = a2cfee
     )).
Proof.
  intros * CDS Exec1 Q1 NIn InCtr Ss Exec2 Q2 Q3 Ho Hn Hy1 Hy2 Hy3 Hy4 Hy5 Cst Prim.
  destruct_exec Exec1.
  insert_consistent s2 Step.
  insert_consistent s3 Ss.
  induction Step; subst s2.
  - inversion_event InEv.
    apply consistent_impl_exec in InCtr0; auto. contradiction.
  - same_ctr InEv. subst ctr.
    execute_own CDSctr H7. simpl in *.
    subst now.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    rewrite helper_1, helper_2 in H7; unfold Δ; try auto; try omega.
    inversion H7. clear H7. subst.
    repeat rewrite in_app_iff in InCtr.
    destruct InCtr as [InCtr | InCtr].
    + apply in_smaller_list in InCtr. contradiction.
    + simpl in InCtr.
      destruct InCtr as [InCtr | [InCtr | [InCtr | InCtr]]];
        try contradiction.
      * subst c'. inversion Prim.
      * subst c'. inversion Prim.
        contradict H9. omega.
      * subst c'. resolve_owner H2.
        eapply yearly_checks_not_defaulted_C_rights; eauto.
        unfold yearly_check, At; try omega.
        assert (H' : (price + 0 = price + 0 * b2afee)); try omega.
        rewrite H'. reflexivity.
        omega. omega.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - same_ctr InEv. subst ctr. not_or' CDSctr H4.
  - inversion_event InEv. inconsistent Cst InEv.
  - apply consistent_impl_exec in InCtr0; auto. contradiction.
Qed.
Print CDS_Y3_C1.
Print CDS_Y3_C2.
Print CDS_Y3_C3.
Print CDS_Y3_C.


Require Import ORbdt.
Require Import ExtraLib.
Import Utf8.
Import Coqlib.

Import eqtype.
Import zint.

Section BOUNDED_BDD.

Context {A: eqType}.

(* A BDD is bounded by n when all variables that appear in the formula are larger than n *)
Definition bounded_bdd (bdd: bdd A) (pc: positive) : Prop :=
  ∀ p, In p (literal_of_bdd bdd) → (pc < p)%positive.

Lemma bounded_lt pc' bdd pc :
  (pc < pc')%positive →
  bounded_bdd bdd pc' →
  bounded_bdd bdd pc.
Proof.
  intros LT H p IN. specialize (H p IN). Psatz.lia.
Qed.

Lemma bounded_bdd_Node_inv p ℓ r pc :
  bounded_bdd (Node p ℓ r) pc →
  (pc < p)%positive ∧ bounded_bdd ℓ pc ∧ bounded_bdd r pc.
Proof.
  intros H.
  split. generalize (H p). simpl. auto.
  split; intros q; generalize (H q); simpl; rewrite in_app; auto.
Qed.

(* When evaluating a BDD that is bounded by n,
   the model can be extended with a smaller variable. *)
Lemma eval_bounded {pc pcm bdd} :
  bounded_bdd bdd pc →
  eval_bdd pcm bdd = eval_bdd (pc :: pcm) bdd.
Proof.
  elim bdd; clear.
  reflexivity.
  intros p ℓ IHℓ r IHr.
  intros BND; apply bounded_bdd_Node_inv in BND.
  destruct BND as (LT & Hℓ & Hr).
  simpl.
  rewrite seq.in_cons.
  destruct (ssrbool.in_mem _ _).
  rewrite orb_true_r; auto.
  case eqP. intros ->. Psatz.lia. auto.
Qed.

Definition check_bounded_bdd (g: bdd A) (n: positive) : bool :=
  List.forallb (Pos.ltb n) (literal_of_bdd g).

Lemma check_bounded_bdd_iff g n :
  reflect (bounded_bdd g n) (check_bounded_bdd g n).
Proof.
  unfold check_bounded_bdd, bounded_bdd.
  match goal with
  | |- context[ forallb ?x ?y ] => set (f := x); set (m := y)
  end.
  generalize (forallb_forall f m).
  destruct (forallb _ _).
  - intros [H _]; specialize (H Logic.eq_refl).
    constructor. intros p IN; generalize (H p IN).
    apply Pos.ltb_lt.
  - intros [_ H]. constructor.
    intros K. apply diff_false_true, H.
    intros p IN; generalize (K p IN).
    apply Pos.ltb_lt.
Qed.

End BOUNDED_BDD.

Lemma literal_of_pcond_lit p :
  literal_of_bdd (pcond_lit p) = p :: nil.
Proof. reflexivity. Qed.

Lemma literal_of_pcond_litN p :
  literal_of_bdd (pcond_litN p) = p :: nil.
Proof. reflexivity. Qed.

Lemma literal_of_pcond_or b1 b2 :
  incl (literal_of_bdd (pcond_or b1 b2)) (literal_of_bdd b1 ++ literal_of_bdd b2).
Proof.
  revert b2. elim b1; clear.
  intros (). intros ? ? (). intros ?; apply incl_refl.
  intros p ℓ IHℓ r IHr b2.
  elim b2; clear b2.
  intros (). intros ? (). simpl. rewrite app_nil_r. apply incl_refl.
  intros p' ℓ' IHℓ' r' IHr'.
  simpl.
  case eqP.
  - intros ->. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE. intros q. repeat (simpl; rewrite in_app). clear -IHℓ IHr.
    intros [ H | [ H | H ] ]. auto. right. specialize (IHℓ _ _ H). rewrite in_app in IHℓ. clear -IHℓ. intuition.
    right. specialize (IHr _ _ H). rewrite in_app in IHr. clear -IHr; intuition.
  - intros NE.
    case Pos.ltb_spec.
    + intros LT. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE'. intros q. repeat (simpl; rewrite in_app).
    intros [ H | [ H | H ] ]. auto. right. specialize (IHℓ _ _ H). repeat (simpl in IHℓ; rewrite in_app in IHℓ). clear -IHℓ. intuition.
    right. specialize (IHr _ _ H). repeat (simpl in IHr; rewrite in_app in IHr). clear -IHr; intuition.
    + intros LE. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ'. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE'. intros q. repeat (simpl; rewrite in_app).
    intros [ H | [ H | H ] ]. auto. specialize (IHℓ' _ H). repeat (simpl in IHℓ'; rewrite in_app in IHℓ'). clear -IHℓ'. intuition.
    specialize (IHr' _ H). repeat (simpl in IHr'; rewrite in_app in IHr'). clear -IHr'; intuition.
Qed.

Lemma literal_of_pcond_and b1 b2 :
  incl (literal_of_bdd (pcond_and b1 b2)) (literal_of_bdd b1 ++ literal_of_bdd b2).
Proof.
  revert b2. elim b1; clear.
  intros (). intros ?; apply incl_refl. intros ? ? ().
  intros p ℓ IHℓ r IHr b2.
  elim b2; clear b2.
  intros (). simpl. rewrite app_nil_r. apply incl_refl. intros ? ().
  intros p' ℓ' IHℓ' r' IHr'.
  simpl.
  case eqP.
  - intros ->. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE. intros q. repeat (simpl; rewrite in_app). clear -IHℓ IHr.
    intros [ H | [ H | H ] ]. auto. right. specialize (IHℓ _ _ H). rewrite in_app in IHℓ. clear -IHℓ. intuition.
    right. specialize (IHr _ _ H). rewrite in_app in IHr. clear -IHr; intuition.
  - intros NE.
    case Pos.ltb_spec.
    + intros LT. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE'. intros q. repeat (simpl; rewrite in_app).
    intros [ H | [ H | H ] ]. auto. right. specialize (IHℓ _ _ H). repeat (simpl in IHℓ; rewrite in_app in IHℓ). clear -IHℓ. intuition.
    right. specialize (IHr _ _ H). repeat (simpl in IHr; rewrite in_app in IHr). clear -IHr; intuition.
    + intros LE. unfold chkN.
    case bdd_eqP.
    intros EQ. eapply incl_tran. apply IHℓ'. clear. intros q. repeat (simpl; rewrite in_app). intuition.
    intros NE'. intros q. repeat (simpl; rewrite in_app).
    intros [ H | [ H | H ] ]. auto. specialize (IHℓ' _ H). repeat (simpl in IHℓ'; rewrite in_app in IHℓ'). clear -IHℓ'. intuition.
    specialize (IHr' _ H). repeat (simpl in IHr'; rewrite in_app in IHr'). clear -IHr'; intuition.
Qed.

Lemma bounded_pcond_or ℓ r pc :
  bounded_bdd ℓ pc →
  bounded_bdd r pc →
  bounded_bdd (pcond_or ℓ r) pc.
Proof.
  intros Hℓ Hr p IN.
  generalize (literal_of_pcond_or _ _ _ IN). rewrite in_app.
  intros [ L | R ]; auto.
Qed.

Lemma bounded_pcond_and ℓ r pc :
  bounded_bdd ℓ pc →
  bounded_bdd r pc →
  bounded_bdd (pcond_and ℓ r) pc.
Proof.
  intros Hℓ Hr p IN.
  generalize (literal_of_pcond_and _ _ _ IN). rewrite in_app.
  intros [ L | R ]; auto.
Qed.

Lemma bounded_pcond_lit x y :
  (y < x)%positive →
  bounded_bdd (pcond_lit x) y.
Proof.
  unfold bounded_bdd.
  rewrite literal_of_pcond_lit. simpl. intuition Psatz.lia.
Qed.

Lemma bounded_pcond_litN x y :
  (y < x)%positive →
  bounded_bdd (pcond_litN x) y.
Proof.
  unfold bounded_bdd.
  rewrite literal_of_pcond_litN. simpl. intuition Psatz.lia.
Qed.

Section ON_BDD.
  Import ssrbool seq.

  Context {A: eqType}.

  Lemma eval_bdd_m (x y: pEnv) :
    (∀ n, In n x ↔ In n y) →
    ∀ bdd : bdd A, eval_bdd x bdd = eval_bdd y bdd.
  Proof.
    intros EXT.
    intros bdd; elim bdd; clear bdd. reflexivity.
    intros n ℓ IHℓ r IHr.
    generalize (EXT n). rewrite <- (ssrlib.InE n x), <- (ssrlib.InE n y).
    simpl. case (n \in _). intros H.
    rewrite (proj1 H Logic.eq_refl). exact IHℓ.
    case (n \in _); auto.
    intros H. generalize (proj2 H Logic.eq_refl). discriminate.
  Qed.

  Lemma not_bounded_bdd_ex (bdd: bdd A) n :
    ¬ bounded_bdd bdd n →
    ∃ m,
    In m (literal_of_bdd bdd) ∧ (m <= n)%positive.
  Proof.
    intros K.
    set (q := literal_of_bdd bdd).
    generalize (min_name_iff q). destruct (min_name _) as [ m | ].
    intros [Hm LE]. exists m. apply (conj Hm).
    case (Pos.leb_spec m n). exact id.
    intros LT. elim K. intros p Hp. specialize (LE _ Hp). Psatz.lia.
    intros Q. elim K. intros p Hp. fold q in Hp. rewrite Q in Hp. destruct Hp.
  Qed.

  Definition bounded_bdd' (bdd: bdd A) n :=
    match n with
    | None => True
    | Some n => bounded_bdd bdd n
    end.

End ON_BDD.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Theory.Unique.
Require Import Category.Structure.Initial.
Require Import Category.Construction.Comma.
Require Import Category.Functor.Diagonal.

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

Section UniversalArrow.

Context `{C : Category}.
Context `{D : Category}.

Class UniversalArrow (c : C) (F : D ⟶ C) := {
arrow_initial : @Initial (=(c) ↓ F);

arrow_obj := snd (`1 (@initial_obj _ arrow_initial));
arrow : c ~> F arrow_obj := `2 (@initial_obj _ arrow_initial)
}.

Notation "c ⟿ F" := (UniversalArrow c F) (at level 20) : category_theory_scope.

Corollary ump_universal_arrows `(c ⟿ F) `(h : c ~> F d) :
∃! g : arrow_obj ~> d, h ≈ fmap[F] g ∘ arrow.
Proof. hammer_hook "Arrow" "Arrow.ump_universal_arrows".
unfold arrow_obj, arrow; simpl.
destruct (@zero _ arrow_initial ((tt, d); h)), x.
simpl in *.
rewrite id_right in e.
exists h1.
assumption.
intros.
rewrite <- id_right in e.
rewrite <- id_right in X.
exact (snd (@zero_unique _ arrow_initial ((tt, d); h)
((tt, h1); e) ((tt, v); X))).
Qed.

End UniversalArrow.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Arith.
Require Import Bedrock.Word.

Definition word32 := word 32. (* 2^5 *)
Definition word64 := word 64. (* 2^6 *)
Definition word128 := word 128. (* 2^7 *)

Definition word_case {T : nat -> Type} (logsz : nat)
           (case32 : T 5)
           (case64 : T 6)
           (case128 : T 7)
           (default : forall k, T k)
  : T logsz
  := match logsz return T logsz with
     | 5 => case32
     | 6 => case64
     | 7 => case128
     | logsz' => default _
     end.

Definition wordT logsz := word_case (T:=fun _ => Set) logsz word32 word64 word128 (fun logsz => word (2^logsz)).

Definition word_case_dep {T : nat -> Set -> Type} (logsz : nat)
           (case32 : T 5 word32)
           (case64 : T 6 word64)
           (case128 : T 7 word128)
           (default : forall k, T k (word (2^k)))
  : T logsz (wordT logsz)
  := match logsz return T logsz (wordT logsz) with
     | 5 => case32
     | 6 => case64
     | 7 => case128
     | logsz' => default _
     end.

Definition ZToWord_gen {sz} (v : Z) : word sz := NToWord _ (Z.to_N v).
Definition wordToZ_gen {sz} (v : word sz) : Z := Z.of_N (wordToN v).

Definition ZToWord32 : Z -> word32 := @ZToWord_gen _.
Definition word32ToZ : word32 -> Z := @wordToZ_gen _.
Definition wadd32 : word32 -> word32 -> word32 := @wplus _.
Definition wsub32 : word32 -> word32 -> word32 := @wminus _.
Definition wmul32 : word32 -> word32 -> word32 := @wmult _.
Definition wshl32 : word32 -> word32 -> word32 := @wordBin N.shiftl _.
Definition wshr32 : word32 -> word32 -> word32 := @wordBin N.shiftr _.
Definition wland32 : word32 -> word32 -> word32 := @wand _.
Definition wlor32 : word32 -> word32 -> word32 := @wor _.

Definition ZToWord64 : Z -> word64 := @ZToWord_gen _.
Definition word64ToZ : word64 -> Z := @wordToZ_gen _.
Definition wadd64 : word64 -> word64 -> word64 := @wplus _.
Definition wsub64 : word64 -> word64 -> word64 := @wminus _.
Definition wmul64 : word64 -> word64 -> word64 := @wmult _.
Definition wshl64 : word64 -> word64 -> word64 := @wordBin N.shiftl _.
Definition wshr64 : word64 -> word64 -> word64 := @wordBin N.shiftr _.
Definition wland64 : word64 -> word64 -> word64 := @wand _.
Definition wlor64 : word64 -> word64 -> word64 := @wor _.

Definition ZToWord128 : Z -> word128 := @ZToWord_gen _.
Definition word128ToZ : word128 -> Z := @wordToZ_gen _.
Definition wadd128 : word128 -> word128 -> word128 := @wplus _.
Definition wsub128 : word128 -> word128 -> word128 := @wminus _.
Definition wmul128 : word128 -> word128 -> word128 := @wmult _.
Definition wshl128 : word128 -> word128 -> word128 := @wordBin N.shiftl _.
Definition wshr128 : word128 -> word128 -> word128 := @wordBin N.shiftr _.
Definition wland128 : word128 -> word128 -> word128 := @wand _.
Definition wlor128 : word128 -> word128 -> word128 := @wor _.

Definition ZToWord {logsz}
  := word_case_dep (T:=fun _ word => Z -> word)
                   logsz ZToWord32 ZToWord64 ZToWord128 (fun _ => @ZToWord_gen _).
Definition wordToZ {logsz}
  := word_case_dep (T:=fun _ word => word -> Z)
                   logsz word32ToZ word64ToZ word128ToZ (fun _ => @wordToZ_gen _).
Definition wadd {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wadd32 wadd64 wadd128 (fun _ => @wplus _).
Definition wsub {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wsub32 wsub64 wsub128 (fun _ => @wminus _).
Definition wmul {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wmul32 wmul64 wmul128 (fun _ => @wmult _).
Definition wshl {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wshl32 wshl64 wshl128 (fun _ => @wordBin N.shiftl _).
Definition wshr {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wshr32 wshr64 wshr128 (fun _ => @wordBin N.shiftr _).
Definition wland {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wland32 wland64 wland128 (fun _ => @wand _).
Definition wlor {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wlor32 wlor64 wlor128 (fun _ => @wor _).

Create HintDb fixed_size_constants discriminated.
Hint Unfold word32 word64 word128
     wadd wadd32 wadd64 wadd128
     wsub wsub32 wsub64 wsub128
     wmul wmul32 wmul64 wmul128
     wshl wshl32 wshl64 wshl128
     wshr wshr32 wshr64 wshr128
     wland wland32 wland64 wland128
     wlor wlor32 wlor64 wlor128 : fixed_size_constants.


Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Export Combinators.
Require Export ComprehensionNotation.

(** * Directed sets of codes *)

(** Now that we have defined finite codes,
    we would next like to define limits of finite codes,
    exactly mirroring the completion of the rationals as the reals.
    We will define limits as equivalence classes of finite codes
    indexed over directed sets,
    which are indexed sets together with a directedness certificate.
    We begin with codes indexed by undirected sets,
    i.e. sets without proof certificates of directedness. *)

Definition Precodes (Var : Set) := {index : Type & index -> Code Var}.

Inductive tree (a : Type) : Type :=
  | tree_none : tree a
  | tree_leaf (x : a) : tree a
  | tree_pair (l r : tree a) : tree a.

Fixpoint tree_reduce {a b : Type}
  (f0 : b) (f1 : a -> b) (f2 : b -> b -> b) (t :tree a) : b :=
  match t with
  | tree_none => f0
  | tree_leaf x => f1 x
  | tree_pair l r => f2 (tree_reduce f0 f1 f2 l) (tree_reduce f0 f1 f2 r)
  end.

Definition predirect {Var : Set} (x : Precodes Var) : Precodes Var :=
  let (index, enum) := x in
  let index' := tree index in
  let enum' := tree_reduce code_bot enum code_join in
  existT _ index' enum'.

Definition precodes_ap {Var : Set} (s1 s2 : Precodes Var) : Precodes Var :=
  let (index1, enum1) := s1 in
  let (index2, enum2) := predirect s2 in
  let index12 := (index1 * index2)%type in
  let enum12 (i : index12) :=
    let (i1, i2) := i in (enum1 i1) * (enum2 i2)
  in
  existT _ index12 enum12.

(** patently Pi02 *)
Definition precodes_le {Var : Set} (s1 s2 : Precodes Var) : Prop :=
  let (index1, enum1) := predirect s1 in
  let (index2, enum2) := predirect s2 in
  forall c : Code Var,
  forall i1 : index1, code_conv (c * (enum1 i1)) ->
  exists i2 : index2, code_conv (c * (enum2 i2)).

(** ** Indexed codes with directedness certificates *)

Record codes {Var : Set} := codes_intro {
  index : Type;
  enum : index -> Code Var;
  join i1 i2 : {i : index | (enum i1 || enum i2 [= enum i)%code};
  nonempty : index
}.

Definition Codes (Var : Set) := @codes Var.

Definition codes_code {Var : Set} (x : Code Var) : Codes Var.
  refine (codes_intro Var unit (fun _  => x) (fun _ _ => _) tt).
  exists tt; auto.
Defined.

Notation "[ x ]" := (codes_code x) : codes_scope.

Open Scope codes_scope.
Delimit Scope codes_scope with codes.
Bind Scope codes_scope with codes.

Section Codes_ap.
  Variable Var : Set.
  Variable s1 s2 : Codes Var.

  Let index1 := s1.(index).
  Let enum1 := s1.(enum).
  Let join1 := s1.(join).
  Let nonempty1 := s1.(nonempty).

  Let index2 := s2.(index).
  Let enum2 := s2.(enum).
  Let join2 := s2.(join).
  Let nonempty2 := s2.(nonempty).

  Let index12 := (index1 * index2)%type.

  Let enum12 (i : index12) : Code Var :=
    let (i1, i2) := i in
    (enum1 i1) * (enum2 i2).

  Let nonempty12 := (nonempty1, nonempty2).

  Definition Codes_ap : Codes Var.
    refine (codes_intro _ index12 enum12 _ nonempty12).
    intros i j.
    destruct i as [i1 i2].
    destruct j as [j1 j2].
    assert (kp1 := join1 i1 j1); destruct kp1 as [k1 p1].
    assert (kp2 := join2 i2 j2); destruct kp2 as [k2 p2].
    exists (k1, k2).
    unfold enum12.
    apply code_le_join in p1.
    apply code_le_join in p2.
    apply code_le_join; split; apply code_ap_le; apply p1 || apply p2.
  Defined.
End Codes_ap.

Definition codes_ap {Var : Set} := Codes_ap Var.
Notation "x * y" := (codes_ap x y) : codes_scope.

Section Codes_sub.
  Variable Var Var' : Set.
  Variable fs : Var -> Codes Var'.
  Variable xs : Codes Var.

  Let index := prod (forall v : Var, (fs v).(index)) xs.(index).

  Let enum (i : index) : Code Var' :=
    let (fi, xi) := i in
    let f v := (fs v).(enum) (fi v) in
    let x := xs.(enum) xi in
    code_sub f x.

  (*
  Let nonempty : index := (fs.(nonempty), xs.(nonempty))%type.
  *)

  Definition Codes_sub : Codes Var'.
    refine (codes_intro _ index enum _ _).
      intros i j.
      destruct i as [i1 i2].
      destruct j as [j1 j2].
      (* FIXME
      assert (kp1 := fs.(join) i1 j1); destruct kp1 as [k1 p1].
      assert (kp2 := xs.(join) i2 j2); destruct kp2 as [k2 p2].
      exists (k1, k2).
      unfold enum12.
      apply code_le_join in p1.
      apply code_le_join in p2.
      apply code_le_join; split; apply code_le_ap; apply p1 || apply p2.
     *)
     admit.
   admit.
  Defined.
End Codes_sub.

Definition codes_sub {Var Var' : Set} := Codes_sub Var Var'.
Notation "x @ f" := (codes_sub x f) : codes_scope.

Instance code_abs_le (Var Var' : Set) (b : Var -> option Var') :
  Proper (code_le ==> code_le) (code_abs b).
Proof.
  intros x x' Hx.
Admitted.

Section Codes_abs.
  Variable Var Var' : Set.
  Variable b : Var -> option Var'.
  Variable x : Codes Var.

  Let enum i := code_abs b (x.(enum) i).

  Definition Codes_abs : Codes Var'.
    refine (codes_intro _ x.(index) enum _ x.(nonempty)).
    intros i1 i2.
    assert (j := x.(join) i1 i2); destruct j as [i12 H]; exists i12.
    unfold enum; simpl.
    apply code_le_join in H; destruct H as [H1 H2].
    apply code_le_join; split; apply code_abs_le; auto.
  Defined.
End Codes_abs.

Definition codes_abs {Var Var' : Set} := Codes_abs Var Var'.

Section Codes_lambda.
  Variable Var : Set.
  Variable x y : Codes (nat + Var).

  Let index := (x.(index) * y.(index))%type.

  Let enum (i : index) : Code (nat + Var) :=
    let (i1, i2) := i in
    code_lambda (x.(enum) i1) (y.(enum) i2).

  Let nonempty := (x.(nonempty), y.(nonempty)).

  Definition Codes_lambda : Codes (nat + Var).
    refine (codes_intro _ index enum _ nonempty).
    intros i1 i2.
    admit. (* TODO fix [code_lambda] to work here *)
  Defined.
End Codes_lambda.

Instance code_close_le (Var : Set) : Proper (code_le ==> code_le) (@close_var Var).
Proof.
  intros x x' xx'.
Admitted.

Definition codes_close {Var : Set} (x : Codes (nat + Var)) : Codes Var.
  refine (codes_intro
      _
      x.(index)
      (fun i => close_var (x.(enum) i))
      _
      x.(nonempty)).
  intros i1 i2.
  assert (j := x.(join) i1 i2); destruct j as [i12 H]; exists i12.
  apply code_le_join in H; destruct H as [H1 H2].
  apply code_le_join; split; apply code_close_le; auto.
Defined.

Definition codes_lambda {Var : Set} := Codes_lambda Var.
Notation "\ x , y" := (codes_lambda x y) : codes_scope.

(* does this require extensionality?
Lemma codess_ap_comm :
  forall x y, codess_ap (codess_codes x) (codess_codes y) = codess_codes (x * y).
Proof.
  intros x y.
  compute; auto.
*)

(** The information ordering is now patently $\Pi_0^2$ *)

Definition codes_le {Var : Set} (s1 s2 : Codes Var) : Prop :=
  let (index1, enum1, _, _) := s1 in
  let (index2, enum2, _, _) := s2 in
  forall {Var' : Set} (c : Code Var') (f : Var -> Code Var'),
  forall i1 : index1, code_conv (c * (enum1 i1 @ f))%code ->
  exists i2 : index2, code_conv (c * (enum2 i2 @ f))%code.

Definition codes_eq {Var : Set} (x y : Codes Var) : Prop :=
  codes_le x y /\ codes_le y x.

Notation "x [= y" := (codes_le x y) : codes_scope.
Notation "x == y" := (codes_eq x y) : codes_scope.

(** Now we demonstrate the power of indexing over directed sets.
    The simple implicit definition of [A_implicit] is not directed. *)

Definition direct {Var : Set} (p : Precodes Var) : Codes Var.
  destruct p as [index enum].
  refine (codes_intro _ (tree index) (tree_reduce BOT enum code_join) _ _).
    intros i j.
    exists (tree_pair _ i j).
    compute; auto.
  apply tree_none.
Defined.

Definition codes_sup {Var : Set} {index : Type} (enum : index -> Code Var) :
  Codes Var :=
  direct (existT _ index enum).

Section direct_example.
  Open Scope code_scope.
  Variable Var : Set.
  Let x := make_var Var 0.
  Let y := make_var Var 1.
  Let z := make_var Var 2.
  Let pair := Eval compute in close_var (\x, \y, \z, z * x * y).
  Notation "<< x , y >>" := (pair * x * y).
  Let A_implicit : Codes Var :=
    codes_sup (<<s, r>> for s : Code Var for r : Code Var if r o s [= I).
End direct_example.


(**
The identity pseudo functor on a bicategory.

Authors: Dan Frumin, Niels van der Weide

Ported from: https://github.com/nmvdw/groupoids
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.

Section IdentityFunctor.
  Variable (C : bicat).

  Definition id_functor_d : psfunctor_data C C.
  Proof.
    use make_psfunctor_data.
    - exact (λ x, x).
    - exact (λ _ _ x, x).
    - exact (λ _ _ _ _ x, x).
    - exact (λ x, id2 _).
    - exact (λ _ _ _ _ _, id2 _).
  Defined.

  Definition id_functor_laws : psfunctor_laws id_functor_d.
  Proof.
    repeat split.
    - intros a b f ; cbn in *.
      rewrite id2_rwhisker.
      rewrite !id2_left.
      reflexivity.
    - intros a b f ; cbn in *.
      rewrite lwhisker_id2.
      rewrite !id2_left.
      reflexivity.
    - intros a b c d f g h ; cbn in *.
      rewrite lwhisker_id2, id2_rwhisker.
      rewrite !id2_left, !id2_right.
      reflexivity.
    - intros a b c f g h α ; cbn in *.
      rewrite !id2_left, !id2_right.
      reflexivity.
    - intros a b c f g h α ; cbn in *.
      rewrite !id2_left, !id2_right.
      reflexivity.
  Qed.

  Definition id_psfunctor : psfunctor C C.
  Proof.
    use make_psfunctor.
    - exact id_functor_d.
    - exact id_functor_laws.
    - split ; cbn ; intros ; is_iso.
  Defined.
End IdentityFunctor.


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

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

(* proof of the sub-formula property in the sequent calculus *)
Require Import Arith.
Require Import Max.
Require Export Sequent.
Set Implicit Arguments.
Unset Strict Implicit.

(* some arithmetic results that will be used in the final proof *)

Lemma maxNatL : forall n m : nat, max n m = 0 -> n = 0.
Proof.
 intros m n H.
 cut (m <= 0).
 intro.
 cut (0 = m); auto.
 apply le_n_O_eq.
 assumption.
 rewrite <- H.
 apply le_max_l.
Qed.

Lemma maxNatR : forall n m : nat, max n m = 0 -> m = 0.
Proof.
 intros m m' H.
 cut (0 = m'); auto.
 cut (m' <= 0).
 intro.
 apply le_n_O_eq.
 assumption.
 rewrite <- H.
 auto with arith.
Qed.
(* end of arithmetic part *)

(* definition of the degree of a formula recursively *)
 Fixpoint degreeFormula (Atoms : Set) (F : Form Atoms) {struct F} : nat :=
   match F with
   | At Atoms => 1
   | Slash F1 F2 => S (max (degreeFormula F1) (degreeFormula F2))
   | Backslash F1 F2 => S (max (degreeFormula F1) (degreeFormula F2))
   | Dot F1 F2 => S (max (degreeFormula F1) (degreeFormula F2))
   end.

(* Lemma that states that the degree of a formula is strictly positif *)
Lemma degreeForm_O :
 forall (Atoms : Set) (F : Form Atoms), 1 <= degreeFormula F.
Proof.
 intros Atoms F.
 elim F; intros; simpl in |- *; auto with arith.
Qed.

(* Recursive definition of the degree of a proof which is
 the max of the degree of its cut rules (the degree of a cut rule
 is the degree of the formula which is eliminated in the conclusion
sequent )*)

Fixpoint degreeProof (Atoms : Set) (Gamma : Term Atoms)
 (B : Form Atoms) (E : gentzen_extension) (p : gentzenSequent E Gamma B)
 {struct p} : nat :=
  match p with
  | Ax _ => 0
  | RightSlash _ _ _ H => degreeProof H
  | RightBackSlash _ _ _ H => degreeProof H
  | RightDot _ _ _ _ H1 H2 => max (degreeProof H1) (degreeProof H2)
  | LeftSlash _ _ _ _ _ _ R H1 H2 => max (degreeProof H1) (degreeProof H2)
  | LeftBackSlash _ _ _ _ _ _ R H1 H2 =>
      max (degreeProof H1) (degreeProof H2)
  | LeftDot _ _ _ _ _ R H => degreeProof H
  | CutRule _ _ _ A _ R H1 H2 =>
      max (max (degreeFormula A) (degreeProof H1)) (degreeProof H2)
  | SequentExtension _ _ _ _ _ E R H => degreeProof H
  end.

(* test *)

(* Eval Compute in (degreeProof (application A B E)).
     = (0)
     : nat*)

(* Inductive definition of the relation subFormula *)
Inductive subFormula (Atoms : Set) : Form Atoms -> Form Atoms -> Prop :=
  | equalForm : forall A : Form Atoms, subFormula A A
  | slashL :
      forall A B C : Form Atoms, subFormula A B -> subFormula A (Slash B C)
  | slashR :
      forall A B C : Form Atoms, subFormula A B -> subFormula A (Slash C B)
  | backslashL :
      forall A B C : Form Atoms,
      subFormula A B -> subFormula A (Backslash B C)
  | backslashR :
      forall A B C : Form Atoms,
      subFormula A B -> subFormula A (Backslash C B)
  | dotL :
      forall A B C : Form Atoms, subFormula A B -> subFormula A (Dot B C)
  | dotR :
      forall A B C : Form Atoms, subFormula A B -> subFormula A (Dot C B).

(*some lemmas concerning the relation subformula *)

(* Lemma that states that the only subformula of a primitif type
is this primitif type itself *)
Lemma subAt :
 forall (Atoms : Set) (A : Form Atoms) (at_ : Atoms),
 subFormula A (At at_) -> A = At at_.
 intros Atoms A at_ H.
 inversion H.
 reflexivity.
Qed.

Lemma subSlash :
 forall (Atoms : Set) (A B C : Form Atoms),
 subFormula A (Slash B C) ->
 A = Slash B C \/ subFormula A B \/ subFormula A C.

 intros Atoms A B C H.
 inversion H; auto.
Qed.

Lemma subBackslash :
 forall (Atoms : Set) (A B C : Form Atoms),
 subFormula A (Backslash B C) ->
 A = Backslash B C \/ subFormula A B \/ subFormula A C.

 intros Atoms A B C H.
 inversion H; auto.
Qed.

Lemma subDot :
 forall (Atoms : Set) (A B C : Form Atoms),
 subFormula A (Dot B C) -> A = Dot B C \/ subFormula A B \/ subFormula A C.
 intros Atoms A B C H.
 inversion H; auto.

Defined.

Lemma subFormulaTrans :
 forall (Atoms : Set) (A B C : Form Atoms),
 subFormula A B -> subFormula B C -> subFormula A C.

 intros At A B C.
 elim C.
 intros a H H0.
 elim (subAt H0).
 assumption.
 intros f H f0 H0 H1 H2.
 elim (subSlash H2); intro H3.
 rewrite <- H3; auto.
 elim H3; intro.
 apply slashL; auto.
 apply slashR; auto.
 intros f H f0 H0 H1 H2.
 elim (subDot H2); intro H3.
 rewrite <- H3; auto.
 elim H3; intro.
 apply dotL; auto.
 apply dotR; auto.
 intros f H f0 H0 H1 H2.
 elim (subBackslash H2); intro H3.
 rewrite <- H3; auto.
 elim H3; clear H3; intro.
 apply backslashL; auto.
 apply backslashR; auto.
Qed.

Inductive subFormTerm (Atoms : Set) : Form Atoms -> Term Atoms -> Prop :=
  | eqFT :
      forall A B : Form Atoms, subFormula A B -> subFormTerm A (OneForm B)
  | comL :
      forall (A : Form Atoms) (T1 T2 : Term Atoms),
      subFormTerm A T1 -> subFormTerm A (Comma T1 T2)
  | comR :
      forall (A : Form Atoms) (T1 T2 : Term Atoms),
      subFormTerm A T1 -> subFormTerm A (Comma T2 T1).

Lemma oneFormSub :
 forall (Atoms : Set) (A B : Form Atoms),
 subFormTerm A (OneForm B) -> subFormula A B.
 intros Atoms A B H.
 inversion H.
 assumption.
Qed.

Lemma comSub :
 forall (Atoms : Set) (f : Form Atoms) (T1 T2 : Term Atoms),
 subFormTerm f (Comma T1 T2) -> subFormTerm f T1 \/ subFormTerm f T2.

 intros Atoms f T1 T2 H.
 inversion H.
 left; assumption.
 right; assumption.
Qed.

Definition subReplace1 :
  forall (Atoms : Set) (T1 T2 T3 T4 : Term Atoms) (F : Form Atoms),
  replace T1 T2 T3 T4 -> subFormTerm F T3 -> subFormTerm F T1.
 simple induction 1.
 auto.
 intros.
 apply comL.
 auto.
 intros.
 apply comR.
 auto.
Defined.

Definition subReplace2 :
  forall (Atoms : Set) (T1 T2 T3 T4 : Term Atoms) (F : Form Atoms),
  replace T1 T2 T3 T4 -> subFormTerm F T4 -> subFormTerm F T2.

 simple induction 1.
 auto.
 intros.
 apply comL.
 auto.
 intros.
 apply comR.
 auto.
Defined.

Definition subReplace3 :
  forall (Atoms : Set) (T1 T2 T3 T4 : Term Atoms) (x : Form Atoms),
  replace T1 T2 T3 T4 ->
  subFormTerm x T1 -> subFormTerm x T2 \/ subFormTerm x T3.

 simple induction 1.
 auto.
 intros.
 elim (comSub H1).
 intro.
 elim (H0 H2).
 intro; left; apply comL; auto.
 auto.
 intro; left; apply comR; auto.
 intros.
 elim (comSub H1).
 intro; left; apply comL; auto.
 intro H2.
 elim (H0 H2).
 intro; left; apply comR; auto.
 auto.
Defined.

Definition CutFreeProof (Atoms : Set) (Gamma : Term Atoms)
  (B : Form Atoms) (E : gentzen_extension) (p : gentzenSequent E Gamma B) :=
  degreeProof p = 0 :>nat.

Lemma notCutFree :
 forall (Atoms : Set) (E : gentzen_extension) (T1 T2 D : Term Atoms)
   (A C : Form Atoms) (r : replace T1 T2 (OneForm A) D)
   (p1 : gentzenSequent E D A) (p2 : gentzenSequent E T1 C),
 ~ CutFreeProof (CutRule r p1 p2).

 intros At E T1 T2 D A C r p1 p2.
 red in |- *.
 unfold CutFreeProof in |- *.
 simpl in |- *.
 intro H.
 cut (1 <= degreeFormula A).
 intro H1.
 cut (degreeFormula A = 0).
 intro H3.
 rewrite H3 in H1.
 generalize H1.
 cut (~ 1 <= 0).
 auto.
 apply le_Sn_O.
 cut (max (degreeFormula A) (degreeProof p1) = 0).
 intro; eapply maxNatL; eauto.
 eapply maxNatL; eauto.
 apply degreeForm_O.
Qed.

Inductive subProofOne (Atoms : Set) (E : gentzen_extension) :
forall (Gamma1 Gamma2 : Term Atoms) (B C : Form Atoms),
gentzenSequent E Gamma1 B -> gentzenSequent E Gamma2 C -> Prop :=
  | rs :
      forall (Gamma : Term Atoms) (A B : Form Atoms)
        (p : gentzenSequent E (Comma Gamma (OneForm B)) A),
      subProofOne p (RightSlash p)
  | rbs :
      forall (Gamma : Term Atoms) (A B : Form Atoms)
        (p : gentzenSequent E (Comma (OneForm B) Gamma) A),
      subProofOne p (RightBackSlash p)
  | rd1 :
      forall (Gamma Delta : Term Atoms) (A B : Form Atoms)
        (p1 : gentzenSequent E Gamma A) (p2 : gentzenSequent E Delta B),
      subProofOne p1 (RightDot p1 p2)
  | rd2 :
      forall (Gamma Delta : Term Atoms) (A B : Form Atoms)
        (p1 : gentzenSequent E Gamma A) (p2 : gentzenSequent E Delta B),
      subProofOne p2 (RightDot p1 p2)
  | ls1 :
      forall (Delta Gamma Gamma' : Term Atoms) (A B C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A)
               (Comma (OneForm (Slash A B)) Delta))
        (p1 : gentzenSequent E Delta B) (p2 : gentzenSequent E Gamma C),
      subProofOne p1 (LeftSlash r p1 p2)
  | ls2 :
      forall (Delta Gamma Gamma' : Term Atoms) (A B C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A)
               (Comma (OneForm (Slash A B)) Delta))
        (p1 : gentzenSequent E Delta B) (p2 : gentzenSequent E Gamma C),
      subProofOne p2 (LeftSlash r p1 p2)
  | lbs1 :
      forall (Delta Gamma Gamma' : Term Atoms) (A B C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A)
               (Comma Delta (OneForm (Backslash B A))))
        (p1 : gentzenSequent E Delta B) (p2 : gentzenSequent E Gamma C),
      subProofOne p1 (LeftBackSlash r p1 p2)
  | lbs2 :
      forall (Delta Gamma Gamma' : Term Atoms) (A B C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A)
               (Comma Delta (OneForm (Backslash B A))))
        (p1 : gentzenSequent E Delta B) (p2 : gentzenSequent E Gamma C),
      subProofOne p2 (LeftBackSlash r p1 p2)
  | ld :
      forall (Gamma Gamma' : Term Atoms) (A B C : Form Atoms)
        (r : replace Gamma Gamma' (Comma (OneForm A) (OneForm B))
               (OneForm (Dot A B))) (p : gentzenSequent E Gamma C),
      subProofOne p (LeftDot r p)
  | cr1 :
      forall (Delta Gamma Gamma' : Term Atoms) (A C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A) Delta)
        (p1 : gentzenSequent E Delta A) (p2 : gentzenSequent E Gamma C),
      subProofOne p1 (CutRule r p1 p2)
  | cr2 :
      forall (Delta Gamma Gamma' : Term Atoms) (A C : Form Atoms)
        (r : replace Gamma Gamma' (OneForm A) Delta)
        (p1 : gentzenSequent E Delta A) (p2 : gentzenSequent E Gamma C),
      subProofOne p2 (CutRule r p1 p2)
  | se :
      forall (Gamma Gamma' T1 T2 : Term Atoms) (C : Form Atoms)
        (e : E Atoms T1 T2) (r : replace Gamma Gamma' T1 T2)
        (p : gentzenSequent E Gamma C),
      subProofOne p (SequentExtension e r p).

Inductive subProof (Atoms : Set) (E : gentzen_extension) :
forall (Gamma1 Gamma2 : Term Atoms) (B C : Form Atoms),
gentzenSequent E Gamma1 B -> gentzenSequent E Gamma2 C -> Prop :=
  | sameProof :
      forall (T : Term Atoms) (A : Form Atoms) (p : gentzenSequent E T A),
      subProof p p
  | subProof1 :
      forall (T1 T2 T3 : Term Atoms) (A1 A2 A3 : Form Atoms)
        (p1 : gentzenSequent E T1 A1) (p2 : gentzenSequent E T2 A2)
        (p3 : gentzenSequent E T3 A3),
      subProof p2 p1 -> subProofOne p3 p2 -> subProof p3 p1.

Lemma CutFreeSubProofOne :
 forall (Atoms : Set) (Gamma1 Gamma2 : Term Atoms)
   (B C : Form Atoms) (E : gentzen_extension) (p : gentzenSequent E Gamma1 B)
   (q : gentzenSequent E Gamma2 C),
 subProofOne q p -> CutFreeProof p -> CutFreeProof q.

 simple induction 1; intros; unfold CutFreeProof in H0; simpl in H0;
  unfold CutFreeProof in |- *.
 assumption.
 auto.
 eapply maxNatL; eauto.
 eapply maxNatR; eauto.
 eapply maxNatL; eauto.
 eapply maxNatR; eauto.
 eapply maxNatL; eauto.
 eapply maxNatR; eauto.
 auto.
 cut (max (degreeFormula A) (degreeProof p1) = 0).
 intro.
 eapply maxNatR; eauto.
 eapply maxNatL; eauto.
 eapply maxNatR; eauto.
 auto.
Qed.

Lemma CutFreeSubProof :
 forall (Atoms : Set) (Gamma1 Gamma2 : Term Atoms)
   (B C : Form Atoms) (E : gentzen_extension) (p : gentzenSequent E Gamma1 B)
   (q : gentzenSequent E Gamma2 C),
 subProof q p -> CutFreeProof p -> CutFreeProof q.

 simple induction 1.
 auto.
 intros T1 T2 T3 A1 A2 A3 p1 p2; intros.
 apply CutFreeSubProofOne with T2 A2 p2; auto.
Qed.

Definition extensionSub (Atoms : Set) (X : gentzen_extension) :=
  forall (T1 T2 : Term Atoms) (F : Form Atoms),
  X Atoms T1 T2 -> subFormTerm F T1 -> subFormTerm F T2.

Lemma subFormulaPropertyOne :
 forall (Atoms : Set) (Gamma1 Gamma2 : Term Atoms)
   (B C x : Form Atoms) (E : gentzen_extension)
   (p : gentzenSequent E Gamma1 B) (q : gentzenSequent E Gamma2 C),
 extensionSub Atoms E ->
 subProofOne q p ->
 CutFreeProof p ->
 subFormTerm x Gamma2 \/ subFormula x C ->
 subFormTerm x Gamma1 \/ subFormula x B.

 intros Atoms G1 G2 B C x E p q Ex H.
 elim H; intros.
 elim H1; clear H1; intro H1.
 elim (comSub H1); clear H1; intro.
 auto.
 right; apply slashR; apply oneFormSub; auto.
 right; apply slashL; auto.
 elim H1; clear H1; intro H1.
 elim (comSub H1); intro.
 right; apply backslashL; apply oneFormSub; auto.
 auto.
 right; apply backslashR; auto.
 elim H1; clear H1; intro H1.
 left; apply comL; auto.
 right; apply dotL; auto.
 elim H1; clear H1; intro H1.
 left; apply comR; auto.
 right; apply dotR; auto.
 elim H1; clear H1; intro H1.
 left; eapply subReplace2; eauto.
 apply comR; auto.
 left; eapply subReplace2.
 eauto.
 apply comL; apply eqFT; apply slashR; auto.
 elim H1; clear H1; intro H1.
 elim (subReplace3 r H1).
 auto.
 intro; left; eapply subReplace2.
 eauto.
 apply comL; apply eqFT; apply slashL; apply oneFormSub; auto.
 auto.
 elim H1; clear H1; intro H1.
 left; eapply subReplace2.
 eauto.
 apply comL; auto.
 left; eapply subReplace2.
 eauto.
 apply comR; apply eqFT; apply backslashL; auto.
 elim H1; clear H1; intro H1.
 elim (subReplace3 r H1).
 auto.
 intro; left; eapply subReplace2.
 eauto.
 apply comR; apply eqFT; apply backslashR; apply oneFormSub; auto.
 auto.
 elim H1; clear H1; intro H1.
 elim (subReplace3 r H1).
 auto.
 intro H2.
 elim (comSub H2).
 intro; left; eapply subReplace2.
 eauto.
 apply eqFT; apply dotL; apply oneFormSub; auto.
 intro; left; eapply subReplace2.
 eauto.
 apply eqFT; apply dotR; apply oneFormSub; auto.
 auto.
 cut (~ CutFreeProof (CutRule r p1 p2)).
 intro H2.
 elim H2; auto.
 apply notCutFree.
 cut (~ CutFreeProof (CutRule r p1 p2)).
 intro H2; elim H2; auto.
 apply notCutFree.
 elim H1; clear H1; intro H1.
 elim (subReplace3 r H1); intro H2.
 auto.
 left; eapply subReplace2.
 eauto.
 unfold extensionSub in Ex.
 eapply Ex; eauto.
 auto.
Qed.

Lemma subFormulaProperty :
 forall (Atoms : Set) (Gamma1 Gamma2 : Term Atoms)
   (B C x : Form Atoms) (E : gentzen_extension)
   (p : gentzenSequent E Gamma1 B) (q : gentzenSequent E Gamma2 C),
 extensionSub Atoms E ->
 subProof q p ->
 CutFreeProof p ->
 subFormTerm x Gamma2 \/ subFormula x C ->
 subFormTerm x Gamma1 \/ subFormula x B.

 simple induction 2.
 auto.
 intros T1 T2 T3 A1 A2 A3 p1 p2 p3; intros.
 apply H2.
 auto.
 apply subFormulaPropertyOne with T3 A3 E p2 p3.
 auto.
 auto.
 apply CutFreeSubProof with T1 A1 p1; auto.
 auto.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb ln_facts Rbigop arg_rmax.
Require Import num_occ proba entropy types jtypes divergence.
Require Import conditional_divergence error_exponent channel_code channel.
Require Import success_decode_bound.

(** * Converse of the Channel Coding Theorem *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope reals_ext_scope.
Local Open Scope proba_scope.
Local Open Scope types_scope.
Local Open Scope divergence_scope.

Section channel_coding_converse_intermediate_lemma.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis Hc : capacity W cap.

Variable minRate : R.
Hypothesis HminRate : minRate > cap.

Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof.
case/card_gt0P : Anot0 => a _; exact: (dist_domain_not_empty (W a)).
Qed.

Lemma channel_coding_converse_gen : exists Delta, 0 < Delta /\ forall n',
  let n := n'.+1 in forall (M : finType) (c : code A B M n), (0 < #|M|)%nat ->
    minRate <= CodeRate c ->
      scha(W, c) <= INR (n.+1)^(#|A| + #|A| * #|B|) * exp2 (- INR n * Delta).
Proof.
move: error_exponent_bound => /(_ _ _ Bnot0 W _ Hc _ HminRate); case => Delta [Delta_pos HDelta].
exists Delta; split => // n' n M c Mnot0 H.
apply: (leR_trans (success_bound W Mnot0 c)).
set Pmax := arg_rmax _ _ _.
set tc :=  _.-typed_code _.
rewrite pow_add -mulRA.
apply leR_wpmul2l; first exact/pow_le/leR0n.
apply (leR_trans (typed_success_bound W Mnot0 (Pmax.-typed_code c))).
apply leR_wpmul2l; first exact/pow_le/leR0n.
set Vmax := arg_rmax _ _ _.
rewrite /success_factor_bound /exp_cdiv.
case : ifP => Hcase; last by rewrite mul0R.
rewrite -ExpD.
apply Exp_le_increasing => //.
rewrite -mulRDr 2!mulNR.
rewrite leR_oppr oppRK; apply/leR_wpmul2l; first exact/leR0n.
have {Hcase}Hcase : Pmax |- Vmax << W.
  move=> a Hp b /eqP Hw.
  move/forallP : Hcase.
  by move/(_ a)/implyP/(_ Hp)/forallP/(_ b)/implyP/(_ Hw)/eqP.
apply (leR_trans (HDelta Pmax Vmax Hcase)) => /=.
exact/leR_add2l/Rle_max_compat_l/leR_add2r.
Qed.

End channel_coding_converse_intermediate_lemma.

Section channel_coding_converse.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis w_cap : capacity W cap.

Variable epsilon : R.
Hypothesis eps_gt0 : 0 < epsilon.

Variable minRate : R.
Hypothesis minRate_cap : minRate > cap.

(** Converse of the Channel Coding Theorem #<a name="label_channel_coding_converse"> </a># *)

Theorem channel_coding_converse : exists n0,
  forall n M (c : code A B M n),
    (0 < #|M|)%nat -> n0 < INR n -> minRate <= CodeRate c -> scha(W, c) < epsilon.
Proof.
case: (channel_coding_converse_gen w_cap minRate_cap) => Delta [Delta_pos HDelta].
pose K := (#|A| + #|A| * #|B|)%nat.
pose n0 := 2 ^ K * INR K.+1`! / ((Delta * ln 2) ^ K.+1) / epsilon.
exists n0 => n M c HM n0_n HminRate.
have Rlt0n : 0 < INR n.
  apply: (ltR_trans _ n0_n).
  rewrite /n0.
  apply mulR_gt0; last exact/invR_gt0.
  rewrite /Rdiv -mulRA.
  apply mulR_gt0; first by apply pow_gt0; fourier.
  apply mulR_gt0;
    [exact/ltR0n/fact_gt0 | exact/invR_gt0/pow_gt0/mulR_gt0].
destruct n as [|n'].
  by apply ltRR in Rlt0n.
set n := n'.+1.
apply: (@leR_ltR_trans (INR n.+1 ^ K * exp2 (- INR n * Delta))).
  exact: HDelta.
move: (n0_n) => /(@ltR_pmul2l (/ INR n) _) => /(_ (invR_gt0 (INR n) Rlt0n)).
rewrite mulVR ?INR_eq0' //.
move/(@ltR_pmul2l epsilon) => /(_ eps_gt0); rewrite mulR1 => H1'.
apply: (leR_ltR_trans _ H1') => {H1'}.
rewrite /n0 [in X in _ <= X]mulRC -2![in X in _ <= X]mulRA.
rewrite mulVR ?mulR1; last exact/eqP/gtR_eqF.
apply Rge_le; rewrite mulRC -2!mulRA; apply Rle_ge.
set aux := INR _ * (_ * _).
have aux_gt0 : 0 < aux.
  apply mulR_gt0; first exact/ltR0n/fact_gt0.
  apply mulR_gt0; [exact/invR_gt0/pow_gt0/mulR_gt0 | exact/invR_gt0].
apply (@leR_trans ((INR n.+1 / INR n) ^ K * aux)); last first.
  apply leR_pmul => //.
  - apply/pow_ge0/divR_ge0 => //; exact: leR0n.
  - exact: ltRW.
  - apply pow_incr; split.
    + apply divR_ge0 => //; exact: leR0n.
    + apply (@leR_pmul2r (INR n)) => //.
      rewrite -mulRA mulVR // ?mulR1 ?INR_eq0' ?gtn_eqF // (_ : 2 = INR 2) //.
      rewrite -mult_INR; apply/le_INR/leP; by rewrite multE -{1}(mul1n n) ltn_pmul2r.
  - exact/leRR.
rewrite expRM -mulRA; apply leR_pmul => //.
- exact/pow_ge0/ltRW/ltR0n.
- exact/leRR.
- apply invR_le => //.
  + apply mulR_gt0; last exact aux_gt0.
    rewrite expRV ?INR_eq0' //; exact/invR_gt0/pow_gt0.
  + rewrite -exp2_Ropp mulNR oppRK /exp2.
    have nDeltaln2 : 0 <= INR n * Delta * ln 2.
      apply mulR_ge0; last exact/ltRW.
      apply mulR_ge0; [exact/leR0n | exact/ltRW].
    apply: (leR_trans _ (exp_lb (K.+1) nDeltaln2)) => {nDeltaln2}.
    apply Req_le.
    rewrite invRM; last 2 first.
      exact/gtR_eqF/pow_gt0/invR_gt0.
      exact/gtR_eqF.
    rewrite mulRC invRM; last 2 first.
      by apply/eqP; rewrite INR_eq0' gtn_eqF // fact_gt0.
      apply/nesym/ltR_eqF/mulR_gt0; last exact/invR_gt0.
      exact/invR_gt0/pow_gt0/mulR_gt0.
    rewrite -mulRA mulRC invRM; last 2 first.
    - apply/eqP/invR_neq0; rewrite pow_eq0 mulR_eq0 negb_or ln2_neq0 andbT; exact/eqP/gtR_eqF.
    - apply/eqP/invR_neq0; by rewrite INR_eq0'.
    - rewrite invRK; last first.
        apply/eqP; rewrite pow_eq0 mulR_eq0 negb_or ln2_neq0 andbT; exact/eqP/gtR_eqF.
      rewrite invRK; last by apply/eqP; rewrite INR_eq0'.
      rewrite (_ : / (/ INR n) ^ K = (INR n) ^ K); last first.
        rewrite expRV ?INR_eq0' // invRK //; apply/eqP/pow_not0; by rewrite INR_eq0'.
      rewrite /Rdiv; congr (_ * _).
      by rewrite -mulRA -powS mulRC -expRM mulRA.
Qed.

End channel_coding_converse.


Require Import String.
Require Import List.
Import ListNotations.

Class registered {X} (ty:X) :=
(* {assumptionType proofType} := *)
{
  assumptionType: Type;
  assumption: assumptionType;
  proofType: Type;
  proof: proofType
}.

Definition listAssumption {X} (P:X->Prop) (xs:list X) := forall t, In t xs -> P t.

Definition listProof {X} (P:X->Prop) (f:forall x, P x) (xs:list X) : listAssumption P xs :=
(list_ind (fun xs0 : list X => listAssumption P xs0)
            (fun (t : X) (H0 : In t []) => match H0 return (P t) with
                                                  end)
            (fun (a : X) (xs0 : list X) (IHxs : listAssumption P xs0)
               (t : X) (H0 : In t (a :: xs0)) =>
             match H0 with
             | or_introl H1 => Coq.Init.Logic.eq_ind a (fun t0 : X => P t0) (f a) t H1
             | or_intror H1 => IHxs t H1
             end) xs).

Instance test : registered list :=
{|
    assumption := @listAssumption;
    proof := @listProof
|}.

Goal registered list.
Proof.
  refine (_).
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The heap is path checked using identifiers as and paths, so this
 is the domain of the Upsilon context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.
Require Import Coq.Structures.Equalities.

Require Export BooleanEqualityDef.
Require Export EVarModuleDef.
Require Export PathModuleDef.
Require Export CpdtTactics.
Require Export Case.

Module EVarPathModule <: BooleanEquality.
  Module Path := PathModule.
  Include Path.Types.
  Module EV := EVarModule.
  Definition EVar := EV.t.

Module Types.
Definition UE := prod EVar Path.
End Types.
Include Types.

(* Does andb here break unfold ? *)
Function beq_ue (u u' : UE) : bool :=
  match u, u' with
    | (x,p), (x', p') => andb (EV.eqb x x') (Path.beq_path p p')
  end.
Hint Resolve beq_ue.

Lemma beq_ue_refl:
 forall (u : UE),
   beq_ue u u = true.
Proof.
  induction u; crush.
Qed.
Hint Resolve beq_ue_refl.

Lemma beq_ue_sym : forall u u', beq_ue u u' = beq_ue u' u.
Proof.
  induction u; induction u'; try solve[crush].
  unfold beq_ue.
  fold beq_ue.
  rewrite EV.eqb_sym.
  rewrite Path.beq_path_sym.
  reflexivity.
Qed.
Hint Immediate beq_ue_sym.

Lemma beq_ue_to_eq:
  forall u u',
    beq_ue u u' = true ->
    u = u'.
Proof.
  induction u; induction u'; try solve [crush].
  unfold beq_ue.
  fold beq_ue.
  intros.
  apply andb_true_iff in H.
  inversion H.
  apply EV.eqb_to_eq in H0.
  apply Path.beq_path_eq in H1.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_ue_to_eq.

Lemma beq_ue_trans:
  forall u u0 u1,
    beq_ue u u0 = true ->
    beq_ue u0 u1 = true ->
    beq_ue u u1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_ue_to_eq in H.
  apply beq_ue_to_eq in H0.
  subst.
  apply beq_ue_refl.
Qed.

Lemma beq_ue_to_neq:
  forall u u',
    beq_ue u u' = false ->
    u <> u'.
Proof.
  induction u; induction u'; try solve [crush].
  unfold beq_ue.
  fold beq_ue.
  intros.
  apply andb_false_iff in H.
  inversion H.
  apply EV.eqb_to_neq in H0.
  crush.
  apply Path.beq_path_neq in H0.
  crush.
Qed.
Hint Resolve beq_ue_to_eq.

Lemma beq_ue_iff_eq:    forall a b, beq_ue a b = true <-> a = b.
Proof.
  intros.
  split.
  apply beq_ue_to_eq.
  intros.
  rewrite H.
  apply beq_ue_refl.
Qed.
Hint Resolve beq_ue_iff_eq.

Lemma beq_ue_iff_neq:   forall a b, beq_ue a b = false <-> a <> b.
Proof.
  intros.
  split.
  apply beq_ue_to_neq.
  intros.
  induction a; induction b; try solve[crush].
Admitted.
Hint Resolve beq_ue_iff_neq.

Definition t := UE.
Definition eqb := beq_ue.
Definition eqb_refl := beq_ue_refl.
Definition eqb_sym := beq_ue_sym.
Definition eqb_trans := beq_ue_trans.
Definition eqb_to_eq := beq_ue_to_eq.
Definition eqb_to_neq := beq_ue_to_neq.
Definition eqb_iff_eq := beq_ue_iff_eq.
Definition eqb_iff_neq := beq_ue_iff_neq.

Fixpoint eq (a b : t) : Prop :=
    match eqb a b with
     | false => False
     | true => True
    end.

Ltac destruct_away :=
  repeat match goal with
    | [ |- ?X = true <-> _ ] => destruct X; try solve[crush]
         end.

Lemma eqb_eq : forall x y : t, eqb x y = true <-> eq x y.
Proof.
  induction x; induction y;
  try solve[
        unfold eq;
        unfold eqb;
        destruct_away;
        crush].
Qed.

Lemma eq_refl:
 forall (a : t),
   eq a a.
Proof.
  intros.
  rewrite <- eqb_eq.
  apply eqb_refl.
Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
  intros.
  rewrite <- eqb_eq.
  rewrite <- eqb_eq in H.
  rewrite eqb_sym.
  assumption.
Qed.

Lemma eq_trans :
  forall x y z,
    eq x y -> eq y z -> eq x z.
Proof.
  intros.
  rewrite <- eqb_eq.
  rewrite <- eqb_eq in H.
  rewrite <- eqb_eq in H0.
  apply eqb_trans with (u:= x) (u0:= y) (u1:= z); try assumption.
Qed.

Instance eq_equiv : Equivalence eq.
Proof.
  split.
  exact eq_refl.
  exact eq_sym.
  exact eq_trans.
Defined.

Ltac destruct_evidence :=
  repeat match goal with
    | [ |- {(if ?X then True else False)} + { _ } ] =>
      destruct X; try solve[simpl; right; congruence];
      try solve[simpl; left; trivial]
 end.

Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
Proof.
  intros.
  destruct x; destruct y;  unfold eq; unfold eqb; destruct_evidence; crush.
Qed.

End EVarPathModule.