Require Import Defs List_Facts Term_Defs StructTactics Preamble.

Require Import Lia Coq.Program.Tactics.

Require Import List.
Import List.ListNotations.

(*

Require Import Lists.List.
*)

Set Nested Proofs Allowed.

Ltac same_index :=
  match goal with
  | [H: anno ?t _ = (?n, _),
        H': anno ?t _ = (?n', _) |- _] =>
    assert_new_proof_by (n = n') eauto
  end.

Lemma same_anno_range: forall t i a b n n',
    anno t i = (n,a) ->
    anno t i = (n',b) ->
    n = n'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try destruct a;
    ff.
Defined.

(*
    (* Full automation causes proof to take ~3x longer *)
    (*
    try
      (destruct a;
       ff; tauto);
    try (ff; tauto);
    try (
        ff;
        repeat (same_index; subst);
        congruence).
     *)
  -
    destruct a; ff.
  -
    ff.
  -
    ff.
  -
    ff.
Defined.

    (*
    repeat (same_index; subst);
      congruence.
     *)

    (*
  -
    ff;
    repeat (same_index; subst);
    congruence.
  -
    ff;
      repeat (same_index; subst);
      congruence. *)
 Defined.
*)

Lemma anno_mono : forall (t:Term) (i j:nat) (t':AnnoTerm),
  anno t i = (j,t') ->
  j > i.
Proof.
  induction t; intros; (*i j t' ls b H; *)
    ff;
    repeat find_apply_hyp_hyp;
    lia.
Defined.
Hint Resolve anno_mono : core.

Lemma anno_range:
  forall x i j t',
     anno x i = (j,t') ->
    range (t') = (i, j).
Proof.
  induction x; intros; ff.
Defined.

Ltac haha :=
  let asdff := eapply anno_mono; eauto in
  match goal with
  | [H: anno _ ?x = (?y,_) |- _] => assert_new_proof_by (y > x) (asdff)
  end.

Ltac hehe :=
  match goal with
  | [H: anno ?x ?y = (_,_) |- _] => pose_new_proof (anno_range x y)
  end.

Ltac hehe' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x (S y))
  end.

Ltac hehe'' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x y)
  end.

Ltac do_list_empty :=
  match goal with
    [H: length ?ls = 0 |- _] =>
    assert_new_proof_by (ls = []) ltac:(destruct ls; solve_by_inversion)
  end.

(*
Lemma anno_lrange:
  forall x i j ls t' b,
    length ls = nss x ->
    anno x i ls b = Some (j,t') ->
    list_subset ls (lrange t').
Proof.
  induction x; intros;
    try (ff';
         try do_list_empty;
         ff';
         try tauto;
         congruence).
Defined.

Lemma anno_lrange'
  : forall (x : Term) (i j : nat) (ls : list nat)
      (t' : AnnoTerm),
    (*length ls = nss x -> *)
    anno x i ls true = Some (j, t') ->
    list_subset (lrange t') ls.
Proof.
  intros.
  generalizeEverythingElse x.
  induction x; intros;
    try (ff'; tauto).
Defined.

Lemma both_anno_lrange
  : forall (x : Term) (i j : nat) (ls : list nat)
      (ls' : LocRange) (t' : AnnoTerm),
    length ls = nss x ->
    anno x i ls true = Some (j,t') ->
    list_subset (lrange t') ls /\ list_subset ls (lrange t').
Proof.
  split.
  - eapply anno_lrange'; eauto.
  - eapply anno_lrange; eauto.
Defined.

Lemma false_succeeds: forall t i ls,
    anno t i ls false = None ->
    False.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try destruct a;
    ff;
    eauto.
Defined.

Lemma nss_iff_anss: forall t i ls n a b,
    anno t i ls b = Some (n,a) ->
    nss t = anss a.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try destruct a;
    ff;
    try eauto;
    try (
        repeat find_apply_hyp_hyp;
        lia).
Defined.

Ltac list_facts' :=
  do_firstn_skipn_len;
  (*do_anno_some_fact; *)
  do_firstn_factt;
  do_firstn_skipn;
  nodup_list_firstn;
  nodup_list_skipn;
  do_nodup_firstn;
  do_nodup_skipn;
  do_nodup_contra.

Lemma anno_some_fact: forall t i ls n a,
    anno t i ls true = Some (n, a) ->
    length ls >= nss t.
Proof.
  induction t; intros.
  -
    ff.
    destruct ls; ff; lia.
  -
    ff.
    lia.
  -
    ff.
    list_facts'.

    assert (length ((firstn (nss t1) ls)) >= nss t1) by eauto.
    assert (length (skipn (nss t1) ls) >= nss t2) by eauto.

    (*

    assert (length ls = length (firstn (nss t1) ls) +
                        length (skipn (nss t1) ls)).
    {
      eapply firstn_skipn_len.
    } *)
    lia.
    (*
  -
    ff.
    list_facts'.
    assert (length ((firstn (nss t1) ls)) >= nss t1) by eauto.
    assert (length (skipn (nss t1) ls) >= nss t2) by eauto.
    lia.

  (*

    assert (length ls = length (firstn (nss t1) ls) +
                        length (skipn (nss t1) ls)).
    {
      eapply firstn_skipn_len.
    }
    lia. *)
  -
    ff.
    +

      list_facts'.
      assert (length ((firstn (nss t1) l0)) >= nss t1) by eauto.
      assert (length (skipn (nss t1) l0) >= nss t2) by eauto.
      ff.
      lia.

      (*

    +
      list_facts'.
      assert (length ((firstn (nss t1) [])) >= nss t1) by eauto.
      assert (length (skipn (nss t1) []) >= nss t2) by eauto.
      ff.
      lia.
    +
      list_facts'.
      assert (length ((firstn (nss t1) l2)) >= nss t1) by eauto.
      assert (length (skipn (nss t1) l2) >= nss t2) by eauto.
      ff.
      lia. *)
*)
Defined.

Ltac do_anno_some_fact :=
  repeat
    match goal with
    | [H: anno ?t _ ?ls _ = Some (_,_) |- _] =>
      assert_new_proof_by (length ls >= nss t) ltac:(eapply anno_some_fact; apply H)
    end.

Ltac list_facts :=
  do_firstn_skipn_len;
  do_anno_some_fact;
  do_firstn_factt;
  do_firstn_skipn;
  nodup_list_firstn;
  nodup_list_skipn;
  do_nodup_firstn;
  do_nodup_skipn;
  do_nodup_contra.

Lemma list_too_short: forall t i ls,
      anno t i ls true = None ->
      length ls < nss t.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a; ff.
  -
    ff.
    exfalso.
    eapply false_succeeds; eauto.
  -
    ff.
    list_facts.

    +

      assert (length (skipn (nss t1) ls) < nss t2) by eauto.
      lia.

      (*

      assert (length (firstn (nss t1) ls) >= nss t1).
      {
        eapply anno_some_fact; eauto.
      }

      assert (length (firstn (nss t1) ls) = nss t1).
      {
        eapply firstn_factt; eauto.
      }

      assert (length ls = length (firstn (nss t1) ls) + length (skipn (nss t1) ls)).
      {
        eapply firstn_skipn_len; eauto.
      }
      lia. *)

    +
      assert (length (firstn (nss t1) ls) < nss t1) by eauto.

      assert (length ls < (nss t1)).
      {
        eapply firstn_fact'; eauto.
      }

      lia.
      (*
  -
    ff.
    list_facts.
    +
      assert (length (skipn (nss t1) ls) < nss t2) by eauto.
      lia.
      (*

      assert (length (firstn (nss t1) ls) >= nss t1).
      {
        eapply anno_some_fact; eauto.
      }

      assert (length (firstn (nss t1) ls) = nss t1).
      {
        eapply firstn_factt; eauto.
      }

      assert (length ls = length (firstn (nss t1) ls) + length (skipn (nss t1) ls)).
      {
        eapply firstn_skipn_len; eauto.
      }
      lia. *)

    +
      assert (length (firstn (nss t1) ls) < nss t1) by eauto.

      assert (length ls < (nss t1)).
      {
        eapply firstn_fact'; eauto.
      }

      lia.
  -
    ff;
      try (
      list_facts;
      lia).

    +
      list_facts.
      assert (length (skipn (nss t1) l0) < nss t2) by eauto.
      ff.
      lia.

      (*

      assert (length (firstn (nss t1) []) = (nss t1)).
      {
        assert (length (firstn (nss t1) l2) >= (nss t1)).
        {
          eapply anno_some_fact; eauto.
        }

        eapply firstn_factt; eauto.
      }

      assert (length l2 = length (firstn (nss t1) l2) + length (skipn (nss t1) l2)).
      {
        eapply firstn_skipn_len; eauto.
      }
      lia. *)
    +

      assert (length (firstn (nss t1) l0) < nss t1) by eauto.
      ff.
      assert (nss t1 > length l0).
      {
        eapply firstn_fact'; eauto.
      }

      lia.
*)
Defined.

Lemma anno_some: forall t i l b,
  length l = nss t ->
  exists res,
    anno t i l b = Some res.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      ff;
      eauto.
  -
    cbn in *.
    assert (exists x y, l = [x; y]).
    {
      destruct l; try solve_by_inversion.
      invc H.
      destruct l; try solve_by_inversion.
      invc H1.
      assert (l = []) by (destruct l; solve_by_inversion).
      subst.
      eauto.
    }
    destruct_conjs.
    subst.
    ff.
    +
      eauto.
    +
      exfalso.
      eapply false_succeeds; eauto.
    +
      destruct b;
        ff.

  -
    ff.
    +
      eauto.
    +

      destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto).
    ++
      assert (length ((skipn (nss t1) l)) < nss t2).
      {
        eapply list_too_short; eauto.
      }

      assert (length (firstn (nss t1) l) = nss t1).
      {
        assert (length (firstn (nss t1) l) >= nss t1).
        {
          eapply anno_some_fact; eauto.
        }
        eapply firstn_factt; eauto.
      }

      assert (length l = length (firstn (nss t1) l) + length (skipn (nss t1) l)).
      {
        eapply firstn_skipn_len; eauto.
      }
      lia.
    +
      destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto).
      ++

        assert (length ((firstn (nss t1) l)) < nss t1).
        {
          eapply list_too_short; eauto.
        }
        (*
         assert (length l = length (firstn (nss t1) l) + length (skipn (nss t1) l)).
        {
          eapply firstn_skipn_len; eauto.
        }
         *)
        assert (length l < nss t1).
        {
          eapply firstn_fact'; eauto.
        }
        lia.
        (*

  -
    ff.
    +
      eauto.
    +

      destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto).
      ++
        assert (length ((skipn (nss t1) l)) < nss t2).
        {
          eapply list_too_short; eauto.
        }

        assert (length (firstn (nss t1) l) = nss t1).
        {
          assert (length (firstn (nss t1) l) >= nss t1).
          {
            eapply anno_some_fact; eauto.
          }
          eapply firstn_factt; eauto.
        }

        assert (length l = length (firstn (nss t1) l) + length (skipn (nss t1) l)).
        {
          eapply firstn_skipn_len; eauto.
        }
        lia.
    +
      destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto).
      ++

        assert (length ((firstn (nss t1) l)) < nss t1).
        {
          eapply list_too_short; eauto.
        }
        (*
         assert (length l = length (firstn (nss t1) l) + length (skipn (nss t1) l)).
        {
          eapply firstn_skipn_len; eauto.
        }
         *)
        assert (length l < nss t1).
        {
          eapply firstn_fact'; eauto.
        }
        lia.
  -
    ff;
      try (eauto; tauto);
      try lia.
    +
      destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto; tauto).
      ++

      assert (length (skipn (nss t1) l1) < nss t2).
      {
        eapply list_too_short; eauto.
      }

      assert (length (firstn (nss t1) l1) = nss t1).
      {

        assert (length (firstn (nss t1) l1) >= nss t1).
        {
          eapply anno_some_fact; eauto.
        }

        eapply firstn_factt; eauto.
      }
      list_facts.

      lia.

      (*

      assert (length l3 = length (firstn (nss t1) l3) + length (skipn (nss t1) l3)).
        {
          eapply firstn_skipn_len; eauto.
        }
        lia. *)
    +
       destruct b;
        try (exfalso;
             eapply false_succeeds;
             eauto; tauto).
       ++
         assert (length (firstn (nss t1) l1) < nss t1).
         {
           eapply list_too_short; eauto.
         }

         assert (length l1 < nss t1).
         {
           eapply firstn_fact'; eauto.
         }

         lia.
    +
      destruct b.
      ++
        ff.
      ++
        ff.
        (*
    +
      destruct b;
        ff. *)
         *)

        Grab Existential Variables.

      eauto.
      eauto.
      eauto.
      eauto.
      eauto.
      eauto.
      (*
      eauto.
      eauto.
      eauto.
      eauto.
      eauto.
      eauto. *)
Defined.

(*
Lemma anno_len_exact:
  forall t i j ls t',
    anno t i ls true = Some (j, ([], t')) ->
    length ls = anss t'.
Proof.
  intros.
  assert (length ls = anss t' + (length ([]:list nat))).
  {
    eapply anno_len; eauto.
  }
  simpl in *.
  lia.
Defined.
*)

Lemma lrange_nss: forall t i ls  n a,
    length ls = nss t ->
    anno t i ls true = Some (n, a) ->
    length (lrange a) = nss t. (* + length ls'. *)
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    ff.
Defined.

(*

    ff; eauto.

    assert (length (lrange a0) = nss t1) by eauto.

    assert (length (lrange a1) = nss t2) by eauto.

    assert (length (firstn (nss t1) ls) = nss t1).
    {
      assert (length (firstn (nss t1) ls) >= nss t1).
      {
        eapply anno_some_fact; eauto.
      }

      eapply firstn_factt; eauto.
    }

    (*
    assert (length (skipn (nss t1) ls) = nss t2).
    {
      assert (length (skipn (nss t1) ls) >= nss t2).
      {
        eapply anno_some_fact; eauto.
      }

      admit.
    }
     *)

     assert (length ls = length (firstn (nss t1) ls) + length (skipn (nss t1) ls)).
        {
          eapply firstn_skipn_len; eauto.
        }

        lia.
  -

    (*assert (length (lrange a0) = nss t1) by eauto. *)

    assert (length ls = anss a0 + length l).
    {
      eapply anno_len; eauto.
    }

    assert (length l = anss a1).
    {

      assert (anss a1 = anss a1 + (length ([]:list nat))).
      {
        eauto.
      }
      rewrite H1.

      eapply anno_len; eauto.
    }

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    lia.
  -
    ff.
    ff.
    ff; eauto.

    assert (length (lrange a1) = nss t2) by eauto.

    assert (length ls = anss a0 + length l).
    {
      eapply anno_len; eauto.
    }

    assert (length l = anss a1).
    {
      assert (anss a1 = anss a1 + (length ([]:list nat))).
      {
        eauto.
      }
      rewrite H1.

      eapply anno_len; eauto.
    }

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    lia.
  -
    ff.
    ff; eauto.

    assert (length (lrange a1) = nss t2) by eauto.

    assert (length l4 = anss a0 + length l).
    {
      eapply anno_len; eauto.
    }

    assert (length l = anss a1).
    {
      assert (anss a1 = anss a1 + (length ([]:list nat))).
      {
        eauto.
      }
      rewrite H1.

      eapply anno_len; eauto.
    }

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    erewrite nss_iff_anss.
    Focus 2.
    eassumption.

    lia.
Defined.
*)

*)

Lemma anno_well_formed_r:
  forall t i j t',
    (* length ls = nss t ->
    NoDup ls -> *)
    anno t i = (j, t') ->
    well_formed_r t'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      ff.
  -
    ff.
    +
      econstructor.
      eauto.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      assert (n0 > S i) by (eapply anno_mono; eauto).
      lia.
      (*
    +
      econstructor.
      eauto.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      assert (n0 > S i) by (eapply anno_mono; eauto).
      lia.
    +
      econstructor.
      eauto.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      assert (n0 > S i) by (eapply anno_mono; eauto).
      lia. *)
  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      (*
      Check anno_range.
      Check anno_mono.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      simpl.

      eapply anno_mono; eauto.
       *)

Defined.

      (*
  -
    ff.
    econstructor.
    eauto.
    eauto.

     simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      assert (n > (S i)) by (eapply anno_mono; eauto).

      assert (n0 > n) by (eapply anno_mono; eauto).

      repeat erewrite anno_range.
      Focus 2.
      eassumption.
      Focus 2.
      eassumption.

      simpl.
      lia.

      econstructor.
      eauto.
      eauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

       assert (n > (S i)) by (eapply anno_mono; eauto).

      assert (n0 > n) by (eapply anno_mono; eauto).

      repeat erewrite anno_range.
      Focus 2.
      eassumption.
      Focus 2.
      eassumption.

      simpl.
      lia.

      econstructor.
      eauto.
      eauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

       assert (n > (S i)) by (eapply anno_mono; eauto).

      assert (n0 > n) by (eapply anno_mono; eauto).

      repeat erewrite anno_range.
      Focus 2.
      eassumption.
      Focus 2.
      eassumption.

      simpl.
      lia.

      (*

            econstructor.
      eauto.
      eauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

       assert (n > (S i)) by (eapply anno_mono; eauto).

      assert (n0 > n) by (eapply anno_mono; eauto).

      repeat erewrite anno_range.
      Focus 2.
      eassumption.
      Focus 2.
      eassumption.

      simpl.
      lia.

            econstructor.
      eauto.
      eauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

      simpl.
      erewrite anno_range.
      Focus 2.
      eassumption.
      tauto.

       assert (n > (S i)) by (eapply anno_mono; eauto).

      assert (n0 > n) by (eapply anno_mono; eauto).

      repeat erewrite anno_range.
      Focus 2.
      eassumption.
      Focus 2.
      eassumption.

      simpl.
      lia. *)
Defined.
*)


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.

Require Export LogRelIE.PseudoType.

#[export]
#[refine] Instance vrPTy : Vr PTy := {| vr := ptvar |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushPTypesMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module PTyKit <: Kit.

  Definition TM := PTy.
  Definition inst_vr := vrPTy.

  Section Application.

    Context {Y : Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y PTy}.

    #[refine] Global Instance inst_ap : Ap PTy Y := {| ap := apPTy |}.
    Proof.
      induction x; crush.
    Defined.

    #[refine] Global Instance inst_ap_vr : LemApVr PTy Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj PTy Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y PTy}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z PTy}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z PTy} :
    LemApComp PTy Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y PTy} :
    LemApLiftSub PTy Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (τ: PTy) :
    ∀ (ξ: Sub Ix) (ζ: Sub PTy), τ[ξ][ζ] = τ[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction τ; crush. Qed.

End PTyKit.

Module InstPTy := Inst.Inst PTyKit.
Export InstPTy. (* Export for shorter names. *)

#[export]
Instance wsVrPTy: WsVr PTy.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section ApplicationPTy.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y PTy}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y PTy}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApPTy : WsAp PTy Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ;
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsPTy ?δ ?t =>
              change (wsPTy δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
  Qed.
End ApplicationPTy.

#[export]
Instance wsWkPTy : WsWk PTy.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.


Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.
Require Import hoare_total.

(* rule for if in weakest precondition form *)
Lemma wp_if : forall t x v s1 s2 P1 P2 G R Q,
  let wp :=
    EX val:value,
      store_op (fun r => r#v = Some val) &&
    (

      ((!!(val = value_label (L 0)) && P1))
      ||
      ((EX x1:value, (EX x2:value,
        !!(val = (value_cons x1 x2)))) && P2)
    )
   in
  hoare t x G R P1 s1 Q ->
  hoare t x G R P2 s2 Q ->
  hoare t x G R wp (instr_if_nil v s1 s2) Q.
Proof.
  intros.
  apply hoare_if.
  unfold wp.
  hnf; intros.
  destruct H1 as [val [? ?]].
  destruct a as [p' [r t']].
  destruct H1 as [_ [? _]].
  destruct H2.
  destruct H2. simpl in H2.
  subst val.
  split; auto. hnf; auto.
  rewrite H1. split; auto.
  destruct H2.
  destruct H2 as [x1 [x2 ?]].
  simpl in H2.
  subst val.
  split; auto. hnf; auto.
  rewrite H1. auto.
  apply hoare_weaken_pre with P1; auto.
  unfold wp; hnf; intuition.
  destruct a as [? [? ?]].
  destruct H1.
  destruct H1.
  destruct H1.
  unfold store_op, world_op in *;
    simpl in *; intuition.
  rewrite H2 in H5.
  inv H5.
  destruct H3 as [? [? ?]]; discriminate.
  apply hoare_weaken_pre with P2; auto.
  unfold wp; hnf; intuition.
  destruct a as [? [? ?]].
  destruct H1.
  destruct H1.
  destruct H1.
  unfold store_op, world_op in *;
    simpl in *; intuition.
  subst x0.
  rewrite H2 in H5.
  destruct H5 as [? [? ?]]; discriminate.
Qed.

Section wp.
  Variable t:terminationMeasure.
  Variables G R:pred world.

  Fixpoint is_basic (i:instruction) : bool :=
    match i with
    | instr_call _ => false
    | instr_seq s1 s2 => andb (is_basic s1) (is_basic s2)
    | _ => true
    end.

  Fixpoint wp (x:nat) (i:instruction) (POST:pred world) { struct i } : pred world :=
    match i with
    | instr_return => R

    | instr_assert P => (G --> proj1_sig P) && POST

    | instr_getlabel l v =>  box (setM v (value_label l)) POST

    | instr_fetch_field v1 0 v2 =>
        EX x1:value, EX x2:value,
          store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x1) POST

    | instr_fetch_field v1 1 v2 =>
        EX x1:value, EX x2:value,
          store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x2) POST

    | instr_cons v1 v2 v3 =>
      (EX x1:value, EX x2:value,
        store_op (fun r => r#v1 = Some x1 /\ r#v2 = Some x2) &&
          box (setM v3 (value_cons x1 x2)) POST)

    | instr_if_nil v s1 s2 =>

    EX val:value,
      store_op (fun r => r#v = Some val) &&
    (

      ((!!(val = value_label (L 0)) && wp x s1 POST))
      ||
      ((EX x1:value, (EX x2:value,
        !!(val = (value_cons x1 x2)))) && wp x s2 POST)
    )

    | instr_call v =>
      EX l:label, EX A:Type, EX lP:(A->pred world), EX lQ:(A -> pred world), EX n':nat, EX a:A,
        store_op (fun r => r#v = Some (value_label l) /\ t l r = Some n' /\ n' < x) &&
        (G --> funptr l A lP lQ) && lP a && (closed (lQ a --> POST))

    | instr_seq s1 s2 =>
        if is_basic s1 then wp 0 s1 (wp x s2 POST) else
        if is_basic s2 then wp x s1 (wp 0 s2 POST) else
        EX n:nat, EX m:nat,
           wp n s1 (wp m s2 POST) && !!(n+m = x)

    | _ => FF
    end.
End wp.

Lemma hoare_wp : forall i x t G R P Q,
  boxy K.expandM G ->
  P |-- wp t G R x i Q ->
  hoare t x G R P i Q.
Proof.
  induction i; simpl; intros.
  apply hoare_weaken_time with 0. omega.
  apply hoare_weaken_post with P.
  hnf; intros. spec H0 a; intuition. destruct H2; auto.
  apply hoare_assert; auto.
  intro a. spec H0 a. intuition.
  destruct H1. spec H0; auto.
  destruct H0. spec H0 a. spec H0; auto.

  apply hoare_weaken_time with 0. omega.
  eapply hoare_weaken_pre.
  2: eapply hoare_getlabel. auto.
  destruct n.

  apply hoare_weaken_time with 0. omega.
  eapply hoare_weaken_pre.
  apply H0.
  apply hoare_ex_pre. intro x1.
  apply hoare_ex_pre. intro x2.
  apply hoare_step_fetch0.
  destruct n.
  apply hoare_weaken_time with 0. omega.
  eapply hoare_weaken_pre.
  apply H0.
  apply hoare_ex_pre. intro x1.
  apply hoare_ex_pre. intro x2.
  apply hoare_step_fetch1.
  eapply hoare_weaken_pre.
  apply H0. repeat intro. elim H6.

  apply hoare_weaken_time with 0. omega.
  eapply hoare_weaken_pre.
  apply H0.
  apply hoare_ex_pre. intro x1.
  apply hoare_ex_pre. intro x2.
  apply hoare_cons.

  eapply hoare_weaken_pre.
  apply H0.
  destruct (is_basic i1).
  change x with (0+x).
  apply hoare_seq with (wp t G R x i2 Q); auto.
  destruct (is_basic i2).
  pattern x at 1.
  replace x with (x+0) by omega.
  apply hoare_seq with (wp t G R 0 i2 Q); auto.
  apply hoare_ex_pre. intro n.
  apply hoare_ex_pre. intro m.
  eapply hoare_weaken_pre with
    (!!(n+m = x) && (wp t G R n i1 (wp t G R m i2 Q))).
  hnf; unfold andp; simpl; intuition.
  apply hoare_fact_pre. intro.
  subst x.
  apply hoare_seq with (wp t G R m i2 Q); auto.

  eapply hoare_weaken_pre.
  apply H0.
  apply wp_if.
  apply IHi1; auto. hnf; auto.
  apply IHi2; auto. hnf; auto.

  eapply hoare_weaken_pre.
  apply H0.
  apply hoare_call.

  apply hoare_weaken_time with 0. omega.
  eapply hoare_weaken_pre.
  apply H0.
  apply hoare_weaken_post with FF.
  hnf; intros. elim H1.
  apply hoare_return.

  apply hoare_weaken_pre with FF; auto.
  repeat intro. elim H6.
Qed.


(* Celsius project *)
(* Clément Blaudeau - Lamp@EPFL & Inria 2020-2022 *)
(* ------------------------------------------------------------------------ *)
(* This file defines the definitional interpreter of the language. It is then shown equivalent to
the big step-semantics (when it succeeds) *)

From Celsius Require Import Semantics.
Implicit Type (σ: Store) (ρ ω: Env) (l: Loc).

(* ------------------------------------------------------------------------ *)
(** ** Evaluation results *)

(* Evaluation result *)
Inductive result : Type :=
| Timeout
| Error
| Success : Loc -> Store -> result.

Inductive result_l : Type :=
| Timeout_l
| Error_l
| Success_l ρ σ : result_l.

Inductive result_i : Type :=
| Timeout_i
| Error_i
| Success_i σ : result_i.

(* ------------------------------------------------------------------------ *)
(** ** Definitional Evaluator (with fuel) *)

Fixpoint eval e σ ρ v k :=
  match k with
  | 0 => Timeout
  | S n => match e with
          (** Var: simple lookup of the store *)
          | e_var x => (**r [e = x] *)
              (match (getVal ρ x) with
               | Some v => (Success v σ)
               | _ => Error
               end )

          (** This: returns current value *)
          | e_this => (Success v σ) (**r [e = this] *)

          (** Field access: compute object value and access field *)
          | e_fld e0 x => (**r [e = e0.x] *)
              ( match (⟦e0⟧(σ, ρ, v, n)) with
                | Success v0 σ1 =>
                    match (getObj σ1 v0) with
                    | Some (c, f) =>
                        match (getVal f x) with
                        | Some v1 => Success v1 σ1
                        | _ => Error end
                    | _ => Error end
                | z => z end )

          (** Method call : compute object value, compute arguments and do the call*)
          | e_mtd e0 m el => (**r [e = e0.m(el)] *)
              (match (⟦e0⟧(σ, ρ, v, n)) with
               | Success v0 σ1 =>
                   ( match (getObj σ1 v0) with
                     | Some (C, _) =>
                         ( match (ct C)  with
                           | (class _  _ Mtds) =>
                               ( match Mtds m with
                                 | Some (method μ x _ e1) =>
                                     ( match (⟦_ el _⟧(σ1, ρ, v, n)) with
                                       | Success_l args_val σ2 =>
                                           let ρ1 := args_val in ⟦e1⟧(σ2, ρ1, v0, n)
                                       | Error_l => Error
                                       | Timeout_l => Timeout
                                       end)
                                 | _ => Error end)
                           end )
                     | _ => Error end)
               | z => z end)

          (** New class *)
          | e_new C args => (**r [e = new C(args)] *)
              (match (⟦_ args _⟧(σ, ρ, v, n)) with
               | Success_l args_val σ1 =>
                   ( let I := (length σ1) in (* Fresh location for new object *)
                     let ρ_init := args_val in (* Local env during initialization *)
                     let σ2 := σ1 ++ [(C, [])] in (* New object with empty local env *)
                     match (init C I 0 ρ_init σ2 n) with
                     | Success_i σ3 => (Success I σ3) (* Returns new object and updated store *)
                     | Error_i => Error
                     | Timeout_i => Timeout
                     end )
               | Error_l => Error
               | Timeout_l => Timeout
               end) (* Invalid args *)

          (** Field assignment *)
          | e_asgn e1 x e2 e' => (**r [e = (e1.x ← e2 ; e')] *)
              (match (⟦e1⟧(σ, ρ, v, n)) with
               | Success v1 σ1 =>
                   match (⟦e2⟧(σ1, ρ, v, n)) with
                   | Success v2 σ2 =>
                       ( let σ3 := (assign v1 x v2 σ2) in
                         ⟦e'⟧(σ3, ρ, v, n))
                   | z => z end
               | z => z end )
          end
  end

where "⟦ e ⟧ ( σ , ρ , ψ , n )" := (eval e σ ρ ψ n)

(** Evaluation of a list of expressions (fold) *)
with eval_list (e_l: list Expr) σ ρ ψ n :=
       match n with
       | 0 => Timeout_l
       | S n => match e_l with
               | [] => Success_l [] σ
               | e::e_l =>
                   match (⟦e⟧(σ, ρ, ψ, n)) with
                   | Success v σ' =>
                       match ⟦_ e_l _⟧(σ', ρ, ψ, n) with
                       | Success_l vl σ'' => Success_l (v::vl) σ''
                       | z => z
                       end
                   | Error => Error_l
                   | Timeout => Timeout_l
                   end
               end
       end
where  "⟦_ el _⟧ ( σ , ρ , ψ , n )" := (eval_list el σ ρ ψ n)

(** Initialization for the list of fields (when fields up to x have been initialized) *)
with init (C: ClN) (ψ : Loc) x ρ σ n : result_i :=
       match n with
       | 0 => Timeout_i
       | S n =>
           let 'class _ fields _ := ct C in
           match nth_error fields x with
               | None => if (x =? dom fields) then Success_i σ else Error_i
               | Some (field T e) =>
                   match ⟦e⟧(σ, ρ, ψ, n) with
                   | Success v σ1 =>
                       match (assign_new ψ x v σ1) with
                       | Some σ2 => init C ψ (S x) ρ σ2 n
                       | _ => Error_i
                       end
                   | Error => Error_i
                   | Timeout => Timeout_i
                   end
               end
       end.

(* The evaluation of a program is defined as the evaluation of the [main] of the Entryclass *)
Definition eval_prog n :=
  match ct Entry with
  | class nil nil Mtds =>
      match Mtds main  with
      | Some (method hot nil T e) => ⟦e⟧([(Entry, [])], [], 0, n)
      | _ => Error
      end
  | _ => Error
  end.

(* Associated tactics *)
Ltac destruct_eval He v σ' :=
  match goal with
  | H: context[ match ⟦ ?e ⟧(?σ, ?ρ, ?ψ , ?k) with _ => _ end ] |- _ =>
      destruct (⟦ e ⟧ (σ, ρ, ψ, k)) as [ | | v σ' ] eqn:He
  | H: context[ match ⟦_ ?el _⟧ (?σ, ?ρ, ?ψ, ?k) with _ => _ end ] |- _ =>
      destruct (⟦_ el _⟧ (σ, ρ, ψ, k)) as [ | | v σ' ] eqn:He
  end; try congruence.

Ltac destruct_eval_f :=
  let freshH := fresh "H" in
  let freshv := fresh "v" in
  let freshσ := fresh "σ" in
  destruct_eval freshH freshv freshσ.

(* ------------------------------------------------------------------------ *)
(** A simple result on lengths *)

Lemma EvalListLength :
  forall el n σ σ' ρ ψ vl ,
    ⟦_ el _⟧(σ, ρ, ψ, n) = Success_l vl σ' ->
    length el = length vl.
Proof.
  induction el; steps;
    destruct n; simpl; try discriminate.
  - inversion H; steps.
  - inversion H.
    destruct_eval_f ; steps.
    eapply IHel in matched1. steps.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Evaluator fuel-monotonicity *)
(* We show that adding more fuel does not changes a succeeding evaluation *)

Lemma eval_step_monotonicity_aux: forall n,
    (forall m, m > n ->
          (forall e σ ρ ψ v σ', ⟦ e ⟧ (σ, ρ, ψ, n) = Success v σ' ->
                           ⟦ e ⟧ (σ, ρ, ψ, m) = Success v σ')) /\
      (forall m, m > n ->
            (forall el σ ρ ψ vl σ', ⟦_ el _⟧ (σ, ρ, ψ, n) = Success_l vl σ' ->
                               ⟦_ el _⟧ (σ, ρ, ψ, m) = Success_l vl σ')) /\
      (forall m, m > n ->
            (forall C ψ x ρ σ σ', init C ψ x ρ σ n = Success_i σ' ->
                                  init C ψ x ρ σ m = Success_i σ')).
Proof with (try lia).
  induction n as [n IHn] using lt_wf_ind. destruct n.
  - repeat split; intros; inversion H0.
  - repeat split; intros ; destruct m...
    + (* expression *)
      destruct (IHn n) as [Hexp [Hlist Hinit]]...
      destruct e.
      * steps; eauto.
      * steps; eauto.
      * inversion H0; repeat destruct_match => //; subst.
        eapply (Hexp m) in matched; steps...
      * inversion H0; repeat destruct_match => //.
        rewrite_any.
        eapply (Hexp m) in matched, H2...
        eapply (Hlist m) in matched5...
        steps.
      * inversion H0; repeat destruct_match => //.
        rewrite_any.
        eapply (Hlist m) in matched...
        eapply (Hinit m) in matched0...
        steps.
      * inversion H0; repeat destruct_match => //; sort.
        rewrite_any.
        eapply (Hexp m) in matched, matched0, H2...
        steps.
    + (* lists *)
      simpl in *.
      destruct el; eauto.
      destruct_eval_f.
      eapply (IHn n)  with (m := m) in H1; eauto with lia.
      destruct_match; try discriminate.
      destruct_eval_f.
      inversion H1; subst.
      eapply (IHn n) with (m := m) in H2; eauto with lia.
      steps.
    + (* init *)
      simpl in *.
      ct_lookup C.
      destruct (nth_error Flds x) as [[_ e]|]; eauto.
      destruct_eval_f.
      eapply (IHn n)  with (m := m) in H1; eauto with lia.
      steps.
      eapply (IHn n) with (m := m); eauto with lia.
Qed.

Theorem eval_step_monotonicity:
  forall n m e σ ρ ψ l σ',
    n < m ->
    ⟦ e ⟧ (σ, ρ, ψ, n) = Success l σ' ->
    ⟦ e ⟧ (σ, ρ, ψ, m) = Success l σ'.
Proof.
  intros.
  pose proof (eval_step_monotonicity_aux n) as [He _].
  eauto with lia.
Qed.

Theorem evalList_step_monotonicity:
  forall n m el σ ρ ψ vl σ',
    n < m ->
    ⟦_ el _⟧ (σ, ρ, ψ, n) = Success_l vl σ' ->
    ⟦_ el _⟧ (σ, ρ, ψ, m) = Success_l vl σ'.
Proof.
  intros.
  pose proof (eval_step_monotonicity_aux n) as [_ [Hel _]].
  eauto with lia.
Qed.

Theorem init_step_monotonicity:
  forall n m C ρ ψ x σ σ',
    n < m ->
    init C ψ x ρ σ n = Success_i σ' ->
    init C ψ x ρ σ m = Success_i σ'.
Proof with try lia.
  intros.
  pose proof (eval_step_monotonicity_aux n) as [_ [_ H__init]].
  eauto with lia.
Qed.

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

(* The success of the big step predicates implies the success of the eval function *)
Lemma evalP_implies_eval :
  (forall e σ ρ ψ l σ',
      ⟦ e ⟧ (σ, ρ, ψ) --> (l,σ') ->
      exists n, ⟦ e ⟧ (σ, ρ, ψ, n) = Success l σ') /\
    (forall el σ ρ ψ vl σ',
        ⟦el⟧ (σ, ρ, ψ) --> (vl, σ') ->
        exists n, ⟦_ el _⟧ (σ, ρ, ψ, n) = Success_l vl σ') /\
    (forall C ψ x ρ σ σ',
        initP C ψ x ρ σ σ' ->
        exists n, init C ψ x ρ σ n = Success_i σ').
Proof with (cross_rewrites; eauto 3 using evalP, evalListP, initP; try lia).
  apply evalP_multi_ind; intros;
    try solve [exists 1; steps];
    repeat match goal with
      | H: exists n, _ |- _ => destruct H as [?n H]
      end.
  + exists (S n); steps.
  + remember (S (max n1 (max n0 n))) as n2.
    eapply eval_step_monotonicity with (m := n2) in IH__e0, IH__e2...
    eapply evalList_step_monotonicity with (m := n2) in IH__el...
    exists (S n2). simpl; repeat rewrite_any => //.
  + remember (S (max n n0)) as n1.
    eapply evalList_step_monotonicity with (m := n1) in IH__args...
    eapply init_step_monotonicity with (m := n1) in IH__init...
    exists (S n1). simpl; subst.
    rewrite IH__args IH__init => //.
  + remember (S (max n (max n0 n1))) as n2.
    eapply eval_step_monotonicity with (m := n2) in IH__e1, IH__e2, IH__e'...
    exists (S n2). simpl. rewrite IH__e1 IH__e2 IH__e'...
  + remember (S (max n n0)) as n1.
    eapply eval_step_monotonicity with (m := n1) in IH__e...
    eapply evalList_step_monotonicity with (m := n1) in IH__el...
    exists (S n1). simpl. rewrite IH__e IH__el...
  + exists 1; simpl. rewrite H__ct.
    lets [_ ?]: nth_error_None Flds (dom Flds).
    rewrite H...
    rewrite Nat.eqb_refl...

  + remember (S (max n n0)) as n1.
    eapply eval_step_monotonicity with (m := n1) in IH__e...
    eapply init_step_monotonicity with (m := n1) in IH__init...
    exists (S n1).
    simpl in *. rewrite H__ct H__fld IH__e H__assign...
Qed.

(* Conversely, the success of the eval function implies the success of the predicate *)
Lemma eval_implies_evalP :
  forall n,
    (forall e σ ρ ψ v σ',
        ⟦ e ⟧(σ, ρ, ψ, n) = Success v σ' -> ⟦ e ⟧(σ, ρ, ψ) --> (v, σ')) /\
      (forall el σ ρ ψ vl σ',
          ⟦_ el _⟧(σ, ρ, ψ, n) = Success_l vl σ' -> ⟦ el ⟧(σ, ρ, ψ) --> (vl,σ')) /\
      (forall C ψ x ρ σ σ',
          init C ψ x ρ σ n = Success_i σ' ->
          initP C ψ x ρ σ σ').
Proof with (eauto using evalP, evalListP, initP; try lia).
  induction n as [n IHn] using lt_wf_ind.
  destruct n; repeat split => //.
  all: intros; move : (IHn n) => [ ] // => IHn__e [IHn__el IHn__init]; clear IHn.
  + simpl in H. steps...
  + steps; eauto using evalP...
  + steps; eauto using initP...
    apply Nat.eqb_eq in matched1; subst...
Qed.

(* Then the theorem : *)
Theorem evalP_eval :
  forall e σ ρ ψ l σ',
    ⟦ e ⟧p (σ, ρ, ψ) --> (l,σ') <-> exists n, ⟦ e ⟧(σ, ρ, ψ, n) = Success l σ'.
Proof.
  split; intros;
    [eapply evalP_implies_eval| inverts H; eapply eval_implies_evalP]; eauto.
Qed.

(* Specialized lemmas *)
Corollary eval_implies_evalP_expr :
  forall e σ ρ ψ l σ' n,
    ⟦ e ⟧ (σ, ρ, ψ, n) = Success l σ' -> ⟦ e ⟧(σ, ρ, ψ) --> (l,σ').
Proof.
  intros; eapply eval_implies_evalP; eauto.
Qed.

Corollary eval_implies_evalP_list :
  forall el σ ρ ψ vl σ' n,
    ⟦_ el _⟧ (σ, ρ, ψ, n) = Success_l vl σ' -> ⟦ el ⟧(σ, ρ, ψ) --> (vl,σ').
Proof.
  intros; eapply eval_implies_evalP; eauto.
Qed.

Corollary init_implies_initP :
  forall C ψ x ρ σ n σ',
    init C ψ x ρ σ n = Success_i σ' ->
    initP C ψ x ρ σ σ'.
Proof.
  intros; eapply eval_implies_evalP; eauto.
Qed.