Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.
Require Import Coq.Lists.SetoidList.

Require Import Aniceto.Graphs.Graph.
Require Import Aniceto.Pair.
Require Import Aniceto.List.

Require Import HJ.Phasers.Lang.
Require Import HJ.Phasers.TransDiff.
Require Import HJ.Phasers.PhaseDiff.
Require Import HJ.Phasers.Typesystem.
Require Import HJ.Vars.
Require Import HJ.Tid.

Section SR.

Definition tid_eq_sig x y := if TID.eq_dec x y then 1%Z else 0%Z.

Definition wait_delta t e := ((tid_eq_sig (snd e) t) - (tid_eq_sig (fst e) t)) % Z.

Lemma wait_delta_refl:
  forall t t',
  wait_delta t (t', t') = 0%Z.
Proof.
  intros.
  unfold wait_delta, tid_eq_sig.
  simpl.
  destruct (TID.eq_dec t' t); intuition.
Qed.

Lemma wait_delta_left:
  forall t t',
  t <> t' ->
  wait_delta t (t, t') = (- 1)%Z.
Proof.
  intros.
  unfold wait_delta, tid_eq_sig.
  simpl.
  destruct (TID.eq_dec t' t), (TID.eq_dec t t);
  rewrite tid_eq_rw in *; subst; intuition.
Qed.

Lemma wait_delta_right:
  forall t t',
  t <> t' ->
  wait_delta t (t', t) = 1%Z.
Proof.
  intros.
  unfold wait_delta, tid_eq_sig.
  simpl.
  destruct (TID.eq_dec t' t), (TID.eq_dec t t);
  rewrite tid_eq_rw in *; subst; intuition.
Qed.

Lemma wait_delta_neq:
  forall t t1 t2,
  t <> t1 ->
  t <> t2 ->
  wait_delta t (t1, t2) = 0%Z.
Proof.
  intros.
  unfold wait_delta, tid_eq_sig.
  simpl.
  destruct (TID.eq_dec t1 t), (TID.eq_dec t2 t);
  rewrite tid_eq_rw in *; subst; intuition.
Qed.

Lemma wait_phase_wait:
  forall v,
  wait_phase (Taskview.wait v) = S (wait_phase v).
Proof.
  intros.
  unfold wait.
  simpl.
  intuition.
Qed.

Lemma Z_add_to_succ:
  forall p,
  Pos.add p xH = Pos.succ p.
Proof.
  intros.
  destruct p; repeat auto.
Qed.

Lemma Z_of_nat_succ:
  forall (n:nat),
  Z.of_nat (S n) = ((Z.of_nat n) + 1) % Z.
Proof.
 intros.
 unfold Z.of_nat.
 destruct n.
 - auto.
 - simpl.
   rewrite Z_add_to_succ.
   trivial.
Qed.

Lemma ph_diff_add_wait:
  forall t t1 t2 z v ph,
  ph_diff (Map_TID.add t (Taskview.wait v) ph) (t1, t2) z ->
  Map_TID.MapsTo t v ph ->
  ph_diff ph (t1, t2) (z + wait_delta t (t1, t2)).
Proof.
  intros.
    inversion H; subst; clear H.
    rewrite Map_TID_Facts.add_mapsto_iff in *.
    destruct H3 as [(?,?)|(?,?)].
    + destruct H5 as [(?,?)|(?,?)].
      * subst.
        subst.
        rewrite wait_delta_refl.
        remember (Z.of_nat (wait_phase (Taskview.wait v))) as z.
        assert (Heq: ((z - z + 0 = 0) %Z)). {
          intuition.
        }
        rewrite Heq.
        eauto using Map_TID_Extra.mapsto_to_in, ph_diff_refl.
      * subst.
        rewrite wait_delta_left; auto.
        rewrite wait_phase_wait.
        rewrite Z_of_nat_succ.
        assert (Heq:
          (Z.of_nat (wait_phase v) + 1 - Z.of_nat (wait_phase v2) + -1 =
          (Z.of_nat (wait_phase v) - Z.of_nat (wait_phase v2))) % Z). {
          intuition.
        }
        rewrite Heq.
        auto using ph_diff_def.
    + destruct H5 as [(?,?)|(?,?)].
      * subst.
        rewrite wait_delta_right; auto.
        rewrite wait_phase_wait.
        rewrite Z_of_nat_succ.
        assert (Heq: (
          (Z.of_nat (wait_phase v1) - (Z.of_nat (wait_phase v) + 1) + 1) =
          (Z.of_nat (wait_phase v1) - (Z.of_nat (wait_phase v)))) % Z). {
          intuition.
        }
        rewrite Heq.
        auto using ph_diff_def.
      * rewrite wait_delta_neq; repeat auto.
        assert (Heq: (
          (Z.of_nat (wait_phase v1) - Z.of_nat (wait_phase v2) + 0) =
          (Z.of_nat (wait_phase v1) - Z.of_nat (wait_phase v2))) % Z). {
          intuition.
        }
        rewrite Heq; auto using ph_diff.
Qed.

Lemma in_neq:
  forall t t1 ph,
  ~ Map_TID.In (elt:=taskview) t ph ->
  Map_TID.In (elt:=taskview) t1 ph ->
  t <> t1.
Proof.
  intros.
  destruct (TID.eq_dec t t1); repeat auto.
  subst.
  contradiction.
Qed.

Lemma ph_wait_in:
  forall t t' ph,
  Map_TID.In t (wait t' ph) ->
  Map_TID.In t ph.
Proof.
  intros.
  apply Map_TID_Extra.in_to_mapsto in H.
  destruct H as (v, mt).
  unfold wait, Phaser.update in *.
  remember (Map_TID.find _ _).
  symmetry in Heqo.
  destruct o as [v'|].
  - apply Map_TID_Facts.add_mapsto_iff in mt.
    rewrite <- Map_TID_Facts.find_mapsto_iff in Heqo.
    destruct mt.
    + destruct H.
      subst.
      eauto using Map_TID_Extra.mapsto_to_in.
    + destruct H; eauto using Map_TID_Extra.mapsto_to_in.
  - eauto using Map_TID_Extra.mapsto_to_in.
Qed.

Lemma ph_diff_apply_wait:
  forall t t1 t2 z ph,
  ph_diff (wait t ph) (t1, t2) z ->
  ph_diff ph (t1, t2) (z + wait_delta t (t1, t2)).
Proof.
  intros.
  remember (Map_TID.find t ph).
  symmetry in Heqo.
  destruct o as [v|].
  - apply Map_TID_Facts.find_mapsto_iff in Heqo.
    assert (R:=Heqo).
    apply wait_rw in R; rewrite R in *.
    eauto using ph_diff_add_wait.
 - unfold wait, Phaser.update in *.
   rewrite Heqo in *.
   rewrite <- Map_TID_Facts.not_find_in_iff in Heqo.
   assert (t <> t1). {
     apply ph_diff_inv_left in H.
     intuition; subst.
     contradiction.
   }
   assert (t <> t2). {
     apply ph_diff_inv_right in H.
     intuition; subst.
     contradiction.
   }
   rewrite wait_delta_neq; repeat auto.
   assert (Heq: ((z + 0 = z) % Z)); intuition.
   rewrite Heq.
   assumption.
Qed.

Lemma pm_diff_wait_all:
  forall t e z pm,
  pm_diff (wait_all t pm) e z ->
  pm_diff pm e (z + wait_delta t e).
Proof.
  intros.
  destruct e as (t1, t2).
  inversion H; subst; clear H.
  unfold foreach in *.
  apply Map_PHID_Facts.mapi_inv in H0.
  destruct H0 as (ph', (p', (?, (?, ?)))).
  subst.
  rename ph' into ph.
  eauto using ph_diff_apply_wait, pm_diff_def.
Qed.

Lemma walk2_wait_all:
  forall t pm t1 t2 w,
  Walk2 (HasDiff (pm_diff (wait_all t pm))) t1 t2 w ->
  Walk2 (HasDiff (pm_diff pm)) t1 t2 w.
Proof.
  intros.
  apply walk2_impl with (E:=HasDiff (pm_diff (wait_all t pm))); repeat auto.
  intros.
  unfold HasDiff in *.
  destruct e as (ta, tb).
  destruct H0 as (z, ?).
  eauto using pm_diff_wait_all.
Qed.

Lemma pm_diff_mapi_sig:
  forall t t1 t2 pm z,
  pm_diff (wait_all t pm) (t1, t2) z ->
  pm_diff pm (t1, t2) (z - (tid_eq_sig t1 t) + (tid_eq_sig t2 t)).
Proof.
  intros.
  assert (Heq: ((z - tid_eq_sig t1 t + tid_eq_sig t2 t) = (z + wait_delta t (t1, t2))) %Z). {
    unfold wait_delta.
    simpl.
    intuition.
  }
  rewrite Heq.
  eauto using pm_diff_wait_all.
Qed.

Lemma diff_sum_wait_all:
  forall w t t1 tn pm z,
  DiffSum (pm_diff (wait_all t pm)) w z ->
  StartsWith w t1 ->
  EndsWith w tn ->
  DiffSum (pm_diff pm) w (z - (tid_eq_sig t1 t) + (tid_eq_sig tn t)).
Proof.
  intros w.
  induction w.
  { (* absurd case *)
    intros.
    inversion H; subst.
    apply ends_with_nil_inv in H1.
    inversion H1.
  }
  intros.
  destruct a as (t1', t2).
  assert (t1' = t1). { eauto using starts_with_eq. }
  destruct w.
  - subst.
    inversion H.
    subst.
    assert (t2 = tn). {
      eauto using ends_with_eq.
    }
    subst.
    apply pm_diff_mapi_sig in H5.
    auto using diff_sum_pair.
  - subst.
    destruct p as (t2', t3).
    inversion H; subst; clear H.
    rename t2' into t2.
    assert (StartsWith ((t2, t3) :: w) t2). {
      eauto using starts_with_def.
    }
    apply ends_with_inv in H1.
    assert ( DiffSum (pm_diff pm) ((t2, t3) :: w) (s - tid_eq_sig t2 t + tid_eq_sig tn t)). {
      apply IHw; repeat auto.
    }
    apply pm_diff_mapi_sig in H9. (* invert diff_mapi *)
    simpl in *.
    assert (Heq: ((z0 + s - tid_eq_sig t1 t + tid_eq_sig tn t) =
          (z0 - tid_eq_sig t1 t + tid_eq_sig t2 t) +
          (s - tid_eq_sig t2 t + tid_eq_sig tn t)) % Z). { intuition. }
    rewrite Heq.
    auto using diff_sum_cons.
Qed.

Lemma transdiff_wait_all:
  forall t pm t1 t2 z,
  TransDiff (pm_diff (wait_all t pm)) t1 t2 z ->
  TransDiff (pm_diff pm) t1 t2 (z - (tid_eq_sig t1 t) + (tid_eq_sig t2 t)).
Proof.
  intros.
  inversion H; subst; clear H.
  apply walk2_wait_all in H1.
  inversion H1; subst.
  apply diff_sum_wait_all with (t1:=t1) (tn:=t2) in H0; repeat auto.
  eauto using trans_diff_def.
Qed.

Lemma sr_wait_all:
  forall pm t,
  Valid pm ->
  Valid (wait_all t pm).
Proof.
  unfold Valid in *.
  unfold TransDiffFun in *.
  intros.
  apply transdiff_wait_all in H0.
  apply transdiff_wait_all in H1.
  assert (Hx := H _ _ _ _ H0 H1).
  intuition.
Qed.

Section PreservesDiff.
  Variable f : phasermap -> phasermap.
(*
  Variable preserves_ph_diff:
    forall p ph pm z t1 t2,
    ph_diff ph t1 t2 z ->
    Map_PHID.MapsTo p ph (f pm) ->
    exists ph', Map_PHID.MapsTo p ph' pm /\ ph_diff ph' t1 t2 z.
*)
(*
  Let preserves_pm_diff:
    forall t1 t2 z pm,
    pm_diff (f pm) t1 t2 z ->
    pm_diff pm t1 t2 z.
  Proof.
    intros.
    inversion H; subst; clear H.
    apply preserves_ph_diff with (z:=z) (t1:=t1) (t2:=t2) in H0; auto.
    destruct H0 as (ph', (mt, d)).
    eauto using pm_diff_def.
  Qed.
*)
  Variable preserves_diff:
    forall e z pm,
    pm_diff (f pm) e z ->
    pm_diff pm e z.

  Lemma preserves_walk2:
    forall pm t1 t2 w,
    Walk2 (HasDiff (pm_diff (f pm))) t1 t2 w ->
    Walk2 (HasDiff (pm_diff pm)) t1 t2 w.
  Proof.
    intros.
    apply walk2_impl with (E:=HasDiff (pm_diff (f pm))); repeat auto.
    intros.
    unfold HasDiff in *.
    destruct e as (ta, tb).
    destruct H0 as (z, ?).
    eauto using preserves_diff.
  Qed.

  Let preserves_diff_sum:
    forall w t1 tn pm z,
    DiffSum (pm_diff (f pm)) w z ->
    StartsWith w t1 ->
    EndsWith w tn ->
    DiffSum (pm_diff pm) w z.
  Proof.
    intros w.
    induction w.
    { (* absurd case *)
      intros.
      inversion H; subst.
      apply ends_with_nil_inv in H1.
      inversion H1.
    }
    intros.
    destruct a as (t1', t2).
    assert (t1' = t1) by eauto using starts_with_eq.
    destruct w; subst.
    - inversion H.
      assert (t2 = tn) by eauto using ends_with_eq.
      subst.
      auto using preserves_diff, diff_sum_pair.
    - destruct p as (t2', t3).
      inversion H; subst; clear H.
      rename t2' into t2.
      assert (StartsWith ((t2, t3) :: w) t2). {
        eauto using starts_with_def.
      }
      apply ends_with_inv in H1.
      assert ( DiffSum (pm_diff pm) ((t2, t3) :: w) s) by eauto.
      apply preserves_diff in H9. (* invert diff_mapi *)
      simpl in *.
      auto using diff_sum_cons.
  Qed.

  Let preserves_transdiff:
    forall pm t1 t2 z,
    TransDiff (pm_diff (f pm)) t1 t2 z ->
    TransDiff (pm_diff pm) t1 t2 z.
  Proof.
    intros.
    inversion H; subst; clear H.
    apply preserves_walk2 in H1.
    inversion H1; subst.
    eauto using trans_diff_def, preserves_diff_sum.
  Qed.

  Lemma preserves_diff_sr:
    forall pm,
    Valid pm ->
    Valid (f pm).
  Proof.
    unfold Valid in *.
    unfold TransDiffFun in *.
    intros.
    eauto using preserves_transdiff.
  Qed.

End PreservesDiff.

Section Drop.
  Let ph_diff_apply_drop:
    forall t e z ph,
    ph_diff (drop t ph) e z ->
    ph_diff ph e z.
  Proof.
    intros.
    inversion H; subst.
    apply drop_mapsto_inv in H0.
    apply drop_mapsto_inv in H1.
    destruct H0; destruct H1.
    auto using ph_diff_def.
  Qed.

  Let ph_diff_drop_all:
    forall t e z pm,
    pm_diff (drop_all t pm) e z ->
    pm_diff pm e z.
  Proof.
    intros.
    unfold drop_all, foreach in *.
    inversion H; subst; clear H.
    inversion H1; subst; clear H1.
    apply Map_PHID_Facts.mapi_inv in H0.
    destruct H0 as (ph', (p', (?, (?, ?)))).
    subst.
    eauto using pm_diff_def, ph_diff_def.
  Qed.

  Lemma sr_drop_all:
    forall pm t,
    Valid pm ->
    Valid (drop_all t pm).
  Proof.
    intros.
    eauto using preserves_diff_sr, ph_diff_drop_all.
  Qed.

  Let pm_diff_preserves_drop:
    forall p t pm e z,
    pm_diff (ph_drop p t pm) e z ->
    pm_diff pm e z.
  Proof.
    intros.
    inversion H; subst; clear H.
    unfold ph_drop, update in *.
    remember (Map_PHID.find  _ _).
    symmetry in Heqo.
    destruct o as [ph'|].
    - rewrite <- Map_PHID_Facts.find_mapsto_iff in Heqo.
      apply Map_PHID_Facts.add_mapsto_iff in H0.
      destruct H0.
      + destruct H.
        subst.
        eauto using pm_diff_def, ph_diff_def.
      + destruct H.
        eauto using pm_diff_def, ph_diff_def.
    - eauto using pm_diff_def, ph_diff_def.
  Qed.

  Lemma sr_ph_drop:
    forall pm p t,
    Valid pm ->
    Valid (ph_drop p t pm).
  Proof.
    intros.
    eauto using preserves_diff_sr.
  Qed.

End Drop.

Section Signal.
  Let ph_diff_signal:
    forall t e z ph,
    ph_diff (signal t ph) e z ->
    ph_diff ph e z.
  Proof.
    intros.
    inversion H; subst.
    apply signal_mapsto_inv in H0.
    apply signal_mapsto_inv in H1.
    destruct H0.
    - destruct H1.
      + destruct a as (?, (?,(?,?))).
        destruct a0 as (?, (?,(?,?))).
        subst.
        repeat rewrite signal_preserves_wait_phase in *.
        auto using ph_diff_def.
      + destruct a as (?, (?,(?,?))).
        destruct a0 as (?, ?).
        subst.
        repeat rewrite signal_preserves_wait_phase in *.
        auto using ph_diff_def.
    - destruct H1.
      + destruct a0 as (?, (?,(?,?))).
        destruct a as (?, ?).
        subst.
        repeat rewrite signal_preserves_wait_phase in *.
        auto using ph_diff_def.
      + destruct a0 as (?, ?).
        destruct a as (?, ?).
        subst.
        repeat rewrite signal_preserves_wait_phase in *.
        auto using ph_diff_def.
  Qed.

  Let ph_diff_try_signal:
    forall t e z ph,
    ph_diff (try_signal t ph) e z ->
    ph_diff ph e z.
  Proof.
    intros.
    inversion H; subst.
    apply try_signal_mapsto_inv in H0.
    apply try_signal_mapsto_inv in H1.
    destruct H0.
    - destruct H1.
      + destruct a as (?, (?,(?,?))).
        destruct a0 as (?, (?,(?,?))).
        subst.
        repeat rewrite try_signal_preserves_wait_phase in *.
        auto using ph_diff_def.
      + destruct a as (?, (?,(?,?))).
        destruct a0 as (?, ?).
        subst.
        repeat rewrite try_signal_preserves_wait_phase in *.
        auto using ph_diff_def.
    - destruct H1.
      + destruct a0 as (?, (?,(?,?))).
        destruct a as (?, ?).
        subst.
        repeat rewrite try_signal_preserves_wait_phase in *.
        auto using ph_diff_def.
      + destruct a0 as (?, ?).
        destruct a as (?, ?).
        subst.
        repeat rewrite try_signal_preserves_wait_phase in *.
        auto using ph_diff_def.
  Qed.

  Let pm_diff_signal_all:
    forall t e z pm,
    pm_diff (signal_all t pm) e z ->
    pm_diff pm e z.
  Proof.
    intros.
    unfold signal_all, foreach in *.
    inversion H; subst; clear H.
    apply Map_PHID_Facts.mapi_inv in H0.
    destruct H0 as (ph', (p', (?, (?, ?)))).
    subst.
    eauto using pm_diff_def, ph_diff_def, ph_diff_try_signal.
  Qed.

  Lemma sr_signal_all:
    forall pm t,
    Valid pm ->
    Valid (signal_all t pm).
  Proof.
    eauto using preserves_diff_sr, pm_diff_signal_all.
  Qed.

  Let pm_diff_ph_signal:
    forall p' t e z pm,
    pm_diff (ph_signal p' t pm) e z ->
    pm_diff pm e z.
  Proof.
    intros.
    inversion H; subst; clear H.
    unfold ph_signal, update in *.
    remember (Map_PHID.find  _ _).
    symmetry in Heqo.
    destruct o as [ph'|].
    - rewrite <- Map_PHID_Facts.find_mapsto_iff in Heqo.
      apply Map_PHID_Facts.add_mapsto_iff in H0.
      destruct H0.
      + destruct H.
        subst.
        eauto using pm_diff_def, ph_diff_def.
      + destruct H.
        eauto using pm_diff_def, ph_diff_def.
    - eauto using pm_diff_def, ph_diff_def.
  Qed.

  Lemma sr_ph_signal:
    forall pm p t,
    Valid pm ->
    Valid (ph_signal p t pm).
  Proof.
    intros.
    eauto using preserves_diff_sr, pm_diff_ph_signal.
  Qed.

End Signal.

  Let DiffSumEx E (m:phasermap) t1 t2 w z :=
    DiffSum (pm_diff m) w z /\ Walk2 E t1 t2 w.

  Let diff_sum_ex_cons:
    forall (E:(tid*tid)->Prop) m t1 t2 tn l s z,
    E (t1, t2) ->
    pm_diff m (t1, t2) z ->
    DiffSumEx E m t2 tn l s ->
    DiffSumEx E m t1 tn ((t1, t2) :: l) (z + s).
  Proof.
    intros.
    unfold DiffSumEx in *.
    destruct H1.
    split.
    - destruct l. {
        inversion H2.
        subst.
        apply ends_with_nil_inv in H4.
        inversion H4.
      }
      destruct p.
      inversion H2.
      subst.
      assert (t = t2). {
        eauto using starts_with_eq.
      }
      subst.
      auto using diff_sum_cons.
    - auto using walk2_cons.
  Qed.

Section PhNew.
  (**
    The gist of the proof is on taking a diff sum on [ph_new p t pm]
    and creating a new diff sum with the same result on [pm].
    The difficulty in doing this translation is that the path in the
    diff sum mentions phaser [p], then [p] is not in [pm]. But
    we also know that if [p] is mentioned in the original diff sum,
    then it can only be a self loop where we are comparing [t] with
    itself via [p] and the diff is zero, in which case we can discard
    any edge (t, t) and obtain a diff sum on [pm] with the same result. *)

  Let pm_diff_ph_new:
    forall p t t1 t2 z pm,
    (t1 <> t \/ t2 <> t) ->
    pm_diff (ph_new p t pm) (t1, t2) z ->
    pm_diff pm (t1, t2) z.
  Proof.
    intros.
    unfold ph_new in *.
    inversion H0; subst.
    apply Map_PHID_Facts.add_mapsto_iff in H1.
    destruct H1.
    - destruct H1.
      subst.
      inversion H2; subst; clear H2.
      apply make_mapsto in H4.
      apply make_mapsto in H6.
      destruct H4, H6.
      repeat subst.
      destruct H;
      contradiction H; trivial.
    - destruct H1.
      eauto using pm_diff_def.
  Qed.

  (* Removes all self links *)

  Variable t:tid.

  Let skip_self p := if pair_eq_dec TID.eq_dec (t,t) p then false else true.

  Let skip_self_inv_false:
    forall x y,
    skip_self (x, y) = false ->
    x = t /\ y = t.
  Proof.
    unfold skip_self.
    intros.
    remember (pair_eq_dec _ _ _).
    destruct s.
    - inversion e; auto.
    - inversion H.
  Qed.

  Let skip_self_inv_true:
    forall x y,
    skip_self (x, y) = true ->
    x <> t \/ y <> t.
  Proof.
    unfold skip_self.
    intros.
    remember (pair_eq_dec _ _ _).
    destruct s.
    - inversion H.
    - destruct (TID.eq_dec x t). {
        subst.
        right.
        destruct (TID.eq_dec y t). {
          subst.
          contradiction n.
          trivial.
        }
        auto.
      }
      intuition.
  Qed.

  Let linked_filter_self:
    forall a w,
    Linked a w ->
    Connected w ->
    Linked a (filter skip_self w).
  Proof.
    intros.
    induction w as [|e].
    - auto.
    - destruct a as (x, y).
      destruct e as (y', z).
      assert (Hx:= H).
      apply linked_inv in H.
      subst.
      simpl.
      remember (skip_self (y, z)).
      symmetry in Heqb.
      destruct b; auto using linked_eq.
      apply skip_self_inv_false in Heqb.
      destruct Heqb.
      subst.
      inversion H0; subst.
      assert (Linked (x, t) w) by auto.
      auto.
  Qed.

  Let walk_filter_self:
    forall E w,
    Walk E w ->
    Walk E (filter skip_self w).
  Proof.
    intros.
    induction w.
    - simpl in *.
      auto.
    - simpl.
      remember (skip_self a).
      symmetry in Heqb.
      destruct b.
      + inversion H; subst.
        assert (Hx := H2).
        apply walk_inv in H2; destruct H2.
        auto using walk_cons.
      + destruct a as (x,y).
        apply skip_self_inv_false in Heqb.
        destruct Heqb.
        subst.
        inversion H; auto.
  Qed.

  Let filter_skip_inv_cons_eq_nil:
    forall w p,
    filter skip_self (p :: w) = nil ->
    p = (t, t).
  Proof.
    intros.
    simpl in H.
    remember (skip_self p).
    symmetry in Heqb.
    destruct b. {
      inversion H.
    }
    destruct p.
    apply skip_self_inv_false in Heqb.
    destruct Heqb.
    subst.
    trivial.
  Qed.

  Let filter_skip_inv_ends_with:
    forall w p,
    filter skip_self (p :: w) = nil ->
    EndsWith (p::w) t.
  Proof.
    induction w; intros.
    - apply filter_skip_inv_cons_eq_nil in H.
      subst.
      auto using ends_with_edge.
    - apply ends_with_cons.
      apply IHw.
      simpl in *.
      destruct (skip_self p).
      + inversion H.
      + auto.
  Qed.

  Let filter_skip_ends_with:
    forall E w x,
    Walk E w ->
    EndsWith w x ->
    filter skip_self w = nil \/
    EndsWith (filter skip_self w) x.
  Proof.
    induction w; intros. {
      apply ends_with_nil_inv in H0.
      inversion H0.
    }
    simpl.
    remember (skip_self a).
    symmetry in Heqb.
    destruct w. {
      destruct a as (y,x').
      apply ends_with_inv_cons_nil in H0.
      destruct b. {
        right.
        subst.
        simpl.
        auto using ends_with_edge.
      }
      apply skip_self_inv_false in Heqb.
      destruct Heqb.
      repeat subst.
      intuition.
    }
    assert (ew : EndsWith (p :: w) x) by eauto using ends_with_inv.
    assert (W:  Walk E (p :: w)) by (inversion H; auto).
    apply IHw in ew; auto.
    destruct b. {
      right.
      destruct ew as [ew|ew]. {
        rewrite ew.
        assert (Hx := ew).
        apply filter_skip_inv_cons_eq_nil in ew.
        apply filter_skip_inv_ends_with in Hx.
        subst.
        inversion H.
        subst.
        destruct a as (a, t').
        apply linked_inv in H5.
        rewrite <- H5 in *.
        apply ends_with_inv in H0.
        assert (x = t). {
          eauto using ends_with_fun.
        }
        rewrite H1.
        auto using ends_with_edge.
      }
      auto using ends_with_cons.
    }
    intuition.
  Qed.

  Let ends_with_filter_skip:
    forall E t1 t2 tn l,
    Walk E ((t1, t2) :: l) ->
    EndsWith ((t1, t2) :: l) tn ->
    filter skip_self l = nil ->
    EndsWith ((t1, t2) :: nil) tn.
  Proof.
    intros.
    destruct l. {
      assumption.
    }
    apply ends_with_inv in H0.
    assert (tn = t). {
      apply filter_skip_inv_ends_with in H1.
      eauto using ends_with_fun.
    }
    subst.
    assert (t2 = t). {
      assert (R: p = (t, t)). {
        assert (List.In p (p :: l)) by auto using in_eq.
        assert (R: ~ List.In p (filter skip_self (p :: l))). {
          rewrite H1.
          intuition.
        }
        apply filter_notin_to_false in R; auto.
        destruct p.
        apply skip_self_inv_false in R.
        destruct R.
        subst; auto.
      }
      subst.
      inversion H.
      subst.
      eauto using linked_inv.
    }
    subst; auto using ends_with_edge.
  Qed.

  Let filter_skip_walk2_aux_1:
    forall p w E t1 t2 tn,
    filter skip_self (p :: w) = nil ->
    Walk2 E t2 tn (p :: w) ->
    EndsWith ((t1,t2) :: filter skip_self (p :: w)) tn.
  Proof.
    intros.
    assert (Hx := H0).
    inversion Hx.
            subst.
            assert (tn = t). {
              eauto using filter_skip_inv_ends_with, ends_with_fun.
            }
            apply walk2_inv_cons in Hx.
            destruct Hx as (?, (?,?)).
            rewrite H.
            subst.
            assert (R: t2 = t). {
              assert (Hy : List.In (t2, x) ((t2,x) :: w)) by auto using in_eq.
              apply filter_notin_to_false with (f:=skip_self) in Hy.
              - apply skip_self_inv_false in Hy.
                destruct Hy; auto.
              - rewrite H.
                intuition.
            }
            subst.
            auto using ends_with_edge.
  Qed.

  Let filter_skip_walk2:
    forall E tn w t1,
    Walk2 E t1 tn w ->
    filter skip_self w = nil \/
    Walk2 E t1 tn (filter skip_self w).
  Proof.
    induction w; intros. {
      intuition.
    }
    simpl in *.
    remember (skip_self a).
    symmetry in Heqb.
    destruct w.
    - simpl in *.
      destruct b. {
        auto.
      }
      intuition.
    - apply walk2_inv in H.
      destruct H as (t2,(?,(?,?))).
      destruct b. {
        right.
        assert (Hx:=H1).
        apply IHw in H1.
        destruct H1.
        - apply walk2_def.
          + subst; auto using starts_with_def.
          + rewrite H in *.
            apply filter_skip_walk2_aux_1 with (E:=E) (t1:=t1) (t2:=t2) (tn:=tn) in H1; auto.
          + rewrite H1.
            subst.
            auto using edge_to_walk.
        - subst.
          auto using walk2_cons.
      }
      destruct a as (x, y).
      apply skip_self_inv_false in Heqb.
      inversion H; subst; clear H.
      destruct Heqb; subst.
      subst.
      apply IHw in H1.
      destruct H1; auto.
  Qed.

  Let diff_sum_2_sieve:
    forall E m tn w t1 z,
    DiffSumEx E m t1 tn w z ->
    ((filter skip_self w = nil /\ z = 0%Z)
    \/ (filter skip_self w <> nil /\ DiffSumEx E m t1 tn (filter skip_self w) z)).
  Proof.
    induction w; intros. {
      destruct H as (?, ?).
      inversion H.
      left.
      intuition.
    }
    destruct H as (?, ?).
    destruct a as (t1', t2).
    inversion H0; subst.
    assert (t1' = t1) by
    eauto using starts_with_eq; subst.
    simpl.
    remember (skip_self (t1, t2)).
    symmetry in Heqb.
    destruct b. {
      right.
      inversion H; subst.
      - simpl.
        split; try split; auto with *.
      - rename w0 into w.
        assert (D: DiffSumEx E m t2 tn ((t2,t4)::w) s). {
          unfold DiffSumEx.
          apply walk2_inv_2 in H0.
          intuition.
        }
        apply IHw in D.
        split; auto with *.
        destruct D as [(R1,?)|?]. {
          assert (R2: (z0 + s = z0)%Z) by
          intuition.
          rewrite R1.
          rewrite R2.
          split.
          - inversion H3.
            auto using diff_sum_pair.
          - apply filter_skip_walk2 in H0.
            remember ((t2,t4)::_) as l.
            destruct H0. {
              assert (R3: (t1,t2)::filter skip_self l = filter skip_self ((t1, t2) :: l)). {
              simpl.
              rewrite Heqb.
              trivial.
            }
            rewrite R1 in R3.
            rewrite <- R3 in H0.
            inversion H0.
          }
          rewrite <- R1.
          simpl in H0.
          rewrite Heqb in *.
          assumption.
        }
        destruct H4.
        apply diff_sum_ex_cons.
        + inversion H3; auto.
        + inversion H; auto.
        + auto.
      }
      apply skip_self_inv_false in Heqb.
      destruct Heqb; subst.
      destruct w. {
        left.
        inversion H.
        subst.
        simpl in *.
        apply pm_diff_refl_inv in H7.
        intuition.
      }
      destruct p as (t', t1).
      assert (t' = t). {
        inversion H3.
        subst.
        eauto using linked_inv.
      }
      subst.
      assert (DiffSumEx E m t tn ((t,t1)::w) z). {
        apply walk2_inv_2 in H0.
        split.
        - inversion H; subst.
          assert (z0 = 0%Z) by eauto using pm_diff_refl_inv.
          subst.
          inversion H.
          subst.
          assert ((0 + s = s)%Z). {
            intuition.
          }
          rewrite H4 in *.
          rewrite H6.
          apply pm_diff_refl_inv in H14.
          subst.
          assert (R: (0 + s0 = s0)%Z) by intuition.
          rewrite R.
          assumption.
        - assumption.
      }
      auto.
  Qed.

  Let transdiff_diff_sum_ex:
    forall m tn t1 z,
    TransDiff (pm_diff m) t1 tn z ->
    ((t1 = t /\ tn = t /\ z = 0%Z)
    \/ exists w, w <> nil /\ DiffSumEx (HasDiff (pm_diff m)) m t1 tn (filter skip_self w) z).
  Proof.
    intros.
    inversion H.
    subst.
    assert (DiffSumEx (HasDiff (pm_diff m)) m t1  tn w z). {
      split; auto.
    }
    apply diff_sum_2_sieve in H2.
    destruct H2.
    - left.
      inversion H1.
      subst.
      destruct w. {
        apply ends_with_nil_inv in H4.
        inversion H4.
      }
      destruct p as (t1', ?).
      assert (t1' = t1). {
       eauto using starts_with_eq.
      }
      subst.
      destruct H2.
      assert (t1 = t). {
        assert (Hx : ~ List.In (t1, t0) (filter skip_self ((t1, t0) :: w))). {
          rewrite H2.
          intuition.
        }
        apply filter_notin_to_false in Hx.
        - apply skip_self_inv_false in Hx; destruct Hx; subst; auto.
        - auto using in_eq.
      }
      assert (tn = t). {
        eauto using ends_with_fun, filter_skip_inv_ends_with.
      }
      intuition.
    - right.
      destruct H2.
      exists w.
      split.
      + intuition.
        subst.
        auto.
      + auto.
  Qed.

  Let in_pm_diff:
    forall p m w e z,
    List.In e (filter skip_self w) ->
    pm_diff (ph_new p t m) e z ->
    pm_diff m e z.
  Proof.
    intros.
    destruct e as (ti, tj).
    rewrite filter_In in H.
    destruct H.
    apply skip_self_inv_true in H1.
    eauto using pm_diff_ph_new.
  Qed.

  Let has_diff_trans:
    forall p t1 tn m z w,
    DiffSumEx (HasDiff (pm_diff (ph_new p t m))) (ph_new p t m) t1 tn (filter skip_self w) z ->
    DiffSumEx (HasDiff (pm_diff m)) m t1 tn (filter skip_self w) z.
  Proof.
    intros.
    destruct H.
    split.
    - eauto using diff_sum_impl_weak.
    - apply walk2_impl_weak with (E:=(HasDiff (pm_diff (ph_new p t m)))); auto.
      intros.
      inversion H2.
      unfold HasDiff.
      eauto.
  Qed.

  Let transdiff_fin:
    forall p m tn t1 z,
    TransDiff (pm_diff (ph_new p t m)) t1 tn z ->
    ((t1 = t /\ tn = t /\ z = 0%Z)
    \/ TransDiff (pm_diff m) t1 tn z).
  Proof.
    intros.
    apply transdiff_diff_sum_ex in H.
    destruct H. {
      intuition.
    }
    right.
    destruct H as (w, (Hn, Hd)).
    apply has_diff_trans in Hd.
    inversion Hd.
    eauto using trans_diff_def.
  Qed.

  Lemma pm_diff_to_refl_left:
    forall t1 t2 z pm,
    pm_diff pm (t1, t2) z ->
    pm_diff pm (t1, t1) 0%Z.
  Proof.
    intros.
    inversion H.
    apply ph_diff_inv_left in H1.
    eauto using pm_diff_refl.
  Qed.

  Lemma trans_diff_inv_refl:
    forall t pm z,
    TransDiff (pm_diff pm) t t z ->
    TransDiff (pm_diff pm) t t 0%Z.
  Proof.
    intros.
    inversion H.
    subst.
    inversion H0; subst; auto.
    - assert (t1 = t0). {
        inversion H1; eauto using starts_with_eq.
      }
      subst.
      assert (pm_diff pm (t0, t0) 0%Z). {
        eauto using pm_diff_to_refl_left.
      }
      apply trans_diff_def with ((t0,t0)::nil).
      auto using diff_sum_pair.
      apply edge_to_walk2.
      unfold HasDiff.
      eauto.
    - assert (t1 = t0). {
        inversion H1; eauto using starts_with_eq.
      }
      subst.
      assert (pm_diff pm (t0, t0) 0%Z). {
        eauto using pm_diff_to_refl_left.
      }
      apply trans_diff_def with ((t0,t0)::nil).
      auto using diff_sum_pair.
      apply edge_to_walk2.
      unfold HasDiff.
      eauto.
  Qed.

  Lemma sr_ph_new:
    forall p pm,
    Valid pm ->
    Valid (ph_new p t pm).
  Proof.
    unfold Valid in *.
    unfold TransDiffFun in *.
    intros.
    apply transdiff_fin in H0.
    apply transdiff_fin in H1.
    destruct H0, H1.
    - intuition.
    - destruct H0 as (?,(?,?)).
      subst.
      eauto using trans_diff_inv_refl.
    - destruct H1 as (?,(?,?)).
      subst.
      eauto using trans_diff_inv_refl.
    - eauto.
  Qed.

End PhNew.

Section Async.

  (**
    The idea behind the proof of subject reduction for async is that given a
    phasermap [async ps t m], for any diff-sum ranging from [t1] to task [t2]
    with path [w] and a sum of [s], you define [sigma] as replacing [t'] by [t]
    and then create a diff-sum from [sigma t1] to [sigma t2] with a path of
    [map sigma w] that also has a sum of [s].
  *)

  Variable t:tid.
(*
  Variable p : phid.
*)
  Variable pm : phasermap.

  Variable ps : phased.

  Let chg_tid t' := if TID.eq_dec t' (get_new_task ps) then t else t'.

  Let chg_edge (e:tid * tid) := match e with (x,y) => (chg_tid x, chg_tid y) end.

  Variable pre: AsyncPre ps t pm.

  Notation pm' := (async ps t pm).

  Let chg_edge_inv:
    forall pi ph ti v,
    Map_PHID.MapsTo pi ph pm' ->
    Map_TID.MapsTo ti v ph ->
    (exists ph' v', Map_PHID.MapsTo pi ph' pm /\ Map_TID.MapsTo t v' ph' /\ wait_phase v = wait_phase v') \/
    (exists ph' v', Map_PHID.MapsTo pi ph' pm /\ Map_TID.MapsTo ti v' ph' /\ wait_phase v = wait_phase v').
  Proof.
    intros.
    apply async_mapsto_rw in H.
    destruct H as (ph', (R, mt)).
    rewrite R in *; clear R.
    destruct (async_1_rw ps t pi ph').
    - destruct e as (r, (i, R)).
      rewrite R in *; clear R.
      apply register_inv_mapsto in H0.
      destruct H0 as [mt2|(?, (v', (mt2, R)))].
      + right; eauto.
      + left.
        subst.
        exists ph'.
        exists v'.
        intuition.
   - destruct a as (R, Hx).
     right.
     rewrite R in *; clear R.
     eauto.
  Qed.

  Let chg_tid_impl:
    forall p ph x v,
    Map_PHID.MapsTo p ph pm' ->
    Map_TID.MapsTo x v ph ->
    exists ph' v',
    Map_PHID.MapsTo p ph' pm /\
    Map_TID.MapsTo (chg_tid x) v' ph' /\
    wait_phase v = wait_phase v'.
  Proof.
    intros.
    destruct (Map_PHID_Extra.in_dec phid_eq_rw p (get_args ps)). {
      apply Map_PHID_Extra.in_to_mapsto in i.
      rewrite async_mapsto_rw in H.
      destruct H as  (ph', (R, mt)).
      rewrite R in *; clear R.
      unfold chg_tid.
      destruct i as (r, ?).
      destruct (TID.eq_dec x (get_new_task ps)). {
        subst.
        assert (Map_TID.In t ph') by eauto using async_pre_to_in_ph.
        apply async_1_mapsto_eq with (r:=r) in H0; auto.
        destruct H0 as (v1', (mt1, R1)).
        subst.
        eauto.
      }
      apply async_1_mapsto_neq in H0; auto; clear n.
      eauto.
    }
    rewrite async_mapsto_rw in H.
    destruct H as  (ph', (R, mt)).
    subst.
    apply async_1_mapsto in H0.
    destruct H0 as [?|(v',(r,(?,(?,mt'))))]. {
      unfold chg_tid.
      destruct (TID.eq_dec x (get_new_task ps)). {
        subst.
        inversion pre.
        contradiction H1.
        eapply in_def; eauto using Map_TID_Extra.mapsto_to_in.
      }
      eauto.
    }
    subst.
    contradiction n.
    eauto using Map_PHID_Extra.mapsto_to_in.
  Qed.

  Let chg_edge_ph_impl:
    forall p ph e z,
    Map_PHID.MapsTo p ph pm' ->
    ph_diff ph e z ->
    exists ph',
    Map_PHID.MapsTo p ph' pm /\ ph_diff ph' (chg_edge e) z.
  Proof.
    intros.
    destruct e as (x,y).
    simpl in *.
    inversion H0; subst; clear H0.
    apply chg_tid_impl with (p:=p) in H3; auto.
    destruct H3 as (ph1, (v1', (mt1, (mt2, R1)))).
    rewrite R1; clear R1.
    apply chg_tid_impl with (p:=p) in H5; auto.
    destruct H5 as (ph2, (v2', (mt3, (mt4, R2)))).
    rewrite R2; clear R2.
    assert (ph2 = ph1) by eauto using Map_PHID_Facts.MapsTo_fun; subst.
    eauto using ph_diff_def.
  Qed.

  Let chg_edge_impl:
    forall p ph e z,
    Map_PHID.MapsTo p ph pm' ->
    ph_diff ph e z ->
    pm_diff pm (chg_edge e) z.
  Proof.
    intros.
    destruct e as (x,y).
    simpl in *.
    eapply chg_edge_ph_impl in H0; eauto.
    destruct H0 as (?, (?,?)).
    eauto using pm_diff_def.
  Qed.

  Let edge_impl:
    forall e z,
    pm_diff pm' e z ->
    pm_diff pm (chg_edge e) z.
  Proof.
    intros.
    inversion H; clear H.
    inversion pre; clear pre.
    eauto.
  Qed.

  Let walk_chg_edge:
    forall w,
    Walk (HasDiff (pm_diff pm')) w ->
    Walk (HasDiff (pm_diff pm)) (map chg_edge w).
  Proof.
    intros.
    apply walk_map_impl with (E:=(HasDiff (pm_diff pm'))); intros; auto.
    - destruct H0.
      unfold HasDiff.
      exists x.
      eauto.
    - destruct w0.
      + apply linked_nil.
      + destruct p as (x, y).
        simpl.
        destruct a as (a,b).
        apply linked_inv in H0.
        simpl in *.
        subst.
        apply linked_eq.
  Qed.

  Let starts_with_chg_edge:
    forall w x,
    StartsWith w x ->
    StartsWith (map chg_edge w) (chg_tid x).
  Proof.
    destruct w; intros. {
      apply starts_with_inv_nil in H.
      inversion H.
    }
    destruct p as (a,b).
    simpl.
    apply starts_with_eq in H.
    subst.
    auto using starts_with_def.
  Qed.

  Let ends_with_chg_edge:
    forall w x,
    EndsWith w x ->
    EndsWith (map chg_edge w) (chg_tid x).
  Proof.
    induction w; intros. {
      apply ends_with_nil_inv in H.
      inversion H.
    }
    destruct a as (a,b).
    destruct w. {
      simpl.
      apply ends_with_eq in H; subst.
      eauto using ends_with_edge.
    }
    simpl in *.
    apply ends_with_inv in H.
    eauto using ends_with_cons.
  Qed.

  Let walk2_chg_edge:
    forall t1 t2 w,
    Walk2 (HasDiff (pm_diff pm')) t1 t2 w ->
    Walk2 (HasDiff (pm_diff pm)) (chg_tid t1) (chg_tid t2) (map chg_edge w).
  Proof.
    intros.
    inversion H.
    subst.
    eauto using walk2_def.
  Qed.

  Let diff_sum_chg_edge:
    forall w z,
    DiffSum (pm_diff pm') w z ->
    DiffSum (pm_diff pm) (map chg_edge w) z.
  Proof.
    induction w; intros.
    - simpl.
      inversion H.
      subst.
      auto using diff_sum_nil.
    - inversion H; subst.
      + inversion H.
        subst.
        simpl.
        apply edge_impl in H4.
        simpl in *.
        auto using diff_sum_pair.
      + apply edge_impl in H4.
        simpl in *.
        auto using diff_sum_cons.
  Qed.

  Let trans_diff_chg:
    forall t1 t2 z,
    TransDiff (pm_diff pm') t1 t2 z ->
    TransDiff (pm_diff pm) (chg_tid t1) (chg_tid t2) z.
  Proof.
    intros.
    inversion H.
    subst.
    eauto using trans_diff_def.
  Qed.

  Lemma sr_async:
    Valid pm ->
    Valid pm'.
  Proof.
    intros.
    unfold Valid in *.
    unfold TransDiffFun in *.
    intros.
    eauto.
  Qed.

End Async.

  Lemma subject_reduction:
    forall m t o m',
    Valid m ->
    Reduces m t o m' ->
    Valid m'.
  Proof.
    intros.
    destruct H0.
    destruct o; simpl in *.
    - auto using sr_ph_new.
    - auto using sr_ph_signal.
    - auto using sr_ph_drop.
    - auto using sr_signal_all.
    - auto using sr_wait_all.
    - auto using sr_drop_all.
    - auto using sr_async.
  Qed.
(*
  Lemma diff_sum_absurd_make:
    forall w z,
    ~ DiffSum (pm_diff make) w z.
  Proof.
    unfold not,make; intros.
    inversion H; subst; clear H.
    -
  Qed.
*)

  Lemma pm_diff_absurd_empty:
    forall v1 v2 z,
    ~ pm_diff make (v1, v2) z.
  Proof.
    unfold not, make; intros.
    inversion H; subst; clear H.
    apply Map_PHID_Facts.empty_mapsto_iff in H0.
    assumption.
  Qed.

  Lemma trans_diff_absurd_empty:
    forall t1 t2 z,
    ~ TransDiff (pm_diff make) t1 t2 z.
  Proof.
    unfold not; intros.
    inversion H; subst; clear H.
    assert (exists e, List.In e w). {
      destruct w. {
        apply walk2_nil_inv in H1.
        contradiction.
      }
      eauto using in_eq.
    }
    destruct H as ((v1,v2), Hi).
    eapply walk2_to_edge in Hi; eauto.
    inversion Hi; subst; clear Hi.
    apply pm_diff_absurd_empty in H.
    assumption.
  Qed.

  Lemma valid_make:
    Valid make.
  Proof.
    unfold Valid, TransDiffFun.
    intros.
    apply trans_diff_absurd_empty in H.
    contradiction.
  Qed.

  Lemma reduces_n_to_valid:
    forall l pm,
    Trace.ReducesN pm l ->
    Valid pm.
  Proof.
    induction l; intros. {
      inversion H; subst.
      auto using valid_make.
    }
    inversion H; subst; clear H.
    eauto using Trace.reduces_n_cons, subject_reduction.
  Qed.
End SR.


Set Implicit Arguments.
Record prod A B := pair { fst : A ; snd : B }.
Definition idS := Set.
Goal forall x y : prod Set Set, forall H : fst x = fst y, fst x = fst y.
  intros.
  change (@fst _ _ ?z) with (@fst Set idS z) at 2.
  apply H.
Qed.

(* Toplevel input, characters 20-58:
Error: Failed to get enough information from the left-hand side to type the
right-hand side. *)


From idt Require Import all.
From oadt.lang_oadt Require Import
     base syntax semantics typing infrastructure
     equivalence values head preservation.
Import syntax.notations typing.notations.

Ltac tsf_pared ctor mpared :=
  let H := fresh in
  pose proof ctor as H;
  repeat
    lazymatch type of H with
    | lc _ -> ?T' => specialize_any H
    | ?T -> ?T' =>
        let P := subst_pattern T pared (fun Σ => rtc (pared Σ)) in
        refine (P -> _ : Prop); specialize_any H
    | forall e : ?T, _ =>
        refine (forall e : T, _ : Prop); specialize (H e)
    | ?Σ ⊢ ?e ⇛ ?e' => exact (mpared Σ e e')
    end.

MetaCoq Run (tsf_ind_gen_from
               pared "mpared"
               ltac:(tsf_ctors pared (append "M") tsf_pared)).

Section fix_gctx.

Implicit Types (b : bool) (x X y Y : atom) (L : aset).

#[local]
Coercion EFVar : atom >-> expr.

Context (Σ : gctx).
Context (Hwf : gctx_wf Σ).

#[local]
Set Default Proof Using "All".

Lemma mpared_lc e e' :
  lc e ->
  e ⇛* e' ->
  lc e'.
Proof.
  eapply rtc_preserve; eauto using pared_lc2.
Qed.

Lemma mpared_preservation Γ e l e' τ :
  Γ ⊢ e :{l} τ ->
  e ⇛* e' ->
  Γ ⊢ e' :{l} τ.
Proof.
  eapply rtc_preserve with (P := fun e => Γ ⊢ e :{l} τ).
  eauto using pared_preservation.
Qed.

Lemma mpared_woval ω τ :
  woval ω ->
  ω ⇛* τ ->
  woval τ.
Proof.
  eapply rtc_preserve; eauto using pared_woval.
Qed.

Lemma mpared_body e e' L :
  body e ->
  (forall x, x ∉ L -> <{ e^x }> ⇛* <{ e'^x }>) ->
  body e'.
Proof.
  unfold body.
  intros. simp_hyps. eexists. simpl_cofin. eauto using mpared_lc.
Qed.

Lemma mpared_subst1 e s s' x :
  s ⇛* s' ->
  lc e ->
  <{ {x↦s}e }> ⇛* <{ {x↦s'}e }>.
Proof.
  induction 1; try reflexivity.
  econstructor; eauto using pared_subst1.
Qed.

(** Similar to [mpared_subst1], but for the cases when the substitution is a
[body]. The whole proof strategy for [mpared_sound] using this lemma is not
particularly elegant. *)
Lemma mpared_subst_body1 e s s' x L :
  (* This condition may be provable with some side conditions, but it is too
  much work. *)
  (forall s s' L,
      (forall x, x ∉ L -> <{ s^x }> ⇛ <{ s'^x }>) ->
      <{ {x↦s}e }> ⇛ <{ {x↦s'}e }>) ->
  (forall x, x ∉ L -> <{ s^x }> ⇛* <{ s'^x }>) ->
  <{ {x↦s}e }> ⇛* <{ {x↦s'}e }>.
Proof.
  intros Hp H.
  simpl_cofin.
  match type of H with
  | ?s ⇛* ?s' => remember s; remember s'
  end.
  revert dependent s.
  induction H; intros; subst.
  - select (<{ _^_ }> = <{ _^_ }>) (fun H => apply open_inj in H).
    subst; reflexivity. fast_set_solver!!.
  - match goal with
    | H : <{ ?s^(fvar ?x) }> ⇛ ?e |- _ =>
        is_var e;
        assert (lc e) by eauto using pared_lc2;
        assert (e = open x (close x e)) by (by rewrite open_close)
    end.
    eapply rtc_l; [ | auto_apply ]; try set_shelve; eauto.

    eapply Hp.
    simpl_cofin.
    eapply pared_rename; try set_shelve; eauto. qauto.

  Unshelve.
  all: rewrite ?close_fv by auto; fast_set_solver!!.
Qed.

Lemma mpared_sound e1 e2 :
  mpared Σ e1 e2 ->
  lc e1 ->
  Σ ⊢ e1 ⇛* e2.
Proof.
  destruct 1; intros;
    repeat lc_inv;
    (* Generate [lc] and [woval] hypotheses from [⇛*] relation. *)
    do_hyps (fun H =>
               try lazymatch type of H with
                   | _ ⇛* _ =>
                       dup_hyp H (fun H =>
                                    apply mpared_lc in H; [ | solve [ eauto ] ])
                   | forall _, _ -> _ ⇛* _ =>
                       dup_hyp H (fun H =>
                                    eapply mpared_body in H;
                                    [ destruct H
                                    | solve [ eauto using body_intro ] ])
                   | woval _ =>
                       dup_hyp H (fun H =>
                                    eapply mpared_woval in H; [ | solve [ eauto ] ])
                   end);
    (* Consecutively apply [transitivity] such that any adjacent configurations
    differ in only one subexpression. *)
    let sol s s' e e' tac :=
      match eval pattern s in e with
      | ?f _ =>
          transitivity (f s'); [
            let x := fresh "x" in
            let H := fresh in
            pick_fresh as x;
            assert (forall s, f s = <{ {x↦s},(f x) }>) as H
                by (intros; simpl; rewrite ?decide_True by reflexivity;
                    rewrite ?subst_fresh by eauto; reflexivity);
            hnf in H;
            rewrite (H s);
            rewrite (H s');
            solve [ tac H ]
          | ]
      end in
    let rec go :=
      lazymatch goal with
      | H : ?s ⇛* ?s' |- ?e ⇛* ?e' =>
          sol s s' e e' ltac:(fun H => eapply mpared_subst1; eauto using lc);
          clear H; go
      | H : forall _, _ -> <{ ?s^_ }> ⇛* <{ ?s'^_ }> |- ?e ⇛* ?e' =>
          sol s s' e e' ltac:(fun H => eapply mpared_subst_body1; eauto;
                                     intros; rewrite <- ?H;
                                     eauto 10 using pared, lc);
          clear H; go
      (* Solve the last step. *)
      | |- _ => try reflexivity; apply rtc_once; eauto 10 using pared
      end in go.
Qed.

Lemma mpared_ocase b ω1 ω2 v e1 e2 e1' e2' L1 L2 :
  oval v ->
  otval ω1 -> otval ω2 ->
  body e1 -> body e2 ->
  (forall x, x ∉ L1 -> <{ e1^x }> ⇛* <{ e1'^x }>) ->
  (forall x, x ∉ L2 -> <{ e2^x }> ⇛* <{ e2'^x }>) ->
  <{ ~case [inj@b<(ω1 ~+ ω2)> v] of e1 | e2 }> ⇛* <{ ite b (e1'^v) (e2'^v) }>.
Proof.
  intros.
  select! (otval _) (fun H => use (ovalty_inhabited _ H)).
  select! (forall x, _ -> _ ⇛* _)
        (fun H => dup_hyp H (fun H => apply mpared_body in H; eauto)).
  select! (body _) (fun H => destruct H).
  etrans.
  - apply mpared_sound; eauto using lc, otval.
    econstructor; eauto using mpared.
  - case_split;
      (etrans; [ apply mpared_sound; eauto 10 using body_open_lc with lc;
                 econstructor; try reflexivity
               | reflexivity ]).
Qed.

Lemma mpared_tape v :
  oval v ->
  <{ tape v }> ⇛* v.
Proof.
  intros. eauto 10 using mpared_sound, mpared with lc.
Qed.

End fix_gctx.

Create HintDb mpared discriminated.
#[export]
Hint Resolve mpared_sound : mpared.
#[export]
Hint Constructors mpared : mpared.
#[export]
Hint Resolve mpared_ocase : mpared.
#[export]
Hint Resolve mpared_tape : mpared.

Ltac relax_mpared :=
  match goal with
  | |- mpared ?Σ ?e _ =>
    refine (eq_ind _ (fun e' => mpared Σ e e') _ _ _)
  end.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Inductive multInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall (i:I) (b:B i), Set  :=
mlin1d : forall a, multInd A I B f g (f a) (g (f a)).
(* | mlin2d : forall a2a, multInd A I B f g (f a2a) (g (f a2a)). *)

Require Import SquiggleEq.UsefulTypes.

Run TemplateProgram (genParamIndAll [] "Top.multIndices2.multInd").

(*
Check Top_multIndices2_multInd_pmtcty_RR0_indices_irr. (* correct! *)
Print Top_multIndices2_multInd_pmtcty_RR0_constr_0_tot. (* correct! *)

Require Import ReflParam.Trecord.
Locate BestOne12.
Locate BestOne21.

Run TemplateProgram (genParamIndTotAll [] true "Top.multIndices2.multInd").
*)

Run TemplateProgram (mkIndEnv "indTransEnv" ["Top.multIndices2.multInd"]).
Run TemplateProgram (genWrappers indTransEnv).


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Numbers.DecimalString.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Cava.Util.List.

Inductive type :=
| Unit : type
| Nat : type
| Pair : type -> type -> type
.

Fixpoint denote_type (t: type) :=
  match t with
  | Unit => unit
  | Nat => nat
  | Pair x y => (denote_type x * denote_type y)%type
  end.

Fixpoint absorb_any (x y: type) :=
  match x, y with
  | Unit, x => x
  | x, Unit => x
  | _, _ => Pair x y
  end.

Fixpoint absorb_right (x y: type) :=
  match x, y with
  | x, Unit => x
  | _, _ => Pair x y
  end.

Declare Scope circuit_type_scope.
Delimit Scope circuit_type_scope with circuit_type.
Open Scope circuit_type_scope.
Notation "[ ]" := Unit (format "[ ]") : circuit_type_scope.
Notation "[ x ]" := (Pair x Unit) : circuit_type_scope.
Notation "[ x ; y ; .. ; z ]" := (Pair x (Pair y .. (Pair z Unit) ..)) : circuit_type_scope.
Notation "x ** y" := (Pair x y)(at level 60, right associativity) : circuit_type_scope.
Notation "x ++ y" := (absorb_any x y) (at level 60, right associativity): circuit_type_scope.

Definition tvar : Type := type -> Type.
Existing Class tvar.

Section Vars.
  Inductive Circuit {var: tvar}: type -> type -> type -> Type :=
  | Var : forall {x},     var x -> Circuit [] [] x
  | Abs : forall {s x y z}, (var x -> Circuit s y z) -> Circuit s (x ** y) z
  | App : forall {s1 s2 x y z}, Circuit s1 (x ** y) z -> Circuit s2 [] x -> Circuit (s1 ++ s2) y z

  | Let: forall {x y z s1 s2}, Circuit s1 [] x -> (var x -> Circuit s2 y z) -> Circuit (s1++s2) y z
  (* slightly different fomualtion, but equivalent to loop delay *)
  | LetDelay : forall {x y z s1 s2}, denote_type x
    -> (var x -> Circuit s1 [] x)
    -> (var x -> Circuit s2 y z)
    -> Circuit (x ++ s1 ++ s2) y z

  | Delay: forall {x}, denote_type x -> Circuit x [x] x

  | AddMod : nat -> Circuit [] [Nat; Nat] Nat

  | DestructTuple: forall {x y z s}, Circuit [] [] (x**y) -> (var x -> var y -> Circuit s y z) -> Circuit s y z
  | MakeTuple: forall {x y}, Circuit [] [x;y] (x**y)
  .
End Vars.

Definition split_absorbed_denotation {x y}
  : denote_type (x ++ y) -> denote_type x * denote_type y :=
  match x, y with
  | [],_ => fun x => (tt,x)
  | _,[] => fun x => (x, tt)
  | _, _ => fun x => x
  end.

Definition combine_absorbed_denotation {x y}
  : denote_type x -> denote_type y -> denote_type (x ++ y) :=
  match x,y with
  | [], _ => fun _ y => y
  | _, [] => fun x _ => x
  | _, _ => fun x y => (x,y)
  end.

Fixpoint step {i s o} (c : Circuit s i o)
  : denote_type s -> denote_type i -> denote_type s * denote_type o :=
  match c in Circuit s i o return denote_type s -> denote_type i -> denote_type s * denote_type o with
  | Var x => fun _ _ => (tt, x)
  | Abs f => fun s '(i1,i2) =>
    step (f i1) s i2
  | App f x => fun s i =>
    let '(sf, sx) := split_absorbed_denotation s in
    let '(nsx, x) := step x sx tt in
    let '(nsf, o) := step f sf (x, i) in
    (combine_absorbed_denotation nsf nsx, o)
  | Delay _ => fun s '(i,tt) => (i, s)
  | AddMod n => fun _ '(a,(b,_)) => (tt, (a + b) mod (2 ^ n))
  | Let x f => fun s i =>
    let '(sx, sf) := split_absorbed_denotation s in
    let '(nsx, x) := step x sx tt in
    let '(nsf, o) := step (f x) sf i in
    (combine_absorbed_denotation nsx nsf, o)
  | LetDelay _ x f => fun s i =>
    let '(sx, s12) := split_absorbed_denotation s in
    let '(s1, s2) := split_absorbed_denotation s12 in

    let '(ns1, x) := step (x sx) s1 tt in
    let '(ns2, o) := step (f x) s2 i in

    (combine_absorbed_denotation x (combine_absorbed_denotation ns1 ns2), o)

  | DestructTuple tup f => fun s i =>
    let '(x,y) := (snd (step tup tt tt)) in
    let '(ns, o) := step (f x y) s i in
    (ns, o)
  | MakeTuple => fun _ '(x,(y,_)) =>
    (tt, (x, y))
  end.

Fixpoint default {t: type} : denote_type t :=
  match t with
  | Unit => tt
  | Nat => 0
  | Pair x y => (@default x, @default y)
  end.

Fixpoint reset_state {i s o} (c : Circuit (var:=denote_type) s i o) : denote_type s :=
  match c in Circuit s i o return denote_type s with
  | Var _ => tt
  | Abs f => reset_state (f default)
  | App f x => combine_absorbed_denotation (reset_state f) (reset_state x)
  | Let x f => combine_absorbed_denotation (reset_state x) (reset_state (f default))
  | LetDelay initial x f =>
    combine_absorbed_denotation initial
      (combine_absorbed_denotation (reset_state (x default)) (reset_state (f default)))
  | Delay initial => initial
  | AddMod _ => tt
  | MakeTuple => tt
  | DestructTuple tup f => combine_absorbed_denotation (reset_state tup) (reset_state (f default default))
  end.

Definition simulate {s i o} (c : Circuit (var:=denote_type) s i o) (input : list (denote_type i)) : list (denote_type o) :=
  fold_left_accumulate (step c) input (reset_state c).

Declare Scope expr_scope.
Declare Custom Entry expr.
Delimit Scope expr_scope with expr.

Notation "{{ x }}" := (x)%expr  (at level 1, x custom expr at level 99).
Notation "f x" := (App f x) (in custom expr at level 3, left associativity) : expr_scope.
Notation "x" := (Var x) (in custom expr, x ident) : expr_scope.
Notation "[[ x ]]" := (x)(in custom expr at level 2, x constr at level 99) : expr_scope.
Notation "'fun' x .. y => e" := ( (Abs (fun x => .. (Abs (fun y => e)) ..) )%expr
 ) (in custom expr at level 1, x binder, y binder, e custom expr at level 1) : expr_scope.

Notation "'let' x := a 'in' e" := (Let a (fun x => e))
  (in custom expr at level 1, x pattern at level 4, e at level 7, a at level 1) : expr_scope.
Notation "'let/delay' x := a 'initially' v 'in' b" := (LetDelay v (fun x => a) (fun x => b))
  (in custom expr at level 1, x pattern at level 4, v constr at level 99, b at level 7, a at level 1) : expr_scope.
Notation "'delay' x 'initially' v" := (App (Delay v) x)
  (in custom expr at level 1, x at level 4, v constr at level 7) : expr_scope.

(* Custom entry means we either need to add primitives as explicit notation or
 * provide escaping *)
Notation "'addmod' v" := (AddMod v)
  (in custom expr at level 1, v constr at level 7) : expr_scope.

Notation "( x , y )" := (App (App MakeTuple x) y)
  (in custom expr, x at level 4, y at level 4) : expr_scope.

Section Var.
  Context {var : tvar}.

  Definition test {A} : Circuit [] [A] A := {{
    fun a => let b := a in a
  }}.

  Definition fork2 {A} : Circuit [] [A] (A ** A) := {{
    fun a => (a, a)
  }}.

  (* I've used 'initially' to separate initial values that aren't part of the
   * bind/app phoas structure. e.g.*)
  (* delay _ initially _ *)
  (* (self referenceing binder equivalent to loop) =*)
  (* let/delay _ := _ initially _ *)
  Definition fibonacci {sz: nat}: Circuit (Nat ** Nat) [] Nat := {{
    let/delay r1 :=
      let r2 := delay r1 initially (2^sz-1:denote_type Nat) in
      addmod sz r1 r2
      initially (1:denote_type Nat) in
    r1
  }}.
End Var.

Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.

Fixpoint fibonacci_nat (n : nat) :=
  match n with
  | 0 => 0
  | S m =>
    let f_m := fibonacci_nat m in
    match m with
    | 0 => 1
    | S p => fibonacci_nat p + f_m
    end
  end.

Definition spec_of_fibonacci (sz : nat) (input : list unit) : list nat
  := map (fun n => fibonacci_nat n mod (2 ^ sz)) (seq 0 (List.length input)).

Lemma fork2_step A state input : step (fork2 (A:=A)) state (input, tt) = (tt, (input, input)).
Proof. reflexivity. Qed.

Lemma fibonacci_step sz state input :
  step (fibonacci (sz:=sz)) state input
  = let sum := (fst state + snd state) mod (2 ^ sz) in
    (sum, fst state, sum).
Proof.
  intros; cbn [step fibonacci ].
  repeat (destruct_pair_let; cbn [split_absorbed_denotation combine_absorbed_denotation List.app absorb_any fst snd]).
  reflexivity.
Qed.

Definition fibonacci_invariant {sz}
           (t : nat) (loop_state : nat * nat)
           (output_accumulator : list nat) : Prop :=
  let r1 := fst loop_state in
  let r2 := snd loop_state in
  (* at timestep t... *)
  (* ...r1 holds fibonacci_nat (t-1), or 1 if t=0 *)
  r1 = match t with
       | 0 => 1
       | S t_minus1 => (fibonacci_nat t_minus1) mod (2 ^ sz)
       end
  (* ... and r2 holds fibonacci_nat (t-2), or 1 if t=1, 2^sz-1 if t=0 *)
  /\ r2 = match t with
         | 0 => 2 ^ sz - 1
         | 1 => 1
         | S (S t_minus2) =>(fibonacci_nat t_minus2) mod (2 ^ sz)
         end
  (* ... and the output accumulator matches the circuit spec for the
     inputs so far *)
  /\ output_accumulator = spec_of_fibonacci sz (repeat tt t).

(* Helper lemma for fibonacci_correct *)
Lemma fibonacci_nat_step n :
  fibonacci_nat (S (S n)) = fibonacci_nat (S n) + fibonacci_nat n.
Proof. cbn [fibonacci_nat]. lia. Qed.

Lemma fibonacci_correct sz input :
  simulate (fibonacci (sz:=sz)) input = spec_of_fibonacci sz input.
Proof.
  cbv [simulate]. rewrite fold_left_accumulate_to_seq with (default:=tt).
  assert (2 ^ sz <> 0) by (apply Nat.pow_nonzero; lia).
  apply fold_left_accumulate_invariant_seq with (I:=fibonacci_invariant (sz:=sz)).
  { cbv [fibonacci_invariant]. ssplit; reflexivity. }
  { cbv [fibonacci_invariant].
    intros; destruct_products; cbn [fst snd] in *; subst; cbn [fst snd].
    rewrite fibonacci_step. cbn [fst snd].
    repeat destruct_one_match.
    { (* t = 0 case *)
      cbn. rewrite Nat.sub_1_r, Nat.succ_pred by lia.
      rewrite Nat.mod_same, Nat.mod_0_l by lia.
      ssplit; reflexivity. }
    { (* t = 1 case *)
      cbn. rewrite Nat.mod_0_l by lia.
      ssplit; reflexivity. }
    { (* t > 1 case *)
      rewrite Nat.add_mod_idemp_r, Nat.add_mod_idemp_l by lia.
      ssplit.
      { cbn [fibonacci_nat]. f_equal; lia. }
      { reflexivity. }
      { cbv [spec_of_fibonacci].
        autorewrite with push_length.
        rewrite seq_S with (len:=S (S _)).
        autorewrite with natsimpl. rewrite map_app.
        cbn [map]. rewrite fibonacci_nat_step.
        reflexivity. } } }
  { cbv [fibonacci_invariant]. intros.
    logical_simplify; subst.
    autorewrite with push_length.
    erewrite <-list_unit_equiv. reflexivity. }
Qed.

Inductive FCircuit : nat -> type -> type -> Type :=
| FVar : forall {s x}, nat -> FCircuit s [] x
| FAbs : forall {s x y z}, FCircuit (S s) y z -> FCircuit s (x ** y) z
| FApp : forall {s x y z}, FCircuit s (x ** y) z -> FCircuit s [] x -> FCircuit s y z

| FLet: forall {s x y z }, FCircuit s [] x -> FCircuit (S s) y z -> FCircuit s y z
| FLetDelay : forall {s x y z}, denote_type x
  -> FCircuit (S s) [] x
  -> FCircuit (S s) y z
  -> FCircuit s y z

| FDelay: forall {s x}, denote_type x -> FCircuit s [x] x

| FAddMod : forall {s}, nat -> FCircuit s [Nat; Nat] Nat

| FDestructTuple: forall {s x y z}, FCircuit s [] (x**y) -> FCircuit (S (S s)) y z -> FCircuit s y z
| FMakeTuple: forall {s x y}, FCircuit s [x;y] (x**y)
.

Fixpoint to_first_order {i s o} n (c : Circuit (var:=fun _ => nat) s i o)
  : FCircuit n i o :=
  match c in Circuit _ i o return FCircuit n i o with
  | Var x => FVar x
  | Abs f => FAbs (to_first_order (S n) (f n))
  | App f x => FApp (to_first_order n f) (to_first_order n x)
  | Delay v => FDelay v
  | AddMod n => FAddMod n
  | Let x f => FLet (to_first_order n x) (to_first_order (S n) (f n))
  | LetDelay v x f => FLetDelay v (to_first_order (S n) (x n)) (to_first_order (S n) (f n))
  | DestructTuple tup f =>
    FDestructTuple (to_first_order n tup)
    (to_first_order (S (S n)) (f n (S n)))
  | MakeTuple => FMakeTuple
  end.

Close Scope list_scope.

Fixpoint fo_state {n i o} (c: FCircuit n i o) : type :=
  match c with
  | FVar _ => Unit
  | FAbs f => fo_state f
  | FApp f x => (fo_state f ++ fo_state x)
  | FLet x f => (fo_state f ++ fo_state x)
  | @FLetDelay _ X _ _ t x f => X ++ (fo_state f ++ fo_state x)
  | @FDelay _ X _ => X
  | FAddMod _ => Unit
  | FDestructTuple tup f => (fo_state tup ++ fo_state f)
  | FMakeTuple => Unit
  end.

Definition fib_fo {sz} := to_first_order 0 (fibonacci (sz:=sz)).

Definition get_phoas_state {i o s var} (_: Circuit (var:=var) s i o) := s.

Compute (fib_fo (sz:=12)).
Compute fo_state (fib_fo (sz:=12)).

Goal forall sz, get_phoas_state (var:=fun _ => nat) (fibonacci (sz:=sz)) = fo_state (fib_fo (sz:=sz)).
  intros.
  cbn [ fo_state fib_fo to_first_order fibonacci absorb_any].
  reflexivity.
Qed.


(**************************************************************************)
(*  This is part of EXCEPTIONS-PL, it is distributed under the terms of   *)
(*         the GNU Lesser General Public License version 3                *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms Bool.
Require Import Program.
Require Prerequistes Terms.
Set Implicit Arguments.

Module Make(Import M: Prerequistes.T).
  Module Export DecorationsExp := Terms.Make(M).

 Inductive kindpl := pl_epure | pl_ppg.

 Inductive is_pl: kindpl -> forall X Y, termpl X Y -> Prop :=
 | is_pl_tpure: forall X Y (f: X -> Y), is_pl pl_epure (@pl_tpure X Y f)
 | is_pl_comp: forall k X Y Z (f: termpl X Y) (g: termpl Y Z), is_pl k f -> is_pl k g -> is_pl k (f O g)
 | is_throw: forall X (e: EName), is_pl pl_ppg (@throw X e)
 | is_try_catch: forall X Y (e: EName) (a: termpl Y X) (b: termpl Y (Val e)), is_pl pl_ppg (@try_catch _ _ e a b)
 | is_pl_pure_ppg: forall X Y (f: termpl X Y), is_pl pl_epure f -> is_pl pl_ppg f.

 Hint Constructors is_pl.

 Ltac pl_edecorate :=  solve[
                          repeat (apply is_pl_comp)
                            ||
		                 (apply is_pl_tpure || apply is_throw || apply is_try_catch || apply is_pl_pure_ppg || assumption)
			    ||
                                 (apply is_pl_pure_ppg)
                        ].
 Class PL_EPURE {A B: Type} (f: termpl A B) := isplp : is_pl pl_epure f.
 Class PL_PPG {A B: Type} (f: termpl A B) := isplthrw : is_pl pl_ppg f.

 Fixpoint fix_has_no_propagator X Y (f: termpl X Y): bool :=
   match f with
     | throw _ _         => false
     | try_catch _ _ _ _ _   => false
     | pl_comp _ _ _ f g => fix_has_no_propagator f && fix_has_no_propagator g
     | _ => true
   end.

 Definition has_no_propogator X Y (f : termpl X Y) : Prop := fix_has_no_propagator f = true.
 Definition has_only_pure X Y (f : termpl X Y) : Prop := fix_has_no_propagator f = true.

 Lemma onlypurecomp : forall X Y Z (f: termpl Y X) (g: termpl Z Y),
      has_only_pure f /\ has_only_pure g -> has_only_pure (g O f).
 Proof.
  intros. unfold has_only_pure. simpl. rewrite andb_true_iff.
  split; apply H.
 Qed.

 Lemma no_untag_tag_ispure : forall X Y (g: termpl X Y),
	(has_only_pure g) -> PL_EPURE g.
 Proof.
    intros. unfold has_only_pure in H. induction g.
    (* tpure *)
    apply is_pl_tpure.
    (* comp *)
    apply is_pl_comp. simpl in H.
    rewrite ?andb_true_iff in H.
    destruct H. destruct H. destruct H0.
    apply IHg1. reflexivity.
    simpl in H.
    rewrite ?andb_true_iff in H.
    destruct H. destruct H. destruct H0.
    apply IHg2. reflexivity.
    (* throw *)
    simpl in H. contradict H. auto.
    (* try/catch *)
    simpl in H. contradict H. auto.
 Qed.

End Make.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import Bool.
Require Import String.
Require Import List.
Require Import Eqdep_dec.
Require Import RelationClasses.
Require Import Utils.
Require Import ForeignType.
Require Import RType.
Require Import BrandRelation.

Section RSubtype.

  Context {ftype:foreign_type}.
  Context {br:brand_relation}.

Inductive subtype : rtype -> rtype -> Prop :=
  | STop r : subtype r ⊤
  | SBottom r : subtype ⊥ r
  | SRefl r : subtype r r
  | SColl r1 r2 : subtype r1 r2 -> subtype (Coll r1) (Coll r2)
  (** Allow width subtyping of open records and depth subtyping of both types of records. Also, a closed record can be a subtype of an open record (but not vice versa) *)
  | SRec k1 k2 rl1 rl2 pf1 pf2 : (forall s r',
                      lookup string_dec rl2 s = Some r' ->
                      exists r, lookup string_dec rl1 s = Some r /\
                                subtype r r') ->
                                (k2 = Closed -> k1 = Closed /\
                                 (forall s, In s (domain rl1) -> In s (domain rl2))) ->
                                subtype (Rec k1 rl1 pf1) (Rec k2 rl2 pf2)
  | SEither l1 l2 r1 r2 :
      subtype l1 l2 ->
      subtype r1 r2 ->
      subtype (Either l1 r1) (Either l2 r2)
  | SArrow in1 in2 out1 out2:
      subtype in2 in1 ->
      subtype out1 out2 ->
      subtype (Arrow in1 out1) (Arrow in2 out2)
  | SBrand b1 b2 : sub_brands brand_relation_brands b1 b2 -> subtype (Brand b1) (Brand b2)
  | SForeign ft1 ft2 :
      foreign_type_sub ft1 ft2 ->
      subtype (Foreign ft1) (Foreign ft2)
.

Lemma SRec_open k1 rl1 rl2 pf1 pf2 :
  (forall s r',
     lookup string_dec rl2 s = Some r' ->
     exists r, lookup string_dec rl1 s = Some r /\
               subtype r r') ->
  subtype (Rec k1 rl1 pf1) (Rec Open rl2 pf2).
Proof.
  intros; constructor; intuition; discriminate.
Qed.

Lemma SRec_closed_in_domain {k1 k2 rl1 rl2 pf1 pf2} :
  subtype (Rec k1 rl1 pf1) (Rec k2 rl2 pf2) ->
  (forall x, In x (domain rl2) -> In x (domain rl1)).
Proof.
  inversion 1; rtype_equalizer; subst; intuition.
  destruct (in_dom_lookup string_dec H0).
  destruct (H3 _ _ H1) as [? [inn ?]].
  apply lookup_in in inn.
  apply in_dom in inn.
  trivial.
Qed.

Lemma SRec_closed_equiv_domain {k1 rl1 rl2 pf1 pf2} :
  subtype (Rec k1 rl1 pf1) (Rec Closed rl2 pf2) ->
  (forall x, In x (domain rl1) <-> In x (domain rl2)).
Proof.
  inversion 1; rtype_equalizer; subst; intuition.
  eapply SRec_closed_in_domain; eauto.
Qed.

  Lemma UIP_refl_dec
        {A:Type}
        (dec:forall x y:A, {x = y} + {x <> y})
        {x:A}
        (p1:x = x) : p1 = eq_refl x.
  Proof.
    intros. apply (UIP_dec); auto.
  Qed.

  (** This follows trivially from the consistency of join and subtype.
      However, this version should have better computational properties.*)

  Hint Constructors subtype : qcert.

  Lemma subtype_both_dec x y :
    (prod ({subtype x y} + {~ subtype x y}) ({subtype y x} + {~ subtype y x})).
  Proof.
    Ltac simp := match goal with
            | [H:(@eq bool ?x ?x) |- _ ] => generalize (UIP_refl_dec bool_dec H); intro; subst H
          end.
    destruct x.
    revert y; induction x
    ; intros y; destruct y as [y pfy]; destruct y; constructor;
    try solve[right; inversion 1 | left; simpl in *; repeat simp; eauto with qcert ].
    - destruct (IHx e (exist _ y pfy)) as [[?|?]_].
      + left. repeat rewrite (Coll_canon).
        auto with qcert.
      + right. intro ss; apply n. inversion ss; subst.
         * erewrite (rtype_ext); eauto with qcert.
         * destruct r1; destruct r2; simpl in *.
           erewrite (rtype_ext e); erewrite (rtype_ext pfy); eauto.
    - destruct (IHx e (exist _ y pfy)) as [_[?|?]].
      + left. repeat rewrite (Coll_canon).
        auto with qcert.
      + right. intro ss; apply n. inversion ss; subst.
         * erewrite (rtype_ext); eauto with qcert.
         * destruct r1; destruct r2; simpl in *.
           erewrite (rtype_ext e); erewrite (rtype_ext pfy); eauto.
    - rename srl into srl0; rename r into srl.
      assert (sub:{forall s r' pf',
      lookup string_dec srl0 s = Some r' ->
      exists r pf, lookup string_dec srl s = Some r /\
                subtype (exist _ r pf) (exist _ r' pf')} + {~ (forall s r' pf',
      lookup string_dec srl0 s = Some r' ->
      exists r pf, lookup string_dec srl s = Some r /\
                subtype (exist _ r pf) (exist _ r' pf'))}).
      + induction srl0; simpl; [left; intros; discriminate | ].
         destruct a.
         case_eq (lookup string_dec srl s).
        * intros ? inn.
          assert (wfr:wf_rtype₀ r = true)
                 by (eapply (wf_rtype₀_Rec_In pfy); simpl; left; reflexivity).
          destruct (Forallt_In H _ (lookup_in string_dec _ inn) (wf_rtype₀_Rec_In e _ _ ((lookup_in string_dec _ inn))) (exist _ r wfr)) as [[?|?]_].

            destruct (IHsrl0 (wf_rtype₀_cons_tail pfy)).
              left. intros ? ? ? eqq. match_destr_in eqq; subst; eauto 2.
                inversion eqq; subst.
                rewrite (rtype_ext pf' wfr); eauto.
              right; intro nin. apply n; intros ss rr rrpf sin.
              specialize (nin ss rr).
              match_destr_in nin; [| intuition ].
              subst.
              apply wf_rtype₀_cons_nin in pfy.
              congruence.
          right; intro nin. specialize (nin s r).
          match_destr_in nin; [| intuition ].
          destruct (nin wfr (eq_refl _)) as [? [?[??]]]; simpl in *.
          rewrite inn in H0. inversion H0; subst.
          apply n.
          rewrite (rtype_ext _ x0). trivial.
        * right; intro nin. specialize (nin s r).
          match_destr_in nin; [| intuition ].
          assert (wfr:wf_rtype₀ r = true)
                 by (eapply (wf_rtype₀_Rec_In pfy); simpl; left; reflexivity).
          destruct (nin wfr (eq_refl _)) as [? [?[??]]].
          congruence.
      + destruct sub.
        * destruct k0.
          left.
          destruct (from_Rec₀ srl e) as [? [?[??]]]; subst.
          rewrite <- H1.
          destruct (from_Rec₀ _ pfy) as [? [?[??]]]; subst.
          rewrite <- H2.
          econstructor; try discriminate.
          intros ? ? lo. destruct r'.
          apply lookup_map_some' in lo.
          destruct (e0 _ _ e1 lo) as [?[?[??]]].
          rewrite <- (lookup_map_some' _ _ _ x5) in H0.
          exists (exist _ x4 x5). intuition.
          destruct k.
             right; inversion 1; intuition; discriminate.
           destruct (incl_list_dec string_dec (domain srl) (domain srl0)).
             left.
             destruct (from_Rec₀ srl e) as [? [?[??]]]; subst.
             rewrite <- H1.
             destruct (from_Rec₀ _ pfy) as [? [?[??]]]; subst.
             rewrite <- H2.
             constructor; intros.
               destruct r'.
               rewrite (lookup_map_some' _ _ _ e1) in H0.
               destruct (e0 _ _ e1 H0) as [?[?[??]]].
               rewrite <- (lookup_map_some' _ _ _ x5) in H3.
               exists (exist _ x4 x5). intuition.
               intuition.
                 specialize (i s).
                 unfold domain in i; repeat rewrite map_map in i.
                 simpl in i.
                 auto.
             right; inversion 1; rtype_equalizer; subst; eauto 2.
             intuition.  apply n.
             intros ? .
             unfold domain; repeat rewrite map_map.
             simpl.
             auto.
        * right; inversion 1; apply n; rtype_equalizer; subst; eauto with qcert.
          intros.
          rewrite <- (lookup_map_some' _ _ _ pf') in H1.
          destruct (H4 _ _ H1) as [? [??]].
          destruct x.
          exists x; exists e0.
          rewrite <- (lookup_map_some' _ _ _ e0).
          intuition.
    - rename srl into srl0; rename r into srl.
      assert (sub:{forall s r' pf',
      lookup string_dec srl s = Some r' ->
      exists r pf, lookup string_dec srl0 s = Some r /\
                subtype (exist _ r pf) (exist _ r' pf')} + {~ (forall s r' pf',
      lookup string_dec srl s = Some r' ->
      exists r pf, lookup string_dec srl0 s = Some r /\
                   subtype (exist _ r pf) (exist _ r' pf'))}).
      + induction srl; simpl; [left; intros; discriminate | ].
        destruct a.
        case_eq (lookup string_dec srl0 s).
        * intros ? inn.
          assert (wfr0:wf_rtype₀ r0 = true)
            by (eapply (wf_rtype₀_Rec_In pfy); eapply lookup_in; eauto).
          assert (wfr:wf_rtype₀ r = true)
            by (eapply (wf_rtype₀_Rec_In e); simpl; left; reflexivity).
          invcs H.
          simpl in H2.
          destruct (H2 wfr (exist _ r0 wfr0)) as [_ issub].
          { destruct issub.
            - destruct (IHsrl H3 (wf_rtype₀_cons_tail e)).
              + left; intros ? ? ? eqq.
                match_destr_in eqq; subst; eauto 2.
                inversion eqq; subst.
                rewrite (rtype_ext pf' wfr); eauto.
              + right; intro nin. apply n; intros ss rr rrpf sin.
                specialize (nin ss rr).
                match_destr_in nin; [| intuition ].
                subst.
                apply wf_rtype₀_cons_nin in e.
                congruence.
            - right; intro nin. specialize (nin s r).
              match_destr_in nin; [| intuition ].
              destruct (nin wfr (eq_refl _)) as [? [?[??]]]; simpl in *.
              rewrite inn in H. inversion H; subst.
              apply n.
              rewrite (rtype_ext _ x0). trivial.
          }
        * right; intro nin. specialize (nin s r).
          match_destr_in nin; [| intuition ].
          assert (wfr:wf_rtype₀ r = true)
            by (eapply (wf_rtype₀_Rec_In e); simpl; left; reflexivity).
          destruct (nin wfr (eq_refl _)) as [? [?[??]]].
          congruence.
      + destruct sub.
        * {destruct k.
           - left.
             destruct (from_Rec₀ srl e) as [? [?[??]]]; subst.
             rewrite <- H1.
             destruct (from_Rec₀ _ pfy) as [? [?[??]]]; subst.
             rewrite <- H2.
             econstructor; try discriminate.
             intros ? ? lo. destruct r'.
             apply lookup_map_some' in lo.
             destruct (e0 _ _ e1 lo) as [?[?[??]]].
             rewrite <- (lookup_map_some' _ _ _ x5) in H0.
             exists (exist _ x4 x5). intuition.
           - destruct k0.
             + right.
               inversion 1; subst.
               intuition; discriminate.
             + destruct (incl_list_dec string_dec (domain srl0) (domain srl)).
               * left.
                 destruct (from_Rec₀ srl e) as [? [?[??]]]; subst.
                 rewrite <- H1.
                 destruct (from_Rec₀ _ pfy) as [? [?[??]]]; subst.
                 rewrite <- H2.
                 { constructor; intros.
                   - destruct r'.
                     rewrite (lookup_map_some' _ _ _ e1) in H0.
                     destruct (e0 _ _ e1 H0) as [?[?[??]]].
                     rewrite <- (lookup_map_some' _ _ _ x5) in H3.
                     exists (exist _ x4 x5). intuition.
                   - intuition.
                     specialize (i s).
                     unfold domain in i; repeat rewrite map_map in i.
                     simpl in i.
                     auto.
                 }
               * right; inversion 1; rtype_equalizer; subst; eauto 2.
                 intuition.  apply n.
                 intros ? .
                 unfold domain; repeat rewrite map_map.
                 simpl.
                 auto.
          }
        * right; inversion 1; apply n; rtype_equalizer; subst; eauto with qcert.
          intros.
          rewrite <- (lookup_map_some' _ _ _ pf') in H1.
          destruct (H4 _ _ H1) as [? [??]].
          destruct x.
          exists x; exists e0.
          rewrite <- (lookup_map_some' _ _ _ e0).
          intuition.
    - destruct (Either₀_wf_inv e) as [pfl1 pfr1].
      destruct (Either₀_wf_inv pfy) as [pfl2 pfr2].
      destruct (IHx1 pfl1 (exist _ _ pfl2)) as [[?|?]_].
      + destruct (IHx2 pfr1 (exist _ _ pfr2)) as [[?|?]_].
        * left.
          rewrite (Either_canon _ _ _ pfl1 pfr1).
          rewrite (Either_canon _ _ _ pfl2 pfr2).
          eauto with qcert.
        * right; inversion 1; subst.
            apply n. rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
            rewrite (Either_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Either_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H; rtype_equalizer; subst.
              rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
              subst.
              rewrite (rtype_ext pfr1 (proj2_sig r1)).
              rewrite (rtype_ext pfr2 (proj2_sig r2)).
              destruct r1; destruct r2. simpl in *.
              trivial.
      + right; inversion 1; subst.
         apply n. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rewrite (Either_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Either_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H. rtype_equalizer.
              subst. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.

            subst.
            rewrite (rtype_ext pfl1 (proj2_sig l1)).
            rewrite (rtype_ext pfl2 (proj2_sig l2)).
            destruct l1; destruct l2. simpl in *.
            trivial.
    - destruct (Either₀_wf_inv e) as [pfl1 pfr1].
      destruct (Either₀_wf_inv pfy) as [pfl2 pfr2].
      destruct (IHx1 pfl1 (exist _ _ pfl2)) as [_[?|?]].
      + destruct (IHx2 pfr1 (exist _ _ pfr2)) as [_[?|?]].
        * left.
          rewrite (Either_canon _ _ _ pfl1 pfr1).
          rewrite (Either_canon _ _ _ pfl2 pfr2).
          eauto with qcert.
        * right; inversion 1; subst.
            apply n. rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
            rewrite (Either_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Either_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            { inversion H; rtype_equalizer; subst.
              - rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
              - subst.
              rewrite (rtype_ext pfr2 (proj2_sig r1)).
              rewrite (rtype_ext pfr1 (proj2_sig r2)).
              destruct r1; destruct r2. simpl in *.
              trivial.
            }
      + right; inversion 1; subst.
         apply n. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rewrite (Either_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Either_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H. rtype_equalizer.
              subst. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.

            subst.
            rewrite (rtype_ext pfl2 (proj2_sig l1)).
            rewrite (rtype_ext pfl1 (proj2_sig l2)).
            destruct l1; destruct l2. simpl in *.
            trivial.
    - destruct (Arrow₀_wf_inv e) as [pfl1 pfr1].
      destruct (Arrow₀_wf_inv pfy) as [pfl2 pfr2].
      destruct (IHx1 pfl1 (exist _ _ pfl2)) as [?[?|?]].
      + destruct (IHx2 pfr1 (exist _ _ pfr2)) as [[?|?]?].
        * left.
          rewrite (Arrow_canon _ _ _ pfl1 pfr1).
          rewrite (Arrow_canon _ _ _ pfl2 pfr2).
          econstructor; eauto.
        * right; inversion 1; subst.
            apply n. rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
            rewrite (Arrow_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Arrow_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H; rtype_equalizer; subst.
              rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
              subst.
              rewrite (rtype_ext pfr1 (proj2_sig out1)).
              rewrite (rtype_ext pfr2 (proj2_sig out2)).
              destruct out1; destruct out2. simpl in *.
              trivial.
      + right; inversion 1; subst.
         apply n. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rewrite (Arrow_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Arrow_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H. rtype_equalizer.
            subst. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rtype_equalizer.
            subst.
            rewrite (rtype_ext pfl1 (proj2_sig in1)).
            rewrite (rtype_ext pfl2 (proj2_sig in2)).
            destruct in1; destruct in2. simpl in *.
              trivial.
    - destruct (Arrow₀_wf_inv e) as [pfl1 pfr1].
      destruct (Arrow₀_wf_inv pfy) as [pfl2 pfr2].
      destruct (IHx1 pfl1 (exist _ _ pfl2)) as [[?|?]?].
      + destruct (IHx2 pfr1 (exist _ _ pfr2)) as [?[?|?]].
        * left.
          rewrite (Arrow_canon _ _ _ pfl1 pfr1).
          rewrite (Arrow_canon _ _ _ pfl2 pfr2).
          econstructor; eauto.
        * right; inversion 1; subst.
            apply n. rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
            rewrite (Arrow_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Arrow_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H; rtype_equalizer; subst.
              rewrite (rtype_ext pfr1 pfr2). eauto with qcert.
              subst.
              rewrite (rtype_ext pfr1 (proj2_sig out2)).
              rewrite (rtype_ext pfr2 (proj2_sig out1)).
              destruct out1; destruct out2. simpl in *.
              trivial.
      + right; inversion 1; subst.
         apply n. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rewrite (Arrow_canon _ _ _ pfl1 pfr1) in H.
            rewrite (Arrow_canon _ _ _ pfl2 pfr2) in H.
            apply n.
            inversion H. rtype_equalizer.
            subst. rewrite (rtype_ext pfl1 pfl2). eauto with qcert.
            rtype_equalizer.
            subst.
            rewrite (rtype_ext pfl1 (proj2_sig in2)).
            rewrite (rtype_ext pfl2 (proj2_sig in1)).
            destruct in1; destruct in2. simpl in *.
              trivial.
    - destruct (sub_brands_dec brand_relation_brands b b0).
      + left; repeat rewrite Brand_canon; eauto with qcert.
      + right. inversion 1; subst; eauto 2.
        * intuition.
        * apply n.
          repeat rewrite (canon_brands_equiv).
          trivial.
    - destruct (sub_brands_dec brand_relation_brands b0 b).
      + left; repeat rewrite Brand_canon; eauto with qcert.
      + right. inversion 1; subst; eauto 2.
        * intuition.
        * apply n.
          repeat rewrite (canon_brands_equiv).
          trivial.
    - destruct (foreign_type_sub_dec ft ft0).
      + left. repeat rewrite Foreign_canon.
        apply SForeign; trivial.
      + right; intros sub.
        invcs sub.
        * apply n; reflexivity.
        * intuition.
    - destruct (foreign_type_sub_dec ft0 ft).
      + left. repeat rewrite Foreign_canon.
        apply SForeign; trivial.
      + right; intros sub.
        invcs sub.
        * apply n; reflexivity.
        * intuition.
  Defined.

  Theorem subtype_dec x y : {subtype x y} + {~ subtype x y}.
  Proof.
    destruct (subtype_both_dec x y) as [? _].
    trivial.
  Defined.

End RSubtype.

Section Misc.
  Context  {ftype:foreign_type}.
  Context  {br:brand_relation}.

  Lemma subtype_ext {a b pfa pfb} :
    subtype (exist _ a pfa) (exist _ b pfb) ->
    forall pfa' pfb',
      subtype (exist _ a pfa') (exist _ b pfb').
  Proof.
    intros.
    rewrite (rtype_ext pfa' pfa).
    rewrite (rtype_ext pfb' pfb).
    trivial.
  Qed.

  Lemma subtype_Either_inv {τl τr τl' τr'} :
    subtype (Either τl τr) (Either τl' τr') ->
    subtype τl τl'  /\
    subtype τr τr'.
  Proof.
    inversion 1; rtype_equalizer; subst.
    - subst; split; econstructor.
    - subst. intuition.
  Qed.

  Lemma subtype_Arrow_inv {τl τr τl' τr'} :
    subtype (Arrow τl τr) (Arrow τl' τr') ->
    subtype τl' τl  /\
    subtype τr τr'.
  Proof.
    inversion 1; rtype_equalizer; subst.
    - subst; split; econstructor.
    - subst. intuition.
  Qed.

  Definition check_subtype_pairs (l:list (rtype*rtype)) : bool
    := forallb (fun τs => if subtype_dec (fst τs) (snd τs) then true else false) l.

  Definition enforce_unary_op_schema (ts1:rtype*rtype) (tr:rtype)
    : option (rtype*rtype)
    := if check_subtype_pairs (ts1::nil)
       then Some (tr, (snd ts1))
       else None.

  Definition enforce_binary_op_schema (ts1:rtype*rtype) (ts2:rtype*rtype) (tr:rtype)
    : option (rtype*rtype*rtype)
    := if check_subtype_pairs (ts1::ts2::nil)
       then Some (tr, (snd ts1), (snd ts2))
       else None.

End Misc.

Notation "r1 <: r2" := (subtype r1 r2) (at level 70).


Require Import LanguageUtil.
Require Import BasicProperties.
Require Import Properties.
Require Import KindProperties.

Lemma wf_never_bind_box : forall Γ x,
    ⊢ Γ -> not (x : BOX ∈ Γ).
Proof.
  intros. intro.
  apply binds_inversion in H0 as (Γ1 & Γ2 & E). subst.
  apply wf_ctx_type_correct in H as (k & Sub).
  eapply box_never_welltype. eassumption.
Qed.

Ltac box_welltype_contradiction :=
  repeat progress
    match goal with
    | H : _ ⊢ BOX <: BOX : _ |- _ => contradict H; apply box_never_welltype
    | H : _ : BOX ∈ _ |- _ => contradict H; apply wf_never_bind_box; eauto
    | H : _ ⊢ BOX <: _ : _ |- _ => apply reflexivity_l in H
    | H : _ ⊢ _ <: BOX : _ |- _ => apply reflexivity_r in H
    end
.

Lemma open_is_box_rec : forall e1 e2 n,
    e1 <n> ^^ e2 = BOX -> e1 = BOX \/ e2 = BOX.
Proof.
  induction e1; simpl; intros; try solve [inversion H]; auto.
  - destruct (n0 == n); eauto.
Qed.

Lemma open_is_box : forall e1 e2,
    e1 ^^ e2 = BOX -> e1 = BOX \/ e2 = BOX.
Proof.
  intros. eapply open_is_box_rec. eauto.
Qed.

Lemma open_var_is_box : forall e x,
    e ^` x = BOX -> e = BOX.
Proof.
  intros. apply open_is_box in H. destruct H. auto. inversion H.
Qed.

Lemma head_kind_box_impossible : forall Γ e1 e2 A n,
    Γ ⊢ e1 <: e2 : A -> head_kind A k_box n -> A = BOX \/ False.
Proof.
  intros.
  apply type_correctness in H.
  destruct H as [E | (k & Sub)].
  + auto.
  + eauto using head_kind_box_never_welltype.
Qed.

Lemma pi_head_box_impossible : forall Γ e1 e2 A,
    not (Γ ⊢ e1 <: e2 : e_pi A BOX).
Proof.
  intros. intro. eapply head_kind_box_impossible in H.
  - destruct H. inversion H. auto.
  - constructor. apply h_kind. Unshelve. exact 0.
Qed.

Ltac solve_open_is_box :=
  repeat
    match goal with
    | H : _ ^^ _ = BOX |- _ => apply open_is_box in H as [|]; subst
    | H : _ ⊢ _ <: _ : e_pi _ BOX |- _ => contradict H; apply pi_head_box_impossible
    | _ => solve [box_welltype_contradiction]
    end
.

Lemma box_only_head_kind_star : forall Γ e,
    Γ ⊢ e : BOX -> exists n, head_kind e k_star n.
Proof.
  intros.
  dependent induction H; box_welltype_contradiction; instantiate_cofinites.
  (* star *)
  - exists 0. eauto.
  (* pi *)
  - instantiate_trivial_equals.
    destruct H1. apply head_kind_invert_subst_var in H1. eauto.
  (* app impossible *)
  - solve_open_is_box.
Qed.

Lemma box_never_reduce : forall Γ e,
    Γ ⊢ e : BOX -> forall e', not (e ⟶ e').
Proof.
  intros * Sub.
  dependent induction Sub; intros; intro R;
    try solve [inversion R | box_welltype_contradiction].
  (* r_app *)
  - solve_open_is_box.
Qed.

Lemma castup_box_never_welltype : forall Γ A B,
    not (Γ ⊢ e_castup A BOX : B).
Proof.
  intros. intro.
  dependent induction H.
  - box_welltype_contradiction.
  - eauto.
Qed.

Lemma app_box_never_welltype : forall Γ f1 f2 A,
    not (Γ ⊢ e_app f1 BOX <: e_app f2 BOX : A).
Proof.
  intros. intro.
  dependent induction H.
  - box_welltype_contradiction.
  - eauto.
Qed.

Lemma lambda_box_never_welltype : forall Γ A B,
    not (Γ ⊢ e_abs A BOX : B).
Proof.
  intros. intro.
  dependent induction H.
  - instantiate_cofinites. unfold open_expr_wrt_expr in *. simpl in *.
    box_welltype_contradiction.
  - eauto.
Qed.

Lemma app_of_box_impossible : forall Γ e1 e2 e,
    not (Γ ⊢ e_app e1 e <: e_app e2 e : BOX).
Proof.
  intros. intro.
  inversion H; subst.
  - solve_open_is_box.
  - box_welltype_contradiction.
Qed.

Lemma castdn_of_box_impossible : forall Γ e1 e2,
    not (Γ ⊢ e_castdn e1 <: e_castdn e2 : BOX).
Proof.
  intros. intro.
  inversion H; box_welltype_contradiction.
Qed.

Ltac find_typing_refl_of e H1 :=
  match goal with
  | H : _ ⊢ e : _ |- _ => rename H into H1
  | H : _ ⊢ e <: _ : _ |- _ =>
    pose proof H as H1; apply reflexivity_l in H1
  | H : _ ⊢ _ <: e : _ |- _ =>
    pose proof H as H1; apply reflexivity_r in H1
  end
.

Ltac conclude_head_kind_of e H := repeat
  match goal with
  | _ : head_kind  e _ _ |- _ => fail 1
  | _ : head_kind' e _   |- _ => fail 1
  | _ =>
    match goal with
    | H1 : _ ⊢ e : BOX |- _ =>
      let n := fresh "n" in
      apply box_only_head_kind_star in H1 as [n H]
    | H1 : _ ⊢ e <: _ : BOX |- _ =>
      pose proof H1 as H; apply reflexivity_l in H
    | H1 : _ ⊢ _ <: e : BOX |- _ =>
      pose proof H1 as H; apply reflexivity_r in H
    end
  end
.

Hint Resolve head_kind_box_never_welltype : box.

Ltac box_reasoning :=
  repeat
    progress match goal with
    (* base cases *)
    | _ =>
      solve [box_welltype_contradiction | eauto 3 with box]
    | H : _ ⊢ _ <: _ : e_pi BOX _ |- _ =>
      apply pi_box_impossible in H; contradiction
    | H : _ ⊢ e_app ?e1 ?e <: e_app ?e2 ?e : BOX |- _ =>
      apply app_of_box_impossible in H; contradiction
    | H : _ ⊢ e_castup _ BOX : _ |- _ =>
      apply castup_box_never_welltype in H; contradiction
    | H : _ ⊢ e_app _ BOX <: e_app _ BOX : _ |- _ =>
      apply app_box_never_welltype in H; contradiction
    | H : _ ⊢ e_abs _ BOX : _ |- _ =>
      apply lambda_box_never_welltype in H; contradiction
    | H : _ ⊢ e_castdn _ <: e_castdn _ : BOX |- _ =>
      apply castdn_of_box_impossible in H; contradiction
    (* reasoning *)
    | H1 : head_kind ?e _ _ |- _ =>
      match goal with
      (* if hypothesis exists in the form of binded expression *)
      | _ : _ ⊢ e ^` _ : BOX |- _ => fail 1
      | _ : _ ⊢ e ^` ?x : _ |- _ => apply head_kind_subst_var with (x := x) in H1
      end
    | H1 : head_kind ?e k_star _ |- _ =>
      match goal with
      | _ : _ ⊢ e      : BOX |- _ => fail 1
      | _ : _ ⊢ e : ?A |- _ =>
        let E := fresh "E" in
        assert (E : A = BOX) by eauto using head_kind_star_of_box;
        discharge_equality E
      | H : _ ⊢ e <: _ : _ |- _ => apply reflexivity_l in H
      | H : _ ⊢ _ <: e : _ |- _ => apply reflexivity_r in H
      end
    | H1 : head_kind ?e k_box _ |- _ =>
      let H2 := fresh H1 in
      find_typing_refl_of e H2;
      eapply head_kind_box_never_welltype in H2; [easy | eauto]
    | H : head_kind (?e1 ^^ ?e2) _ _ |- _ =>
      apply head_kind_invert_subst in H as [H | H]; try solve [inversion H]
    | E : ?e ^` _ = BOX |- _ =>
      apply open_var_is_box in E; discharge_equality E
    | E : ?e1 ^^ ?e2 = BOX |- _ =>
      apply open_is_box in E as [E | E]; discharge_equality E
    | H : _ ⊢ ?e : BOX |- _ => conclude_head_kind_of e H
    | H : _ ⊢ ?e1 <: ?e2 : BOX |- _ =>
      match goal with
      | _ =>
        let H1 := fresh "H" in
        let H2 := fresh "H" in
        conclude_head_kind_of e1 H1; conclude_head_kind_of e2 H2
      end
    end
.

Lemma app_head_kind_impossible : forall Γ f1 f2 e A,
    Γ ⊢ e_app f1 e <: e_app f2 e : A -> forall n k, head_kind e k n -> False.
Proof.
  intros.
  dependent induction H.
  - destruct k; box_reasoning.
  - eauto 2.
Qed.

Lemma lambda_head_kind_impossible : forall Γ A e B,
    Γ ⊢ e_abs A e : B -> forall n k, head_kind e k n -> False.
Proof.
  intros.
  dependent induction H.
  - instantiate_cofinites.
    destruct k; box_reasoning.
  - eauto 2.
Qed.

Lemma mu_head_kind_impossible : forall Γ A e B,
    Γ ⊢ e_mu A e : B -> forall n k, head_kind e k n -> False.
Proof.
  intros.
  dependent induction H.
  - instantiate_cofinites. destruct k0; box_reasoning.
  - eauto 2.
Qed.

Lemma castup_head_kind_box_impossible : forall Γ A e B,
    Γ ⊢ e_castup A e : B -> forall n, head_kind e k_box n -> False.
Proof.
  intros.
  dependent induction H.
  - eauto using head_kind_box_never_welltype.
  - eauto.
Qed.

Hint Resolve app_head_kind_impossible : box.
Hint Resolve lambda_head_kind_impossible : box.
Hint Resolve castup_head_kind_box_impossible : box.
Hint Resolve mu_head_kind_impossible : box.

Lemma box_never_be_reduced : forall e e',
    e ⟶ e' -> forall n, head_kind e' k_box n -> forall Γ A, Γ ⊢ e : A -> False.
Proof with eauto 2 with box.
  intros * R.
  dependent induction R; intros.
  (* r_app *)
  - inversion H0.
  (* r_beta *)
  - box_reasoning.
    + dependent induction H3...
  (* r_inst *)
  - inversion H3.
  (* r_mu *)
  - box_reasoning.
  (* r_castdn *)
  - inversion H.
  (* r_cast_inst *)
  - inversion H2.
  (* r_cast_elim *)
  - dependent induction H2...
Qed.

Hint Resolve box_never_be_reduced : box.

Lemma expr_of_box_never_be_reduced' : forall e' e,
    e' ⟶ e -> forall Γ A, Γ ⊢ e : BOX -> forall Γ', Γ' ⊢ e' : A -> False.
Proof.
  intros * R.
  induction R; intros.
  (* r_app *)
  - box_reasoning.
  (* r_beta *)
  - dependent induction H3; box_reasoning.
  (* r_inst *)
  - box_reasoning.
  (* r_mu *)
  - box_reasoning.
  (* r_castdn *)
  - box_reasoning.
  (* r_inst *)
  - box_reasoning.
  (* r_cast_elim *)
  - dependent induction H2.
    + clear IHusub1 IHusub2 H2.
      dependent induction H2_0; box_reasoning.
      Unshelve. exact 0.
    + eauto 2.
Qed.

Hint Resolve expr_of_box_never_be_reduced' : box.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal21.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Nil).
Definition lfind_example_2  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_3  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_4  := ( Cons (Succ Zero) Nil).
Definition lfind_example_5  := ( Cons Zero Nil).
Definition lfind_example_6  := ( Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_7  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_8  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_9  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_10  := ( Cons (Succ (Succ Zero))         (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).
Definition lfind_example_11  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal21_theorem0_51_lem3/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 .