(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* A theory of constructed functions and permutations, including random functions and random permutations. *)

Set Implicit Arguments.
Require Import Crypto.
Require Import Permutation.
Require Import CompFold.
Require Export Array.
Require Import FCF.

Local Open Scope list_scope.
Local Open Scope array_scope.

Require Import State.

Definition oracleMap(D R S: Set)(eqds : EqDec S)(eqdr : EqDec R)(oracle : (S * D) -> Comp (S * R))(s : S)(ds : list D) :=
  compFold _ (fun acc d => [s, r] <-$2 oracle (fst acc, d); ret (fst acc, snd acc ++ r :: nil)) (s, nil) ds.

Section RandomFunc.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Variable RndR : Comp R.
  Hypothesis RndR_wf : well_formed_comp RndR.

  (* A random function *)
  Definition randomFunc(p : (list (D * R)) * D) : Comp (list (D * R) * R) :=
    let (f, d) := p in
    match (arrayLookup _ f d) with
      | None => (r <-$ RndR; ret ((d, r) :: f, r))
      | Some r => ret (f, r)
    end.
  Lemma randomFunc_wf : forall p,
    well_formed_comp (randomFunc p).

    intuition.
    unfold randomFunc.
    case_eq (a#b); intuition; wftac.

  Qed.

  (* Eager random functions can be used to simplify many definitions. *)
  Fixpoint randomFunc_eager_arr(allD : list D) :=
    match allD with
        | nil => ret nil
        | d :: allD' =>
          arr' <-$ randomFunc_eager_arr allD';
            r <-$ RndR;
            ret ((d, r) :: arr')
    end.

  Hint Resolve randomFunc_wf : wftac.

  Theorem inSupportRandomFunc :
    forall a b r,
      a # b = None ->
      In r (getSupport RndR) ->
      In ((b, r) :: a, r) (getSupport (randomFunc (a, b))).

    intuition.
    unfold randomFunc.
    rewrite H.
    eapply getSupport_In_Seq.
    eauto.
    simpl.
    intuition.

  Qed.

  (*
  Section PRF.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.
    Variable A : AdversaryWithOracle unit bool D R (list (D * R)).
    Variable q : nat.

    Definition f_oracle (k : Bvector eta)(p : (list (D * R)) * D) : Comp ((list (D * R)) * R) :=
      [s, d] <-2 p;
      ret (nil, f k d).

    Definition PRF_G0 :=
      k <-$ {0, 1} ^ eta;
      [b, _] <-$2 (A queries (f_oracle k)) q nil tt;
      ret b.

    Definition PRF_G1 :=
      [b, _] <-$2 (A queries randomFunc) q nil tt;
      ret b.

    Definition PRF_Advantage := | Pr[PRF_G0] - Pr[PRF_G1] |.
  End PRF.
  (* A PRF that is secure against a non-adaptive adversary. *)
  Section PRF_NA.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.

    Section PRF_NA_Adversary.
      Variable A_state : Set.
      Variable A1 : Comp ((list D) * A_state ).
      Variable A2 : A_state -> list R -> Comp bool.
      Definition A := (A1, A2).

      Definition PRF_NA_G0 :=
        lsD <-& A;
        lsR <-$ (k <-$ {0, 1} ^ eta; ret (map (f k) lsD));
        A lsR.

      Definition PRF_NA_G1 :=
        lsD <-& A;
        [_, lsR] <-$2 oracleMap _ _ randomFunc nil lsD;
        A lsR.

      Definition PRF_NA_Advantage :=
      | Pr[PRF_NA_G0] - Pr[PRF_NA_G1] |.

    End PRF_NA_Adversary.

    Variable efficient : forall(x : Type), x -> Prop.

    Definition PRF_NA_Assumption epsilon :=
      forall A_state A1 A2,
        efficient A1 ->
        efficient A2 ->
        @PRF_NA_Advantage A_state A1 A2 <= epsilon.

  End PRF_NA.
*)

  (* An iterated PRF security definition.  The adversary supplies several lists of PRF inputs.  The definition chooses a new random key for each list.  *)
  Section PRF_NAI.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.
    Variable A_state : Set.
    Variable A1 : Comp ((list (list D)) * A_state ).
    Variable A2 : A_state -> list (list R) -> Comp bool.

    Definition PRF_NAI_G0 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => k <-$ {0, 1}^eta; ret (map (f k) lsD)) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_G1 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => [_, lsR] <-$2 oracleMap _ _ randomFunc nil lsD; ret lsR) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_Advantage :=
    | Pr[PRF_NAI_G0] - Pr[PRF_NAI_G1] |.

  End PRF_NAI.

End RandomFunc.

