(* This File contains the proof of Hall's marriage theorem on Bipartite Graphs.
   Let G=(L,R,Edge) be a bipartite graph and V= L U R. Then we have,

    Theorem Halls_Thm:  (forall (S: Ensemble U), Included _ S L ->
           (forall m n :nat, (cardinal _ S m /\ cardinal _ (N S) n) -> m <=n ) )
       <-> ( exists Rel': Relation U, Included_in_Edge Rel' /\ Is_L_Perfect Rel').

   where, Included_in_Edge is defined as,

   Definition Included_in_Edge (Rel: Relation U): Prop :=
                    forall x y:U, Rel x y -> Edge x y.

It states that, for any bipartite graph G=(L,R,E),
 forall S in L,|N(S)|>=|S| if and only if there exists an L-perfect matching.

Here, a matching is said to be L-perfect if each vertex in L is part of some edge
of the matching. *)

Require Export Combi_1.
Require Export Graph.
Require Import FiniteDilworth_AB.
Require Import FiniteDilworth.

Section Halls_Thm.

  Variable U: Type.

  Print Finite_Graph.
  Print Graph.
  Print Biper_Graph.

  Variable G: Biper_Graph U. Check (Edge_Rel_of G).

  Let Edge := (Edge_Rel_of (Graph_of_BG G )).
  Let V:= (Vertices_of (Graph_of_BG G)).
  Let L:= L_of G.
  Let R:= R_of G.

  Set Implicit Arguments.

  Check Edge. Check V. Check L. Check R.

  Lemma BG1: Finite _ V.
  Proof. apply  F_Graph_cond. Qed.

   Lemma BG2: Inhabited _ V.
  Proof. apply  NonEmpty_cond. Qed.

  Lemma BGa2: Inhabited _ L.
  Proof. apply LR_Inhabited. Qed.

  Lemma BGb2: Inhabited _ R.
  Proof. apply LR_Inhabited. Qed.

  Lemma BG3: Disjoint _ L R.
  Proof. apply LR_Disj. Qed.

  Lemma BGa3: forall x y: U, Edge x y -> ~ In _ L y.
  Proof. { intros x y H0 H1.
         assert (H2: In _ L x /\ In _ R y). apply LR_Rel. auto.
         assert (H3: Disjoint _ L R). apply LR_Disj. destruct H3.
         absurd (In U (Intersection U L R) y). auto.
         apply Intersection_intro; tauto.  } Qed.

  Lemma BGb3: forall x y: U, Edge x y -> ~ In _ R x.
  Proof. { intros x y H0 H1.
         assert (H2: In _ L x /\ In _ R y). apply LR_Rel. auto.
         assert (H3: Disjoint _ L R). apply LR_Disj. destruct H3.
         absurd (In U (Intersection U L R) x). auto.
         apply Intersection_intro; tauto.  } Qed.

  Lemma BGd3:  forall x y : U, Included U (Couple U x y) L -> ~ Edge x y.
  Proof. { intros x y H0 H1.
         assert (H2: In _ L x /\ In _ L y). { unfold Included in H0.
         split; apply H0; (apply Couple_l || apply Couple_r). }
         absurd (In _ L y). eapply BGa3. exact H1. tauto. } Qed.

  Lemma BGe3:  forall x y : U, Included U (Couple U x y) R ->  ~ Edge  x y.
  Proof.  { intros x y H0 H1.
         assert (H2: In _ R x /\ In _ R y). { unfold Included in H0.
         split; apply H0; (apply Couple_l || apply Couple_r). }
         absurd (In _ R x). eapply BGb3. exact H1. tauto. } Qed.

   Ltac EdgeThm
    :=first [ eapply BGa3 | eapply BGb3   |  eapply BGd3 |  eapply BGe3 ].

  Lemma BG4: V = Union _ L R.
  Proof. apply LR_Union. Qed.

  Lemma BG5: forall x y: U, Edge x y -> (In _ L x /\ In _ R y ).
  Proof. apply LR_Rel. Qed.

  Lemma BGa5: Included _ L V.
    Proof. rewrite BG4.  unfold Included. apply Union_introl. Qed.

  Lemma BGb5: Included _ R V.
   Proof. rewrite BG4.  unfold Included. apply Union_intror. Qed.

  Hint Resolve BG1 BG2 BGa2 BGb2 BG3 BGa3 BGb3 BG4 BG5 BGa5 BGb5 : BG.

  Lemma BG6: Order _  (fun (x: U)(y:U)=> Edge x y \/ x=y ).
  Proof. { Print Order. apply Definition_of_order.
         unfold Reflexive. intro. right; reflexivity.
         unfold Transitive. {
         intros x y z H0 H1.
         elim H0; elim H1.
         { intros. absurd (In _ R y). EdgeThm. exact H. Print Biper_Graph.
           assert (H3: In _ L x /\ In _ R y  ). auto with BG. tauto. }
         { intros. subst. left. tauto. }
         { intros. subst. left. tauto. }
         { intros. subst. right. tauto. } }
         unfold Antisymmetric. {
           intros x y H0 H1. elim H0;elim H1.
           { intros. absurd ( In _ L y). EdgeThm. exact H2.
             assert (H3: In _ L y /\ In _ R x  ). auto with BG. tauto. }
           { intros; subst; reflexivity. }
           { intros; subst; reflexivity. }
           { intros. tauto. } }  } Qed.

 Definition N (S: Ensemble U): Ensemble U:= fun (y: U)=> exists x:U, In _ S x /\ Edge x y.
  Check N V.

  Lemma BG7: forall (e: Ensemble U) (x: U)(y: U), (In _ e x /\ Edge x y )-> In _ (N e) y.
  Proof. intros. unfold In. unfold N.  exists x. tauto. Qed.

  Ltac reduce_N H := try (unfold In in H); unfold N in H.

  Ltac reduce_NG := try (unfold In); unfold N.

  Lemma BG8:  forall x y: U, Edge x y -> (In _ R y ).
  Proof. { intros x y H0. cut (In _ L x /\ In _ R y ). tauto.  auto with BG. } Qed.

  Lemma BG9:  forall x y: U, Edge x y -> (In _ L x ).
  Proof . { intros x y H0. cut (In _ L x /\ In _ R y ). tauto.  auto with BG. } Qed.

  Hint Resolve BG6 BG7 BG8 BG9: BG.

  Lemma BG10: Included _ (N L) R.
  Proof. { unfold Included. intros y H0. reduce_N H0.   destruct H0 as [x H0].
           destruct H0. eauto with BG. } Qed.

  Lemma BG11: Included _ (N L) V.
  Proof. unfold Included. intros. rewrite BG4. apply Union_intror. apply BG10. auto. Qed.

  Lemma BG12: Finite _ (N L).
    Proof.  { apply Finite_downward_closed with (A:= V). auto with BG. apply BG11. } Qed.

  Lemma BG13:  exists m' : nat, cardinal U (N L) m'.
  Proof.  apply finite_cardinal.  apply BG12. Qed.

  Lemma BG14: Finite _ L.
  Proof. apply Finite_downward_closed with (A:= V). auto with BG. auto with BG.  Qed.

  Lemma BG15: Finite _ R.
  Proof. apply Finite_downward_closed with (A:= V). auto with BG. auto with BG.  Qed.

  Lemma BG16: exists m: nat, cardinal U L m.
  Proof. apply finite_cardinal. apply BG14. Qed.

  Lemma BG17: exists n:nat, cardinal U R n.
    Proof. apply finite_cardinal. apply BG15. Qed.

    Hint Resolve  BG10 BG11 BG12 BG13 BG14 BG15 BG16 BG17 : BG.

 (* --------------------------------------------------------------------------------- *)
 (* _____________________ PROOF OF HALL'S THEOREM ___________________________________ *)

  Definition Is_a_matching (Rel: Relation U): Prop:=
     ( forall x y z: U, ((Rel x z /\ Rel y z)\/ (Rel z x /\ Rel z y)) -> x=y).

  Definition Is_L_Perfect (Rel: Relation U): Prop:=
          (Is_a_matching Rel /\ (forall x: U, In _ L x -> (exists y: U, Rel x y)) ).

  Definition Included_in_Edge (Rel: Relation U): Prop := forall x y:U, Rel x y -> Edge x y.
  Check Included_in_Edge.

  Theorem Hall_B:  ( exists Rel': Relation U, Included_in_Edge Rel' /\ Is_L_Perfect Rel')->
                   (forall (S: Ensemble U),
                  Included _ S L -> (forall m n :nat, (cardinal _ S m /\ cardinal _ (N S) n) -> m <=n ) ).

  Proof. { intros. destruct H as [Rel' H]. destruct H as [Ha Hb].
         unfold Is_L_Perfect in Hb. destruct Hb as [Hb Hc].
         unfold Is_a_matching in Hb. unfold Included_in_Edge in Ha.
         pose (N'(S: Ensemble U)(y: U) := exists x:U, In _ S x /\ Rel' x y).

         assert (H2: cardinal _ (N' S) m).
         { eapply Bijection_Relation3 with (A:= S) (R:= Rel').
           { intros.
             assert (H2: exists y : U, Rel' x y).
             { apply Hc. apply H0. auto. } destruct H2 as [y H2].
             assert (H3: Edge x y).
             { auto. }
             exists y. unfold In. unfold N'. split. exists x. tauto. tauto.  }

           { intros.  destruct H. exists x; tauto.  }
           { intros. eapply Hb with (z:=b). left; tauto. }
           { intros. eapply Hb with (z:=a). right;tauto. }
           { tauto. } }

         assert (H3: Included _ (N' S) ( N S)).
         { unfold Included. intros. destruct H. unfold N. unfold In.
           exists x0. split. apply H.  apply Ha.  tauto.  }

         eapply incl_card_le. exact H2. Focus 2. exact H3. tauto.

          }  Qed.

  Theorem Hall_A: (forall (S: Ensemble U),
                 Included _ S L -> (forall m n :nat, (cardinal _ S m /\ cardinal _ (N S) n) -> m <=n ) ) ->
                 ( exists Rel': Relation U, Included_in_Edge Rel' /\ Is_L_Perfect Rel').
  Proof. {

    (* We need a POSET reflecting the property of bipertite graph. *)
    pose (Rel (x: U)(y: U) := (Edge x y \/ x=y) ).
    pose (C:= Union _ L R).
    assert (F: C= V ).
    { unfold C. symmetry. auto with BG. }

   assert (F1: Inhabited U C).
    { rewrite F. auto with BG. }  Print PO.
    assert (F2: Order U Rel). Print FPO.
    { auto with BG. }
    assert (F3: Finite U C).
    { rewrite F. auto with BG. }  Print FPO. Print PO.
    pose ( P := {| PO_of:= {|Carrier_of := C; Rel_of:= Rel; PO_cond1:= F1; PO_cond2:= F2 |};
                   FPO_cond:= F3|} ).

    (* Here we have a POSET P which reflects the Bipertite graph G *)
    intros.
    (* At this point we have assumption H : forall S included in L , |S| <= | N(S)| *)

    assert ( F4:  exists m' : nat, cardinal U (N L) m').
    { auto with BG. } destruct F4 as [m' F4].

    (* We can deduce that the size of L is less than equal to the size of R *)
    assert (F5: forall m n: nat, cardinal _ L m -> cardinal _ R n -> m<=n ).
    { intros m n. intros.
      assert (H2: m<= m'). { apply H with (S:= L). unfold Included.  tauto. tauto. }
      assert (H3: m'<= n). { eapply incl_card_le.  exact F4.  exact H1.  auto with BG. }
      auto with arith. SearchPattern ( _ <= ?x1 -> ?x1 <= _ -> _ <= _). eapply le_trans. exact H2.
      auto. }

    (* Let m be the size of L *)
    assert ( F6: exists m: nat, cardinal U L m).
    { auto with BG. }
    destruct F6 as [m F6].

    assert (F7: exists n:nat, cardinal U R n).
    { auto with BG. } destruct F7 as [n F7].

    (* At this point we have  |L|= m and |R|= n as sizes *)

    assert (F8: m<= n). { eauto. }  (* We have at this point |L| < = |R| *)

     (* L is an antichain *)
    assert ( Hc1: Is_an_antichain_in  P L).
    {  Print Is_an_antichain_in.  unfold Is_an_antichain_in. split.

       split. simpl. unfold C. unfold Included. apply Union_introl.  auto with BG.
       auto. auto with BG. simpl. unfold Rel.  intros x y F12. intro F13.
       elim F13.
       intro F14. elim F14. intro F15. absurd ( Edge x y).
       generalize F12. EdgeThm.  auto. auto.
       intro F14. elim F14. intro F15. absurd ( Edge  y x ).  apply BGd3.
       generalize F12. rewrite <- Couple_comm.  tauto. tauto.
       intro. symmetry. tauto.  }

    assert (Hc2: Is_an_antichain_in  P R).
    {  Print Is_an_antichain_in. unfold Is_an_antichain_in. split.
       split. simpl. unfold C. unfold Included. apply Union_intror.  auto with BG.
       auto. auto with BG. simpl. unfold Rel.  intros x y F12. intro F13.
       elim F13.
       intro F14. elim F14. intro F15. absurd ( Edge x y).
       generalize F12. EdgeThm.  auto. auto.
       intro F14. elim F14. intro F15. absurd ( Edge  y x ).  apply BGe3.
       generalize F12. rewrite <- Couple_comm.  tauto. tauto.
       intro. symmetry. tauto.  }

     assert (F9:  Is_largest_antichain_in  P R) .
    {  Print Is_largest_antichain_in. apply largest_antichain_cond.
         auto.
         intros A n1 n0 T1 T2 T3.
         assert (Tn: n = n1).
         { eapply cardinal_unicity. exact F7.  tauto. }
         rewrite <- Tn in T2. rewrite <- Tn. clear T2.

         pose (AL:= Intersection _ A L).
         pose (AR:= Intersection _ A R).

         assert (T4: Disjoint _ AL AR).
         { apply Disjoint_intro. intros x T4.
           destruct T4 as [x Ta4 T4].
           assert (T5: In _ L x /\ In _ R x). unfold AL in Ta4. unfold AR in T4.
           destruct Ta4. destruct T4.  tauto.
           assert (T6: In _ (Intersection _ L R) x).
           { apply Intersection_intro; tauto. }
           assert (Ta6: Disjoint _ L R ). { auto with BG. }
           absurd (In U ( Intersection U L R) x). destruct Ta6. apply H0.  auto.  }

         assert (T5: Finite _ AL /\ Finite _ AR).
         { split.
           apply Finite_downward_closed with (A:= L).
           auto with BG. unfold AL. auto with sets.
           apply Finite_downward_closed with (A:= R).
           auto with BG. unfold AR. auto with sets.  }

         assert (T6: exists ln0: nat, cardinal _ AL ln0 ).
         { apply finite_cardinal.  tauto.  } destruct T6 as [ln0 T6].
         assert (T7: exists rn0: nat, cardinal _ AR rn0 ).
         { apply finite_cardinal.  tauto. } destruct T7 as [rn0 T7].
         clear T5.

         assert (T0: A = Union _ AL AR).
         { apply Extensionality_Ensembles.
           unfold Same_set.
           split.
           { unfold Included. intros x. intro.
             assert ( H1: In _ C x).
             { destruct T1. destruct H1. simpl in H1. auto.  }
             unfold C in H1.
             destruct H1. apply Union_introl. unfold AL. auto with sets.
             apply Union_intror. unfold AR. auto with sets. }
           { unfold Included.  intro x. intro. destruct H0.
             unfold AL in H0. destruct H0.  tauto.
             unfold AR in H0. destruct H0.  tauto. }   }

         assert (T: ln0 + rn0 = n0 ).
         { assert (Temp: cardinal _ A (ln0 + rn0) ).
           rewrite T0. eapply Disjoint_card. tauto.
           eapply cardinal_unicity. exact Temp. auto.  }

         assert (T8: exists ln0': nat, cardinal _ (N AL) ln0' ).
         { assert (Temp: Finite _ (N AL)).
           {  assert(Included _ (N AL) R ).
              { unfold Included. intros x Temp. destruct Temp.
                destruct H0. cut (In _ L x0 /\ In _ R x ).
                tauto. auto with BG. }

              eapply Finite_downward_closed with (A:=R).  auto with BG.
              tauto. }
           apply finite_cardinal. auto.   }
         destruct T8 as [ ln0' T8].

         assert ( T9: ln0 + rn0 <= ln0' + rn0).
         { assert (Temp: ln0 <= ln0').
           { eapply H with (S:= AL).
             unfold AL. auto with sets. tauto.  }
           omega.  }

         pose (TS:= Union _ AR (N AL)).

         assert (T10: Included _ TS R).
         {   unfold TS.
             assert(Temp1: Included _ (N AL) R ).
              { unfold Included. intros x Temp. destruct Temp.
                destruct H0. cut (In _ L x0 /\ In _ R x ).
                tauto. auto with BG. }
              assert (Temp2: Included _ AR R).
              {  unfold AR. auto with sets.  }
              auto with sets.  }

         assert (Ta10: Disjoint _ AR (N AL)).
         { Print Disjoint. apply Disjoint_intro.
           intros x Temp. destruct Temp as [y H0 H1]. unfold In in H1.
           unfold N in H1. destruct H1 as [x H1].

           assert ( Temp: In _ R y).
           { destruct H1. eauto with BG. }

           assert (Temp1: In _ L x).
           { destruct H1. eauto with BG. }

           assert (Temp2: x<>y).
           { intro Temp3. absurd (In _ R x).  destruct H1.  generalize H2. EdgeThm.
             rewrite Temp3. tauto. }

           assert (Temp3: Rel x y).
           { unfold Rel. left. tauto. }
           destruct T1.

           assert (H4: Included _ (Couple _ x y) A).
           { rewrite T0. unfold Included. intros x0 Temp4.
             destruct Temp4. apply Union_introl. tauto. apply Union_intror. tauto. }

           assert (Temp4: x =y).
           { eapply H3. tauto. left. simpl. tauto. }

           absurd (x=y). tauto. tauto. }

         assert (T11: cardinal _ TS (rn0 + ln0')).
         { unfold TS.  eapply Disjoint_card. tauto. }

         assert ( T12: ln0' + rn0 <= n).
         { eapply incl_card_le with (U:= U) (X:=TS).
           assert (Temp: ln0' + rn0 = rn0 + ln0').
           { auto with arith. } rewrite Temp. auto. exact F7.
           auto.  }

         assert (Temp: n0 <= ln0' + rn0).
         { rewrite <- T.  auto. }

         eauto with arith.

    }

    assert (Fb9:  (exists (cv: Ensemble (Ensemble U)), Is_a_chain_cover  P cv /\
                                                  cardinal _ cv n)).
    { apply DilworthB with (P:= P). exists R. tauto. }

    assert (FS:  exists cv : Ensemble (Ensemble U), Is_a_smallest_chain_cover  P cv /\
                                               cardinal (Ensemble U) cv n).
    { destruct Fb9 as [cv H0]. exists cv. split. Print Is_a_smallest_chain_cover.
      apply smallest_cover_cond.
      { tauto. }
      { intros.  destruct H1. destruct H2.
        assert (sn = n).
        { eapply cardinal_unicity with (X:= cv). auto.  tauto. }
        rewrite H4.
        assert (~ n > n0).
        { eapply DilworthA with (P:=P)(cv:= cover)(a:= R). auto.  auto. auto. auto. }
        assert ( (~n<= n0) <-> n >n0 ).
        { Check nat_P5. eapply nat_P5. }
        destruct H6. elim (classic (n<= n0)). tauto.
        intro. absurd (n>n0). auto. auto.   }
      { apply H0. } }

    assert (F10: (exists cv': Ensemble (Ensemble U), Is_a_disjoint_cover  P cv' /\ cardinal _ cv' n)).
    { apply exists_disjoint_cover. auto.  }

    destruct F10 as [cover F10]. destruct F10 as [F10 F11].  destruct F10 as [F10 Fb10].
    destruct F10 as [F10 Fa10].

    (* Properties of chain cover *)

    (* No two element from L can lie in a chain from cover *)
    assert (HC: forall (x y : U) (c: Ensemble U), In _ cover c ->
               (In _ L x /\ In _ L y /\ In _ c x /\ In _ c y) -> x = y).
    { intros x y c T1 T2. eapply NoTwoCommon with (P:= P) (X:= c) (Y:= L).  apply F10.
      auto.  auto.  intros x0 T3; destruct T3;tauto. intros x0 T3; destruct T3;tauto.  }
     (* No two element from R can lie in a chain from cover *)
     assert (HC0: forall (x y : U) (c: Ensemble U), In _ cover c ->
                (In _ R x /\ In _ R y /\ In _ c x /\ In _ c y) -> x = y).
    { intros x y c T1 T2. eapply NoTwoCommon with (P:= P) (X:= c) (Y:= R).  apply F10.
      auto.  auto.  intros x0 T3; destruct T3;tauto. intros x0 T3; destruct T3;tauto. }

    (* Every element from R lies on some chain from cover *)
    assert (HCa1: forall x: U, In _ R x -> (exists chain: Ensemble U, In _ cover chain /\ In _ chain x)).
    { intros x Temp. eapply Fa10. simpl.  unfold C. apply Union_intror. auto.  }

    (* Every chain from cover has one element from R *)
    assert (HC1: forall chain: Ensemble U, In _ cover chain -> (exists y:U, In _ R y /\ In _ chain y)).
    { eapply Bijection_Relation. auto.
      intros x y b T. eapply HC0 with (c:= b). tauto.  tauto. exact F7. tauto. }

    (* Every element from L lies on some chain from cover *)
    assert (HC2: forall x: U, In _ L x -> (exists chain: Ensemble U, In _ cover chain /\ In _ chain x)).
    { intros x Temp. eapply Fa10. simpl.  unfold C. apply Union_introl. auto. }

    (* For every element in L there is a chain from cover and an element from R such that
       both lies on the chain  *)
    assert (HC3: forall x: U, In _ L x -> (exists (chain: Ensemble U)(y: U), In _ cover chain /\ In _ R y /\
                                                                  In _ chain x /\ In _ chain y)).
    { intros x T.
      assert (T1:  exists chain : Ensemble U, In (Ensemble U) cover chain /\ In U chain x).
      { eauto. } destruct T1 as [chain T1].
      exists chain.
      assert (T2:  exists y : U, In U R y /\ In U chain y).
      { apply HC1. tauto.  } destruct T2 as [y T2].
      exists y. tauto. }

    pose (Rel' (x:U)(y:U) := exists c: Ensemble U, (In _ cover c /\ In _ L x /\ In _ R y) /\
                                              In _ c x /\ In _ c y /\ x <> y ).

    exists Rel'.

    (* We need to prove that Rel' is included in Edge Relation *)
    assert (HR1: Included_in_Edge Rel' ).
    { unfold Included_in_Edge. intros x y T1. unfold Rel' in T1.
      destruct T1 as [c T1].

      assert ( T2: Is_a_chain_in P c).
      { eapply F10. tauto. }
      assert (T3: Included _ (Couple _ x y) c ).
      { unfold Included.  intros x0 T. destruct T; tauto. }
      destruct T2.
      assert (T4: Rel x y \/ Rel y x).
      { auto. }
      unfold Rel in T4.
      assert (T5: Edge x y \/ Edge y x).
      { elim T4.
        { intro T6; left. elim T6. {trivial. }
                                   { intro T7. absurd (x=y);tauto.  } }
        { intro T6; right. elim T6. {trivial. }
            { intro T7. absurd (x=y). tauto.   symmetry. auto. } }
        }

      elim T5.
      { trivial. } { intro T6. absurd ( In _ R y). (* eapply BGb3 *) EdgeThm . exact T6. tauto. } }

    (* Now we prove that Rel' is L_Perfect *)
    assert (HR2: Is_L_Perfect Rel' ).
    { unfold Is_L_Perfect.
      split.
      (* We prove that Rel' is a matching *)
      { unfold Is_a_matching. intros x y z.  intro HR.
        elim HR.
        { intro Hra.  destruct Hra as [Hra Hrb].
          unfold Rel' in Hra. unfold Rel' in  Hrb.
          destruct Hra as [c1 Hra]. destruct Hrb as [c2 Hrb].
          Print Disjoint.
          assert (c1 = c2 \/ Disjoint _ c1 c2).
          { eapply Fb10. tauto. }
           elim H0.
          { intro. eapply NoTwoCommon with (X:= c1) (P:=P)(Y:=L). apply F10. tauto. auto.
            unfold Included. intros. destruct H2. tauto. rewrite H1. tauto.
            unfold Included. intros. destruct H2. tauto.  tauto. }
          intro.
          absurd ( Disjoint _ c1 c2).
            intro T.  destruct T.
            absurd ( In U (Intersection U c1 c2) z).
            auto. apply Intersection_intro; tauto.
            tauto.  }

        { intro Hra.  destruct Hra as [Hra Hrb].
          unfold Rel' in Hra. unfold Rel' in  Hrb.
          destruct Hra as [c1 Hra]. destruct Hrb as [c2 Hrb].
          Print Disjoint.
          assert (c1 = c2 \/ Disjoint _ c1 c2).
          { eapply Fb10. tauto. }
           elim H0.
          { intro. eapply NoTwoCommon with (X:= c1) (P:=P)(Y:=R). apply F10. tauto. auto.
            unfold Included. intros. destruct H2. tauto. rewrite H1. tauto.
            unfold Included. intros. destruct H2. tauto.  tauto. }
          intro.
          absurd (Disjoint _ c1 c2).
            intro T.  destruct T.
            absurd ( In U (Intersection U c1 c2) z).
            auto. apply Intersection_intro; tauto.
            tauto. } }

      (* We prove that for every x in L there is a y in R such that Rel' x y *)
      { intros x HL.
        assert( HL1: exists (chain : Ensemble U) (y : U),
                  In (Ensemble U) cover chain /\ In U R y /\ In U chain x /\ In U chain y).
        { apply HC3. auto. } destruct HL1 as [chain HL1]. destruct HL1 as [y HL1].
        exists y. exists chain.
        split. { tauto. }
               { split. tauto. split. tauto. intro T.
                 absurd (Disjoint _ L R). { intro T1. destruct T1.
                 absurd ( In _ (Intersection _ L R) x). auto.
                 apply Intersection_intro. tauto. rewrite T. tauto. }
                                          { auto with BG. } }   }  }

    tauto.          }   Qed.

  Theorem Halls_Thm:  (forall (S: Ensemble U),
                 Included _ S L -> (forall m n :nat, (cardinal _ S m /\ cardinal _ (N S) n) -> m <=n ) ) <->
                      ( exists Rel': Relation U, Included_in_Edge Rel' /\ Is_L_Perfect Rel').
    Proof.  unfold iff.  split; ( eapply Hall_A ||  eapply Hall_B) . Qed.

End Halls_Thm.


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

Require Import BinPos BinNat Nnat ZArith_base.

Open Scope Z_scope.

Definition NPgeb (a:N)(b:positive) :=
  match a with
   | N0 => false
   | Npos na => match Pcompare na b Eq with Lt => false | _ => true end
  end.

Fixpoint Pdiv_eucl (a b:positive) : N * N :=
  match a with
    | xH =>
       match b with xH => (1, 0)%N | _ => (0, 1)%N end
    | xO a' =>
       let (q, r) := Pdiv_eucl a' b in
       let r' := (2 * r)%N in
        if (NPgeb r' b) then (2 * q + 1, (Nminus r'  (Npos b)))%N
        else  (2 * q, r')%N
    | xI a' =>
       let (q, r) := Pdiv_eucl a' b in
       let r' := (2 * r + 1)%N in
        if (NPgeb r' b) then (2 * q + 1, (Nminus r' (Npos b)))%N
        else  (2 * q, r')%N
  end.

Definition ZOdiv_eucl (a b:Z) : Z * Z :=
  match a, b with
   | Z0,  _ => (Z0, Z0)
   | _, Z0  => (Z0, a)
   | Zpos na, Zpos nb =>
         let (nq, nr) := Pdiv_eucl na nb in
         (Z_of_N nq, Z_of_N nr)
   | Zneg na, Zpos nb =>
         let (nq, nr) := Pdiv_eucl na nb in
         (Zopp (Z_of_N nq), Zopp (Z_of_N nr))
   | Zpos na, Zneg nb =>
         let (nq, nr) := Pdiv_eucl na nb in
         (Zopp (Z_of_N nq), Z_of_N nr)
   | Zneg na, Zneg nb =>
         let (nq, nr) := Pdiv_eucl na nb in
         (Z_of_N nq, Zopp (Z_of_N nr))
  end.

Definition ZOdiv a b := fst (ZOdiv_eucl a b).
Definition ZOmod a b := snd (ZOdiv_eucl a b).

Definition Ndiv_eucl (a b:N) : N * N :=
  match a, b with
   | N0,  _ => (N0, N0)
   | _, N0  => (N0, a)
   | Npos na, Npos nb => Pdiv_eucl na nb
  end.

Definition Ndiv a b := fst (Ndiv_eucl a b).
Definition Nmod a b := snd (Ndiv_eucl a b).

(* Proofs of specifications for these euclidean divisions. *)

Theorem NPgeb_correct: forall (a:N)(b:positive),
  if NPgeb a b then a = (Nminus a (Npos b) + Npos b)%N else True.
Proof.
  destruct a; intros; simpl; auto.
  generalize (Pcompare_Eq_eq p b).
  case_eq (Pcompare p b Eq); intros; auto.
  rewrite H0; auto.
  now rewrite Pminus_mask_diag.
  destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]].
  rewrite H2. rewrite <- H3.
  simpl; f_equal; apply Pplus_comm.
Qed.

Hint Rewrite Z_of_N_plus Z_of_N_mult Z_of_N_minus Zmult_1_l Zmult_assoc
 Zmult_plus_distr_l Zmult_plus_distr_r : zdiv.
Hint Rewrite <- Zplus_assoc : zdiv.

Theorem Pdiv_eucl_correct: forall a b,
  let (q,r) := Pdiv_eucl a b in
  Zpos a = Z_of_N q * Zpos b + Z_of_N r.
Proof.
  induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hq1.
     generalize (NPgeb_correct (2 * r1 + 1) b); case NPgeb; intros H.
     set (u := Nminus (2 * r1 + 1) (Npos b)) in * |- *.
     assert (HH: Z_of_N u = (Z_of_N (2 * r1 + 1) - Zpos b)%Z).
        rewrite H; autorewrite with zdiv; simpl.
        rewrite Zplus_comm, Zminus_plus; trivial.
     rewrite HH; autorewrite with zdiv; simpl Z_of_N.
     rewrite Zpos_xI, Hq1.
     autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial.
     rewrite Zpos_xI, Hq1; autorewrite with zdiv; auto.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hq1.
     generalize (NPgeb_correct (2 * r1) b); case NPgeb; intros H.
     set (u := Nminus (2 * r1) (Npos b)) in * |- *.
     assert (HH: Z_of_N u = (Z_of_N (2 * r1) - Zpos b)%Z).
        rewrite H; autorewrite with zdiv; simpl.
        rewrite Zplus_comm, Zminus_plus; trivial.
     rewrite HH; autorewrite with zdiv; simpl Z_of_N.
     rewrite Zpos_xO, Hq1.
     autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial.
     rewrite Zpos_xO, Hq1; autorewrite with zdiv; auto.
  destruct b; auto.
Qed.

Theorem ZOdiv_eucl_correct: forall a b,
  let (q,r) := ZOdiv_eucl a b in a = q * b + r.
Proof.
  destruct a; destruct b; simpl; auto;
  generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros;
  try change (Zneg p) with (Zopp (Zpos p)); rewrite H.
    destruct n; auto.
  repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_l); trivial.
  repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_r); trivial.
Qed.

Theorem Ndiv_eucl_correct: forall a b,
  let (q,r) := Ndiv_eucl a b in a = (q * b + r)%N.
Proof.
  destruct a; destruct b; simpl; auto;
  generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros;
  destruct n; destruct n0; simpl; simpl in H; try discriminate;
  injection H; intros; subst; trivial.
Qed.


Require Import Limits.Pullback Cubical.PathSquare.
Require Export Algebra.Groups.GrpPullback.
Require Import Algebra.AbGroups.AbelianGroup.
Require Import WildCat.

(** * Pullbacks of abelian groups *)

Section AbPullback.
  (* Variables are named to correspond with Limits.Pullback. *)
  Context {A B C : AbGroup} (f : B $-> A) (g : C $-> A).

  Global Instance ab_pullback_commutative
    : Commutative (@group_sgop (grp_pullback f g)).
  Proof.
    unfold Commutative.
    intros [b [c p]] [d [e q]].
    apply equiv_path_pullback; simpl.
    refine (commutativity _ _; commutativity _ _; _).
    apply equiv_sq_path.
    apply path_ishprop.
  Defined.

  Global Instance isabgroup_ab_pullback
    : IsAbGroup (grp_pullback f g) := {}.

  Definition ab_pullback
    : AbGroup := Build_AbGroup (grp_pullback f g) _.

  (** The corecursion principle is inherited from Groups; use grp_pullback_corec and friends from Groups/GrpPullback.v. *)

End AbPullback.


Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Require Import HMAC_functional_prog.
Require Import Integers.
Require Import Coqlib.

(* Require Import List. Import ListNotations. *)

Definition Blist := list bool.

Fixpoint splitVector (A : Set) (n m : nat) :
  Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0%nat =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v) (* why the function? TODO *)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Eval compute in splitVector 1 2 [true; true; true].

Section HMAC.

SearchAbout Bvector.
Print Bvector.
Check Bvector 10.
Check [true].
Print Vector.

(* b = block size
   c = digest (output) size
   p = padding = b - c (fixed) *)
  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  (* TODO check how this corresponds to SHA
     Seems that h = SHA compression function
     hash_words with SHA's iv is SHA
   *)
  Check hash_words.
  Check h_star.

  Variable splitAndPad : Blist -> list (Bvector b).

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Bvector p.

  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x fpad).
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

Check hash_words.

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in (* concat earlier, then split *)
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

SearchAbout Bvector.

  Definition HMAC_2K (k : Bvector (b + b)) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

Check HMAC_2K.
(* HMAC_2K
     : Bvector (b + b) -> Blist -> Bvector c *)

(* opad and ipad are constants defined in the HMAC spec. *)
Variable opad ipad : Bvector b.
Definition GHMAC (k : Bvector b) :=
  GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Print BVxor.

Definition HMAC (k : Bvector b) :=
  HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Check HMAC.                     (*  : Bvector b -> Blist -> Bvector c *)

End HMAC.

(* ----------------------------------------------------------- Theorem definitions *)

Check HMAC_SHA256.HMAC.            (* list Z -> list Z -> list Z *)

  (* Bvector is little-endian (least significant bit at head; list Z are just translated
from the string (ascii -> nat -> Z); but Int are packed big-endian (with 4 Z -> 1 Int)

each Z is one byte (8 bits) *)

(* TODO: add isbyteZ (from SHA256.v), 0 <= i <= 256 *)

(* *************** byte/bit computational *)

(* TODO: finish this

The term "Vector.append (iterate n' num_new) [bool_digit]" has type
 "Vector.t bool (n' + 1)" while it is expected to have type
"Bvector (S n')".

Function with proof of equivalence? see hash_blocks  *)

(*
Fixpoint iterate (n : nat) (byte : nat) : Bvector n :=
  match n as x return Bvector x with
    | O => Vector.nil bool
    | S n' =>
      let byte_subtract := (byte - NPeano.pow 2 n')%nat in
      let bool_digit := negb (leb byte_subtract 0) in
      let num_new := if bool_digit then byte_subtract else byte in
      Vector.append (iterate n' num_new) [bool_digit] (* could reverse instead *)
  end.

*)

Lemma add_1_r_S : forall (n : nat), (n + 1)%nat = S n.
Proof.
  induction n.
    reflexivity.
    simpl. rewrite -> IHn. reflexivity.
Defined.

(* TODO step through this *)
Locate leb. Check negb.
(* little-endian *)
Fixpoint iterate (n : nat) (byte : nat) : Bvector n.
Proof.
  destruct n.
     apply (Vector.nil bool).
  remember ((byte - NPeano.pow 2 n)%nat) as byte_subtract.
  remember (negb (leb byte_subtract 0)) as bool_digit. (* changed from leb: gt now *)
  remember (if bool_digit then byte_subtract else byte) as num_new.
  rewrite <- add_1_r_S.
  apply (Vector.append (iterate n num_new) [bool_digit]). (* n' *)
Defined.

Print iterate.
Eval compute in iterate 1 255.
Check eq_rec. Print eq_rec. Print eq_rect. Check eq_rect.
Print NPeano.Nat.add_1_r.

(* TODO: fix the latter + 1 *)
Fixpoint byte_to_bits (byte : Z) : Bvector 8 :=
  let max_pow_two := 7%nat in
  iterate (max_pow_two + 1) (nat_of_Z byte + 1).

  Print add_1_r_S.
Eval compute in iterate 8 2.
Eval compute in byte_to_bits 0.
Eval compute in byte_to_bits 1.
Eval compute in byte_to_bits 2.

Eval compute in byte_to_bits 127.
Eval compute in byte_to_bits 128.
Eval compute in byte_to_bits 129.
Eval compute in byte_to_bits 200.
Eval compute in byte_to_bits 255.
Eval compute in byte_to_bits 256. (* not valid *)

(* Parameter byte_to_bits : Z -> Bvector 8. *)

(* Or: concatMap byte_to_bit bytes *)
Check Bvector.
SearchAbout Bvector.
Print Vector.t.

(* how to prove that it's length bytes * 8? *)
(* list of bytes? (type) *)
Fixpoint bytes_to_bits (bytes : list Z) : Bvector (length bytes * 8) :=
  match bytes as x return Bvector (length x * 8) with (* CPDT *)
    | nil => Vector.nil bool
    | x :: xs => Vector.append (byte_to_bits x) (bytes_to_bits xs)
  end.

(* ************* inductive defs *)

SearchAbout Bvector.

Definition asZ (x : bool) : Z := if x then 1 else 0.

(* TODO: maybe prefer b : byte, with Byte.repr? *)
Definition convertByteBits (b : Z) (B : Bvector 8) : Prop :=
  exists (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
   B = [b0; b1; b2; b3; b4; b5; b6; b7] /\
   b =  (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
         + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)).

(* *** *)

(* relationship between a list Z (of bytes) and a Bvector of size (c + p):
toBvector (bytes_to_bits k) = K?

This definition is not easy to use; replaced with bytes_bits_vector' in theorem
 *)
Inductive bytes_bits_vector (c p : nat) (k : list Z) : Bvector (plus c p) -> Prop :=
  | test_n : forall (K : Bvector (plus c p)),
               bytes_bits_vector c p k K (* TODO *)
.

(* relating list Z to Blist
bytes_to_bits m = length M

TODO: big-endian, little-endian?
*)
Inductive bytes_bits_lists : list Z -> Blist -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bytes : list Z) (bits : Blist)
                     (byte : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                bytes_bits_lists bytes bits ->
                convertByteBits byte [b0; b1; b2; b3; b4; b5; b6; b7] ->
                bytes_bits_lists (byte :: bytes)
                                (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits)
.

(* the hashes are "the same": list Z vs Bvector c

toBvector (bytes_to_bits h) = H
this is *almost* the same as bytes_bits_vector, except just c, not c + p
 *)
(* note: need to name c in order to use in Bvector c -- but then need to use names *)
Inductive bytes_bits_vector_wrong (len : nat) (bytes : list Z) (bits : Bvector len) : Prop :=
  | eq_empty_v' : bytes = nil -> len = 0%nat -> bytes_bits_vector_wrong bytes bits
  | eq_cons_v' : bytes_bits_vector_wrong bytes bits.

(*
Fixpoint iterate (n : nat) (byte : nat) : Bvector n.
Proof.
  destruct n.
     apply (Vector.nil bool).
  remember ((byte - NPeano.pow 2 n)%nat) as byte_subtract.
  remember (negb (leb byte_subtract 0)) as bool_digit. (* changed from leb: gt now *)
  remember (if bool_digit then byte_subtract else byte) as num_new.
  rewrite <- add_1_r_S.
  apply (Vector.append (iterate n num_new) [bool_digit]). (* n' *)
Defined.
*)

(*
Inductive bytes_bits_vector' (l : list Z) : Bvector (8 * length l) -> Prop :=
  | eq_empty_v : forall (bits : Bvector (8 * length nil)),
                   bytes_bits_vector' nil bits
  (* TODO: might want to use Vector.nil bool? *)
  | eq_cons_v : forall (bytes : list Z) (bits : Bvector (8 * length bytes))
                       (byte : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                  bytes_bits_vector' bytes bits ->
                  convertByteBits byte [b0; b1; b2; b3; b4; b5; b6; b7] ->
                  bytes_bits_vector' (byte :: bytes)
                                     (* TODO: is this the right endianness? *)
                                     (Vector.append [b0; b1; b2; b3; b4; b5; b6; b7] bits)
.
*)

Lemma list_cons_len {A : Type} :
      forall (x : A) (xs : list A), length (x :: xs) = (1 + length xs)%nat.
Proof. intros. reflexivity. Defined.

Lemma mul_dist : forall (n m : nat), (n * (1 + m))%nat = (n + n * m)%nat.
Proof.
  intros. simpl.
  rewrite -> mult_succ_r. rewrite -> plus_comm. reflexivity.
Defined.

Print mult_succ_r.
Print plus_comm.

Fixpoint squash_list_vector
         (bits_list : list (Bvector 8)) : Bvector (8 * length bits_list).
Proof.
  destruct bits_list.
    apply (Vector.nil bool).
    rewrite -> list_cons_len.
    rewrite -> mul_dist.
    (* TODO watch out for endianness *)
  apply (Vector.append b0 (squash_list_vector bits_list)).
Defined.

SearchAbout Vector.cons.
Check Vector.cons.
Check Vector.cons bool true 1 [false].

(* TODO: how to write a better dependent pattern match? doesn't use the equality of their len
writing it as a proof and destructing n or b1/b2 doesn't work
*)
Fixpoint bvector_eq (n : nat) (m : nat) (b1 : Bvector n) (b2 : Bvector m) : bool :=
  match b1, b2 with             (*  match n as n0 return (Bvector n0) with *)
    | Vector.nil, Vector.nil => true
    | Vector.cons x1 _ xs1, Vector.cons x2 _ xs2 =>
      eqb x1 x2 && bvector_eq xs1 xs2
    | _, _ => false                (* not possible *)
  end.

(* TODO watch out for endianness *)

Definition bytes_bits_vector_comp
         (n : nat) (bytes : list Z) (bits : Bvector n) : bool.
Proof.
  remember (map byte_to_bits bytes) as bits_list_vector.
  remember (squash_list_vector bits_list_vector) as bvector.
  assert (len_eq: length bytes = length bits_list_vector).
    rewrite -> Heqbits_list_vector.
    rewrite -> list_length_map.
    reflexivity.
  (* rewrite -> len_eq in bits. *)
  apply (bvector_eq bvector bits).
Defined.

Print bytes_bits_vector_comp.
(* Seems hard to use in a proof... *)

(* TODO: get this to be required *)
Eval compute in
    bytes_bits_vector_comp (0 :: nil) [true; true; true; true; true; true; true; true].

Lemma bytes_bits_vector_comp_len : forall (n : nat) (bytes : list Z) (bits : Bvector n),
                                     bytes_bits_vector_comp bytes bits = true
                                     -> n = (8 * length bytes)%nat.
Proof.
  (* TODO: bvector_eq is true iff the vectors are the same length *)
Admitted.

Check bytes_bits_vector.
Check HMAC_SHA256.HMAC.         (* ? *)
Check HMAC.
(* HMAC
     : forall c p : nat,
       (Bvector c -> Bvector (b c p) -> Bvector c) ->   // compression function h
       Bvector c ->                          // iv, h's initialization vector
       (Blist -> list (Bvector (b c p))) ->  // splitAndPad (e.g. generate_and_pad)
       Bvector p ->                          // fpad, constant-length padding
       Bvector (b c p) ->                    // opad
       Bvector (b c p) ->                    // ipad

^ Note: this has to do with the internals of SHA256 and HMAC too
SHA's compression function, iv, generate_and_pad (with block vectors),
HMAC's key padding function, HMAC's opad and ipad.
How to convert?

       Bvector (b c p) -> Blist -> Bvector c        // key, message, outputted hash

k is of length b
b = block size
c = output size
p = padding = b - c

why pad the key? why not just let it be size b?
 *)

(* ----------------------------------------- Theorem and parameters *)

(* want Bvector b = 512 bits *)
Print Byte.int.
Print Byte.repr.
Check Byte.unsigned.
Check HMAC_SHA256.sixtyfour.

Definition opad_test :=
     bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour (Byte.repr 52))).
Check opad_test.
(* Definition ipad_test := bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour HMAC_SHA256.Ipad)). *)

Check HMAC.

(* ------------------------------------- *)
Module Equiv.

Definition c:nat := (SHA256_.DigestLength * 8)%nat.
(*Variable p:nat.
Locate HMAC.
Check @HMAC. Check @sha_h.
Check (@HMAC _ p (@sha_h _ p plus) sha_iv (sha_splitandpad_vector p) (fpad p)).
Check (HMAC (sha_h p plus) sha_iv).
*)
Definition p:=(32 * 8)%nat.

Parameter sha_iv : Bvector (SHA256_.DigestLength * 8).

(* Definition sha_h : list Z -> list Z := SHA256_.Hash. *)
(* TODO: c = 32, p = 32 *)
Parameter sha_h : Bvector c -> Bvector (c + p) -> Bvector c.

(* corresponds to block size. b = plus *)

(*  "Blist -> list (Bvector (b SHA256_.DigestLength c))" *)
Parameter sha_splitandpad_vector :
  Blist -> list (Bvector (SHA256_.DigestLength * 8 + p)).

Parameter fpad : Bvector p.

(* Define opad, define ipad, pass converted ipad/opad to respective hmacs *)

(* Is this the theorem we want? Is it useful for the rest of the proofs?
Should it be more abstract? *)

(* TODO: opad <> ipad? *)
(* TODO fill this in *)
(* relies on bytes_bits_vector' too *)
Parameter bytes_bits_conv_vector : byte -> Bvector (plus c p) -> Prop.
(* Does something like:
bytes_bits_vector' (map Byte.unsigned (sixtyfour opad)) OPAD *)

Locate sixtyfour.

Definition bytes_bits_conv_vector'
           (byte_pad : byte) (bits_pad : Bvector (c + p)) : bool :=
  let bytes_pad := map Byte.unsigned (HMAC_SHA256.sixtyfour byte_pad) in
  eqb (bytes_bits_vector_comp bytes_pad bits_pad) true.

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

(*  (let (k_Out, k_In) :=
                       splitVector (b 256 256) (b 256 256)
                         (Vector.append (BVxor (b 256 256) K OP)
                            (BVxor (b 256 256) K IP)) in
Possibly try n = m -> splitVector n m...
*)

SearchAbout Bvector.
(* SearchAbout Vector. *)

Lemma empty_vector : forall (v : Bvector 0),
                       v = [].
Proof.
  intros v.
  (* destruct v. *)

Admitted.

Lemma split_append_id : forall (len : nat) (v1 v2 : Bvector len),
                          splitVector len len (Vector.append v1 v2) = (v1, v2).
Proof.
  induction len; intros v1 v2.
  (* Case len = 0 *)
    (* simpl. rewrite -> empty_vector. *)

    Admitted.

(* TODO: 10/25/14
- pull and merge
- look at ASCII library
   - rewrite iterate to emulate their conversion
- add lemma for xor **
   - lennart: B2b (Byte.xor B1 B2) = Vector.map2 xorb (B2b B1) (B2b B2)
- fill in parameters: sha_h, sha_iv, sha_splitandpad_vector, fpad **
- figure out how to get split lemmas to work
- check bytes_bits_vector' fixpoint
   - look at new definitions, inductive?
   - see if induction works with it
- step through theorem
  - figure out how to use relations in theorem: compositional? f property? **

- some other paper with a good approach?
- generalize technique for crypto
 *)
Theorem HMAC_spec_equiv : forall
                            (k m h : list Z)
                            (K : Bvector (plus c p)) (M : Blist) (H : Bvector c)
                            (op ip : byte) (OP IP : Bvector (plus c p)),
  ((length k) * 8)%nat = b c p ->
  bytes_bits_vector_comp k K = true ->
  bytes_bits_lists m M ->
  bytes_bits_conv_vector' op OP = true ->
  bytes_bits_conv_vector' ip IP = true ->
  HMAC sha_h sha_iv sha_splitandpad_vector fpad OP IP K M = H ->
  HMAC_SHA256.HMAC op ip m k = h -> (* m k, not k m *)
  bytes_bits_vector_comp h H = true.
Proof.
  intros k m h K M H op ip OP IP.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.
  unfold p,c, b in *.
  simpl in *.

  unfold HMAC in *.
  unfold HMAC_SHA256.HMAC in *.

  unfold HMAC_2K in *. unfold GHMAC_2K in *. (* unfold splitVector in *. *)
  (* Still abstract: sha_h, sha_splitandpad_vector, fpad,
     bytes_bits_vector', bytes_bits_conv_vector *)
  rewrite -> split_append_id in HMAC_abstract.

  unfold HMAC_SHA256.OUTER in *. unfold HMAC_SHA256.INNER in *.
    unfold HMAC_SHA256.outerArg in *. unfold HMAC_SHA256.innerArg in *.
    unfold HMAC_SHA256.mkArgZ in *. unfold HMAC_SHA256.mkArg in *.

  unfold BVxor in *. unfold xorb in *. (* unfold Vector.map2 in *. *)
  unfold Byte.xor in *. unfold Z.lxor in *.

    (* Lemma:

BVxor (b 256 256) K OP = Vector.map2 xorb K OP (can unfold xorb)
     ~
                          (map
                          (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                          (combine (map Byte.repr (HMAC_SHA256.mkKey k))
                             (HMAC_SHA256.sixtyfour ip)))

probably want a meta-lemma for composition of relations
r1 x X -> r2 y Y -> ?f ? -> f x y ~ F X Y

try with smaller examples first

figure out how to approach proof: avoid 4-way induction
 *)

  rewrite <- HMAC_abstract.
  rewrite <- HMAC_concrete.

  induction msgs_eq.

Abort.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.

(* neq is reflexive. *)
Definition neq_rel (A:Type): relation A:=
  fun (x y:A) => x <> y.
Global Instance Symmetric_neq: forall A, @Symmetric A (neq_rel A).
Proof. intros ? ? ? H ?. apply H; auto. Qed.

(* Duplicate hypothesis *)
Ltac duplicate H:= let HH := fresh "HH" in assert (HH:=H).

(* "Normal form"  hypothesis*)
Ltac normal_form_not_or:=
  repeat match goal with
         | [ H: ~ ( _ \/ _ ) |- _ ] =>
           apply Classical_Prop.not_or_and in H; destruct H
         end.
Ltac destruct_and:=
  repeat match goal with
         | [ H: _ /\ _  |- _ ] => destruct H
         end.
Ltac reduce_and:=
  repeat match goal with
         | [ |- _ /\ _  ] => split
         end.

(* Stronger form of inversion *)
(* It inverts and rewrites every *new* equality*)
(* NOTE!!: This changes the names of hypothesis!!! *)
(* I considere good practice to not depend on names*)
Ltac revert_but HH:=
  repeat match goal with
         | [ H: _ |- _ ] =>
           progress
             match H with
             | HH => idtac
             | _ => revert H
             end
         end.
Ltac invert HH:=
  revert_but HH;
  inversion HH; subst;
  intros.

(** I find these lemmas very useful.
    Particularly to prove Proper with iff.*)
Lemma forall_exists_iff: forall A (P Q: A -> Prop),
    (forall x, P x <-> Q x) -> (exists x, P x) <-> (exists x, Q x).
Proof.
  intros ? ? ? H1; split; intros [v H2]; eexists; eapply H1; eassumption.
Qed.
Lemma forall_exists_if: forall A (P Q: A -> Prop),
    (forall x, P x -> Q x) -> (exists x, P x) -> (exists x, Q x).
Proof.
  intros ? ? ? H1; intros [v H2]; eexists; eapply H1; eassumption.
Qed.
Lemma forall_and_if:
  forall (A A' B B': Prop),
    (A -> A') -> (B -> B') -> (A /\ B) -> (A' /\ B').
Proof. tauto. Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2014-12-11

* Infinite Ramsey theorem

After "On a Problem of Formal Logic", F. P. Ramsey, London
Math. Soc. s2-30(1):264-286, 1930, doi:10.1112/plms/s2-30.1.264. *)

Set Implicit Arguments.

From Coq Require Import Morphisms Basics Setoid.
From CoLoR Require Import ClassicUtil IotaUtil EpsilonUtil DepChoice
     LogicUtil SetUtil FinSet InfSet NatUtil.

Section S.

  Variables (A : Type) (W : set A).

(****************************************************************************)
(** Infinite pigeon-hole principle with two holes. *)

  Lemma IPHP_with_2_holes (P : Pinf W) (f : elts P -> bool) :
    exists b (Q : Pinf P), forall x (i : mem x Q), f (elt (Pinf_sub Q _ i)) = b.

  Proof.
    destruct P as [P [PW Pinf]]; simpl in *.
    (* We first prove that P is the union of f^-1(true) and f^-1(false). *)
    assert (e : P [=] union (fiber f true) (fiber f false)).
    intro x. repeat unfold mem, union, fiber. split.
    intro xP. case_eq (f (elt xP)); intro f_x.
    left. ex xP. hyp. right. ex xP. hyp.
    intros [[xP _]|[xP _]]; hyp.
    (* Then either f^-1(true) or f^-1(false) is infinite. *)
    rewrite e, infinite_union in Pinf.
    destruct Pinf as [f_true_inf|f_false_inf].
    (* Case f^-1(true) is infinite. *)
    assert (h : fiber f true [<=] P). fo. ex true (mk_Pinf h f_true_inf).
    intros x [xP hx]. rewrite (proof_irrelevance _ _ xP). hyp.
    (* Case f^-1(false) is infinite *)
    assert (h : fiber f false [<=] P). fo. ex false (mk_Pinf h f_false_inf).
    intros x [xP hx]. rewrite (proof_irrelevance _ _ xP). hyp.
  Qed.

(****************************************************************************)
(** Ramsey theorem with 2 colors only. *)

  (* Let [g] be the function that, given a function f from [Pcard P 1]
  to bool, maps every element of [P] to [f (singleton x)]. *)
  Definition g (P : Pinf W) (f : Pcard P 1 -> bool) : elts P -> bool.

  Proof.
    intros [x_val x]. apply f. ex (Pf_singleton x_val). split.
    intro y. simpl. unfold impl. fo. subst. hyp. apply card_singleton.
  Defined.

  (* Let [i] be the function which maps [X] in [Pcard V n] to [add a X]
  in [Pcard P (S n)] provided that [a] is in [P] but not in [V]. *)
  Definition i n P (Q : Pinf P) (U : Pinf Q) V (a : A)
    (aU : mem a U) (VU_a : V [<=] rem a U) : Pcard V n -> Pcard P (S n).

  Proof.
    intro X. ex (Pf_add a X). split.
    simpl. destruct X as [X [XV cXm]]; simpl. rewrite XV, VU_a, add_rem.
    destruct U as [U [UQ Uinf]]; simpl. destruct Q as [Q [QP Qinf]]; simpl.
    trans Q; hyp. apply eq_dec. hyp.
    rewrite card_add. destruct X as [X [XV cXm]]; simpl. rewrite cXm.
    destruct (dec (mem a X)). fo. lia.
  Defined.

  Arguments i [n P Q U V a] _ _ _.

  Lemma i_eq n P (Q : Pinf P) (U : Pinf Q) V (a : A)
        (VU_a : V [<=] rem a U) (aU : mem a U) (X : Pcard V n) :
    i aU VU_a X [=] add a X.

  Proof. refl. Qed.

  (* Let j be the function mapping every X in [Pcard T' n] to (add a X)
  in [Pcard P (S n)]. *)
  Definition j n (P : Pinf W) a (T' : Pinf W) :
    mem a P -> ~mem a T' -> T' [<=] P -> Pcard T' n -> Pcard P (S n).

  Proof.
    intros aP naT TP [X [XT cXn]]. ex (Pf_add a X). split.
    simpl. intro x. unfold impl, mem, add. fo. subst. fo.
    rewrite card_add, cXn. destruct (dec (mem a X)). fo. lia.
  Defined.

  Arguments j n [P a T'] _ _ _ _.

  Lemma j_eq n (P : Pinf W) a (T' : Pinf W) (aP : mem a P) (naT : ~mem a T')
        (TP : T' [<=] P) X : j n aP naT TP X [=] add a X.

  Proof. destruct X as [X [XT cXn]]. refl. Qed.

  Theorem ramsey_with_2_colors : forall n (P : Pinf W)
    (f : Pcard P (S n) -> bool), Proper (Pcard_equiv ==> eq) f ->
    exists b (Q : Pinf P), forall X : Pcard Q (S n), f (Pcard_subset Q X) = b.

  Proof.
    (* We proceed by induction on [n]. *)
    induction n; intros P f f_eq.

    (* Case n=0. *)

    (* We apply the infinite pigeon hole principle. *)
    destruct (IPHP_with_2_holes P (g P f)) as [b [Q h]].
    ex b Q. intros [X [XQ cX1]].
    destruct (card_S cX1) as [a [Y [XaY [naY cY0]]]].
    assert (aQ : mem a Q). apply XQ. change (mem a X); rewrite XaY. simpl. fo.
    rewrite <- (h _ aQ). unfold g; simpl. apply f_eq.
    unfold Pcard_equiv; simpl. rewrite Pf_singleton_eq, XaY, (card_0 cY0). refl.

    (* Case n>0. *)
    revert IHn P f f_eq. generalize (S n); clear n; intros n IH P f f_eq.

    (* Given Q in [Pinf P] and c, we consider the following relation
    on [Pinf Q]. *)
    set (R (Q : Pinf P) c := fun U V : Pinf Q =>
      exists a (aU : mem a U) (VU_a : V [<=] rem a U),
        forall X : Pcard V n, f (i aU VU_a X) = c).

    (* We prove the following key lemma L:
    if [R Q c] is total, then there is T infinite such that
    f is equal to c on [Pcard T (S n)]. *)
    assert (L : forall (Q : Pinf P) c, (forall U, exists V, R Q c U V) ->
      exists T : Pinf P, forall X : Pcard T (S n), f (Pcard_subset T X) = c).
    intros Q c RQc_total.

    (* We apply the axiom of dependent choice to get an infinite
    [R Q c]-sequence V. *)
    destruct (@dep_choice _ (Pinf_self Q) (R Q c) RQc_total) as [V [hV V0]].

    (* V_k is included in P. *)
    assert (VP : forall k, V k [<=] P). intro k. simpl. trans (Pinf_val Q).
    destruct (V k) as [Vk [VkQ Vkinf]]; hyp. destruct Q as [Q [QP Qinf]]; hyp.

    (* Let b_k be the sequence of elements of V_k such that
    V_{k+1} [<=] rem b_k V_k. *)
    assert (b_spec : forall k, exists b (bVk : mem b (V k))
      (VSkVk_b : V (S k) [<=] rem b (V k)),
      forall X : Pcard (V (S k)) n, f (i bVk VSkVk_b X) = c).
    intro k. destruct (hV k) as [b [bVk [VSkVk_b h]]]. ex b bVk VSkVk_b. hyp.
    set (b := fun k => proj1_sig (cid (b_spec k))).

    (* b_k is element of V_k. *)
    assert (bV : forall k, mem (b k) (V k)).
    intro k. unfold b. destruct (cid (b_spec k)) as [a [a1 [a2 a3]]]. hyp.

    (* V_{k+1} [<=] rem b_k V_k. *)
    assert (VSV_b : forall k, V (S k) [<=] rem (b k) (V k)).
    intro k. unfold b. destruct (cid (b_spec k)) as [a [a1 [a2 a3]]]. hyp.

    (* [f o i] is equal to c on Pcard (V (S k)) n. *)
    assert (Vf : forall k
      (X : Pcard (V (S k)) n), f (i (bV k) (VSV_b k) X) = c).
    intros k X. case_eq (cid (b_spec k)); intros a [a1 [a2 a3]] e.
    rewrite <- (a3 X). apply f_eq. unfold Pcard_equiv, Pf_equiv.
    rewrite !i_eq. unfold b. rewrite e; simpl. refl.

    (* b_k is not element of V_{k+1}. *)
    assert (nbVS : forall k, ~mem (b k) (V (S k))).
    intros k h. rewrite VSV_b in h. revert h. apply notin_rem.

    (* V is anti-monotone: the sets V_k are decreasing. *)
    assert (Vle : Proper (le --> subset) V).
    intros l k. unfold flip. revert k l. intro k. induction l; intro hl.
    assert (k=0). lia. subst. refl.
    destruct (le_dec k l) as [kl|nkl]. trans (Pinf_val (V l)).
    2: apply IHl; hyp. rewrite VSV_b. apply subset_rem.
    assert (k=S l). lia. subst. refl.

    (* V_{k+1} is strictly included in V_k. *)
    assert (VSlt : forall k, V (S k) [<] V k).
    intro k. rewrite VSV_b. apply strict_subset_rem. apply bV.

    (* If k < l, then b_l is not element of V_k. *)
    assert (lt_nbV : forall k l, k < l -> ~mem (b k) (V l)).
    intros k l kl h. apply Vle in kl. apply kl in h. revert h. apply nbVS.

    (* Let B be the set of all of the b_k's. *)
    set (B := fun x => exists k, x = b k).

    (* b_k is element of B. *)
    assert (bB : forall k, mem (b k) B). intro k. ex k. refl.

    (* B is included in P. *)
    assert (BP : B [<=] P). intros x [k e]. subst. eapply VP. apply bV.

    (* B is infinite. *)
    assert (Binf : infinite B).
    apply infinite_inj. ex (fun k => elt (bB k)).
    intros k l e. apply sig_eq in e; simpl in e.
    destruct (lt_dec k l) as [kl|nkl].
    apply lt_nbV in kl. rewrite e in kl. gen (bV l). contr.
    destruct (lt_dec l k) as [lk|nlk].
    apply lt_nbV in lk. rewrite <- e in lk. gen (bV k). contr.
    lia.

    (* The solution is [B]. *)
    set (B' := mk_Pinf BP Binf). ex B'.

    (* We now prove that f equals c on [Pcard B' (S n)]. *)
    intro X'. case_eq X'; intros [X X_fin] [XB cXSn] Xeq; rewrite <- Xeq.

    (* Let k0 be the smallest k such that b_k belongs to X. *)
    destruct (card_S cXSn) as [a [Y [XaY [naY cYn]]]].
    unfold Pf_equiv in XaY; simpl in XaY.
    assert (aX : mem a X). rewrite XaY. apply mem_add.
    gen aX; intro aX'. rewrite XB in aX'. destruct aX' as [kd abkd]. subst a.
    set (D := fun k => mem (b k) X). set (k0 := smallest (dec1 D) kd).
    gen (smallest_ok (dec1 D) aX). fold k0. intro bk0X. clear Y XaY naY cYn.

    (* Let Y be X - b_k0. *)
    set (Y := Pf_rem (b k0) X_fin).

    (* Y is included in V_{k0+1}. *)
    assert (YVSk0 : Y [<=] V (S k0)).
    intro x. unfold Y; simpl. unfold rem, mem. intros [nxbk0 xX].
    gen xX; intro xX'. apply XB in xX'. destruct xX' as [k xbk]. subst x.
    assert (k0k : k0 < k).
      assert (k0k' : k0 <= k). unfold k0. apply smallest_comp; hyp.
      destruct (eq_nat_dec k0 k). rewrite e in nxbk0. cong.
      lia.
    unfold lt in k0k. apply (Vle _ _ k0k). apply bV.

    (* card Y = n. *)
    assert (cYm : card Y = n).
    unfold Y. rewrite card_rem. unfold mk_Pf. rewrite cXSn. simpl.
    destruct (dec (mem (b k0) X)). lia. contr.

    set (Y' := mk_Pcard YVSk0 cYm).
    rewrite <- (Vf k0 Y'). apply f_eq. unfold Pcard_equiv, Pf_equiv.
    rewrite i_eq. apply Pcard_subset_equiv. rewrite Xeq.
    unfold Y', mk_Pcard; simpl. sym. apply add_rem. apply eq_dec. hyp.
    (* This ends the proof of lemma L. *)

    set (P' := Pinf_self P).
    destruct (classic (forall U, exists V, R P' true U V))
      as [R_P_true_total|R_P_true_not_total].

    (* Case [R P true] is total. *)
    ex true. eapply L. apply R_P_true_total.

    (* Case [R P true] is not total. *)
    rewrite not_forall_eq in R_P_true_not_total.
    destruct R_P_true_not_total as [E' hE].
    revert hE. rewrite not_exists_eq.
    case_eq E'; intros E [EP Einf] Eeq; rewrite <- Eeq. intro hE.

    (* We now prove that [R E false] is total. *)
    assert (R_E_false_total : forall U, exists V, R E' false U V).
    intro U'. case_eq U'; intros U [UE' Uinf] Ueq; rewrite <- Ueq.
    gen UE'; intro UE. rewrite Eeq in UE. simpl in UE.

    (* Let a be any element of U and let T be U - a. *)
    destruct (infinite_not_empty Uinf) as [a aU]. set (T := rem a U).
    assert (TW : T [<=] W). unfold T. trans U. apply subset_rem.
    trans E; auto. trans (Pinf_val P'); auto. unfold P'; simpl.
    destruct P as [P [PW Pinf]]; hyp.
    assert (Tinf : infinite T). unfold T. rewrite infinite_rem. hyp.
    set (T' := mk_Pinf TW Tinf).

    (* Properties of a and T. *)
    assert (aP : mem a P). rewrite UE, EP in aU. hyp.
    assert (naT : ~mem a T'). simpl. unfold T. apply notin_rem.
    assert (TP : T' [<=] P). simpl. unfold T. rewrite subset_rem. trans E; hyp.

    (* Let g be the function [f o j]. *)
    set (g := fun X : Pcard T' n => f (j n aP naT TP X)).

    assert (g_equiv : Proper (Pcard_equiv ==> eq) g).
    intros X Y. unfold Pcard_equiv, Pf_equiv. intro XY. unfold g. apply f_eq.
    unfold Pcard_equiv, Pf_equiv. rewrite !j_eq. rewrite XY. refl.

    (* By the induction hypothesis on g, there are b and Q such that f
    equals b on [Pcard Q n]. *)
    destruct (IH _ _ g_equiv) as [b [Q hQ]]. destruct b.

    (* Case b = true is absurd since [R P true] is not total. *)
    exfalso. set (Q' := Pinf_subset TP Q). eapply hE with (x := Q'). unfold R.

    assert (aE' : mem a E'). apply UE'. hyp.

    assert (QE'_a : Q' [<=] rem a E'). unfold Q', Pinf_subset.
    destruct Q as [Q [QT Qinf]]; simpl. trans (Pinf_val T'). hyp.
    simpl. unfold T. rewrite UE'. refl.

    ex a aE' QE'_a. intro X.

    assert (Q'Q : Q' [<=] Q). unfold Q', Pinf_subset.
    destruct Q as [Q [QT Qinf]]; simpl. refl.

    rewrite <- (hQ (Pcard_subset Q'Q X)). unfold g. apply f_eq.
    unfold Pcard_equiv, Pf_equiv. rewrite i_eq, j_eq. apply add_equiv.
    refl. unfold Pcard_subset. destruct X as [X [XQ' cXn]]; simpl. refl.

    (* Case b = false. *)
    assert (T'E' : T' [<=] E'). simpl. unfold T. rewrite subset_rem. hyp.
    set (Q' := Pinf_subset T'E' Q). ex Q'. unfold R.

    assert (aU' : mem a U'). rewrite Ueq. hyp.

    assert (Q'U'_a : Q' [<=] rem a U'). unfold Q', Pinf_subset.
    destruct Q as [Q [QT Qinf]]; simpl. trans (Pinf_val T'). hyp.
    simpl. unfold T. rewrite Ueq. refl.

    ex a aU' Q'U'_a. intro X.

    assert (Q'Q : Q' [<=] Q). unfold Q', Pinf_subset.
    destruct Q as [Q [QT Qinf]]; simpl. refl.

    rewrite <- (hQ (Pcard_subset Q'Q X)). unfold g. apply f_eq.
    unfold Pcard_equiv, Pf_equiv. rewrite i_eq, j_eq. apply add_equiv.
    refl. unfold Pcard_subset. destruct X as [X [XQ' cXn]]; simpl. refl.

    (* Conclusion. *)
    ex false. eapply L. apply R_E_false_total.
  Qed.

End S.

Arguments ramsey_with_2_colors [A W n P f] _.

(****************************************************************************)
(** Ramsey theorem with a finite set of colors. *)

Theorem ramsey A (W : set A) n (P : Pinf W) B : forall (C : Pf B)
  (f : Pcard P (S n) -> elts C), Proper (Pcard_equiv ==> elts_eq) f ->
  exists c (Q : Pinf P), forall X : Pcard Q (S n), f (Pcard_subset Q X) = c.

Proof.
  (* We proceed by induction on the cardinal of C (number of colors). *)
  intro C; pattern C; apply card_ind; clear C; induction n0 as [|k IH];
    intros C cardC f f_eq.
  (* card C = 0 *)
  exfalso. apply card_0 in cardC. destruct (f (Pcard_of_inf P n)) as [a aC].
  unfold Pf_equiv in cardC. simpl in cardC. rewrite cardC in aC. fo.
  (* card C = k+1 *)
  destruct (card_S cardC) as [c [D [CaD [naD cardD]]]].
  assert (cC : mem c C). rewrite CaD. apply mem_add. set (c' := elt cC).
  destruct k.
  (* Case k = 0: there is only one color. *)
  ex c'. set (Q := Pinf_self P). ex Q.
  intro X. destruct (f (Pcard_subset Q X)). apply sig_eq; simpl.
  apply card_0 in cardD. rewrite CaD, cardD in m. simpl in m. fo.
  (* Case k>0: there is more than one color. *)
  destruct (card_S cardD) as [d [E [DdE _]]].
  assert (dD : mem d D). rewrite DdE. apply mem_add. clear E DdE.
  (* Let g be function mapping every element X of [Pcard P (S n)] to D
  such that g(X)=f(X) if f(X) is in D, and g(X)=d otherwise. It
  identifies the colors c and d because, if f(X) is not in D, then
  f(X)=c since f(X) is in C and C is [add c D]. *)
  set (g := fun X : Pcard P (S n) =>
              match dec (Pf_val D (elt_val (f X))) with
                | left fXD => elt fXD
                | _ => elt dD
              end).
  assert (g_eq : Proper (Pcard_equiv ==> elts_eq) g).
  intros X Y XY. unfold g. apply f_eq in XY. rewrite XY.
  destruct (dec (Pf_val D (elt_val (f Y)))); refl.
  (* The induction hypothesis on g gives us a color e and a set Q. *)
  destruct (IH _ cardD _ g_eq) as [[e eD] [Q h1]]. destruct (dec (e=d)).
  (* Case e = d. *)
  subst e.
  (* Let j be the function mapping every X in [Pcard Q (S n)] to true
  if f(X)=c, and false otherwise. *)
  set (j := fun X : Pcard Q (S n) =>
    if eq_dec (elt_val (f (Pcard_subset Q X))) c then true else false).
  assert (j_eq : Proper (Pcard_equiv ==> eq) j).
  intros X Y XY. unfold j. case_eq (f (Pcard_subset Q X)); intros b bC fXb.
  apply sig_eq in fXb. rewrite (f_eq _ (Pcard_subset Q Y)) in fXb.
  apply sig_eq in fXb. rewrite fXb. refl. apply Pcard_subset_inj. hyp.
  (* With j, the Ramsey theorem with 2 colors gives us a color b and a set R. *)
  destruct (ramsey_with_2_colors j_eq) as [b [[R [RQ Rinf]] h2]]. simpl in h2.
  assert (RP : R [<=] P).
  trans (Pinf_val Q). hyp. destruct Q as [Q [QP Qinf]]; hyp.
  set (R' := mk_Pinf RP Rinf). destruct b.
  (* Case b = true. Then, f is equal to c on [Pcard R (S n)]. *)
  ex c' R'. intro X. gen (h2 X). unfold j.
  destruct (eq_dec (elt_val (f (Pcard_subset Q (Pcard_subset RQ X)))) c).
  2: discr. intros _. apply sig_eq. simpl. rewrite <- e. apply f_eq.
  unfold Pcard_equiv, Pf_equiv; simpl. apply Pcard_subset_inj.
  sym. apply Pcard_subset_equiv. refl.
  (* Case b = false. Then, f is equal to d on [Pcard R (S n)]. *)
  assert (dC : mem d C). rewrite CaD. simpl. unfold mem, add. auto.
  set (d' := elt dC). ex d' R'. intro X.
  gen (h1 (Pcard_subset RQ X)). gen (h2 X). unfold g, j.
  set (X' := Pcard_subset Q (Pcard_subset RQ X)).
  destruct (eq_dec (elt_val (f X')) c). discr. intros _.
  destruct (dec (Pf_val D (elt_val (f X')))).
  intro e. apply sig_eq in e; simpl in e. apply sig_eq; simpl.
  rewrite <- e. apply f_eq. apply Pcard_subset_equiv. unfold X'.
  sym. do 2 apply Pcard_subset_equiv. refl.
  exfalso. apply n1. revert n0. case_eq (f X'); intros b bC _.
  gen bC; intro bC'. rewrite CaD in bC. simpl. clear -bC. simpl in bC. fo.
  (* Case e <> d. Then, f is equal to e on [Pcard Q (S n)]. *)
  assert (eC : mem e C). rewrite CaD. simpl. unfold mem, add. auto.
  set (e' := elt eC). ex e' Q. intro X. gen (h1 X). unfold g.
  set (X' := Pcard_subset Q X).
  destruct (dec (Pf_val D (elt_val (f X'))));
    intro a; apply sig_eq in a; simpl in a;
    apply sig_eq; simpl; rewrite <- a.
  apply f_eq. refl. firstorder auto with exfalso.
Qed.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Require Import SfLib.
Require Import Maps.
Require Import MoreStlc.

(* ###################################################### *)
(** * Core Definitions *)

(* ################################### *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | TTop   : ty
  | TBase  : id -> ty
  | TArrow : ty -> ty -> ty
  (* record types *)
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  (* record terms *)
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

(* ################################### *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTTop :
        well_formed_ty TTop
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ################################### *)
(** *** Substitution *)

(** Substitution and reduction are as before. *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_id x y then s else t
  | tabs y T t1 =>  tabs y T (if beq_id x y then t1
                             else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr2 => trcons i (subst x s t1) (subst x s tr2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ################################### *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_rnil : value trnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (trcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' =>
      if beq_id i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' =>
      if beq_id i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tproj tr i) ==> (tproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

(* ###################################################################### *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ################################### *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: TTop
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    TArrow S1 S2 <: TArrow T1 T2
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (TRCons i T1 T2) ->
    TRCons i T1 T2 <: TRNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    TRCons i S1 Sr2 <: TRCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (TRCons i1 T1 (TRCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       TRCons i1 T1 (TRCons i2 T2 Tr3)
    <: TRCons i2 T2 (TRCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(* ############################################### *)
(** ** Examples *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).
Notation j := (Id 3).
Notation k := (Id 4).
Notation i := (Id 5).
Notation A := (TBase (Id 6)).
Notation B := (TBase (Id 7)).
Notation C := (TBase (Id 8)).

Definition TRcd_j  :=
  (TRCons j (TArrow B B) TRNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  TRCons k (TArrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (TArrow C TRcd_kj)
          (TArrow C TRNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_2 :
  subtype (TArrow TTop TRcd_kj)
          (TArrow (TArrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_3 :
  subtype (TArrow TRNil (TRCons j A TRNil))
          (TArrow (TRCons k B TRNil) TRNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_4 :
  subtype (TRCons x A (TRCons y B (TRCons z C TRNil)))
          (TRCons z C (TRCons y B (TRCons x A TRNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(* ###################################################################### *)
(** ** Properties of Subtyping *)

(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve by inversion.
  - (* TRCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (beq_id i i0)...  inversion H0; subst...  Qed.

(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve by inversion.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (beq_id i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (beq_idP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (beq_idP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars (rcd_types_match_informal)  *)
(** Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)
(** [] *)

(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (TArrow V1 V2) ->
     exists U1, exists U2,
       (U=(TArrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (TArrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in TArrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- tapp t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- tproj t i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- trcons i t tr \in TRCons i T Tr

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ############################################### *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star  *)
Definition trcd_kj :=
  (trcons k (tabs z A (tvar z))
           (trcons j (tabs z B (tvar z))
                      trnil)).

Example typing_example_0 :
  has_type empty
           (trcons k (tabs z A (tvar z))
                     (trcons j (tabs z B (tvar z))
                               trnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example typing_example_1 :
  has_type empty
           (tapp (tabs x TRcd_j (tproj (tvar x) j))
                   (trcd_kj))
           (TArrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Example typing_example_2 :
  has_type empty
           (tapp (tabs z (TArrow (TArrow C C) TRcd_j)
                           (tproj (tapp (tvar z)
                                            (tabs x C (tvar x)))
                                    j))
                   (tabs z (TArrow C C) trcd_kj))
           (TArrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve by inversion.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (beq_id i i0).
    + (* i is first *)
      inversion H1. subst. exists t...
    + (* i in tail *)
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

(* ########################################## *)
(** *** Progress *)

(** **** Exercise: 3 stars (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (TArrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tabs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t ==> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [t1 t2 ==>
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 ==> t2'] for some term [t2'].  Then [t1 t2 ==>
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 ==>
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr ==>
        tr'] for some term [tr'], then [tr.i ==> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i ==> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [{i=t1, tr}
          ==> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr ==> tr'] for some term [tr'].  Then [{i=t1,
            tr} ==> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ########################################## *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tvar x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tvar x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve by inversion.
  - (* T_Var *)
    exists T...
  - (* T_Sub *)
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tapp t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (TArrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tapp t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve by inversion.
  - (* T_App *)
    exists T1...
  - (* T_Sub *)
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tabs x S1 t2) T ->
     (exists S2, subtype (TArrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tabs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve by inversion.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (tproj t1 i) Ti ->
  exists T, exists Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve by inversion.
  - (* T_Proj *)
    assert (well_formed_ty Ti) as Hwf.
    { (* pf of assertion *)
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T. exists Ti...
  - (* T_Sub *)
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U. exists Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (trcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (TRCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (trcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  - (* T_Sub *)
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri. exists Rr...
  - (* T_RCons *)
    assert (well_formed_ty (TRCons i T Tr)) as Hwf.
    { (* pf of assertion *)
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T. exists Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (tabs x S1 s2) (TArrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ########################################## *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (trcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (beq_idP x x0)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  - (* T_Abs *)
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_beq_id in Hctx...  Qed.

(* ########################################## *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - (* tvar *)
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (beq_idP x y)...
    + (* x=y *)
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      destruct (subtype__wf _ _ Hsub)...
  - (* tapp *)
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - (* tabs *)
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (TArrow T1 T2)... apply T_Abs...
    destruct (beq_idP x y).
    + (* x=y *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x)...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z)...
      subst.  rewrite false_beq_id...
  - (* tproj *)
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  - (* trnil *)
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  - (* trcons *)
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (TRCons i Ti Tr)...
    apply T_RCons...
    + (* record_ty Tr *)
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    + (* record_tm ([x:=v]t2) *)
      inversion Hrcdt2; subst; simpl...  Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  - (* T_Proj *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t ==> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr ==> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

(** $Date: 2016-05-27 14:19:30 -0400 (Fri, 27 May 2016) $ *)