Section RandomPerm.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Variable RndR : Comp R.
  Hypothesis RndR_wf : well_formed_comp RndR.

  Fixpoint inRange(f : list (D * R))(r : R) :=
    match f with
      | nil => false
      | (d', r') :: f' =>
        if (eqb r r') then true
          else (inRange f' r)
    end.

  Definition getUnusedR(f : list (D * R)) :=
    Repeat (RndR) (fun r => negb (inRange f r)).

  Lemma getUnusedR_eq : forall ls1 ls2 x,
    (forall r, inRange ls1 r = inRange ls2 r) ->
    evalDist (getUnusedR ls1) x == evalDist (getUnusedR ls2) x.

    intuition.

    destruct (in_dec (EqDec_dec _) x (getSupport (getUnusedR ls1))).
    unfold getUnusedR in *.

    simpl in i.
    apply filter_In in i; intuition.
    eapply evalDist_Repeat_eq.
    intuition.
    rewrite H.
    trivial.
    eapply filter_In; intuition.
    eapply sumList_permutation.
    eapply NoDup_Permutation.
    eapply filter_NoDup.
    eapply getSupport_NoDup.
    eapply filter_NoDup.
    eapply getSupport_NoDup.
    intuition.
    apply filter_In in H2; intuition.
    eapply filter_In; intuition.
    rewrite <- H.
    trivial.
    apply filter_In in H2; intuition.
    eapply filter_In; intuition.
    rewrite H.
    trivial.

    unfold getUnusedR in *.
    simpl in n.
    apply filter_not_In in n.
    intuition.
    simpl.
    rewrite getSupport_not_In_evalDist_h; intuition.
    repeat rewrite ratMult_0_r.
    intuition.

    simpl.
    unfold indicator.
    rewrite <- H.
    rewrite H0.
    repeat rewrite ratMult_0_l.
    intuition.

  Qed.

  Lemma inRange_map : forall ls x,
    inRange ls x = true ->
    In x (map (@snd D R) ls).

    induction ls; intuition; simpl in *.
    discriminate.
    case_eq (eqb x b); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

    right.
    eapply IHls.
    rewrite H0 in H.
    trivial.
  Qed.

  Lemma getUnusedR_wf : forall ls r,
    inRange ls r = false ->
    In r (getSupport RndR) ->
    well_formed_comp (getUnusedR ls).

    intuition.
    unfold getUnusedR.
    eapply (well_formed_Repeat _ _ r).
    wftac.

    eapply filter_In.
    intuition.
    rewrite H.
    simpl.
    trivial.

    Grab Existential Variables.
    unfold eq_dec; intuition.
    eapply (EqDec_dec _).
  Qed.
  Hint Resolve getUnusedR_wf : wftac.

  (* A random permutation *)
  Definition randomPerm(p : (list (D * R) *  D)) : Comp (list (D * R) * R) :=
    let (f, d) := p in
    match (f#d) with
      | None => (r <-$ getUnusedR f ; ret ((d, r) :: f, r))
      | Some r => ret (f, r)
    end.

  Lemma randomPerm_wf : forall ls b0,
    (forall x, ls#x = None -> exists r, inRange ls r = false /\ In r (getSupport RndR)) ->
    well_formed_comp (randomPerm (ls, b0)).

    intuition.
    unfold randomPerm.
    case_eq (ls#b0); intuition; wftac.
    edestruct H; eauto.
    intuition.
    wftac.
  Qed.

  (* Many proofs involving random permutations will need to query the random permutation repeatedly.  In order to show that each call to the permutation is well-formed, we need to preserve the invariant that the state of the permutation is actually a permutation (as opposed to an arbitrary function).  The well_formed_perm is the predicate that we will use for this invariant. *)
  Definition well_formed_perm ls :=
    forall lsd,
      NoDup lsd ->
      (forall d, In d lsd -> ls#d = None) ->
      exists lsr,
        (forall r, In r lsr -> inRange ls r = false /\ In r (getSupport RndR)) /\
        NoDup lsr /\
        length lsd = length lsr.

  (*
  Lemma well_formed_perm_nil : well_formed_perm nil.

    intuition.
    unfold well_formed_perm.
    intuition.
    econstructor.
    intuition.
    eapply H1.
    eapply getSupport_NoDup.

    exists lsd.
    intuition.

  Qed.
*)

  Lemma well_formed_perm_1 : forall ls,
    well_formed_perm ls ->
    forall d,
    ls#d = None ->
    exists r, inRange ls r = false /\ In r (getSupport RndR).

    intuition.
    specialize (H (d :: nil)).
    edestruct H.
    econstructor.
    simpl. intuition.
    econstructor.
    intuition.
    simpl in *.
    intuition. subst.
    trivial.

    intuition.
    destruct x.
    simpl in *.
    lia.
    destruct x; simpl in *.
    econstructor.
    eapply H2.
    intuition.
    lia.
  Qed.
  Hint Resolve well_formed_perm_1 : wftac.

  Lemma removeFirst_length : forall (A : Set)(eqd : eq_dec A)(ls : list A) a,
    In a ls ->
    S (length (removeFirst eqd ls a)) = length ls.

    induction ls; intuition; simpl in *.
    intuition.
    subst.
    f_equal.
    destruct (eqd a0 a0).
    trivial.
    congruence.
    destruct (eqd a0 a); subst.
    trivial.
    simpl.
    f_equal.
    eauto.
  Qed.

  Lemma well_formed_perm_cons : forall ls d r,
    well_formed_perm ls ->
    ls#d = None ->
    inRange ls r = false ->
    well_formed_perm ((d, r) :: ls).

    unfold well_formed_perm in *.
    intuition.
    destruct (in_dec (EqDec_dec _) d lsd).
    specialize (H3 d).
    intuition.
    simpl in *.
    rewrite eqb_refl in H4.
    discriminate.

    edestruct (H (d :: lsd)).
    econstructor; trivial.
    intuition.
    simpl in *.
    intuition. subst.
    trivial.
    specialize (H3 d0).
    intuition.
    destruct (eqb d0 d).
    discriminate.
    trivial.

    intuition.
    (* now I have |lsd| + 1 unique elements that are not in the range *)
    (* but r may be in there *)
    destruct (in_dec (EqDec_dec _) r x).
    (* r is in the list, take it out and we get a list of the correct length *)
    exists (removeFirst (EqDec_dec _) x r).
    intuition.
    simpl.
    case_eq (eqb r0 r); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in.
    eapply H4.
    eapply H6.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.

    eapply removeFirst_NoDup.
    trivial.

    simpl in H7.
    eapply eq_add_S.
    rewrite H7.
    symmetry.
    eapply removeFirst_length.
    trivial.

    (* r is not in the list, just use the tail of it *)
    destruct x.
    simpl in *. lia.
    exists x.
    intuition.
    simpl in *.
    intuition.
    case_eq (eqb r1 r); intuition.
    exfalso.
    rewrite eqb_leibniz in H10.
    subst.
    intuition.
    eapply H5.
    right.
    trivial.
    eapply H5.
    simpl.
    intuition.
    inversion H4; clear H4; subst.
    trivial.
  Qed.

  Lemma well_formed_perm_cons_2 : forall ls d r1 r2,
    well_formed_perm ls ->
    inRange ls r2 = true ->
    ls#d = None ->
    well_formed_perm ((d, r1) :: (d, r2) :: ls).

    intuition.
    unfold well_formed_perm.
    intuition.
    destruct (in_dec (EqDec_dec _) d lsd).
    specialize (H3 d).
    intuition.
    simpl in *.
    rewrite eqb_refl in H4.
    discriminate.
    edestruct (H (d :: lsd)).
    econstructor; trivial.
    intuition.
    simpl in H4.
    intuition. subst.
    trivial.

    specialize (H3 d0).
    intuition.
    simpl in *.
    destruct (eqb d0 d).
    discriminate.
    trivial.

    intuition.
    destruct (in_dec (EqDec_dec _) r1 x).
    exists (removeFirst (EqDec_dec _) x r1).
    intuition.
    simpl.
    case_eq (eqb r r1); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in.
    eapply H4.
    eauto.
    case_eq (eqb r r2); intuition.
    rewrite eqb_leibniz in H9.
    subst.
    assert (inRange ls r2 = false).
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    congruence.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eauto using removeFirst_NoDup.
    eapply eq_add_S.
    simpl in H7.
    rewrite H7.
    symmetry.
    eapply removeFirst_length.
    trivial.

    destruct x.
    simpl in *.
    lia.
    exists x.
    intuition.
    simpl in *.
    case_eq (eqb r0 r1); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    intuition.
    case_eq (eqb r0 r2); intuition.
    rewrite eqb_leibniz in H11.
    subst.
    assert (inRange ls r2 = false).
    eapply H5.
    intuition.
    congruence.
    eapply H5.
    intuition.
    eapply H5.
    simpl.
    intuition.
    inversion H4; clear H4; subst.
    trivial.
  Qed.

  Lemma getUnusedR_preserves_wf : forall ls d r,
    well_formed_perm ls ->
    ls#d = None ->
    In r (getSupport (getUnusedR ls)) ->
    well_formed_perm ((d, r) :: ls).

    intuition.
    unfold getUnusedR in *.
    simpl in H1.
    apply filter_In in H1.
    intuition.

    eapply well_formed_perm_cons; eauto.
    destruct (inRange ls r); simpl in *; congruence.

  Qed.

  Lemma getUnusedR_ret_preserves_wf : forall ls ls' d r,
    well_formed_perm ls ->
    ls#d = None ->
    In (ls', r) (getSupport (r <-$ getUnusedR ls; ret ((d, r) :: ls, r))) ->
    well_formed_perm ls'.

    intuition.
    apply getSupport_Bind_In in H1.
    destruct H1.
    intuition.
    simpl in H3.
    intuition.
    inversion H1; clear H1; subst.
    eapply getUnusedR_preserves_wf; eauto.

  Qed.

  Lemma randomPerm_preserves_wf : forall ls d ls' r,
    well_formed_perm ls ->
    In (ls', r) (getSupport (randomPerm (ls, d))) ->
    well_formed_perm ls'.

    intuition.
    unfold randomPerm in *.
    case_eq (ls#d); intuition.
    rewrite H1 in H0.
    simpl in *.
    intuition.
    inversion H2; clear H2; subst.
    trivial.

    rewrite H1 in H0.
    eapply getUnusedR_ret_preserves_wf; eauto.
  Qed.

  Lemma randomPerm_preserves_wf_pair : forall ls d p,
    well_formed_perm ls ->
    In p (getSupport (randomPerm (ls, d))) ->
    well_formed_perm (fst p).

    intuition.
    destruct p.
    eapply randomPerm_preserves_wf; eauto.

  Qed.

  Lemma getUnusedR_not_inRange : forall ls d r,
    ls#d = None ->
    In r (getSupport (getUnusedR ls)) ->
    inRange ls r = false.

    intuition.
    unfold getUnusedR in *.
    simpl in *.
    eapply filter_In in H0.
    intuition.
    destruct (inRange ls r); intuition.
  Qed.

  Lemma funcLookup_inRange_true : forall s d r,
    s#d = Some r ->
    inRange s r = true.

    induction s; intuition; simpl in *.
    discriminate.

    case_eq (eqb d a0); intuition;
    rewrite H0 in H.
    inversion H; clear H; subst.
    rewrite eqb_refl.
    trivial.

    case_eq (eqb r b); intuition.
    eauto.

  Qed.

  Lemma inRange_permutation : forall ls1 ls2 r,
    Permutation ls1 ls2 ->
    inRange ls1 r = inRange ls2 r.

    induction 1; intuition; simpl in *.
    rewrite IHPermutation.
    trivial.
    case_eq (eqb r b0); intuition.
    rewrite eqb_leibniz in H.
    subst.
    destruct (eqb b0 b); intuition.

    eauto.

  Qed.

  Lemma inRange_app_cons : forall ls d r x,
    inRange (ls ++ (d, r) :: nil) x = inRange ((d , r) :: ls) x.

    intuition.
    symmetry.
    eapply inRange_permutation.
    eapply Permutation_cons_append.
  Qed.

  Lemma inRange_app : forall ls ls' r,
    inRange ls r = true ->
    inRange (ls ++ ls') r = true.

    induction ls; intuition; simpl in *.
    case_eq (eqb r b); intuition.
    eapply IHls.
    rewrite H0 in H.
    trivial.
  Qed.

  Lemma notInArrayLookupNone :
    forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a,
      (~ In a (fst (unzip arr))) ->
      (arr # a) = None.

    induction arr; intuition; simpl in *.

    case_eq (eqb a a0); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

  Qed.

  Ltac hypInv :=
      try (match goal with
          | [H: Some _ = Some _ |-_ ] => inversion H; clear H; subst
      end); try pairInv.

  Lemma arrayLookup_Some_In_unzip :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a b,
    (arr # a) = Some b ->
    In a (fst (unzip arr)).

  induction arr; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition;
  rewrite H0 in *.
  hypInv.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

  right.
  eapply IHarr.
  eauto.

Qed.

  (*
  Lemma funcLookup_app_some_eq : forall ls d (v : R),
    ls#d = None ->
    (ls ++ (d, v) :: nil)#d = Some v.

    intuition.
    eapply arrayLookup_app_some_eq.
    eauto.

  Qed.

  Lemma funcLookup_app_none : forall ls d d' (v' : R),
    ls#d = None ->
    (ls ++ (d, v') :: nil) # d' = (((d, v') :: ls)#d').

    intuition.
    eapply arrayLookup_app_none; eauto.

  Qed.

  Lemma funcLookup_app_ne : forall ls d (r : R) d',
    d <> d' ->
    (ls ++ (d, r) :: nil)#d' = (ls#d').

    intuition.
    eapply arrayLookup_app_ne; eauto.

  Qed.

  Lemma funcLookup_app_some : forall ls d d' (v v' : R),
    ls#d = Some v ->
    (ls ++ (d, v') :: nil)#d' = (ls#d').

    intuition.
    eapply arrayLookup_app_some.
    eauto.
  Qed.
*)

  Lemma inRange_in_dec : forall ls r,
    inRange ls r = if (in_dec (EqDec_dec _) r (map (@snd D R) ls)) then true else false.

    induction ls; intuition; simpl in *.
    destruct (EqDec_dec R_EqDec b r); subst.
    rewrite eqb_refl.
    trivial.
    case_eq (eqb r b); intuition.
    rewrite eqb_leibniz in H.
    subst.
    intuition.
    exfalso.
    intuition.
    specialize (IHls r).
    destruct (in_dec (EqDec_dec R_EqDec) r (map (snd (B:=R)) ls)).
    trivial.
    trivial.
  Qed.

  Theorem inSupportRandomPerm :
    forall a b r,
      In r (getSupport (getUnusedR a)) ->
      a # b = None ->
      In ((b, r) :: a, r) (getSupport (randomPerm (a, b))).

    intuition.
    unfold randomPerm.
    rewrite H0.
    eapply getSupport_In_Seq.
    eauto.
    simpl.
    intuition.

  Qed.

  (* Equivalence of functions and permutations. *)
  Definition funcs_eq s1 s2 :=
    (forall d, s1#d = (s2#d)) /\
    (forall r, inRange s1 r = inRange s2 r).

  Definition perms_eq s1 s2 :=
    well_formed_perm s1 /\
    well_formed_perm s2 /\
    funcs_eq s1 s2.

  (*
  Lemma perms_eq_nil : perms_eq nil nil.

    unfold perms_eq.
    intuition.
    eapply well_formed_perm_nil.
    eapply well_formed_perm_nil.
    unfold funcs_eq.
    intuition.
  Qed.
*)

  (* Eager random permutations can be used to simplify many definitions. *)
  Fixpoint randomPerm_eager_arr(allD : list D) :=
    match allD with
        | nil => ret nil
        | d :: allD' =>
          arr' <-$ randomPerm_eager_arr allD';
            r <-$ getUnusedR arr';
            ret ((d, r) :: arr')
    end.

End RandomPerm.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import Coq.Program.Equality.
Require Import SystemF.
Require Import Infrastructure.

Module MSubtyping
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MInfrastructure := MInfrastructure(VarTyp)(set).
Export MInfrastructure.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

 *)

Inductive Atomic : PTyp -> Prop :=
  | AInt : Atomic PInt
  | AFun : forall t1 t2, Atomic (Fun t1 t2)
  | AVar : forall v, Atomic (PFVarT v)
  | AForAll : forall d t, Atomic (ForAll d t)
  | ARec : forall l t, Atomic (Rec l t)
  | ABot : Atomic Bot.

Hint Constructors Atomic.
Hint Constructors STType.

(* Subtyping relation *)

Inductive usub : PTyp -> PTyp -> Prop :=
  | USInt : usub PInt PInt
  | USFun : forall o1 o2 o3 o4, usub o3 o1 -> usub o2 o4 -> usub (Fun o1 o2) (Fun  o3 o4)
  | USAnd1 : forall t t1 t2, usub t t1 -> usub t t2 -> usub t (And  t1 t2)
  | USAnd2 : forall t t1 t2 , usub t1 t -> PType t2 -> usub (And t1 t2) t
  | USAnd3 : forall t t1 t2, usub t2 t -> PType t1 -> usub (And t1 t2) t
  | USVar   : forall v, usub (PFVarT v) (PFVarT v)
  | USForAll : forall L d1 d2 t1 t2,
                 (forall x, not (In x L) -> usub (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                 usub d2 d1 ->
                 usub (ForAll d1 t1) (ForAll d2 t2)
  | USTop : forall t, PType t -> usub t Top
  | USBot : forall t, PType t -> usub Bot t
  | USRec : forall l t1 t2, usub t1 t2 -> usub (Rec l t1) (Rec l t2).

Inductive and_coercion (e : SExp var) : PTyp -> sum (SExp var) (SExp var) -> Prop :=
  | ACInt : and_coercion e PInt (inr e)
  | ACFunL : forall A B e1, and_coercion e B (inl e1) ->
                       and_coercion e (Fun A B) (inl (STLam _ e1))
  | ACFunR : forall A B, and_coercion e B (inr e) ->
                    and_coercion e (Fun A B) (inr e)
  | ACAndL : forall A B e1 e2, and_coercion e A (inl e1) ->
                          and_coercion e B (inl e2) ->
                          and_coercion e (And A B) (inl (STPair _ e1 e2))
  | ACAndR1 : forall A B, and_coercion e A (inr e) ->
                     and_coercion e (And A B) (inr e)
  | ACAndR2 : forall A B, and_coercion e B (inr e) ->
                     and_coercion e (And A B) (inr e)
  | ACVar : forall x, and_coercion e (PFVarT x) (inr e)
  | ACForAllL : forall L A d e1,
                  (forall x, not (In x L) ->
                        and_coercion e (open_typ_source A (PFVarT x)) (inl e1)) ->
                  and_coercion e (ForAll d A) (inl (STTLam _ e1))
  | ACForAllR : forall L A d,
                  (forall x, not (In x L) ->
                        and_coercion e (open_typ_source A (PFVarT x)) (inr e)) ->
                  and_coercion e (ForAll d A) (inr e)
  | ACTop : and_coercion e Top (inl (STUnit _))
  | ACBot : and_coercion e Bot (inr e)
  | ACRec : forall l t r, and_coercion e t r ->
                     and_coercion e (Rec l t) r.

Hint Constructors and_coercion.

(* Some properties about and_coercion *)

Definition join_sum : forall {A}, A + A -> A.
  intros A H; destruct H as [a | a]; exact a.
Defined.

Lemma ac_inr_inv : forall t e e', and_coercion e t (inr e') -> and_coercion e t (inr e).
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve ac_inr_inv.

Lemma ac_inr_inv_eq : forall t e e', and_coercion e t (inr e') -> e = e'.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Lemma ac_subst :
  forall t, PType t ->
       forall e c y x,
         x <> y ->
         and_coercion e t c ->
         and_coercion e (subst_typ_source y (PFVarT x) t) c.
Proof.
  intros t Ht.
  induction Ht; intros; eauto.
  - destruct c. inversion H0.
    simpl in *; apply ac_inr_inv_eq in H0; subst.
    destruct (eqb x y); auto.
  - simpl in *.
    destruct c.
    inversion H0; subst.
    apply ACFunL; auto.
    assert (Ha : and_coercion e (Fun t1 t2) (inr s)) by assumption.
    apply ac_inr_inv_eq in Ha; subst.
    inversion H0; subst; auto.
  - simpl in *; destruct c.
    inversion H0; subst.
    apply ACAndL; auto.
    assert (Ha : and_coercion e (And t1 t2) (inr s)) by assumption.
    apply ac_inr_inv_eq in Ha; subst.
    inversion H0; subst; eauto.
  - simpl in *.
    destruct c.
    inversion H2; subst.
    eapply ACForAllL with (L := union L0 (union L (singleton y))); intros z H3.
    rewrite subst_typ_source_open_source_var.
    apply H0.
    not_in_L z.
    assumption.
    apply H4.
    not_in_L z.
    not_in_L z.
    auto.
    assert (Ha : and_coercion e (ForAll d t0) (inr s)) by assumption.
    apply ac_inr_inv_eq in H2; subst.
    inversion Ha; subst.
    eapply ACForAllR with (L := union L0 (union L (singleton y))); intros z H4.
    rewrite subst_typ_source_open_source_var.
    apply H0.
    not_in_L z.
    assumption.
    apply H3.
    not_in_L z.
    not_in_L z.
    auto.
  - inversion H0; subst; simpl; auto.
Qed.

Lemma ac_rename :
  forall L t e c, forall y, PType (open_typ_source t (PFVarT y)) ->
    ~ In y (union L (fv_ptyp t)) -> and_coercion e (open_typ_source t (PFVarT y)) c ->
    (forall x : elt, ~ In x L -> and_coercion e (open_typ_source t (PFVarT x)) c).
Proof.
  intros.
  destruct (VarTyp.eq_dec x y).
  subst; auto.
  rewrite subst_typ_source_intro with (x := y); auto.
  apply ac_subst; auto.
  not_in_L y.
Qed.

Lemma ac_ex : forall L e t,
  (forall x, ~ In x L -> PType (open_typ_source t (PFVarT x))) ->
  (forall x, ~ In x L -> exists c, and_coercion e (open_typ_source t (PFVarT x)) c) ->
  exists c, forall x, ~ In x L -> and_coercion e (open_typ_source t (PFVarT x)) c.
Proof.
  intros L e t H0 H.
  pick_fresh x.
  assert (Ha : ~ In x L) by not_in_L x.
  apply H in Ha.
  destruct Ha as [c HAC].
  exists c.
  intros.
  apply ac_rename with (y := x) (L := L); auto.
  apply H0.
  not_in_L x.
  not_in_L x.
Qed.

Lemma ac_ptype : forall t e, PType t -> exists x, and_coercion e t x.
Proof.
  intros t e Ht.
  induction Ht; eauto.
  - destruct IHHt1, IHHt2.
    destruct x, x0; eauto; apply ac_inr_inv in H0; eauto.
  - destruct IHHt1, IHHt2.
    destruct x, x0; eauto.
  - apply (ac_ex _ _ _ H) in H0.
    destruct IHHt.
    destruct H0.
    destruct x0.
    eexists.
    eapply ACForAllL with (L := L).
    intros.
    apply H0.
    auto.
    eexists.
    eapply ACForAllR with (L := L).
    intros.
    apply H0 in H2.
    now apply ac_inr_inv in H2.
  - destruct IHHt; eauto.
Qed.

(* and_coercion lemmas *)

Lemma ac_inl_term : forall e t r, and_coercion e t (inl r) -> STTerm r.
Proof.
  intros.
  dependent induction H; auto.
  - apply_fresh STTerm_Lam as x.
    unfold open; rewrite <- open_rec_term; auto.
  - pick_fresh x.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha.
    apply body_typ_term_to_term_abs.
    unfold body_typ_term.
    exists (fv e1).
    intros; unfold open_typ_term; rewrite <- open_rec_typ_term_term; auto.
Qed.

Lemma ac_inr_term : forall e t r, STTerm e -> and_coercion e t (inr r) -> STTerm r.
Proof. intros; apply ac_inr_inv_eq in H0; now subst. Qed.

Lemma and_coercion_proj1_term :
  forall t0 (c : SExp var) c',
    PType t0 ->
    STTerm c ->
    and_coercion ((STApp _ c (STProj1 _ (STBVar _ 0)))) t0 c' ->
    STTerm (STLam _ (join_sum c')).
Proof.
  intros.
  apply_fresh STTerm_Lam as x; unfold open; simpl.
  destruct c'; simpl.
  apply ac_inl_term in H1.
  rewrite <- open_rec_term; auto.
  apply ac_inr_inv_eq in H1.
  rewrite <- H1.
  simpl.
  apply STTerm_App; auto.
  rewrite <- open_rec_term; auto.
Qed.

Lemma and_coercion_proj2_term :
  forall t0 (c : SExp var) c',
    PType t0 ->
    STTerm c ->
    and_coercion ((STApp _ c (STProj2 _ (STBVar _ 0)))) t0 c' ->
    STTerm (STLam _ (join_sum c')).
Proof.
  intros.
  apply_fresh STTerm_Lam as x; unfold open; simpl.
  destruct c'; simpl.
  apply ac_inl_term in H1.
  rewrite <- open_rec_term; auto.
  apply ac_inr_inv_eq in H1.
  rewrite <- H1.
  simpl.
  apply STTerm_App; auto.
  rewrite <- open_rec_term; auto.
Qed.

Lemma same_coercion :
  forall A, PType A ->
       forall e c1 c2, and_coercion e A c1 -> and_coercion e A c2 -> c1 = c2.
Proof.
  intros A HPT.
  induction HPT; intros.
  - now inversion H; inversion H0.
  - now inversion H; inversion H0.
  - inversion H; inversion H0; subst; eauto.
    + apply f_equal.
      now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
    + now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
    + now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
  - inversion H; inversion H0; subst; eauto.
    + apply f_equal.
      apply (IHHPT1 _ _ _ H3) in H8.
      apply (IHHPT2 _ _ _ H5) in H10.
      inversion H8; inversion H10; now subst.
    + apply (IHHPT1 _ _ _ H3) in H9; inversion H9.
    + apply (IHHPT2 _ _ _ H5) in H9; inversion H9.
    + apply (IHHPT1 _ _ _ H4) in H7; inversion H7.
    + apply (IHHPT2 _ _ _ H4) in H9; inversion H9.
  - inversion H1; inversion H2; subst; eauto.
    + pick_fresh x.
      assert (Ha : @inl _ (SExp var) e1 = inl e0).
      eapply H0 with (x := x).
      not_in_L x.
      apply H6; not_in_L x.
      apply H10; not_in_L x.
      inversion Ha; now subst.
    + pick_fresh x.
      assert (Ha : inl e1 = inr e).
      eapply H0 with (x := x).
      not_in_L x.
      apply H6; not_in_L x.
      apply H10; not_in_L x.
      inversion Ha.
    + pick_fresh x.
      assert (Ha : inl e1 = inr e).
      eapply H0 with (x := x).
      not_in_L x.
      apply H10; not_in_L x.
      apply H6; not_in_L x.
      inversion Ha.
  - inversion H; inversion H0; subst; auto;
    apply (IHHTL _ _ _ H4) in H8; now inversion H8.
  - inversion H; inversion H0; subst; eauto.
  - inversion H; inversion H0; subst; eauto.
Qed.

Fixpoint and_coercion' (t : PTyp) (e : SExp var) {struct t} : sum (SExp var) (SExp var).
refine(
  match t with
    | PInt => inr e
    | Fun _ B => match (and_coercion' B e) with
                  | inl l => inl (STLam _ l)
                  | inr r => inr r
                 end
    | And A B => match (and_coercion' A e, and_coercion' B e) with
                  | (inl l1, inl l2) =>
                    inl (STPair _ l1 l2)
                  | _ => inr e
                end
    | PBVarT _  => inr e
    | PFVarT _ => inr e
    | ForAll d A => match and_coercion' A e with
                     | inl l => inl (STTLam _ l)
                     | inr e => inr e
                   end
    | Top    => inl (STUnit _)
    | Bot    => inr e
    | Rec l t => and_coercion' t e
  end).
Defined.
(*
pick_fresh x.
destruct (and_coercion (open_typ_source A (PFVarT x)) e).
apply (inl (STTLam _ s)).
apply (inr s).
Admitted. *)

Inductive sub : PTyp -> PTyp -> (SExp var) -> Prop :=
  | SInt : sub PInt PInt (STLam _ (STBVar _ 0))
  | SFun : forall o1 o2 o3 o4 c1 c2,
             sub o3 o1 c1 ->
             sub o2 o4 c2 ->
             sub (Fun o1 o2) (Fun o3 o4) (STLam _ (STLam _ (STApp _ c2 (STApp _ (STBVar _ 1) (STApp _ c1 (STBVar _ 0))))))
  | SAnd1 : forall t t1 t2 c1 c2,
              sub t t1 c1 ->
              sub t t2 c2 ->
              sub t (And t1 t2) (STLam _ (STPair _ (STApp _ c1 (STBVar _ 0)) (STApp _ c2 (STBVar _ 0))))
  | SAnd2 : forall t t1 t2 c ac,
              sub t1 t c ->
              Atomic t ->
              PType t2 ->
              and_coercion ((STApp _ c (STProj1 _ (STBVar _ 0)))) t ac ->
              sub (And t1 t2) t (STLam _ (join_sum ac))
              (*
              sub (And t1 t2) t (STLam _ (join_sum (and_coercion' t ((STApp _ c (STProj1 _ (STBVar _ 0))))))) *)
  | SAnd3 : forall t t1 t2 c ac,
              sub t2 t c ->
              Atomic t ->
              PType t1 ->
              (* sub (And t1 t2) t (STLam _ (join_sum (and_coercion' t ((STApp _ c (STProj2 _ (STBVar _ 0))))))) *)
              and_coercion ((STApp _ c (STProj2 _ (STBVar _ 0)))) t ac ->
              sub (And t1 t2) t (STLam _ (join_sum ac))
  | SVar : forall v, sub (PFVarT v) (PFVarT v) (STLam _ (STBVar _ 0))
  | SForAll : forall L d1 d2 t1 t2 c c',
                (forall x, not (In x L) -> sub (open_typ_source t1 (PFVarT x))
                                         (open_typ_source t2 (PFVarT x))
                                         (open_typ_term c (STFVarT x))) ->
                sub d2 d1 c' ->
                sub (ForAll d1 t1) (ForAll d2 t2)
                    (STLam _ (STTLam _ (STApp _ c (STTApp _ (STBVar _ 0) (STBVarT 0)))))
  | STop : forall t, PType t -> sub t Top (STLam _ (STUnit _))
  | SBot : forall t, PType t -> sub Bot t (STLam _ (STUnit _))
  | SRec : forall l t1 t2 c, sub t1 t2 c -> sub (Rec l t1) (Rec l t2) c.

Hint Constructors Atomic sub usub.

Definition Sub (t1 t2 : PTyp) : Prop := exists (e:SExp var), sub t1 t2 e.

Lemma sub_lc : forall t1 t2, Sub t1 t2 -> PType t1 /\ PType t2.
Proof.
  intros t1 t2 HSub.
  destruct HSub.
  induction H; eauto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub; auto.
  - destruct IHsub; auto.
  - destruct IHsub; split.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
  - destruct IHsub; auto.
Qed.

Hint Resolve sub_lc.

(* Smart constructors for Sub *)

Definition stop : forall t, PType t -> Sub t Top.
unfold Sub; eauto.
Defined.

Definition sint : Sub PInt PInt.
unfold Sub. exists (STLam _ (STBVar _ 0)).
exact SInt.
Defined.

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros. destruct H. destruct H0.
exists (STLam _ (
       STLam _ (STApp _ x0 (STApp _ (STBVar _ 1) (STApp _ x (STBVar _ 0)))))).
apply SFun. auto. auto.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
unfold Sub. intros. destruct H. destruct H0.
exists (STLam _ (
       STPair _ (STApp _ x (STBVar _ 0)) (STApp _ x0 (STBVar _ 0)))).
apply SAnd1. auto. auto.
Defined.

Definition sand2_atomic :
  forall t t1 t2, Sub t1 t -> Atomic t -> PType t2 -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0.
  destruct H; destruct t; try (now inversion H1); eauto.
  - assert (Ha : Sub t1 (Fun t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t1 (ForAll t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t1 (Rec v t0)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> PType t2 -> Sub (And t1 t2) t.
  intro t.
  induction t; intros.
  (* Case PInt *)
  - apply sand2_atomic; auto.
  (* Case Fun *)
  - apply sand2_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1; auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
    inversion H1; subst.
    assert (Ha1 : Sub (And Bot t3) t1) by (apply IHt1; unfold Sub; eauto).
    assert (Ha2 : Sub (And Bot t3) t2) by (apply IHt2; unfold Sub; eauto).
    destruct Ha1, Ha2; eauto.
  (* Case BVar *)
  - inversion H. inversion H1; inversion H3. inversion H2.
  (* Case FVar *)
  - apply sand2_atomic; auto.
  (* Case ForAll *)
  - apply sand2_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
  (* Case Bot *)
  - apply sand2_atomic; auto.
  (* Case Rec *)
  - apply sand2_atomic; auto.
Defined.

Definition sand3_atomic :
  forall t t1 t2, Sub t2 t -> Atomic t -> PType t1 -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0.
  destruct t; try (now inversion H1); destruct H; eauto.
  - assert (Ha : Sub t2 (Fun t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t2 (ForAll t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t2 (Rec v t0)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> PType t1 -> Sub (And t1 t2) t.
  intros t; induction t; intros.
  (* Case PInt *)
  - apply sand3_atomic; auto.
  (* Case Fun *)
  - apply sand3_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1. auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
    inversion H1; subst.
    assert (Ha1 : Sub (And t0 Bot) t1) by (apply IHt1; unfold Sub; eauto).
    assert (Ha2 : Sub (And t0 Bot) t2) by (apply IHt2; unfold Sub; eauto).
    destruct Ha1, Ha2; eauto.
  (* Case BVar *)
  - inversion H; inversion H1; inversion H3. inversion H2.
  (* Case FVar *)
  - apply sand3_atomic; auto.
  (* Case ForAll *)
  - apply sand3_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
  (* Case Bot *)
  - apply sand3_atomic; auto.
  (* Case Rec *)
  - apply sand3_atomic; auto.
Qed.

Definition svar : forall v, Sub (PFVarT v) (PFVarT v).
  intros.
  unfold Sub.
  exists (STLam _ (STBVar _ 0)).
  apply SVar.
Defined.

(*
Definition sforall : forall L t1 t2 c,
                (forall x, not (In x L) -> sub (open_ptyp t1 (PFVar x))
                                         (open_ptyp t2 (PFVar x))
                                         (open_typ_term c (STFVarT x))) ->
                Sub (ForAll t1) (ForAll t2).
  intros.
  unfold Sub.
  eexists.
  eapply SForAll.
  intros.

  pick_fresh.
 *)

Definition srec : forall l t1 t2, Sub t1 t2 -> Sub (Rec l t1) (Rec l t2).
  intros l t1 t2 HSub; unfold Sub in *; destruct HSub; eauto.
Qed.

Hint Constructors sub.
Hint Resolve stop sint sfun sand1 sand2 sand3 svar srec.

Lemma coercions_produce_terms :
  forall E A B, sub A B E -> STTerm E.
Proof.
  intros.
  induction H.
  (* Case SInt *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SFun *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_Lam as y; cbn.
    apply STTerm_App.
    repeat rewrite <- open_rec_term; assumption.
    apply STTerm_App.
    apply STTerm_Var.
    apply STTerm_App; [ repeat rewrite <- open_rec_term; auto | apply STTerm_Var ].
  (* Case SAnd1 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_Pair.
    apply STTerm_App; repeat rewrite <- open_rec_term; auto.
    rewrite <- open_rec_term; auto.
  (* Case SAnd2 *)
  - apply and_coercion_proj1_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t1 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SAnd3 *)
  - apply and_coercion_proj2_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t2 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SVar *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SForAll *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_TLam as y; cbn.
    apply STTerm_App; auto.
    assert (Ha : not (In y L)) by (not_in_L y).
    apply H0 in Ha.
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term; auto.
  (* Case STop *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SBot *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SRec *)
  - auto.
Qed.

Lemma sub_inv :
  forall t1 t2 e x n,
    sub (open_rec_typ_source n (PFVarT x) t1) (open_rec_typ_source n (PFVarT x) t2) e ->
    exists e', e = open_rec_typ_term n (STFVarT x) e'.
Proof.
  intros t1 t2 e x n H.
  unfold open.
  inversion H; intros.
  - exists (STLam var (STBVar var 0)); now simpl.
  - exists (STLam var
       (STLam var
          (STApp var c2
                 (STApp var (STBVar var 1) (STApp var c1 (STBVar var 0)))))).
    unfold open_typ_term; simpl.
    apply coercions_produce_terms in H2; apply coercions_produce_terms in H3.
    repeat rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var
       (STPair var (STApp var c1 (STBVar var 0))
               (STApp var c2 (STBVar var 0)))).
    simpl.
    unfold open_typ_term; simpl.
    apply coercions_produce_terms in H1; apply coercions_produce_terms in H3.
    repeat rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (join_sum ac)).
    unfold open_typ_term; simpl.
    destruct ac; simpl.
    apply ac_inl_term in H4.
    rewrite <- open_rec_typ_term_term; auto.
    apply ac_inr_inv_eq in H4.
    subst; simpl.
    apply coercions_produce_terms in H1.
    rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (join_sum ac)).
    unfold open_typ_term; simpl.
    destruct ac; simpl.
    apply ac_inl_term in H4.
    rewrite <- open_rec_typ_term_term; auto.
    apply ac_inr_inv_eq in H4.
    subst; simpl.
    apply coercions_produce_terms in H1.
    rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (STBVar var 0)); now simpl.
  - exists (STLam var
             (STTLam var (STApp var c (STTApp var (STBVar var 0) (STBVarT 0))))).
    rewrite <- open_rec_typ_term_term.
    auto.
    rewrite <- H4 in H.
    apply coercions_produce_terms in H.
    apply H.
 - exists (STLam var (STUnit var)); now simpl.
 - exists (STLam var (STUnit var)); now simpl.
 - exists e.
   subst.
   apply coercions_produce_terms in H2.
   rewrite <- open_rec_typ_term_term; auto.
Qed.

(** Interlude: substitution of types in term **)

Fixpoint subst_typ_term (z : var) (u : STyp) (t : SExp var) {struct t} : SExp var :=
  match t with
  | STBVar _ i     => STBVar _ i
  | STFVar _ x     => STFVar _ x
  | STUnit _       => STUnit _
  | STLit _ n      => STLit _ n
  | STLam _ t      => STLam _ (subst_typ_term z u t)
  | STApp _ t1 t2  => STApp _ (subst_typ_term z u t1) (subst_typ_term z u t2)
  | STPair _ t1 t2 => STPair _ (subst_typ_term z u t1) (subst_typ_term z u t2)
  | STProj1 _ t    => STProj1 _ (subst_typ_term z u t)
  | STProj2 _ t    => STProj2 _ (subst_typ_term z u t)
  | STTLam _ t     => STTLam _ (subst_typ_term z u t)
  | STTApp _ t ty  => STTApp _ (subst_typ_term z u t) (subst_typ z u ty)
  end.

Lemma subst_typ_term_fresh :
  forall x t u, not (In x (fv t)) ->  subst_typ_term x u t = t.
Proof.
  intros; induction t0; simpl in *; auto.
  - rewrite IHt0; auto.
  - rewrite IHt0_1; [ rewrite IHt0_2 | not_in_L x ]; [ reflexivity | not_in_L x ].
  - rewrite IHt0_1; [ rewrite IHt0_2 | not_in_L x ]; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ | not_in_L x ].
    rewrite subst_typ_fresh; auto; not_in_L x.
Qed.

Lemma subst_typ_open' : forall x u t1 t2, STType u -> forall n,
  subst_typ x u (open_rec_typ n t1 t2) = open_rec_typ n (subst_typ x u t1) (subst_typ x u t2).
Proof.
  intros x u t1 t2.
  induction t2; intros; simpl; auto; try (apply f_equal; auto).
  - rewrite IHt2_1; auto; rewrite IHt2_2; auto.
  - rewrite IHt2_1; auto; rewrite IHt2_2; auto.
  - case_eq (eqb v x); intros; [ rewrite <- open_rec_type | ]; auto.
  - case_eq (Nat.eqb n0 n); intros; auto.
Qed.

Lemma subst_typ_term_open : forall x u t1 t2, STType u ->
  subst_typ_term x u (open_typ_term t1 t2) = open_typ_term (subst_typ_term x u t1) (subst_typ x u t2).
Proof.
  intros. unfold open_typ_term. generalize 0.
  induction t1; intros; simpl; auto; try (apply f_equal; auto).
  - rewrite IHt1_1; rewrite IHt1_2; auto.
  - rewrite IHt1_1; rewrite IHt1_2; auto.
  - rewrite IHt1.
    rewrite <- subst_typ_open'; auto.
Qed.

Lemma subst_typ_open_var :
  forall x y u t,
    y <> x -> STType u ->
    open_typ_term (subst_typ_term x u t) (STFVarT y) =
    subst_typ_term x u (open_typ_term t (STFVarT y)).
Proof.
  intros Neq Wu. intros. rewrite subst_typ_term_open; auto. simpl.
  case_eq (VarTyp.eqb Wu Neq); intros; auto.
  exfalso; apply H.
  now apply eqb_eq in H1.
Qed.

Lemma subst_typ_term_intro : forall x t u,
  not (In x (fv t)) -> STType u ->
  open_typ_term t u = subst_typ_term x u (open_typ_term t (STFVarT x)).
Proof.
  intros Fr Wu.
  intros.
  rewrite subst_typ_term_open.
  rewrite subst_typ_term_fresh.
  simpl.
  case_eq (eqb Fr Fr); intros; auto.
  apply EqFacts.eqb_neq in H1; exfalso; apply H1; reflexivity.
  auto. auto.
Qed.

Lemma sub_rename :
  forall L t1 t2 c, forall y,
    PType (open_typ_source t1 (PFVarT y)) ->
    PType (open_typ_source t2 (PFVarT y)) ->
    ~ In y (union L (union (fv c) (union (fv_ptyp t1) (fv_ptyp t2)))) ->
    sub (open_typ_source t1 (PFVarT y))
        (open_typ_source t2 (PFVarT y))
        (open_typ_term c (STFVarT y)) ->
    (forall x : elt, ~ In x L -> sub (open_typ_source t1 (PFVarT x))
                               (open_typ_source t2 (PFVarT x))
                               (open_typ_term c (STFVarT x))).
Proof.
  intros.
  destruct (VarTyp.eq_dec x y).
  subst; auto.
  rewrite subst_typ_source_intro with (x := y); auto.
  rewrite subst_typ_source_intro with (x := y) (t := t2); auto.
  rewrite subst_typ_term_intro with (x := y).
  admit. (* TODO we need something like our usub_subst and substitution of types on terms *)
  not_in_L y.
  auto.
  not_in_L y.
  not_in_L y.
Admitted.

Lemma sub_ex : forall L t1 t2,
  (forall x, ~ In x L -> PType (open_typ_source t1 (PFVarT x))) ->
  (forall x, ~ In x L -> PType (open_typ_source t2 (PFVarT x))) ->
  (forall x, ~ In x L -> exists c, sub (open_typ_source t1 (PFVarT x))
                            (open_typ_source t2 (PFVarT x))
                            (open_typ_term c (STFVarT x))) ->
  exists c, forall x, ~ In x L -> sub (open_typ_source t1 (PFVarT x))
                           (open_typ_source t2 (PFVarT x))
                           (open_typ_term c (STFVarT x)).
Proof.
  intros L t1 t2 H1 H2 H.
  pick_fresh x.
  assert (Ha : ~ In x L) by not_in_L x.
  apply H in Ha.
  destruct Ha as [c HAC].
  exists c.
  intros.
  apply sub_rename with (y := x) (L := L); auto.
  apply H1; not_in_L x.
  apply H2; not_in_L x.
  admit.
Admitted.

Lemma sound_sub : forall t1 t2, usub t1 t2 -> Sub t1 t2.
  intros; induction H; auto.
  - destruct IHusub as [c Hsub].
    unfold Sub in *.
    assert (Ha : forall x : elt,
       ~ In x L ->
       exists e : SExp var,
         sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))
             (open_typ_term e (STFVarT x))).
    intros.
    apply H0 in H2.
    destruct H2.
    assert (H3 : sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x)) x0) by assumption.
    apply sub_inv in H2.
    destruct H2; subst.
    eauto.
    clear H0.
    apply sub_ex in Ha.
    destruct Ha.
    eexists.
    apply_fresh SForAll as x; auto.
    apply H0.
    not_in_L y.
    eauto.
    intros.
    apply Ha in H0; destruct H0.
    assert (HSub : Sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))).
    unfold Sub; eauto.
    apply sub_lc in HSub; now destruct HSub.
    intros.
    apply Ha in H0; destruct H0.
    assert (HSub : Sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))).
    unfold Sub; eauto.
    apply sub_lc in HSub; now destruct HSub.
  - unfold Sub; eauto.
Qed.

Lemma complete_sub : forall t1 t2, Sub t1 t2 -> usub t1 t2.
Proof.
  intros; destruct H; induction H; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
    auto.
Qed.

(* Properties about sub *)

Lemma usub_refl : forall t, PType t -> usub t t.
Proof.
  intros t HWFt; induction HWFt; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
    auto.
Qed.

Lemma usub_and_l : forall t1 t2 t3, usub t1 (And t2 t3) -> usub t1 t2.
Proof.
  intros t1 t2 t3 Husub.
  apply complete_sub.
  apply sound_sub in Husub as [c Hsub].
  inversion Hsub; subst.
  exists c1; auto. inversion H0. inversion H0.
  inversion H; unfold Sub; eauto.
Qed.

Lemma usub_and_r : forall t1 t2 t3, usub t1 (And t2 t3) -> usub t1 t3.
Proof.
  intros t1 t2 t3 Husub.
  apply complete_sub.
  apply sound_sub in Husub as [c Hsub].
  inversion Hsub; subst.
  exists c2; auto. inversion H0. inversion H0.
  inversion H; unfold Sub; eauto.
Qed.

Lemma usub_lc : forall t1 t2, usub t1 t2 -> PType t1 /\ PType t2.
Proof.
  intros.
  apply sound_sub in H.
  now apply sub_lc in H.
Qed.

Lemma usub_trans_mid :
  forall A B C D, usub A B -> usub B C -> usub C D -> usub A D.
Proof.
  intros A B C D HusubAB HusubBC HusubCD.
  generalize dependent A.
  generalize dependent D.
  induction HusubBC; intros; auto.
  - dependent induction HusubAB; subst; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
  - dependent induction HusubAB; subst; auto.
    dependent induction HusubCD; subst; auto.
    apply USAnd1.
    apply IHHusubCD1; auto.
    intros; auto.
    subst.
    apply usub_and_l with (t3 := t2); eauto.
    intros; auto.
    subst.
    apply usub_and_l with (t3 := t2); eauto.
    apply IHHusubCD2; auto.
    intros; auto.
    subst.
    apply usub_and_r with (t2 := t1); eauto.
    intros; auto.
    subst.
    apply usub_and_r with (t2 := t1); eauto.
    apply usub_lc in HusubAB1; apply usub_lc in HusubAB2.
    apply USTop; destruct HusubAB1; destruct HusubAB2; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubAB; subst; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
  - dependent induction HusubAB; subst; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubCD; subst; auto.
    dependent induction HusubAB; subst; auto.
    apply_fresh USForAll as x.
    apply H0 with (x := x).
    not_in_L x.
    apply H1.
    not_in_L x.
    apply H3.
    not_in_L x.
    auto.
    apply USBot; auto.
    apply_fresh PType_ForAll as x.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
    assert (Ha : ~ In x L0) by not_in_L x.
    apply H1 in Ha.
    apply usub_lc in Ha; destruct Ha; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubAB; subst; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; destruct HusubAB; auto.
    dependent induction HusubAB; subst; auto.
    apply usub_lc in HusubCD; destruct HusubCD; auto.
Qed.

Lemma usub_trans :
  forall B A C, PType C -> usub A B -> usub B C -> usub A C.
Proof.
  intros B A C HWFC HusubAB HusubBC.
  assert (HusubCC : usub C C).
  eapply usub_refl; apply HWFC.
  eapply usub_trans_mid.
  apply HusubAB.
  apply HusubBC.
  apply HusubCC.
Qed.

Lemma usub_subst :
  forall A B z u,
    usub A B ->
    PType u ->
    usub (subst_typ_source z u A) (subst_typ_source z u B).
Proof.
  intros A B z u HSub HWFu.
  induction HSub; intros; simpl; eauto.
  - apply USAnd2; auto; now apply subst_source_lc.
  - apply USAnd3; auto; now apply subst_source_lc.
  - destruct eqb; auto.
    eapply usub_refl; apply HWFu.
  - apply_fresh USForAll as x.
    repeat rewrite subst_typ_source_open_source_var; auto.
    apply H0; auto.
    not_in_L x.
    not_in_L x.
    not_in_L x.
    auto.
  - apply USTop.
    apply subst_source_lc; auto.
  - apply USBot.
    apply subst_source_lc; auto.
Qed.

Lemma usub_subst_not_in :
  forall A B u z,
    not (In z (fv_ptyp B)) ->
    usub A B ->
    PType u ->
    usub (subst_typ_source z u A) B.
Proof.
  intros A ty u z HNotIn HSub HWFu.
  erewrite <- subst_typ_source_fresh with (t := ty).
  eapply usub_subst; eauto.
  auto.
Qed.

End MSubtyping.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.

Require Import Category.Instance.Cat.
Require Import Category.Instance.Fun.
Require Import Category.Theory.Natural.Transformation.

Require Import Enriched.Category.
Require Import Enriched.TwoCategory.

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

Section Cat.

Program Definition eid_2cat C : (1 ⟶ [C, C])%functor_type := {|
  fobj := fun _ => Id;
  fmap := fun _ _ _ => nat_id;
|}.

Definition horizontal_composition {C D E : Category} {F G : C ⟶ D} {H K : D ⟶ E} (f : F ⟹ G) (g : H ⟹ K) : H ○ F ⟹ K ○ G := nat_compose (inside f K) (outside g F).

Lemma horizontal_composition_respects {C D E : Category} {F G : C ⟶ D} {H K : D ⟶ E} : Proper (equiv (A := F ⟹ G) ==> equiv (A := H ⟹ K) ==> equiv) horizontal_composition.
Proof.
  proper.
  unfold horizontal_composition.
  specialize (X A).
  specialize (X0 (F A)).
  rewrite X, X0.
  reflexivity.
Qed.

Definition fobj_2cat {C D E : Category} : ([D, E]) ∏ ([C, D]) -> ([C, E]) := fun FG : ([D, E]) ∏ ([C, D]) => let (F, G) := FG in F ○ G.

Definition fmap_2cat {C D E : Category} (x y : ([D, E]) ∏ ([C, D])) (fg : x ~{ ([D, E]) ∏ ([C, D]) }~> y) : fobj_2cat x ~{ [C, E] }~> fobj_2cat y.
Proof.
  destruct x as [x0 x1], y as [y0 y1].
  simpl in fg.
  destruct fg as [f g].
  simpl.
  exact (horizontal_composition g f).
Defined.

Lemma fmap_comp_2cat {C D E : Category} : ∀ (x y z : ([D, E]) ∏ ([C, D])) (f : y ~{ ([D, E]) ∏ ([C, D]) }~> z)
 (g : x ~{ ([D, E]) ∏ ([C, D]) }~> y),
 fmap_2cat x z (f ∘ g)%morphism ≈ (fmap_2cat y z f ∘ fmap_2cat x y g)%morphism.
Proof.
  intros.
  destruct x as [x0 x1], y as [y0 y1], z as [z0 z1].
  destruct f as [f0 f1], g as [g0 g1].
  simpl in f0, f1, g0, g1.
  simpl.
  intro.
  normal.
  repeat rewrite naturality.
  rewrite fmap_comp.
  normal.
  reflexivity.
Qed.

Program Definition ecompose_2cat C D E : (([D, E]) ∏ ([C, D])) ⟶ ([C, E]) := {|
  fobj := fobj_2cat;
  fmap := fmap_2cat;
  fmap_respects := _;
  fmap_id := _;
  fmap_comp := fmap_comp_2cat
|}.
Next Obligation.
  proper.
  simpl in X, H.
  unfold fmap_2cat.
  apply (horizontal_composition_respects _ _ H _ _ X A).
Qed.

Obligation Tactic := idtac.
Program Definition TwoCat : TwoCategory :={|
  eobj     := Category;
  ehom     := fun C D => ([C, D] : obj[Cat]);
  eid      := (eid_2cat : ∀ x : Category, (@I _ Cat_Monoidal) ~{ Cat }~> ([x, x]));
  ecompose := ecompose_2cat;
|}.
Next Obligation.
  intros C D.
  simpl.
  unshelve eexists _.
  intros.
  destruct x as [x' F].
  unfold snd.
  clear x'.
  isomorphism.
  transform.
  simpl.
  apply nat_id.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  transform.
  simpl;apply nat_id.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;rewrite <- fmap_comp;normal;reflexivity.
  simpl;rewrite <- fmap_comp;normal;reflexivity.
  compute.
  intros.
  destruct x as [x' x], y as [y' y], f as [f' f].
  clear x' y' f'.
  repeat rewrite fmap_id.
  rewrite id_left.
  reflexivity.
Qed.
Next Obligation.
  intros C D.
  simpl.
  unshelve eexists _.
  intros.
  destruct x as [F x'].
  unfold fst.
  isomorphism.
  transform.
  simpl.
  apply nat_id.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  transform.
  simpl;apply nat_id.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;do 2 rewrite <- fmap_comp;normal;reflexivity.
  simpl;rewrite <- fmap_comp;normal;reflexivity.
  simpl;rewrite <- fmap_comp;normal;reflexivity.
  intros [x x'] [y y'] [f f'] A.
  compute.
  simpl in f.
  clear x' y' f'.
  repeat rewrite fmap_id.
  rewrite id_left, id_right.
  reflexivity.
Qed.
Next Obligation.
  intros A B C D.
  simpl.
  unshelve eexists _.
  intros [[x0 x1] x2].
  simpl.
  isomorphism.
  transform.
  intros;simpl;apply nat_id.
  simpl;normal;reflexivity.
  simpl;normal;reflexivity.
  transform.
  intros;simpl;apply nat_id.
  simpl;normal;reflexivity.
  simpl;normal;reflexivity.
  simpl;repeat rewrite fmap_id;normal;reflexivity.
  simpl;repeat rewrite fmap_id;normal;reflexivity.
  intros [[x0 x1] x2] [[y0 y1] y2].
  simpl.
  intros [[f0 f1] f2] A0.
  simpl.
  normal.
  rewrite fmap_id.
  normal.
  reflexivity.
Qed.
End Cat.


Require Import floyd.proofauto.
Require Import progs.revarray.
Require Import floyd.sublist.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition reverse_spec :=
 DECLARE _reverse
  WITH a0: val, sh : share, contents : list int, size: Z
  PRE [ _a OF (tptr tint), _n OF tint ]
          PROP (0 <= size <= Int.max_signed; writable_share sh)
          LOCAL (temp _a a0; temp _n (Vint (Int.repr size)))
          SEP (data_at sh (tarray tint size) (map Vint contents) a0)
  POST [ tvoid ]
     PROP() LOCAL()
     SEP(data_at sh (tarray tint size) (map Vint (rev contents)) a0).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=   ltac:(with_library prog [reverse_spec; main_spec]).

Definition flip_ends {A} lo hi (contents: list A) :=
  sublist 0 lo (rev contents)
  ++ sublist lo hi contents
  ++ sublist hi (Zlength contents) (rev contents).

Definition reverse_Inv a0 sh contents size :=
 (EX j:Z,
  (PROP  (0 <= j; j <= size-j)
   LOCAL  (temp _a a0; temp _lo (Vint (Int.repr j)); temp _hi (Vint (Int.repr (size-j))))
   SEP (data_at sh (tarray tint size) (flip_ends j (size-j) contents) a0)))%assert.

Lemma Zlength_flip_ends:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_ends i j al) = Zlength al.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. omega.
Qed.
Hint Rewrite @Zlength_flip_ends using (autorewrite with sublist; omega) : sublist.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_ends j (size - j) contents = rev contents.
Proof.
  intros.
  unfold flip_ends.
  rewrite <- (Zlen_le_1_rev (sublist j (size-j) contents))
      by (autorewrite with sublist; omega).
  rewrite !sublist_rev by (autorewrite with sublist; omega).
 rewrite <- !rev_app_distr, ?H.
 autorewrite with sublist; auto.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
sublist 0 j (flip_ends j (size - j) al) ++
sublist (size - j - 1) (size - j) al ++
sublist (j + 1) size
  (sublist 0 (size - j - 1) (flip_ends j (size - j) al) ++
   sublist j (j + 1) (flip_ends j (size - j) al) ++
   sublist (size - j) size (flip_ends j (size - j) al)) =
flip_ends (j + 1) (size - (j + 1)) al.
Proof.
intros.
unfold flip_ends.
rewrite <- H.
autorewrite with sublist.
rewrite (sublist_split 0 j (j+1)) by (autorewrite with sublist; omega).
rewrite !app_ass.
f_equal. f_equal.
rewrite !sublist_rev, <- ?H by omega.
rewrite Zlen_le_1_rev by (autorewrite with sublist; omega).
f_equal; omega.
rewrite (sublist_app2 (size-j) size)
 by (autorewrite with sublist; omega).
autorewrite with sublist.
rewrite sublist_app'
 by (autorewrite with sublist; omega).
autorewrite with sublist.
f_equal.
f_equal; omega.
autorewrite with sublist.
  rewrite <- (Zlen_le_1_rev (sublist j (1+j) al))
      by (autorewrite with sublist; omega).
rewrite !sublist_rev, <- ?H by omega.
 rewrite <- !rev_app_distr, <- ?H.
 autorewrite with sublist.
 f_equal; f_equal; omega.
Qed.

Lemma flip_ends_map:
  forall A B (F: A -> B) lo hi (al: list A),
  flip_ends lo hi (map F al) = map F (flip_ends lo hi al).
Proof.
intros.
unfold flip_ends.
rewrite !map_app.
rewrite !map_sublist, !map_rev, Zlength_map.
auto.
Qed.

Lemma flip_fact_2:
  forall {A} (al: list A) size j d,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al d =
  Znth (size - j - 1) (flip_ends j (size - j) al) d.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. auto.
Qed.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* lo = 0; *)
forward. (* hi = n; *)

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
Exists 0.
entailer!.
+ f_equal; f_equal; omega.
+ unfold flip_ends; autorewrite with sublist; auto.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
forward. (* t = a[lo]; *)
{
  entailer!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map with (d':=Int.zero)
   by (autorewrite with sublist; omega).
  apply I.
}
forward.  (* s = a[hi-1]; *)
{
  entailer!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map with (d':=Int.zero)
   by (autorewrite with sublist; omega).
  apply I.
}
rewrite <- flip_fact_2 by (rewrite ?Zlength_flip_ends; omega).
forward. (*  a[hi-1] = t; *)
forward. (* a[lo] = s; *)
forward. (* lo++; *)
forward. (* hi--; *)

(* Prove postcondition of loop body implies loop invariant *)
 Exists (Zsucc j).
 entailer!.
 f_equal; f_equal; omega.
 apply derives_refl'.
 unfold data_at.    f_equal.
 clear - H0 HRE H1.
 forget (map Vint contents) as al.
 remember (Zlength al) as size.
 repeat match goal with |- context [reptype ?t] => change (reptype t) with val end.
 unfold upd_Znth.
 rewrite !Znth_cons_sublist by (repeat rewrite Zlength_flip_ends; try omega).
 rewrite ?Zlength_app, ?Zlength_firstn, ?Z.max_r by omega.
 rewrite ?Zlength_flip_ends by omega.
 rewrite ?Zlength_sublist by (rewrite ?Zlength_flip_ends ; omega).
 unfold Z.succ. rewrite <- Heqsize. autorewrite with sublist.
 replace (size - j - 1 + (1 + j)) with size by (clear; omega).
 apply flip_fact_3; auto.

* (* after the loop *)
forward. (* return; *)
rewrite map_rev. rewrite flip_fact_1 by omega.
auto.
Qed.

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.

forward_call  (*  revarray(four,4); *)
  (four, Ews, four_contents, 4).
   split; [computable | auto].
forward_call  (*  revarray(four,4); *)
    (four,Ews, rev four_contents,4).
   split; [computable | auto].
rewrite rev_involutive.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.


Inductive person : Type := barack | michelle | malia.

Inductive W : person -> Type :=
  | w_michelle : W barack
  | w_malia : W michelle.

Check W.
(* W : person -> Prop *)

Check W barack.
(* W barack : Prop *)

Check w_michelle.
(* w_michelle : W barack *)

Search W _.
(* w_malia: W michelle
w_michelle: W barack *)


Require Import List Arith Lia.
Require Import TPPMark2019.Util.

Set Implicit Arguments.

Lemma nth_error_eq {A} : forall (xs ys : list A), (forall i, nth_error xs i = nth_error ys i) <-> xs = ys.
Proof.
  intros.
  split; intros; subst; auto.
  revert ys H.
  induction xs.
  - destruct ys; auto.
    intro H.
    specialize (H 0).
    inversion H.
  - destruct ys.
    + intro H.
      specialize (H 0).
      inversion H.
    + intro H.
      f_equal.
      * specialize (H 0).
        now inversion H.
      * apply IHxs.
        intro i.
        specialize (H (S i)).
        apply H.
Qed.

Module Tape.
  Class ops (A : Type) (V : Type) :=
    {
      read : A -> V;
      write : V -> A -> A;
      move_right : A -> A;
      move_left : A -> A;
    }.

  Class spec (A : Type) (V : Type) `{c : ops A V} :=
    {
      size: A -> nat;
      head : A -> nat;
      to_list : A -> list V;
      to_list_size : forall t, size t = length (to_list t);
      head_spec : forall t, size t <> 0 -> head t < size t;
      read_spec : forall t, size t <> 0 -> List.nth_error (to_list t) (head t) = Some (read t);
      write_spec_head : forall v t, size t <> 0 -> List.nth_error (to_list (write v t)) (head t) = Some v;
      write_spec_other : forall i v t,
          size t <> 0 ->
          i <> head t ->
          List.nth_error (to_list (write v t)) i = List.nth_error (to_list t) i;
      write_head : forall v t, head (write v t) = head t;
      move_right_list : forall t, to_list (move_right t) = to_list t;
      move_right_head : forall t, size t <> 0 ->
                             head (move_right t) =
                             if S (head t) =? size t
                             then 0
                             else S (head t);
      move_left_list : forall t, to_list (move_left t) = to_list t;
      move_left_head : forall t, size t <> 0 -> head (move_left t) =
                            match head t with
                            | 0 => size t - 1
                            | S h => h
                            end
    }.

  Lemma nth_error_Some : forall A V `{ops A V} `{spec A V} (tape : A) i v,
      nth_error (Tape.to_list tape) i = Some v -> i < Tape.size tape.
  Proof.
    intros until v.
    intro.
    rewrite to_list_size.
    rewrite <- List.nth_error_Some.
    congruence.
  Qed.

  Lemma write_spec : forall A V `{ops A V} `{spec A V} (tape : A) v i,
      size tape <> 0 ->
      List.nth_error (to_list (write v tape)) i =
      if i =? head tape
      then (Some v)
      else List.nth_error (to_list tape) i.
  Proof.
    intros.
    destruct (Nat.eqb_spec i (head tape)); subst.
    - apply write_spec_head; auto.
    - apply write_spec_other; auto.
  Qed.

  Lemma write_size : forall A V `{ops A V} `{spec A V} (tape : A) (v : V),
      size tape <> 0 ->
      size (write v tape) = size tape.
  Proof.
    intros until v.
    intro Hnz.
    enough (forall i, Nat.ltb i (size (write v tape)) = Nat.ltb i (size tape)) as Hltbeq.
    - revert Hltbeq.
      generalize (size (write v tape)) as n.
      generalize (size tape) as m.
      intros.
      apply Nat.le_antisymm.
      + specialize (Hltbeq m).
        rewrite Nat.ltb_irrefl in Hltbeq.
        now rewrite Nat.ltb_ge in Hltbeq.
      + specialize (Hltbeq n).
        rewrite Nat.ltb_irrefl in Hltbeq.
        symmetry in Hltbeq.
        now rewrite Nat.ltb_ge in Hltbeq.
    - intro i.
      destruct (List.nth_error (to_list (write v tape)) i) eqn: Heq.
      + replace (i <? size (write v tape)) with true; symmetry; rewrite Nat.ltb_lt.
        * destruct (Nat.eq_dec i (head tape)); subst; auto using head_spec.
          rewrite to_list_size, <- List.nth_error_Some.
          rewrite write_spec_other in Heq; congruence.
        * rewrite to_list_size, <- List.nth_error_Some.
          congruence.
      + replace (i <? size (write v tape)) with false; symmetry;
          rewrite Nat.ltb_ge, to_list_size, <- nth_error_None; auto.
        destruct (Nat.eq_dec i (head tape)).
        * subst. rewrite write_spec_head in Heq; congruence.
        * rewrite write_spec_other in Heq; congruence.
  Qed.

  Lemma move_left_size : forall A V `{ops A V} `{spec A V} (tape : A),
      size (move_left tape) = size tape.
  Proof.
    intros.
    now rewrite !to_list_size, move_left_list.
  Qed.

  Lemma move_right_size : forall A V `{ops A V} `{spec A V} (tape : A),
      size (move_right tape) = size tape.
  Proof.
    intros.
    now rewrite !to_list_size, move_right_list.
  Qed.

  Lemma read_write_id : forall A V `{ops A V} `{spec A V} (tape  : A) (v : V),
      size tape <> 0 ->
      v = read tape ->
      to_list (write v tape) = to_list tape.
  Proof.
    intros.
    apply nth_error_eq.
    intro i.
    rewrite write_spec; auto.
    destruct_cmpbs.
    pose proof (read_spec tape) as Hread.
    subst.
    intuition.
  Qed.

  Definition replace_at {A} i (xs ys : list A) (v : A) :=
    exists a l r, length l = i /\ xs = l ++ a :: r /\ ys = l ++ v :: r.

  Lemma skipn_Sn : forall {A} i (xs : list A) (x : A), nth_error xs i = Some x -> skipn i xs = x :: skipn (S i) xs.
  Proof.
    intros A i xs x.
    revert i.
    induction xs; simpl.
    - destruct i; inversion 1.
    - destruct i; simpl in *; try congruence.
      apply IHxs.
  Qed.

  Lemma skipn_nth_error :
    forall {A} s i (xs : list A), nth_error (skipn s xs) i = nth_error xs (s + i).
  Proof.
    induction s; intros.
    - reflexivity.
    - destruct xs; simpl; auto.
      destruct i; auto.
  Qed.

  Lemma firstn_nth_error :
    forall {A} s i (xs : list A),
      nth_error (firstn s xs) i =
      if i <? s
      then nth_error xs i
      else None.
  Proof.
    induction s; intros.
    - destruct (Nat.ltb_spec i 0); simpl; try lia.
      destruct i; auto.
    - destruct i.
      + destruct_cmpbs; try lia.
        destruct xs; auto.
      + destruct xs; simpl.
        * destruct Nat.ltb; auto.
        * rewrite IHs.
          destruct_cmpbs; auto with zarith; lia.
  Qed.

  Lemma write_replace_at : forall A V `{ops A V} `{spec A V} (tape : A) (v : V),
      size tape <> 0 ->
      replace_at (Tape.head tape) (Tape.to_list tape) (Tape.to_list (Tape.write v tape)) v.
  Proof.
    intros until v.
    intro Hsnz.
    exists (read tape).
    exists (List.firstn (head tape) (to_list tape)).
    exists (List.skipn (S (head tape)) (to_list tape)).
    pose proof (head_spec tape Hsnz) as Hhead.
    pose Hsnz as Hlennz.
    rewrite to_list_size in Hhead, Hlennz.
    split; [| split].
    - rewrite firstn_length_le; auto with zarith.
    - rewrite <- (firstn_skipn (head tape) (to_list tape)) at 1.
      rewrite <- skipn_Sn; auto.
      now apply read_spec.
    - rewrite <- (firstn_skipn (head tape) (to_list (write v tape))).
      replace (firstn (head tape) (to_list tape)) with (firstn (head tape) (to_list (write v tape))).
      + replace (skipn (S (head tape)) (to_list tape)) with (skipn (S (head tape)) (to_list (write v tape))).
        * rewrite <- skipn_Sn; auto.
          now apply write_spec_head.
        * apply nth_error_eq.
          intro i.
          rewrite !skipn_nth_error.
          apply write_spec_other; auto with zarith.
      + apply nth_error_eq.
        intro i.
        rewrite !firstn_nth_error.
        destruct_cmpb; auto.
        apply write_spec_other; auto with zarith.
  Qed.

  Lemma count_occ_app : forall {A} eq_dec xs ys (v : A),
      List.count_occ eq_dec (xs ++ ys) v = List.count_occ eq_dec xs v + List.count_occ eq_dec ys v.
  Proof.
    intros.
    induction xs; simpl; auto.
    destruct eq_dec; simpl; auto.
  Qed.

  Lemma write_count_occ_ge : forall A V `{ops A V} `{spec A V}
                                    (eq_dec : forall x y, {x = y} + {x <> y}) (tape : A) (v : V),
      size tape <> 0 ->
      List.count_occ eq_dec (to_list tape) v <=
      List.count_occ eq_dec (to_list (Tape.write v tape)) v.
  Proof.
    intros.
    cut (forall i (xs ys : list V),
            replace_at i xs ys v -> List.count_occ eq_dec xs v <= List.count_occ eq_dec ys v).
    - intro H'.
      apply (H'(head tape)); auto using write_replace_at.
    - intros i xs ys Hrep.
      destruct Hrep as (a & l & r & Hlen & Hl & Hr).
      subst.
      rewrite !count_occ_app.
      simpl.
      repeat destruct eq_dec; subst; try congruence; auto with arith.
  Qed.

  Lemma write_count_occ_gt : forall A V `{ops A V} `{spec A V} (eq_dec : forall x y, {x = y} + {x <> y}) (tape : A) (v : V),
      size tape <> 0 ->
      read tape <> v ->
      List.count_occ eq_dec (to_list tape) v <
      List.count_occ eq_dec (to_list (write v tape)) v.
  Proof.
    intros.
    cut (forall i (xs ys : list V),
            nth_error xs i <> Some v ->
            replace_at i xs ys v -> List.count_occ eq_dec xs v < List.count_occ eq_dec ys v).
    - intro H'.
      apply (H'(head tape)); auto using write_replace_at.
      pose proof (read_spec tape) as Hread.
      cut_hyp Hread; auto.
      congruence.
    - intros i xs ys Hne Hrep.
      destruct Hrep as (a & l & r & Hlen & Hl & Hr).
      subst.
      rewrite !count_occ_app.
      simpl.
      repeat destruct eq_dec; subst; try congruence; auto with arith.
      contradict Hne.
      rewrite nth_error_app2; auto.
      rewrite Nat.sub_diag.
      reflexivity.
  Qed.

End Tape.


Require Export Lambda.SF.Dep.
Require Coq.Vectors.Vector.
Import Vector.VectorNotations.

(** [Prop] is used instead of [Set] & [Type]
    because [Prop], like System F, is impredicative. *)

Equations eq_doh : forall {A B : Type}, A = B -> A -> B :=
  eq_doh eq_refl a := a.

Equations denote_type : forall {Δ : nat}, Vector.t Prop Δ  -> type Δ -> Prop :=
  denote_type σ (TId X)  := Vector.nth σ X;
  denote_type σ (∀ τ)%ty := forall (X : Prop), denote_type (X :: σ)%vector τ;
  denote_type σ (τ₁ → τ₂)%ty :=
    denote_type σ τ₁ -> denote_type σ τ₂.

(*Local Transparent denote_type.*)

Definition denote_type_cons :
  forall {Δ : nat} {τ : type Δ} {σ : Vector.t Prop Δ} (X : Prop),
    denote_type σ τ -> denote_type (X :: σ)%vector (rename_type Fin.FS τ).
Proof.
  (* TODO: needs mapply lemma. *)
Admitted.

Equations denote_hlist_cons :
  forall {Δ : nat} {Γ : list (type Δ)} {σ : Vector.t Prop Δ} (X : Prop),
    hlist (denote_type σ) Γ ->
    hlist (denote_type (X :: σ)%vector) (map (rename_type Fin.FS) Γ) :=
  denote_hlist_cons _ hnil := hnil;
  denote_hlist_cons X (hcons τ hl) :=
    hcons (denote_type_cons X τ) (denote_hlist_cons X hl).

Lemma denote_type_sub :
  forall {Δ : nat} (σ : Vector.t Prop Δ) (τ : type (S Δ)) (τ' : type Δ),
    denote_type σ (τ `[[τ']])%ty
    = (denote_type (denote_type σ τ' :: σ)%vector τ).
Proof.
  intros Δ σ τ τ'.
  unfold "_ `[[ _ ]]".
Admitted.

Equations denote_term
  : forall {Δ : nat} {Γ : list (type Δ)}
      {τ : type Δ} (σ : Vector.t Prop Δ),
    hlist (denote_type σ) Γ -> Γ ⊢ τ -> denote_type σ τ :=
  denote_term _ ϵ (Id _ _ hs) := lookup_has ϵ hs;
  denote_term σ ϵ (λ τ ⇒ t)%term :=
    fun x : denote_type σ τ => denote_term σ (hcons x ϵ) t;
  denote_term σ ϵ (t₁ ⋅ t₂)%term :=
    (denote_term σ ϵ t₁) (denote_term σ ϵ t₂);
  denote_term (Δ:=Δ) (Γ:=Γ) σ ϵ (Λ t)%term :=
    fun (X : Prop) => denote_term (X :: σ) (denote_hlist_cons X ϵ) t;
  denote_term (Δ:=Δ) (Γ:=Γ) σ ϵ (t ⦗τ⦘)%term := _.
Next Obligation.
Proof.
  rewrite denote_type_sub.
  exact (denote_term _ _ _ σ ϵ t (denote_type σ τ)).
Defined.