Require Import Coqlib.
Require Import Maps.
Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Require Import Metatheory.
Require Import Program.Tactics.
Require Import dom_tree.
Require Import ListSet.
Require Import dom_set.
Require Import Sorted.
Require Import analysis.
Import LLVMsyntax.
Import LLVMinfra.

(* This file proves properties of creating dominator trees based on set. *)

Fixpoint dtree_dom (dt: DTree) : atoms :=
match dt with
| DT_node l0 dts0 => {{l0}} `union` dtrees_dom dts0
end
with dtrees_dom (dts: DTrees) : atoms :=
match dts with
| DT_nil => empty
| DT_cons dt0 dts0 => dtree_dom dt0 `union` dtrees_dom dts0
end.

(* l1 >> l2, l1 strict dominates l2 *)
Definition gt_sdom (res: l -> set l) (l1 l2:l) : bool :=
match res l2 with
| dts2 => in_dec l_dec l1 dts2
end.

Fixpoint find_min (res: l -> set l) (acc:l) (dts: set l): l :=
match dts with
| nil => acc
| l0::dts' =>
    if (gt_sdom res acc l0) then
      find_min res l0 dts'
    else
      find_min res acc dts'
end.

Fixpoint insert_sort_sdom_iter (res: l -> set l) (l0:l)
  (prefix suffix:list l) : list l :=
match suffix with
| nil => List.rev (l0 :: prefix)
| l1::suffix' =>
    if gt_sdom res l0 l1 then (List.rev (l0 :: prefix)) ++ suffix
    else insert_sort_sdom_iter res l0 (l1::prefix) suffix'
end.

Fixpoint insert_sort_sdom (res: l -> set l) (data:list l) (acc:list l): list l :=
match data with
| nil => acc
| l1 :: data' =>
    insert_sort_sdom res data' (insert_sort_sdom_iter res l1 nil acc)
end.

Definition sort_sdom (res: l -> set l) (data:list l): list l :=
insert_sort_sdom res data nil.

Definition gt_dom_prop (res: l -> set l) (l1 l2:l) : Prop :=
gt_sdom res l1 l2 = true \/ l1 = l2.

Definition gt_sdom_prop (res: l -> set l) (l1 l2:l) : Prop :=
gt_sdom res l1 l2 = true.

Fixpoint remove_redundant (input: list l) : list l :=
match input with
| a :: ((b :: _) as input') =>
    if (l_dec a b) then remove_redundant input'
    else a :: remove_redundant input'
| _ => input
end.

Fixpoint compute_sdom_chains_aux (res: l -> set l)
  (bd: list l) (acc: list (l * list l)) : list (l * list l) :=
match bd with
| nil => acc
| l0 :: bd' =>
    match res l0 with
    | dts0 =>
        compute_sdom_chains_aux res bd'
          ((l0, remove_redundant (sort_sdom res (l0 :: dts0)))::acc)
    end
end.

Definition compute_sdom_chains (res: l -> set l) rd
  : list (l * list l) :=
compute_sdom_chains_aux res rd nil.

Fixpoint find_idom_aux (res: l -> set l) (acc:l) (dts: set l)
  : option l :=
match dts with
| nil => Some acc
| l0::dts' =>
    match res l0, res acc with
    | dts1, dts2 =>
        if (in_dec l_dec l0 dts2)
        then (* acc << l0 *)
          find_idom_aux res acc dts'
        else
          if (in_dec l_dec acc dts1)
          then (* l0 << acc *)
            find_idom_aux res l0 dts'
          else (* l0 and acc are incompariable *)
            None
    end
end.

(* We should prove that this function is not partial. *)
Definition find_idom (res: l -> set l) (l0:l) : option l :=
match res l0 with
| l1::dts0 => find_idom_aux res l1 dts0
| _ => None
end.

Fixpoint compute_idoms (res: l -> set l) (rd: list l)
  (acc: list (l * l)) : list (l * l) :=
match rd with
| nil => acc
| l0 :: rd' =>
    match find_idom res l0 with
    | None => compute_idoms res rd' acc
    | Some l1 => compute_idoms res rd' ((l1,l0)::acc)
    end
end.

Definition create_dtree (f: fdef) : option DTree :=
match getEntryLabel f, reachablity_analysis f with
| Some root, Some rd =>
    let dt := AlgDom.sdom f in
    let chains := compute_sdom_chains dt rd in
    Some (create_dtree_from_chains eq_atom_dec root chains)
| _, _ => None
end.

Ltac simpl_in_dec :=
  match goal with
  | H: @eq bool (@proj_sumbool _ _  (@in_dec _ ?dec ?a ?s)) true |- _ =>
       destruct (in_dec dec a s); inv H
  | H: is_true (@proj_sumbool _ _  (@in_dec _ ?dec ?a ?s)) |- _ =>
       destruct (in_dec dec a s); inv H
  end.

Ltac solve_in_dec :=
  match goal with
  | |- @eq bool (@proj_sumbool _ _  (@in_dec _ ?dec ?a ?s)) true =>
      destruct (in_dec dec a s); auto
  end.

Ltac elim_in_nil :=
match goal with
| i0: In _ ?l |- ?l <> nil =>
  let J := fresh "J" in
  intro J; rewrite J in i0; auto
| i0: In _ ?l, H: ?l = nil |- False =>
  rewrite H in i0; auto
end.

Lemma insert_sort_sdom_iter_safe: forall res l0 suffix l1 prefix,
  (In l0 (prefix ++ suffix) \/ l0 = l1) <->
  In l0 (insert_sort_sdom_iter res l1 prefix suffix).
Proof.
  induction suffix; simpl; intros.
    split; intro J.
      apply in_or_app.
      destruct J as [J | J]; subst.
        left. simpl_env in J. apply in_rev in J; auto.
        right. simpl. auto.

      apply in_app_or in J. simpl in J. simpl_env.
      destruct J as [J | [J | J]]; subst; auto.
        left. apply in_rev in J; auto.
        tauto.

    simpl_env. simpl.
    split; intro J.
      destruct (gt_sdom res l1 a).
        destruct J as [J | J]; subst.
          apply in_app_or in J. simpl in J.
          apply in_or_app. simpl.
          destruct J as [J | [J | J]]; subst; auto.
            apply in_rev in J; auto.

          apply in_or_app. simpl. auto.
        apply IHsuffix.
          destruct J as [J | J]; auto.
          left. simpl.
          apply in_app_or in J. simpl in J.
          destruct J as [J | [J | J]]; subst; auto.
            right. apply in_or_app; auto.
            right. apply in_or_app; auto.

      destruct (gt_sdom res l1 a).
        apply in_app_or in J. simpl in J.
        destruct J as [J | [J | [J | J]]]; subst; auto.
          left. apply in_or_app. simpl.
          apply in_rev in J; auto.

          left. apply in_or_app. simpl. auto.
          left. apply in_or_app. simpl. auto.
        apply IHsuffix in J.
          destruct J as [J | J]; auto.
          left. apply in_or_app. simpl.
          apply in_app_or in J. simpl in J.
          destruct J as [[J | J] | J]; subst; auto.
Qed.

Lemma insert_sort_sdom_safe: forall res data acc l0,
  (In l0 acc \/ In l0 data) <-> In l0 (insert_sort_sdom res data acc).
Proof.
  induction data; simpl; intros; auto.
    split; tauto.

    split; intro.
      apply IHdata.
      destruct H as [H | [H | H]]; subst; auto.
        left.
        apply insert_sort_sdom_iter_safe; auto.

        left.
        apply insert_sort_sdom_iter_safe; auto.

      apply IHdata in H.
      destruct H as [H | H]; auto.
      apply insert_sort_sdom_iter_safe in H.
      destruct H; auto.
Qed.

Lemma sort_sdom_safe: forall res input l0,
  In l0 (sort_sdom res input) <-> In l0 input.
Proof.
  intros.
  unfold sort_sdom.
  destruct (@insert_sort_sdom_safe res input nil l0) as [J1 J2].
  split; intro; auto.
    apply J2 in H. destruct H as [H | H]; auto. inv H.
Qed.

Lemma remove_redundant_safe: forall l0 input,
  In l0 (remove_redundant input) <-> In l0 input.
Proof.
  induction input; simpl.
    split; auto.

    destruct input.
      simpl. split; auto.

      destruct IHinput as [J1 J2].
      destruct (l_dec a l1); subst.
        split; intros.
          apply J1 in H.
            simpl in H. simpl.
            destruct H; auto.

          apply J2.
            simpl in H. simpl.
            destruct H as [H | [H | H]]; auto.

        split; intros.
          Local Opaque remove_redundant.
          simpl in H.
          destruct H as [H | H]; auto.

          simpl.
          destruct H as [H | H]; auto.
          Transparent remove_redundant.
Qed.

Lemma remove_redundant_HdRel: forall R a input,
  HdRel R a input ->
  HdRel R a (remove_redundant input).
Proof.
  induction input; simpl; intros; auto.
    destruct input; auto.
      inv H.
      destruct (l_dec a0 l0); subst.
        apply IHinput. apply HdRel_cons; auto.
        apply HdRel_cons; auto.
Qed.

Lemma remove_redundant_In: forall a input,
  In a (remove_redundant input) -> In a input.
Proof.
  induction input; simpl; intros; auto.
    destruct input; auto.
      destruct (l_dec a0 l0); subst.
        apply IHinput in H; auto.

        Local Opaque remove_redundant.
        simpl in H.
        destruct H as [H | H]; auto.
        Transparent remove_redundant.
Qed.

Lemma remove_redundant_sorted: forall R input,
  Sorted R input -> Sorted R (remove_redundant input).
Proof.
  induction input; intros; simpl; auto.
    destruct input; auto.
      inv H.
      apply IHinput in H2.
      destruct (l_dec a l0); subst; auto.
        apply Sorted_cons; auto.
          apply remove_redundant_HdRel; auto.
Qed.

Lemma remove_redundant_NoDup: forall (R:l -> l -> Prop) input
  (P0:forall a b c,
        In a input ->
        In b input ->
        In c input -> a <> b -> R a b -> R b c -> a <> c),
  StronglySorted R input ->
  NoDup (remove_redundant input).
Proof.
  induction input; intros; simpl; auto.
    destruct input; auto.
      inv H.
      assert (H2':=H2).
      apply IHinput in H2.
        destruct (l_dec a l0); subst; auto.
          apply NoDup_cons; auto.
          intro J.
          apply remove_redundant_In in J.
          simpl in J.
          destruct J as [J | J]; subst.
            congruence.

            eapply Forall_forall with (x:=l0) in H3; simpl; eauto.
            inv H2'.
            eapply Forall_forall with (x:=a) in H4; eauto.
            apply P0 with (c:=a) in H3; simpl; auto.

        intros. apply P0 with (b:=b); simpl; auto.
Qed.

Lemma remove_redundant_NoDup': forall R input
  (P0:forall a, In a input -> ~ R a a),
  StronglySorted R input ->
  NoDup (remove_redundant input).
Proof.
  induction input; intros; simpl; auto.
    destruct input; auto.
      inv H.
      apply IHinput in H2.
        destruct (l_dec a l0); subst; auto.
          apply NoDup_cons; auto.
          intro J.
          apply remove_redundant_In in J.
          eapply Forall_forall in H3; eauto.
          revert H3. apply P0. simpl. auto.
        intros. apply P0. simpl. simpl in H.
        destruct H; auto.
Qed.

Lemma compute_sdom_chains_aux__dom : forall res l0 chain0 rd acc,
  In (l0, chain0) (compute_sdom_chains_aux res rd acc) ->
  In l0 rd \/ In (l0, chain0) acc.
Proof.
  induction rd; simpl; intros; auto.
    apply IHrd in H.
    destruct H as [H | H]; auto.
    simpl in H.
    destruct H as [H | H]; auto.
    inv H; auto.
Qed.

Lemma compute_sdom_chains__dom : forall res rd l0 chain0,
  In (l0, chain0) (compute_sdom_chains res rd) -> In l0 rd.
Proof.
  unfold compute_sdom_chains.
  intros.
  apply compute_sdom_chains_aux__dom in H.
  destruct H as [H | H]; auto.
  inv H.
Qed.

Lemma compute_sdom_chains_aux_sorted__helper: forall bd0 bd bs_contents res x
  (bs_bound : incl bs_contents bd0) (l1 : l) (Hinc : incl (l1 :: bd) bd0)
  (H1 : In x (sort_sdom res (l1 :: bs_contents))),
  In x bd0.
Proof.
  intros.
  apply sort_sdom_safe in H1.
  simpl in H1.
  destruct H1 as [H1 | H1]; subst.
    apply Hinc. simpl; auto.
    apply bs_bound. auto.
Qed.

Lemma in_gt_sdom__in_bound_fdef: forall f l1 l2
  (Hin: gt_sdom (AlgDom.sdom f) l1 l2 = true),
  In l1 (bound_fdef f).
Proof.
  unfold gt_sdom.
  intros. simpl_in_dec.
  eapply AlgDomProps.in_bound_dom__in_bound_fdef; eauto.
Qed.

Lemma NoDup_gt_dom_prop_sorted__gt_dsom_prop_sorted: forall f chain
  (Hsorted: Sorted (gt_dom_prop (AlgDom.sdom f)) chain)
  (Huniq: NoDup chain),
  Sorted (gt_sdom_prop (AlgDom.sdom f)) chain.
Proof.
  intros.
  induction Hsorted; simpl; intros; auto.
    inv Huniq.
    constructor; auto.
      inv H; auto.
      constructor.
        destruct H0; subst; auto.
          contradict H2; simpl; auto.
Qed.

Lemma compute_sdom_chains_aux_safe: forall (res:l -> set l)
  l0 l1 chain0 dts0 bd acc,
  (forall l0 l1 chain0 dts0,
    In (l0, chain0) acc ->
    res l0 = dts0 ->
    (In l1 chain0 <-> In l1 (l0 :: dts0))) ->
  In (l0, chain0) (compute_sdom_chains_aux res bd acc) ->
  res l0 = dts0 ->
  (In l1 chain0 <-> In l1 (l0 :: dts0)).
Proof.
  induction bd; intros; eauto.
    simpl in H0.
    apply IHbd in H0; auto.
    intros. simpl in H2.
    destruct H2 as [H2 | H2]; eauto.
    inv H2.
    destruct (@remove_redundant_safe l3 (sort_sdom res (l2 :: res l2)))
      as [J1 J2].
    destruct (@sort_sdom_safe res (l2 :: res l2) l3) as [J3 J4].
    split; eauto.
Qed.

Lemma compute_sdom_chains_safe: forall res rd l0 chain l1 dts0 ,
  In (l0, chain) (compute_sdom_chains res rd) ->
  res l0 = dts0 ->
  (In l1 chain <-> In l1 (l0 :: dts0)).
Proof.
  intros.
  unfold compute_sdom_chains in H.
  eapply compute_sdom_chains_aux_safe in H; eauto.
  simpl. intros. tauto.
Qed.

Lemma gt_sdom_prop_entry: forall f l1 entry
  (H: getEntryLabel f = Some entry)
  (H4: gt_sdom_prop (AlgDom.sdom f) l1 entry),
  False.
Proof.
  intros.
  unfold gt_sdom_prop, gt_sdom in H4.
  assert (exists sts,
    getEntryBlock f = Some (entry, sts)) as Hentry.
    destruct f as [fh bs]. destruct bs; tinv H.
    destruct b; inv H; simpl; eauto.
  destruct Hentry as [sts Hentry].
  apply AlgDom.dom_entrypoint in Hentry.
  simpl_in_dec. rewrite Hentry in i0. auto.
Qed.

Lemma entry_in_compute_sdom_chains: forall entry l0 chain0 res rd
  (H:forall b, b <> entry /\ In b rd ->
     match res b with
     | dts => In entry dts
     end)
  (H0:In (l0, chain0) (compute_sdom_chains res rd))
  (Huniq:NoDup chain0)
  (G:(length chain0 > 1)%nat),
  In entry chain0.
Proof.
  intros.
  assert (H0':=H0).
  apply compute_sdom_chains__dom in H0'.
  assert (H1':=H0).
  eapply compute_sdom_chains_safe with (l1:=entry) in H0; eauto.
  apply H0.
  simpl.
  destruct (l_dec l0 entry); subst; auto.
Qed.

Lemma compute_sdom_chains__in_bound: forall l0 chain0 f rd
  (Hinc: incl rd (bound_fdef f)),
  In (l0, chain0) (compute_sdom_chains (AlgDom.sdom f) rd) ->
  incl chain0 (bound_fdef f).
Proof.
  intros.
  intros x Hin.
  assert (H':=H).
  eapply compute_sdom_chains_safe in H; eauto.
  eapply H in Hin.
  simpl in Hin.
  destruct Hin as [Hin | Hin]; subst.
    apply compute_sdom_chains__dom in H'; auto.
    eapply AlgDomProps.in_bound_dom__in_bound_fdef; eauto.
Qed.

Section GtDomProps.

Variable (f:fdef).
Hypothesis (Hentry: getEntryBlock f <> None).
Hypothesis (Hbranch: AlgDom.branchs_in_fdef f).
Hypothesis (Huniq: uniqFdef f).

Lemma gt_dom_prop_trans : forall l1 l2 l3
  (HBinF1: In l1 (bound_fdef f))
  (HBinF2: In l2 (bound_fdef f))
  (HBinF3: In l3 (bound_fdef f))
  (H1 : gt_dom_prop (AlgDom.sdom f) l1 l2)
  (H2 : gt_dom_prop (AlgDom.sdom f) l2 l3),
  gt_dom_prop (AlgDom.sdom f) l1 l3.
Proof.
  unfold gt_dom_prop, gt_sdom.
  intros.
  apply In_bound_fdef__blockInFdefB in HBinF1.
  apply In_bound_fdef__blockInFdefB in HBinF2.
  apply In_bound_fdef__blockInFdefB in HBinF3.
  destruct HBinF1 as [sts1 HBinF1].
  destruct HBinF2 as [sts2 HBinF2].
  destruct HBinF3 as [sts3 HBinF3].
  destruct (l_dec l1 l3); auto.
  destruct H2 as [H2 | H2]; subst; auto.
  Case "l2 in sdom(l3)".
    simpl_in_dec.
    left.
    assert (domination f l2 l3) as Hdom23.
      eapply AlgDomProps.dom_is_sound; simpl; eauto.
    destruct H1 as [H1 | H1]; subst.
    SCase "l1 in sdom(l2)".
      simpl_in_dec.
      assert (domination f l1 l2) as Hdom12.
        eapply AlgDomProps.dom_is_sound; simpl; eauto.
      assert (strict_domination f l1 l3) as Hsdom13.
        apply DecDom.dom_sdom; auto.
        eapply DecDom.dom_tran; eauto.
      eapply AlgDom.sdom_is_complete in Hsdom13; eauto 1.
        solve_in_dec.

    SCase "l1=l2".
      assert (strict_domination f l2 l3) as Hsdom23.
        apply DecDom.dom_sdom; auto.
      eapply AlgDom.sdom_is_complete in Hsdom23; eauto 1.
        solve_in_dec.
Qed.

Lemma gt_dom_dec_aux: forall l1 l2 l3
  (Hreach: reachable f l3)
  (HBinF1: In l1 (bound_fdef f))
  (HBinF2: In l2 (bound_fdef f))
  (HBinF3: In l3 (bound_fdef f)),
  gt_sdom (AlgDom.sdom f) l1 l3 ->
  gt_sdom (AlgDom.sdom f) l2 l3 ->
  gt_dom_prop (AlgDom.sdom f) l1 l2 \/
  gt_dom_prop (AlgDom.sdom f) l2 l1.
Proof.
  unfold gt_dom_prop, gt_sdom. intros.
  destruct (l_dec l1 l2); auto.
  repeat simpl_in_dec.
  apply In_bound_fdef__blockInFdefB in HBinF1.
  apply In_bound_fdef__blockInFdefB in HBinF2.
  apply In_bound_fdef__blockInFdefB in HBinF3.
  destruct HBinF1 as [sts1 HBinF1].
  destruct HBinF2 as [sts2 HBinF2].
  destruct HBinF3 as [sts3 HBinF3].
  assert (strict_domination f l1 l3) as Hsdom13.
    eapply AlgDomProps.sdom_is_sound; eauto.
  assert (strict_domination f l2 l3) as Hsdom23.
    eapply AlgDomProps.sdom_is_sound; eauto.
  assert (Hentry':=Hentry).
  apply nonempty_getEntryBlock__getEntryLabel in Hentry'.
  destruct Hentry' as [entry Hentry'].
  assert (reachable f l2) as Hreach2.
    apply DecDom.sdom_reachable in Hsdom23; auto.
  assert (reachable f l1) as Hreach1.
    apply DecDom.sdom_reachable in Hsdom13; auto.
  destruct (l_dec l1 entry); subst.
    left. left.
    assert (set_In entry (AlgDom.sdom f l2)) as G.
      eapply AlgDomProps.entry_doms_others; eauto.
    solve_in_dec.
  destruct (l_dec l2 entry); subst.
    right. left.
    assert (set_In entry (AlgDom.sdom f l1)) as G.
      eapply AlgDomProps.entry_doms_others; eauto.
    solve_in_dec.
  eapply DecDom.sdom_ordered with (l1:=l2) in Hsdom13; eauto 1.
  destruct Hsdom13 as [Hsdom21 | Hsdom12].
  Case "1".
    right.
    eapply AlgDom.sdom_is_complete in Hsdom21; eauto 1.
      left. solve_in_dec.
  Case "2".
    left.
    eapply AlgDom.sdom_is_complete in Hsdom12; eauto 1.
      left. solve_in_dec.
Qed.

Lemma gt_dom_dec: forall l1 l2 l3
  (Hreach: reachable f l3)
  (HBinF1: In l1 (bound_fdef f))
  (HBinF2: In l2 (bound_fdef f))
  (HBinF3: In l3 (bound_fdef f)),
  gt_dom_prop (AlgDom.sdom f) l1 l3 ->
  gt_dom_prop (AlgDom.sdom f) l2 l3 ->
  gt_dom_prop (AlgDom.sdom f) l1 l2 \/
  gt_dom_prop (AlgDom.sdom f) l2 l1.
Proof.
  intros.
  destruct H as [H | H]; subst; auto.
  destruct H0 as [H0 | H0]; subst.
    eapply gt_dom_dec_aux; eauto.
    left. left. auto.
Qed.

Lemma gt_sdom_dec: forall l1 l2 l3
  (Hneq: l1 <> l2)
  (Hreach: reachable f l3)
  (HBinF1: In l1 (bound_fdef f))
  (HBinF2: In l2 (bound_fdef f))
  (HBinF3: In l3 (bound_fdef f)),
  gt_sdom (AlgDom.sdom f) l1 l3 ->
  gt_sdom (AlgDom.sdom f) l2 l3 ->
  gt_sdom (AlgDom.sdom f) l1 l2 \/
  gt_sdom (AlgDom.sdom f) l2 l1.
Proof.
  intros.
  apply gt_dom_dec with (l1:=l1) (l2:=l2) (l3:=l3) in Hreach; auto.
    destruct Hreach as [[J | J] | [J | J]]; subst; auto; try congruence.
    left. auto.
    left. auto.
Qed.

Lemma gt_sdom_prop_irrefl: forall a (Hreach : reachable f a),
  gt_sdom (AlgDom.sdom f) a a = false.
Proof.
  unfold gt_sdom.
  intros.
  assert (J:=Hreach).
  apply reachable__in_bound in Hreach; eauto 2.
  apply In_bound_fdef__blockInFdefB in Hreach.
  destruct Hreach as [stss HBinF].
  destruct (in_dec l_dec a (AlgDom.sdom f a)); simpl; auto.
  eapply AlgDomProps.sdom_is_sound with (l':=a) in HBinF; eauto 1.
    apply DecDom.sdom_isnt_refl in HBinF; auto.
      congruence.
Qed.

Hypothesis getEntryBlock_inv : forall
  (l3 : l)
  (l' : l)
  (ps : phinodes)
  (cs : cmds)
  (tmn : terminator)
  (HBinF : blockInFdefB (l3, stmts_intro ps cs tmn) f = true)
  (Hsucc : In l' (successors_terminator tmn)) a sts0
  (H : getEntryBlock f = Some (a, sts0)),
  l' <> a.

Lemma gt_sdom_prop_trans : forall
  l1 l2 l3
  (HBinF1: In l1 (bound_fdef f))
  (HBinF2: In l2 (bound_fdef f))
  (HBinF3: In l3 (bound_fdef f))
  (H1 : gt_sdom (AlgDom.sdom f) l1 l2 = true)
  (H2 : gt_sdom (AlgDom.sdom f)  l2 l3 = true),
  gt_sdom (AlgDom.sdom f)  l1 l3 = true.
Proof.
  unfold gt_sdom.
  intros.
  repeat simpl_in_dec.
  apply In_bound_fdef__blockInFdefB in HBinF1.
  apply In_bound_fdef__blockInFdefB in HBinF2.
  apply In_bound_fdef__blockInFdefB in HBinF3.
  destruct HBinF1 as [sts1 HBinF1].
  destruct HBinF2 as [sts2 HBinF2].
  destruct HBinF3 as [sts3 HBinF3].
  destruct (reachable_dec f l3).
  Case "1".
    assert (strict_domination f l2 l3) as Hsdom23.
      eapply AlgDomProps.sdom_is_sound; eauto.
    assert (reachable f l2) as Hreach2.
      apply DecDom.sdom_reachable in Hsdom23; auto.
    assert (strict_domination f l1 l2) as Hsdom12.
      eapply AlgDomProps.sdom_is_sound; eauto.
    assert (strict_domination f l1 l3) as Hsdom13.
      eapply DecDom.sdom_tran with (l2:=l2); eauto.
    eapply AlgDom.sdom_is_complete in Hsdom13; eauto 1.
      solve_in_dec.
  Case "2".
    eapply AlgDom.dom_unreachable in H; eauto 1.
      apply blockInFdefB_in_bound_fdef in HBinF1.
      unfold vertexes_fdef in HBinF1.
      rewrite H.
      solve_in_dec.
Qed.

Lemma gt_sdom_prop_trans1 : forall l1 l2 l3
  (Hreach: reachable f l3)
  (HBinF2: In l2 (bound_fdef f))
  (H1 : gt_sdom (AlgDom.sdom f) l1 l2 = true)
  (H2 : gt_dom_prop (AlgDom.sdom f) l2 l3),
  gt_sdom (AlgDom.sdom f) l1 l3 = true.
Proof.
  intros.
  assert (HBinF1: In l1 (bound_fdef f)).
    eapply in_gt_sdom__in_bound_fdef; eauto.
  assert (HBinF3: In l3 (bound_fdef f)).
    eapply reachable__in_bound; eauto 2.
  unfold gt_dom_prop, gt_sdom in *.
  destruct (in_dec l_dec l1); inv H1.
  apply In_bound_fdef__blockInFdefB in HBinF1.
  apply In_bound_fdef__blockInFdefB in HBinF2.
  apply In_bound_fdef__blockInFdefB in HBinF3.
  destruct HBinF1 as [sts1 HBinF1].
  destruct HBinF2 as [sts2 HBinF2].
  destruct HBinF3 as [sts3 HBinF3].
  assert (domination f l2 l3) as Hdom23.
    eapply AlgDomProps.dom_is_sound; eauto.
      destruct H2 as [H2 | H2]; simpl; auto.
        simpl_in_dec; auto.
  assert (reachable f l2) as Hreach2.
     apply DecDom.dom_reachable in Hdom23; auto.
  assert (strict_domination f l1 l2) as Hsdom12.
    eapply AlgDomProps.sdom_is_sound; eauto.
  eapply DecDom.sdom_tran1 with (l3:=l3) in Hsdom12; eauto 1.
  eapply AlgDom.sdom_is_complete in Hsdom12; eauto 1.
    solve_in_dec.
Qed.

End GtDomProps.

Require Import typings_props.
Require Import typings.
Import LLVMtypings.

Ltac solve_dom :=
try solve [
  eauto 1 |
  unfold AlgDomProps.getEntryBlock_inv; eapply getEntryBlock_inv'; eauto 1 |
  eapply wf_fdef__non_entry; eauto 1 |
  eapply branches_in_vertexes; eauto 1 |
  eapply wf_fdef__wf_entry; eauto 1 |
  unfold AlgDom.branchs_in_fdef; eapply branches_in_bound_fdef; eauto 1
].

Lemma insert_sort_sdom_iter_sorted: forall S M f (HwfF: wf_fdef S M f)
  (Huniq: uniqFdef f) l3 (Hin3: In l3 (bound_fdef f)) (Hreach: reachable f l3)
  l0 (Hin0: In l0 (bound_fdef f))
  (Hsd03: gt_dom_prop (AlgDom.sdom f) l0 l3) suffix prefix
  (G: forall l', In l' (prefix ++ suffix) ->
      gt_dom_prop (AlgDom.sdom f) l' l3 /\ In l' (bound_fdef f)),
  Sorted (gt_dom_prop (AlgDom.sdom f))
    (List.rev prefix ++ suffix) ->
  (forall l1 prefix', prefix = l1 :: prefix' ->
      gt_dom_prop (AlgDom.sdom f) l1 l0) ->
  Sorted (gt_dom_prop (AlgDom.sdom f))
    (insert_sort_sdom_iter (AlgDom.sdom f) l0 prefix suffix).
Proof.
  induction suffix; simpl; intros.
    simpl_env in *.
    apply sorted_append; auto.
      intros.
      apply H0 with (prefix':=rev l1'); auto.
        rewrite <- rev_involutive at 1.
        rewrite H1. rewrite rev_unit. auto.

    remember (gt_sdom (AlgDom.sdom f) l0 a) as R.
    destruct R.
      simpl_env. simpl.
      apply sorted_insert; auto.
        intros.
        apply H0 with (prefix':=rev l1'); auto.
          rewrite <- rev_involutive at 1.
          rewrite H1. rewrite rev_unit. auto.

        intros.
        inv H1.
        unfold gt_dom_prop. auto.

      apply IHsuffix.
        intros. apply G.
        apply in_or_app. simpl.
        apply in_app_or in H1. simpl in H1.
        destruct H1 as [[H1 | H1] | H1]; auto.

        simpl. simpl_env. simpl. auto.

        intros. inv H1.
        assert (gt_dom_prop (AlgDom.sdom f) l1 l0 \/
                gt_dom_prop (AlgDom.sdom f) l0 l1) as J.
          assert (In l1 (prefix'++l1::suffix)) as Hin1. apply in_middle.
          apply G in Hin1. destruct Hin1 as [J1 J2].
          eapply gt_dom_dec; solve_dom.
        destruct J; auto.
        unfold gt_dom_prop in H1. unfold gt_dom_prop.
        destruct (l_dec l0 l1); auto.
        destruct H1 as [H1 | H1]; auto.
        rewrite <- HeqR in H1. congruence.
Qed.

Lemma insert_sort_sdom_sorted: forall S M f (HwfF: wf_fdef S M f)
  (Huniq: uniqFdef f) l3 (Hin3: In l3 (bound_fdef f)) (Hreach: reachable f l3)
  data acc
  (G: forall l', In l' (data++acc) ->
      gt_dom_prop (AlgDom.sdom f) l' l3 /\ In l' (bound_fdef f)),
  Sorted (gt_dom_prop (AlgDom.sdom f)) acc ->
  Sorted (gt_dom_prop (AlgDom.sdom f))
         (insert_sort_sdom (AlgDom.sdom f) data acc).
Proof.
  induction data; simpl; intros; auto.
    apply IHdata.
      intros. apply G.
      apply in_app_or in H0.
      destruct H0 as [H0 | H0].
        right. apply in_or_app; auto.
        apply insert_sort_sdom_iter_safe in H0.
        destruct H0 as [H0 | H0]; auto.
          right. apply in_or_app. simpl_env in H0. auto.

      assert (a = a \/ In a (data++acc)) as Hin. auto.
      apply G in Hin. destruct Hin as [J1 J2].
      eapply insert_sort_sdom_iter_sorted with (l3:=l3); eauto.
        intros. apply G. right. apply in_or_app. simpl_env in H0. auto.

        intros. inv H0.
Qed.

Lemma sort_sdom_sorted: forall S M f (HwfF: wf_fdef S M f)
  (Huniq: uniqFdef f) l3 (Hin3: In l3 (bound_fdef f)) (Hreach: reachable f l3)
  input
  (G: forall l', In l' input ->
      gt_dom_prop (AlgDom.sdom f) l' l3 /\ In l' (bound_fdef f)),
  Sorted (gt_dom_prop (AlgDom.sdom f))
         (sort_sdom (AlgDom.sdom f) input).
Proof.
  intros. unfold sort_sdom.
  eapply insert_sort_sdom_sorted; simpl_env; eauto.
Qed.

Lemma compute_sdom_chains_aux_sorted: forall S M f
  (HwfF: wf_fdef S M f) (Huniq: uniqFdef f)
  l0 chain0 bd (Hinc: incl bd (bound_fdef f))
  (Hreach: forall x, In x bd -> reachable f x) acc,
  (forall l0 chain0, In (l0, chain0) acc ->
    Sorted (gt_dom_prop (AlgDom.sdom f)) chain0 /\
    NoDup chain0) ->
  In (l0, chain0)
    (compute_sdom_chains_aux (AlgDom.sdom f) bd acc) ->
  Sorted (gt_dom_prop (AlgDom.sdom f)) chain0 /\ NoDup chain0.
Proof.
  induction bd as [|a bd]; simpl; intros; eauto.
    apply IHbd in H0; auto.
    Case "1".
      simpl_env in Hinc.
      apply AtomSet.incl_app_invr in Hinc; auto.
    Case "2".
      intros l1 chain1 H1.
      destruct H1 as [H1 | H1]; eauto.
      inv H1.
      assert (In l1 (bound_fdef f)) as G1.
        apply Hinc; simpl; auto.
      assert (forall l' : l,
        In l' (l1 :: AlgDom.sdom f l1) ->
        gt_dom_prop (AlgDom.sdom f) l' l1 /\ In l' (bound_fdef f))
        as G2.
        intros l' Hin.
        simpl in Hin.
        destruct Hin as [EQ | Hin]; subst.
          unfold gt_dom_prop. split; auto.

          split.
            unfold gt_dom_prop, gt_sdom.
            left. solve_in_dec.

            eapply AlgDomProps.in_bound_dom__in_bound_fdef; eauto.
      split.
      SCase "2.1".
        apply remove_redundant_sorted; auto.
          eapply sort_sdom_sorted; eauto.
      SCase "2.2".
        apply remove_redundant_NoDup with
          (R:=gt_dom_prop (AlgDom.sdom f)); auto.
        SSCase "2.2.1".
          intros.
          destruct H5; subst; try congruence.
          assert (reachable f c) as Hreachc.
            apply sort_sdom_safe in H3.
              simpl in H3.
              destruct H3 as [H3 | H3]; subst.
                apply Hreach; auto.

                assert (reachable f l1) as Hreach1. apply Hreach; auto.
                eapply DecDom.sdom_reachable; eauto.
                  assert (In l1 (bound_fdef f)) as Hin.
                    apply Hinc; simpl; auto.
                  apply In_bound_fdef__blockInFdefB in Hin.
                  destruct Hin as [sts HBinF].
                  eapply AlgDomProps.sdom_is_sound; solve_dom.

Ltac find_in_bound_fdef :=
match goal with
| G1 : In ?l1 (bound_fdef ?f),
  H2 : In ?b
         (sort_sdom (AlgDom.sdom ?f)
            (?l1 :: AlgDom.sdom ?f ?l1)) |-
  In ?b (bound_fdef ?f) =>
  apply sort_sdom_safe in H2;
  destruct_in H2; eauto using AlgDomProps.in_bound_dom__in_bound_fdef
end.

          eapply gt_sdom_prop_trans1 with (l1:=a) in H6;
            eauto using compute_sdom_chains_aux_sorted__helper;
            try find_in_bound_fdef; solve_dom.
            intro EQ; subst.
            apply gt_sdom_prop_irrefl with (a:=c) in Hreachc; solve_dom.
            rewrite Hreachc in H6. congruence.

         SSCase "2.2.2".
          apply strict_Sorted_StronglySorted.
            intros.
            eapply gt_dom_prop_trans with (l2:=y);
              eauto using compute_sdom_chains_aux_sorted__helper;
              try find_in_bound_fdef; solve_dom.
            eapply sort_sdom_sorted; eauto.
Qed.

Lemma compute_sdom_chains_sorted: forall S M f
  (HwfF: wf_fdef S M f) (Huniq: uniqFdef f)
  rd (Hinc: incl rd (bound_fdef f)) (Hreach: forall x, In x rd -> reachable f x)
  l0 chain,
  In (l0, chain) (compute_sdom_chains (AlgDom.sdom f) rd) ->
  Sorted (gt_sdom_prop (AlgDom.sdom f)) chain /\ NoDup chain.
Proof.
  intros.
  unfold compute_sdom_chains in H.
  eapply compute_sdom_chains_aux_sorted in H; eauto.
    destruct H as [H1 H2].
    split; auto.
      apply NoDup_gt_dom_prop_sorted__gt_dsom_prop_sorted; auto.

    simpl. intros. tauto.
Qed.

Lemma entry_is_head_of_compute_sdom_chains: forall S M f
  (HwfF: wf_fdef S M f) (Huniq: uniqFdef f) entry rd l0 chain0
  (H:getEntryLabel f = Some entry)
  (H0:reachablity_analysis f = Some rd)
  (H1:In (l0, chain0)
    (compute_sdom_chains (AlgDom.sdom f) rd))
  (G:(length chain0 > 1)%nat),
  exists chain0', chain0 = entry :: chain0'.
Proof.
  intros.
  assert (forall b,
    b <> entry /\ In b rd ->
    match AlgDom.sdom f b with
    | dts => In entry dts
    end) as J.
    intros b Hp.
    destruct Hp as [Hp1 Hp2].
    eapply reachablity_analysis__reachable in Hp2; eauto.
    eapply AlgDomProps.entry_doms_others; solve_dom; eauto.

  assert (J0:=H0).
  apply reachablity_analysis__in_bound in H0.
  assert (forall x : atom, In x rd -> reachable f x) as W.
    intros. eapply reachablity_analysis__reachable; eauto.
  assert (J1:=H1).
  eapply compute_sdom_chains_sorted in J1; eauto.
  destruct J1 as [J1 J2].
  assert (H1':=H1).
  apply entry_in_compute_sdom_chains with (entry:=entry) in H1'; auto.
  apply compute_sdom_chains__in_bound in H1; auto.
  destruct chain0.
    inv H1'.

    simpl in H1'.
    destruct (l_dec l1 entry); subst; eauto.
    destruct H1' as [Heq | H1']; subst.
      congruence.

      apply strict_Sorted_StronglySorted in J1; auto.
        inv J1.
        inv J2.
        eapply Forall_forall in H5; eauto.
        apply gt_sdom_prop_entry in H5; tauto.

        intros.
        eapply gt_sdom_prop_trans with (l2:=y); solve_dom; eauto.
Qed.

Definition wf_chain f dt (chain:list l) : Prop :=
match chain with
| entry :: _ :: _ =>
   let res := (AlgDom.sdom f) in
   entry = get_dtree_root dt /\
   Sorted (gt_sdom_prop res) chain /\ NoDup chain
| _ => True
end.

Lemma compute_sdom_chains__wf_chain: forall S M f
  (HwfF: wf_fdef S M f) (Huniq: uniqFdef f) l0 chain0 entry rd,
  getEntryLabel f = Some entry ->
  reachablity_analysis f =  Some rd ->
  In (l0, chain0) (compute_sdom_chains (AlgDom.sdom f) rd) ->
  wf_chain f (DT_node entry DT_nil) chain0.
Proof.
  intros.
  destruct chain0; simpl; auto.
  destruct chain0; simpl; auto.
  assert (H1':=H1).
  eapply entry_is_head_of_compute_sdom_chains in H1';
    simpl; try solve [eauto | omega].
  destruct H1' as [chain0' H1']; subst; simpl.
  inv H1'.
  split; auto.
    eapply compute_sdom_chains_sorted;
      eauto using reachablity_analysis__in_bound.
      intros. eapply reachablity_analysis__reachable; eauto.
Qed.

Lemma create_dtree__wf_dtree: forall f dt,
  create_dtree f = Some dt ->
  match getEntryLabel f, reachablity_analysis f with
  | Some root, Some rd =>
      let dt' := AlgDom.sdom f in
      let chains := compute_sdom_chains dt' rd in
      forall p0 ch0,
        (is_dtree_edge eq_atom_dec dt p0 ch0 ->
         exists l0, exists chain0,
           In (l0, chain0) chains /\ is_chain_edge chain0 p0 ch0) /\
        ((exists l0, exists chain0,
           In (l0, chain0) chains /\
           chain_connects_dtree (DT_node root DT_nil) chain0 /\
           is_chain_edge chain0 p0 ch0) -> is_dtree_edge eq_atom_dec dt p0 ch0)
  | _, _ => False
  end.
Proof.
  unfold create_dtree.
  intros.
  remember (getEntryLabel f) as R.
  destruct R; tinv H.
  remember (reachablity_analysis f) as R.
  destruct R; inv H.
  intros.
  apply create_dtree_from_chains__is_dtree_edge__is_chain_edge.
Qed.

Definition in_dtree_dom__in_dtree_insert_dom_prop (dt:DTree) :=
forall i0 p ch tl,
  i0 `in` (dtree_dom dt) ->
  i0 `in` (dtree_dom (dtree_insert eq_atom_dec dt p ch tl)).

Definition in_dtrees_dom__in_dtrees_insert_dom_prop (dts:DTrees) :=
forall i0 ch tl,
  i0 `in` (dtrees_dom dts) ->
  i0 `in` (dtrees_dom (dtrees_insert eq_atom_dec dts ch tl)).

Lemma in_dtree_dom__in_dtree_insert_dom_mutrec :
  (forall dt, in_dtree_dom__in_dtree_insert_dom_prop dt) /\
  (forall dts, in_dtrees_dom__in_dtrees_insert_dom_prop dts).
Proof.
  apply dtree_mutrec;
    unfold in_dtree_dom__in_dtree_insert_dom_prop,
           in_dtrees_dom__in_dtrees_insert_dom_prop;
    simpl; intros.
  Case "DT_node".
  destruct (eq_atom_dec p a); subst; simpl; auto.
    apply AtomSetFacts.union_iff in H0.
    apply AtomSetFacts.union_iff.
    destruct H0; auto.
  Case "DT_nil".
  contradict H. auto.
  Case "DT_cons".
  apply AtomSetFacts.union_iff in H1.
  destruct d as [l0 ?].
  destruct_if; simpl.
    SCase "1".
    destruct tl; simpl.
      SSCase "1.1".
      apply AtomSetFacts.union_iff.
      destruct H1 as [H1 | H1]; auto.
      SSCase "1.2".
      apply AtomSetFacts.union_iff.
      destruct H1 as [H1 | H1]; auto.
        left. apply H; auto.
    SCase "2".
    apply AtomSetFacts.union_iff.
    destruct H1 as [H1 | H1]; auto.
Qed.

Lemma in_dtree_dom__in_dtree_insert_dom: forall dt i0 p ch tl,
  i0 `in` (dtree_dom dt) ->
  i0 `in` (dtree_dom (dtree_insert eq_atom_dec dt p ch tl)).
Proof.
  destruct in_dtree_dom__in_dtree_insert_dom_mutrec as [H _].
  unfold in_dtree_dom__in_dtree_insert_dom_prop in H. auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal35.

Set Printing Depth 1000.
Definition lfind_eval  y:=
plus y Zero.

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).


(** * Opposite functors *)
Require Category.Dual.
Import Category.Dual.CategoryDualNotations.
Require Import Category.Core Functor.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.

(** ** Definition of [Fᵒᵖ] *)
Definition opposite C D (F : Functor C D) : Functor C^op D^op
  := Build_Functor (C^op) (D^op)
                   (object_of F)
                   (fun s d (m : morphism C^op s d) => (F _1 m)%morphism)
                   (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
                   (identity_of F).

Local Notation "F ^op" := (opposite F) : functor_scope.

Local Open Scope functor_scope.

(** ** [ᵒᵖ] is judgmentally involutive *)
Definition opposite_involutive C D (F : Functor C D) : (F^op)^op = F
  := idpath.

Module Export FunctorDualNotations.
  Notation "F ^op" := (opposite F) : functor_scope.
End FunctorDualNotations.


Inductive Interval:Type :=
| interval_def (b:nat) (e:nat): b <= e -> Interval.


Require concrete.
Require abstract.
Require Import reachability.
Require Import List.
Set Implicit Arguments.

Section contents.

  Variables (chs: concrete.System) (ahs: abstract.System)
    (abs: concrete.State chs -> abstract.State ahs).

  Record Respects: Prop :=
    { RespectsInit: forall s,
        concrete.initial s -> abstract.initial (abs s) = true
    ; RespectsDisc: forall s1 s2,
       concrete.disc_trans s1 s2 ->
         In (abs s2) (abstract.disc_trans (abs s1))
    ; RespectsCont: forall s1 s2,
       concrete.cont_trans s1 s2 ->
         In (abs s2) (abstract.cont_trans (abs s1))
    }.

  Variable respects: Respects.

  Lemma reachable_alternating_concrete_abstract (s: concrete.State chs):
    concrete.alternating_reachable s -> abstract.reachable (abs s).
  Proof with auto.
    unfold concrete.alternating_reachable.
    unfold abstract.reachable.
    intros.
    destruct H.
    destruct H.
    exists (abs x).
    split. firstorder.
    destruct H0.
      apply reachable_alternating_A.
      induction H0.
        apply reachable_alternating_a_init.
      destruct respects.
      apply reachable_alternating_a_next with (abs s) (abs s')...
    apply reachable_alternating_B with (abs s).
      clear H1.
      induction H0.
        apply reachable_alternating_a_init.
      destruct respects.
      apply reachable_alternating_a_next with (abs s) (abs s'0)...
    destruct respects...
  Qed.

  Lemma reachable_concrete_abstract (s: concrete.State chs):
    concrete.reachable s -> abstract.reachable (abs s).
  Proof.
    intros. apply reachable_alternating_concrete_abstract.
    apply concrete.reachable_alternating. assumption.
  Qed.

  Theorem safe (s: concrete.State chs):
    ~ abstract.reachable (abs s) -> ~ concrete.reachable s.
  Proof.
    intros s H0 H1. apply H0.
    apply reachable_concrete_abstract. assumption.
  Qed.

  Theorem safe' s: ~ abstract.reachable s ->
    forall u, abs u = s -> ~ concrete.reachable u.
  Proof. intros. subst. apply safe. assumption. Qed.
    (* hm, these sound good, but can't possible
     be the whole story.. *)

    (* ah, we need something like:
  Theorem safe'' s: ~ abstract.reachable _ s ->
    forall u, u in rsquare(s) -> ~ concrete.reachable u.
     *)

End contents.


Require Import isla.isla.
Require Import isla.aarch64.aarch64.
Require Export isla.examples.pkvm_handler.a7414.

Lemma a7414_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a7414) -∗
  instr_body pc (ldp_mapsto_spec pc "R0" "R1" "SP_EL2" 0 None).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a7414_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a7414_spec pc).
Global Existing Instance a7414_spec_inst.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.DeepEmbedded.Parameter.
Require Logic.SeparationLogic.DeepEmbedded.SeparationEmpLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class Parametric_SeparationLogic (PAR: SL_Parameter) (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} {empL: EmpLanguage L} (GammaP: Provable L) {minAX: MinimumAxiomatization L GammaP} {ipAX: IntuitionisticPropositionalLogic L GammaP} {sepconAX: SepconAxiomatization L GammaP} {wandAX: WandAxiomatization L GammaP} {empAX: EmpAxiomatization L GammaP} := {
  Parametric_DM: WEM = true -> DeMorganPropositionalLogic L GammaP;
  Parametric_GD: IC = true -> GodelDummettPropositionalLogic L GammaP;
  Parametric_C: EM = true -> ClassicalPropositionalLogic L GammaP;
  Parametric_GC: SCE = true -> GarbageCollectSeparationLogic L GammaP;
  Parametric_NE: ESE = true -> NonsplitEmpSeparationLogic L GammaP;
  Parametric_ED: ED = true -> DupEmpSeparationLogic L GammaP
}.

Section SeparationLogic.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}.

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sepconL SeparationEmpLanguage.wandL SeparationEmpLanguage.empL.

Context (PAR: SL_Parameter).

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| weak_excluded_middle: WEM = true -> forall x, provable (~~ x || ~~ ~~ x)
| impp_choice: IC = true -> forall x y, provable ((x --> y) || (y --> x))
| excluded_middle: EM = true -> forall x, provable (x || ~~ x)
| sepcon_comm_impp: forall x y, provable (x * y --> y * x)
| sepcon_assoc1: forall x y z, provable (x * (y * z) --> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_emp: forall x, provable (x * emp <--> x)
| sepcon_elim1: SCE = true -> forall x y, provable (x * y --> x)
| emp_sepcon_truep_elim: ESE = true -> forall x, provable (x * TT && emp --> x)
| emp_dup: ED = true -> forall x, provable (x && emp --> x * x).

Instance GP: Provable SeparationEmpLanguage.L := Build_Provable _ provable.

Instance GD: Derivable SeparationEmpLanguage.L := Provable2Derivable.

Instance AX: NormalAxiomatization SeparationEmpLanguage.L GP GD :=
  Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization SeparationEmpLanguage.L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipAX: IntuitionisticPropositionalLogic SeparationEmpLanguage.L GP.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance wandAX: WandAxiomatization SeparationEmpLanguage.L GP.
Proof.
  constructor.
  intros; split.
  + apply wand_sepcon_adjoint1.
  + apply wand_sepcon_adjoint2.
Qed.

Instance sepconAX: SepconAxiomatization SeparationEmpLanguage.L GP.
Proof.
  assert (SepconAxiomatization_weak SeparationEmpLanguage.L GP).
  {
    constructor.
    + apply sepcon_comm_impp.
    + apply sepcon_assoc1.
  }
  eapply @SepconAxiomatizationWeak2SepconAxiomatization;
  try typeclasses eauto.
  eapply @Adj2SepconMono;
  try typeclasses eauto.
Qed.

Instance empAX: EmpAxiomatization SeparationEmpLanguage.L GP.
Proof.
  eapply @EmpAxiomatizationIff2EmpAxiomatization;
  try typeclasses eauto.
  constructor.
  apply sepcon_emp.
Qed.

Instance sepcon_orp_AX: SepconOrAxiomatization SeparationEmpLanguage.L GP.
Proof.
  eapply @Adj2SepconOr;
  try typeclasses eauto.
Qed.

Instance sepcon_falsep_AX: SepconFalseAxiomatization SeparationEmpLanguage.L GP.
Proof.
  eapply @Adj2SepconFalse;
  try typeclasses eauto.
Qed.

Instance ParAX: Parametric_SeparationLogic PAR SeparationEmpLanguage.L GP.
Proof.
  constructor.
  + intros; constructor.
    apply weak_excluded_middle; auto.
  + intros; constructor.
    apply impp_choice; auto.
  + intros; constructor.
    apply excluded_middle; auto.
  + intros; constructor.
    apply sepcon_elim1; auto.
  + intros; constructor.
    apply emp_sepcon_truep_elim; auto.
  + intros; constructor.
    apply emp_dup; auto.
Qed.

End SeparationLogic.


(* natural models *)

Unset Automatic Introduction.
Require Ktheory.Elements.
Require Import Ktheory.Utilities.
Require Import RezkCompletion.precategories
               RezkCompletion.yoneda
               RezkCompletion.category_hset
               RezkCompletion.functors_transformations.
Require Import Foundations.hlevel2.hSet.

Import RezkCompletion.pathnotations.PathNotations
       Ktheory.Utilities.Notation.

Module Import Notation.
  Notation Hom := precategory_morphisms.
  Notation "b ← a" := (precategory_morphisms a b) (at level 50).
  Notation "a → b" := (precategory_morphisms a b) (at level 50).
  Notation "a ==> b" := (functor a b) (at level 50).
  Notation "f ;; g" := (precategories.compose f g) (at level 50, only parsing).
  Notation "g ∘ f" := (precategories.compose f g) (at level 50, only parsing).
  Notation "# F" := (functor_on_morphisms F) (at level 3).
  Notation "C '^op'" := (opp_precat C) (at level 3).
  Notation SET := hset_precategory.
End Notation.

Definition fiber
{ C : precategory }
{ P Q : C^op ==> SET }
( f : nat_trans P Q)
( q : Elements.cat Q )
: C^op ==> SET .

Proof. intros. refine (tpair _ _ _).
  { refine (tpair _ _ _).
    { intros c.
      refine (tpair _ _ _).
      { exact( total2 ( fun p : Elements.cat P
                                        => Hom (Elements.cat_on_nat_trans f p) q )).


Require Import core core_axioms unscoped unscoped_axioms.
Require Import sysf.

Lemma rinstInst_ty (xi_ty : nat -> nat) :
  ren_ty xi_ty = subst_ty (funcomp var_ty xi_ty).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => rinst_inst_ty xi_ty _ (fun n => eq_refl) x)).

Qed.

Lemma instId_ty : subst_ty var_ty = id.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => idSubst_ty var_ty (fun n => eq_refl) (id x))).

Qed.

Lemma rinstId_ty : @ren_ty id = id.

Proof.
exact (eq_trans (rinstInst_ty (id _)) instId_ty).

Qed.

Lemma varL_ty (sigma_ty : nat -> ty) :
  funcomp (subst_ty sigma_ty) var_ty = sigma_ty.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).

Qed.

Lemma varLRen_ty (xi_ty : nat -> nat) :
  funcomp (ren_ty xi_ty) var_ty = funcomp var_ty xi_ty.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).

Qed.

Lemma renRen'_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat) :
  funcomp (ren_ty zeta_ty) (ren_ty xi_ty) = ren_ty (funcomp zeta_ty xi_ty).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renRen_ty xi_ty zeta_ty n)).

Qed.

Lemma compRen'_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat) :
  funcomp (ren_ty zeta_ty) (subst_ty sigma_ty) =
  subst_ty (funcomp (ren_ty zeta_ty) sigma_ty).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compRen_ty sigma_ty zeta_ty n)).

Qed.

Lemma renComp'_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty) :
  funcomp (subst_ty tau_ty) (ren_ty xi_ty) = subst_ty (funcomp tau_ty xi_ty).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renComp_ty xi_ty tau_ty n)).

Qed.

Lemma compComp'_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty) :
  funcomp (subst_ty tau_ty) (subst_ty sigma_ty) =
  subst_ty (funcomp (subst_ty tau_ty) sigma_ty).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compComp_ty sigma_ty tau_ty n)).

Qed.

Lemma rinstInst_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  ren_tm xi_ty xi_tm = subst_tm (funcomp var_ty xi_ty) (funcomp var_tm xi_tm).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x =>
                 rinst_inst_tm xi_ty xi_tm _ _ (fun n => eq_refl)
                   (fun n => eq_refl) x)).

Qed.

Lemma instId_tm : subst_tm var_ty var_tm = id.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x =>
                 idSubst_tm var_ty var_tm (fun n => eq_refl)
                   (fun n => eq_refl) (id x))).

Qed.

Lemma rinstId_tm : @ren_tm id id = id.

Proof.
exact (eq_trans (rinstInst_tm (id _) (id _)) instId_tm).

Qed.

Lemma varL_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm) :
  funcomp (subst_tm sigma_ty sigma_tm) var_tm = sigma_tm.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).

Qed.

Lemma varLRen_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat) :
  funcomp (ren_tm xi_ty xi_tm) var_tm = funcomp var_tm xi_tm.

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).

Qed.

Lemma renRen'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  funcomp (ren_tm zeta_ty zeta_tm) (ren_tm xi_ty xi_tm) =
  ren_tm (funcomp zeta_ty xi_ty) (funcomp zeta_tm xi_tm).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renRen_tm xi_ty xi_tm zeta_ty zeta_tm n)).

Qed.

Lemma compRen'_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (zeta_ty : nat -> nat) (zeta_tm : nat -> nat) :
  funcomp (ren_tm zeta_ty zeta_tm) (subst_tm sigma_ty sigma_tm) =
  subst_tm (funcomp (ren_ty zeta_ty) sigma_ty)
    (funcomp (ren_tm zeta_ty zeta_tm) sigma_tm).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compRen_tm sigma_ty sigma_tm zeta_ty zeta_tm n)).

Qed.

Lemma renComp'_tm (xi_ty : nat -> nat) (xi_tm : nat -> nat)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  funcomp (subst_tm tau_ty tau_tm) (ren_tm xi_ty xi_tm) =
  subst_tm (funcomp tau_ty xi_ty) (funcomp tau_tm xi_tm).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renComp_tm xi_ty xi_tm tau_ty tau_tm n)).

Qed.

Lemma compComp'_tm (sigma_ty : nat -> ty) (sigma_tm : nat -> tm)
  (tau_ty : nat -> ty) (tau_tm : nat -> tm) :
  funcomp (subst_tm tau_ty tau_tm) (subst_tm sigma_ty sigma_tm) =
  subst_tm (funcomp (subst_ty tau_ty) sigma_ty)
    (funcomp (subst_tm tau_ty tau_tm) sigma_tm).

Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compComp_tm sigma_ty sigma_tm tau_ty tau_tm n)).

Qed.


(** * The Yoneda Lemma *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Category.Dual Functor.Dual.
Require Import Category.Prod.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core.
Require Import Category.Morphisms FunctorCategory.Morphisms.
Require Import SetCategory.
Require Import Functor.Attributes.
Require Import Functor.Composition.Functorial.
Require Import Functor.Identity.
Require ExponentialLaws.Law4.Functors.
Require ProductLaws.
Require Import HomFunctor.
Require Import FunctorCategory.Core.
Require Import NaturalTransformation.Paths.
Require Import HSet HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope functor_scope.

(** Quoting Wikipedia on the Yoneda lemma (chainging [A] to [a] and
    [C] to [A] so that we can use unicode superscripts and
    subscripts):

    In mathematics, specifically in category theory, the Yoneda lemma
    is an abstract result on functors of the type morphisms into a
    fixed object. It is a vast generalisation of Cayley's theorem from
    group theory (viewing a group as a particular kind of category
    with just one object). It allows the embedding of any category
    into a category of functors (contravariant set-valued functors)
    defined on that category. It also clarifies how the embedded
    category, of representable functors and their natural
    transformations, relates to the other objects in the larger
    functor category. It is an important tool that underlies several
    modern developments in algebraic geometry and representation
    theory. It is named after Nobuo Yoneda.

    ** Generalities

    The Yoneda lemma suggests that instead of studying the (locally
    small) category [A], one should study the category of all functors
    of [A] into [Set] (the category of sets with functions as
    morphisms). [Set] is a category we understand well, and a functor
    of [A] into [Set] can be seen as a "representation" of [A] in
    terms of known structures. The original category [A] is contained
    in this functor category, but new objects appear in the functor
    category which were absent and "hidden" in [A]. Treating these new
    objects just like the old ones often unifies and simplifies the
    theory.  This approach is akin to (and in fact generalizes) the
    common method of studying a ring by investigating the modules over
    that ring. The ring takes the place of the category [A], and the
    category of modules over the ring is a category of functors
    defined on [A].

    ** Formal statement

    *** General version

    Yoneda's lemma concerns functors from a fixed category [A] to the
    category of sets, [Set]. If [A] is a locally small category
    (i.e. the hom-sets are actual sets and not proper classes), then
    each object [a] of [A] gives rise to a natural functor to [Set]
    called a hom-functor. This functor is denoted:

    [hᵃ = Hom(a, ─)].

    The (covariant) hom-functor [hᵃ] sends [x] to the set of morphisms
    [Hom(a, x)] and sends a morphism [f] from [x] to [y] to the
    morphism [f ∘ ─] (composition with [f] on the left) that sends a
    morphism [g] in [Hom(a, x)] to the morphism [f ∘ g] in [Hom(a,
    y)]. That is,

    [f ↦ Hom(a, f) = ⟦ Hom(a, x) ∋ g ↦ f ∘ g ∈ Hom(a,y) ⟧].
 *)

(** ** The (co)yoneda functors [A → (Aᵒᵖ → set)] *)
Section yoneda.
  Context `{Funext}.

  (* TODO(JasonGross): Find a way to unify the [yoneda] and [coyoneda] lemmas into a single lemma which is more functorial. *)

  Definition coyoneda A : Functor A^op (A -> set_cat)
    := ExponentialLaws.Law4.Functors.inverse _ _ _ (hom_functor A).

  Definition yoneda A : Functor A (A^op -> set_cat)
    := coyoneda A^op.
End yoneda.

(** ** The (co)yoneda lemma *)
Section coyoneda_lemma.

  Section functor.
    Context `{Funext}.

    Variable A : PreCategory.
    (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's
      lemma says that: *)
    (*Variable F : Functor A (@set_cat fs).*)
    (** For each object [a] of [A], *)
    (*Variable a : A.*)
    (** the natural transformations from [hᵃ] to [F] are in one-to-one
      correspondence with the elements of [F(a)]. That is,

      [Nat(hᵃ, F) ≅ F(a)].

      Moreover this isomorphism is natural in [a] and [F] when both
      sides are regarded as functors from [Setᴬ × A] to
      [Set].

      Given a natural transformation [Φ] from [hᵃ] to [F], the
      corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *)

    (*   Definition coyoneda_lemma_morphism (a : A)
  : morphism set_cat
             (BuildhSet
                (morphism (A -> set_cat) (coyoneda A a) F)
                _)
             (F a)
    := fun phi => phi a 1%morphism. *)

    Definition coyoneda_functor
    : Functor (A -> set_cat)
              (A -> set_cat)
      := (compose_functor _ _ set_cat (coyoneda A)^op)
           o (yoneda (A -> set_cat)).
  End functor.

  Section nt.
    Context `{Funext}.

    Variable A : PreCategory.

    Definition coyoneda_natural_transformation_helper F
    : morphism (_ -> _) (coyoneda_functor A F) F.
    Proof.
      refine (Build_NaturalTransformation
                (coyoneda_functor A F) F
                (fun a phi => phi a 1%morphism)
                _).
      simpl.
      abstract (
          repeat (intro || apply path_forall);
          simpl in *;
            match goal with
              | [ T : NaturalTransformation _ _ |- _ ]
                => simpl rewrite <- (fun s d m => apD10 (commutes T s d m))
            end;
          rewrite ?left_identity, ?right_identity;
          reflexivity
        ).
    Defined.

    Definition coyoneda_natural_transformation
    : morphism (_ -> _)
               (coyoneda_functor A)
               1.
    Proof.
      hnf.
      simpl.
      let F := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
      let G := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in
      refine (Build_NaturalTransformation
                F G
                coyoneda_natural_transformation_helper
                _).
      simpl.
      abstract (repeat first [ intro
                             | progress path_natural_transformation
                             | reflexivity ]).
    Defined.
  End nt.

  Definition coyoneda_lemma_morphism_inverse
             `{Funext}
             A
             (F : object (A -> set_cat))
             a
  : morphism set_cat
             (F a)
             (coyoneda_functor A F a).
  Proof.
    intro Fa.
    hnf.
    simpl in *.
    let F0 := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
    let G0 := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in
    refine (Build_NaturalTransformation
              F0 G0
              (fun a' : A => (fun f : morphism A a a' => F _1 f Fa))
              _
           ).
    simpl.
    abstract (
        repeat first [ reflexivity
                     | intro
                     | apply path_forall
                     | progress rewrite ?composition_of, ?identity_of ]
      ).
  Defined.

  Global Instance coyoneda_lemma `{Funext} A
  : IsIsomorphism (coyoneda_natural_transformation A).
  Proof.
    eapply isisomorphism_natural_transformation.
    simpl.
    intro F.
    eapply isisomorphism_natural_transformation.
    intro a.
    simpl.
    exists (coyoneda_lemma_morphism_inverse F a);
      simpl in *;
    abstract (
        repeat (intro || apply path_forall || path_natural_transformation);
        simpl in *;
          solve [ simpl rewrite <- (fun c d m => ap10 (commutes x c d m));
                  rewrite ?right_identity, ?left_identity;
                  reflexivity
                | rewrite identity_of;
                  reflexivity ]
      ).
  Defined.
End coyoneda_lemma.

Section yoneda_lemma.
  (** There is a contravariant version of Yoneda's lemma which
      concerns contravariant functors from [A] to [Set]. This version
      involves the contravariant hom-functor

      [hₐ = Hom(─, A)],

      which sends [x] to the hom-set [Hom(x, a)]. Given an arbitrary
      contravariant functor [G] from [A] to [Set], Yoneda's lemma
      asserts that

      [Nat(hₐ, G) ≅ G(a)]. *)

  Section functor.
    Context `{Funext}.

    Variable A : PreCategory.
    (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's
      lemma says that: *)
    (*Variable F : Functor A (@set_cat fs).*)
    (** For each object [a] of [A], *)
    (*Variable a : A.*)
    (** the natural transformations from [hᵃ] to [F] are in one-to-one
      correspondence with the elements of [F(a)]. That is,

      [Nat(hᵃ, F) ≅ F(a)].

      Moreover this isomorphism is natural in [a] and [F] when both
      sides are regarded as functors from [Setᴬ × A] to
      [Set].

      Given a natural transformation [Φ] from [hᵃ] to [F], the
      corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *)

    (* Definition yoneda_lemma_morphism A (G : object (A^op -> set_cat)) (a : A)
  : morphism set_cat
             (BuildhSet
                (morphism (A^op -> set_cat) (yoneda A a) G)
                _)
             (G a)
    := fun phi => phi a 1%morphism.*)

    Definition yoneda_functor
    : Functor (A^op -> set_cat)
              (A^op -> set_cat)
      := coyoneda_functor A^op.
  End functor.

  Context `{Funext}.

  Variable A : PreCategory.

  Definition yoneda_natural_transformation
  : morphism (_ -> _)
             1
             (yoneda_functor A)
    := @morphism_inverse _ _ _ _ (coyoneda_lemma A^op).

  Global Instance yoneda_lemma
  : IsIsomorphism yoneda_natural_transformation
    := @isisomorphism_inverse _ _ _ _ (coyoneda_lemma A^op).
End yoneda_lemma.

(** ** The Yoneda embedding

    An important special case of Yoneda's lemma is when the functor
    [F] from [A] to [Set] is another hom-functor [hᵇ]. In this case,
    the covariant version of Yoneda's lemma states that

    [Nat(hᵃ, hᵇ) ≅ Hom(b, a)].

    That is, natural transformations between hom-functors are in
    one-to-one correspondence with morphisms (in the reverse
    direction) between the associated objects. Given a morphism [f : b
    → a] the associated natural transformation is denoted [Hom(f, ─)].

    Mapping each object [a] in [A] to its associated hom-functor [hᵃ=
    Hom(a, ─)] and each morphism [f : B → A] to the corresponding
    natural transformation [Hom(f, ─)] determines a contravariant
    functor [h⁻] from [A] to [Setᴬ], the functor category of all
    (covariant) functors from [A] to [Set]. One can interpret [h⁻] as
    a covariant functor:

    [h⁻ : Aᵒᵖ → Setᴬ].

    The meaning of Yoneda's lemma in this setting is that the functor
    [h⁻] is fully faithful, and therefore gives an embedding of [Aᵒᵖ]
    in the category of functors to [Set]. The collection of all
    functors {[hᵃ], [a] in [A]} is a subcategory of [Set̂ᴬ]. Therefore,
    Yoneda embedding implies that the category [Aᵒᵖ] is isomorphic to
    the category {[hᵃ], [a] in [A]}.

    The contravariant version of Yoneda's lemma states that

    [Nat(hₐ, h_b) ≅ Hom(a, b)].

    Therefore, [h₋] gives rise to a covariant functor from [A] to the
    category of contravariant functors to [Set]:

    [h₋ : A → Set⁽⁽ᴬ⁾ᵒᵖ⁾].

    Yoneda's lemma then states that any locally small category [A] can
    be embedded in the category of contravariant functors from [A] to
    [Set] via [h₋]. This is called the Yoneda embedding. *)

Section FullyFaithful.
  Context `{Funext}.

  Definition coyoneda_embedding (A : PreCategory) : IsFullyFaithful (coyoneda A).
  Proof.
    intros a b.
    pose proof (@isisomorphism_inverse
                  _ _ _ _
                  (@isisomorphism_components_of
                     _ _ _ _ _ _
                     (@isisomorphism_components_of
                        _ _ _ _ _ _
                        (@coyoneda_lemma _ A)
                        (@coyoneda _ A b))
                     a)) as H'.
    simpl in *.
    unfold coyoneda_lemma_morphism_inverse in *; simpl in *.
    unfold Functors.inverse_object_of_morphism_of in *; simpl in *.
    let m := match type of H' with IsIsomorphism ?m => constr:(m) end in
    apply isisomorphism_set_cat_natural_transformation_paths with (T1 := m).
    - simpl.
      clear H'.
      intros; apply path_forall;
      intro;
      rewrite left_identity, right_identity;
      reflexivity.
    - destruct H' as [m' H0' H1'].
      (exists m').
      + exact H0'.
      + exact H1'.
  Qed.

  Definition yoneda_embedding (A : PreCategory) : IsFullyFaithful (yoneda A).
  Proof.
    intros a b.
    pose proof (@coyoneda_embedding A^op a b) as CYE.
    unfold yoneda.
    let T := type of CYE in
    let T' := (eval simpl in T) in
    pose proof ((fun x : T => (x : T')) CYE) as CYE'.
    let G := match goal with |- ?G => constr:(G) end in
    let G' := (eval simpl in G) in
    exact ((fun x : G' => (x : G)) CYE').
  Qed.
End FullyFaithful.


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

- Frederic Blanqui, 2005-06-17

general results on pairs
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil.

Section S.

  Variables (A B : Type)
            (eqdecA : forall x y : A, {x=y}+{~x=y})
            (eqdecB : forall x y : B, {x=y}+{~x=y}).

  Lemma eq_pair_dec : forall x y : A*B, {x=y}+{~x=y}.

  Proof.
    intros (x1,x2) (y1,y2). case (eqdecA x1 y1); intro.
    subst y1. case (eqdecB x2 y2); intro. subst y2. auto.
    right. unfold not. intro. injection H. intro. cong.
    right. unfold not. intro. injection H. intros. cong.
  Qed.

End S.


Require Export Qual.metalib.
Require Export Qual.tactics.
Require Export Qual.labels.
Require Export Qual.weakening.
Require Export Qual.uniq.

Set Implicit Arguments.
Open Scope grade_scope.

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

Lemma Step_substitution : forall b1 b2 a x, Step b1 b2 -> lc_tm a -> Step (subst_tm_tm a x b1) (subst_tm_tm a x b2).
Proof.
  intros. induction H.
  all: try solve [simpl; econstructor; eauto using subst_tm_tm_lc_tm].
  - simpl.
    rewrite subst_tm_tm_open_tm_wrt_tm; auto.
     econstructor; eauto using subst_tm_tm_lc_tm.
     match goal with [H : lc_tm (a_Abs _ _ _) |- _ ] => inversion H end. subst.
     pick fresh y.
     eapply (lc_a_Abs_exists y); eauto using subst_tm_tm_lc_tm.
     replace (a_Var_f y) with (subst_tm_tm a x (a_Var_f y)).
     rewrite <- subst_tm_tm_open_tm_wrt_tm; auto.
     eapply subst_tm_tm_lc_tm; eauto.
     rewrite subst_tm_tm_var_neq; auto.
  - simpl.
    econstructor; eauto using subst_tm_tm_lc_tm.
    inversion H. subst.
     pick fresh y.
     eapply (lc_a_LetPair_exists y); eauto using subst_tm_tm_lc_tm.
     replace (a_Var_f y) with (subst_tm_tm a x (a_Var_f y)).
     rewrite <- subst_tm_tm_open_tm_wrt_tm; auto.
     eapply subst_tm_tm_lc_tm; eauto.
     rewrite subst_tm_tm_var_neq; auto.
  - simpl.
    rewrite subst_tm_tm_open_tm_wrt_tm; auto.
    econstructor; eauto using subst_tm_tm_lc_tm.
    inversion H. subst.
     pick fresh y.
     eapply (lc_a_LetPair_exists y); eauto using subst_tm_tm_lc_tm.
     replace (a_Var_f y) with (subst_tm_tm a x (a_Var_f y)).
     rewrite <- subst_tm_tm_open_tm_wrt_tm; auto.
     eapply subst_tm_tm_lc_tm; eauto.
     rewrite subst_tm_tm_var_neq; auto.
Qed.

(* --- grade --- *)

Lemma Grade_CGrade: forall P phi psi a,  Grade P phi a -> CGrade P phi psi a.
Proof.
  intros.
  destruct (q_leb psi phi) eqn:LE.
  eapply CG_Leq; eauto.
  eapply CG_Nleq; eauto using Grade_uniq, Grade_lc. rewrite LE. done.
Qed.

Local Hint Resolve Grade_CGrade : core.

Ltac substitution_ih :=
    match goal with
      | [H3 : forall P4 P3 x0 phi0,
            [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?phi)] ++ ?P1 = P3 ++ [(x0, phi0)] ++ P4 -> _ |- _ ] =>
                specialize (H3 P1 ([(y, psi0)] ++ P2) x phi  ltac:(auto) _ ltac:(eauto));
        simpl_env in H3;
    rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto using CGrade_lc;
    rewrite subst_tm_tm_var_neq in H3
    end.

Lemma CGrade_Grade_substitution_CGrade : (forall P psi psi0 b,
      CGrade P psi psi0 b -> forall P1 P2 x phi,
        P = P2 ++ [(x,phi)] ++ P1
        -> forall a , CGrade P1 psi phi a
        -> CGrade (P2 ++ P1) psi psi0 (subst_tm_tm a x b)) /\
      (forall P psi b,
          Grade P psi b -> forall P1 P2 x phi,
            P = P2 ++ [(x,phi)] ++ P1
            -> forall a, CGrade P1 psi phi a
                   -> Grade (P2 ++ P1) psi (subst_tm_tm a x b)).
Proof.
  apply CGrade_Grade_mutual.
  all: intros; subst.
  all: try solve [simpl; eauto].
  all: try solve [eapply CG_Nleq; eauto  using subst_tm_tm_lc_tm, CGrade_lc] .
  all: try solve [simpl;
    fresh_apply_Grade y;
    eauto using subst_tm_tm_lc_tm, CGrade_lc;
    repeat spec y;
    substitution_ih;
    eauto].
  - (* Var *)
    destruct (x == x0).
    + subst.
      apply binds_mid_eq in b; auto. subst.
      rewrite subst_tm_tm_var; auto.
      eapply Grade_weakening; try solve_uniq.
      match goal with [ H : CGrade _ _ _ _ |- _ ] => inversion H; clear H; subst end; auto; try done.
    + rewrite subst_tm_tm_var_neq. auto.
      apply binds_remove_mid in b; auto.
      eapply G_Var; eauto.
Qed.

Lemma Grade_substitution_CGrade : forall P2 x phi P1 psi a b,
      Grade (P2 ++ x ~ phi ++ P1) psi b
    -> CGrade P1 psi phi a
    -> Grade (P2 ++ P1) psi (subst_tm_tm a x b).
Proof.
  intros.
  eapply CGrade_Grade_substitution_CGrade; eauto. Qed.

Lemma Grade_substitution_same : forall P2 x phi P1 psi a b,
      Grade (P2 ++ x ~ phi ++ P1) psi b
    -> Grade P1 psi a
    -> Grade (P2 ++ P1) psi (subst_tm_tm a x b).
Proof.
  intros.
  eapply Grade_substitution_CGrade; eauto.
Qed.

Lemma Grade_substitution_irrel : forall P2 x phi P1 psi a b,
      Grade (P2 ++ x ~ phi ++ P1) psi b
    -> not (phi <= psi)
    -> lc_tm a
    -> Grade (P2 ++ P1) psi (subst_tm_tm a x b).
Proof.
  intros.
  eapply Grade_substitution_CGrade; eauto.
  eapply Grade_uniq in H. destruct_uniq.
  eauto.
Qed.

Lemma Grade_open : forall P psi y psi0 a b,
  y `notin` fv_tm_tm a ->
  Grade P psi b ->
  Grade ([(y, psi0)] ++ P) psi (open_tm_wrt_tm a (a_Var_f y)) ->
  Grade P psi (open_tm_wrt_tm a b).
Proof.
  intros.
  move: (Grade_substitution_same nil _ _ H1 H0) => ss.
  rewrite subst_tm_tm_open_tm_wrt_tm in ss.
  eauto using Grade_lc.
  rewrite subst_tm_tm_var in ss.
  rewrite subst_tm_tm_fresh_eq in ss; auto.
Qed.

Lemma Grade_open_irrel : forall P psi y psi0 a b,
  y `notin` fv_tm_tm a ->
  not (psi0 <= psi) ->
  lc_tm b ->
  Grade ([(y, psi0)] ++ P) psi (open_tm_wrt_tm a (a_Var_f y)) ->
  Grade P psi (open_tm_wrt_tm a b).
Proof.
  intros.
  move: (Grade_substitution_irrel nil _ _ H2 ltac:(auto) H1) => ss.
  rewrite subst_tm_tm_open_tm_wrt_tm in ss.
  eauto using Grade_lc.
  rewrite subst_tm_tm_var in ss.
  rewrite subst_tm_tm_fresh_eq in ss; auto.
Qed.

Lemma Grade_renaming : forall y x psi0 P psi b1,
    x `notin` dom P \u fv_tm_tm b1 ->
    y `notin` dom P \u fv_tm_tm b1 \u {{x}} ->
    Grade ([(y, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f y)) ->
    Grade ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)).
Proof.
  intros.
  rewrite (subst_tm_tm_intro y b1); auto.
  move: (Grade_uniq H1) => u.
  destruct (q_leb psi0 psi) eqn:LE.
  - eapply Grade_substitution_same with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); simpl_env.
    eapply Grade_weakening_middle; eauto.
    eapply G_Var; eauto.
    solve_uniq.
  - eapply Grade_substitution_irrel  with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); simpl_env. 2: eauto.
    eapply Grade_weakening_middle; eauto.
    rewrite LE. done.
    auto.
Qed.

Ltac exists_apply_Grade x :=
  let y := fresh in
  fresh_apply_Grade y; eauto;
  eapply (@Grade_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm; auto.

(* --- geq --- *)

Lemma CEq_GEq_equality_substitution :
  (forall P phi phi0 b1 b2,
  CEq P phi phi0 b1 b2 ->  forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a1 a2, CEq P1 phi psi a1 a2
       -> CEq (P2 ++ P1) phi phi0 (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)) /\
  (forall P phi b1 b2,
  GEq P phi b1 b2 -> forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a1 a2, CEq P1 phi psi a1 a2
       -> GEq (P2 ++ P1) phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2)).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; subst; eauto.
  all: try solve [simpl; eauto].
  all: try solve [
    repeat invert_Grade; subst;
    simpl; fresh_apply_GEq y; eauto;
    repeat spec y;
    match goal with
      [
         H5 : forall P3 P4 x0 psi1,
          [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?psi2)] ++ ?P1 = P4 ++ [(x0, psi1)] ++ P3 -> _
          |- _ ] =>
    specialize (H5 P1 ([(y, psi0)] ++ P2) x psi2 ltac:(auto) _ _ ltac:(eauto 3));
    simpl_env in H5;
    simpl_env in H5;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto 3 using CEq_lc1, CEq_lc2;
    repeat rewrite subst_tm_tm_var_neq in H5; eauto
    end] .
  - (* Var *)
    destruct (x == x0).
    + subst.
      repeat rewrite subst_tm_tm_var.
      match goal with [ H : CEq _ _ _ _ _ |- _ ] => inversion H; subst end.
      ++ (*
            psi0 <= psi --
          *)
        eapply GEq_weakening; eauto.
      ++
        apply binds_mid_eq in b; auto. subst.
        done.
        (*
            here we know that not (psi0 <= psi).
          *)
    + repeat rewrite subst_tm_tm_var_neq; eauto.

  - (* CEq  - nleq *)
    move: (CEq_lc1 H0) => h1.
    move: (CEq_lc2 H0) => h2.
    eapply CEq_Nleq; eauto using subst_tm_tm_lc_tm.
Qed.

Lemma GEq_open: forall P psi psi0 a1 a2 a b0 x,
      x \notin fv_tm_tm a -> x \notin fv_tm_tm b0 ->
      CEq P psi psi0 a1 a2 ->
      GEq ([(x, psi0)] ++ P) psi (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm b0 (a_Var_f x)) ->
      GEq P psi (open_tm_wrt_tm a a1) (open_tm_wrt_tm b0 a2).
Proof.
      intros.
      move: (CEq_GEq_equality_substitution) => [_ h1].
      specialize (h1 _ _  _ _ H2 P nil x psi0 ltac:(eauto) _ _ H1).
      repeat rewrite subst_tm_tm_open_tm_wrt_tm in h1; auto.
      eapply CEq_lc1; eauto.
      eapply CEq_lc2; eauto.
      repeat rewrite subst_tm_tm_var in h1.
      repeat rewrite subst_tm_tm_fresh_eq in h1; auto.
Qed.

Lemma CEq_GEq_refl :
  (forall P phi psi a, CGrade P phi psi a -> CEq P phi psi a a) /\
  (forall P phi a, Grade P phi a -> GEq P phi a a).
Proof.
  eapply CGrade_Grade_mutual.
  all: intros; eauto.
Qed.

Lemma GEq_refl : forall P phi a, Grade P phi a -> GEq P phi a a.
  intros. eapply CEq_GEq_refl. auto.
Qed.

Lemma CEq_refl : forall P phi a psi, Grade P phi a -> CEq P phi psi a a.
Proof.
  intros.
  destruct (q_leb psi phi) eqn:LE.
  + eapply CEq_Leq; eauto.
    eapply GEq_refl; eauto.
  + eapply CEq_Nleq; eauto using Grade_uniq, Grade_lc.
    rewrite LE. done.
Qed.

Lemma GEq_substitution_same : forall P1 P2 x psi phi b1 b2 a,
  GEq (P2 ++ [(x,psi)] ++ P1) phi b1 b2
  -> Grade P1 phi a
  -> GEq (P2 ++ P1) phi (subst_tm_tm a x b1) (subst_tm_tm a x b2).
Proof.
  intros.
  move: CEq_GEq_equality_substitution => [_ h].
  eapply h; eauto.
  eapply CEq_refl; auto.
Qed.

Lemma GEq_substitution_irrel : forall P1 P2 x psi phi b1 b2 a1 a2,
  GEq (P2 ++ [(x,psi)] ++ P1) phi b1 b2
  -> not (psi <= phi)
  -> lc_tm a1
  -> lc_tm a2
  -> GEq (P2 ++ P1) phi (subst_tm_tm a1 x b1) (subst_tm_tm a2 x b2).
Proof.
  intros.
  move: CEq_GEq_equality_substitution => [_ h].
  eapply h; eauto.
  eapply CEq_Nleq; eauto.
  move: (GEq_uniq H) => u. solve_uniq.
Qed.

Lemma GEq_renaming : forall y x psi0 P psi b1 b2,
    x `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 ->
    y `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 \u {{x}} ->
    GEq ([(y, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f y)) (open_tm_wrt_tm b2 (a_Var_f y)) ->
    GEq ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x)).
Proof.
  intros.
  rewrite (subst_tm_tm_intro y b1); auto.
  rewrite (subst_tm_tm_intro y b2); auto.
  move: (GEq_uniq H1) => u.
  destruct (q_leb psi0 psi) eqn:LE.
  - eapply GEq_substitution_same with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); simpl_env.
    eapply GEq_weakening_middle; eauto.
    eapply G_Var; eauto.
    solve_uniq.
  - eapply GEq_substitution_irrel  with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); auto; simpl_env.
    eapply GEq_weakening_middle; eauto.
    rewrite LE. done.
Qed.

Ltac exists_apply_GEq x :=
  let y := fresh in
  fresh_apply_GEq y; eauto;
  eapply (@GEq_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm; auto.

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

Local Ltac defeq_subst_ih :=  match goal with
      [
         H5 : forall P3 P4 x0 psi1,
          [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?psi2)] ++ ?P1 = P4 ++ [(x0, psi1)] ++ P3 -> _
          |- _ ] =>
    specialize (H5 P1 ([(y, psi0)] ++ P2) x psi2 ltac:(auto) _ ltac:(eauto 3));
    simpl_env in H5;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto 3 using CGrade_lc;
    repeat rewrite subst_tm_tm_var_neq in H5; eauto end.

Lemma CDefEq_DefEq_substitution_CGrade :
  (forall P phi phi0 b1 b2, CDefEq P phi phi0 b1 b2 -> forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a, CGrade P1 phi psi a
       -> CDefEq (P2 ++ P1) phi phi0 (subst_tm_tm a x b1) (subst_tm_tm a x b2)) /\
  (forall P phi b1 b2, DefEq P phi b1 b2 -> forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a, CGrade P1 phi psi a
       -> DefEq (P2 ++ P1) phi (subst_tm_tm a x b1) (subst_tm_tm a x b2)).
Proof.
  apply CDefEq_DefEq_mutual.
  all: intros; subst.
  all: try solve [eapply Eq_Refl; eauto using Grade_substitution_CGrade].
  all: try solve [eapply Eq_Beta; eauto using Grade_substitution_CGrade, Step_substitution, CGrade_lc].
  all: try solve [simpl; eapply Eq_App; eauto using Grade_substitution_CGrade, subst_tm_tm_lc_tm, CGrade_lc].
  all: try solve [simpl; eapply Eq_WPair; eauto using Grade_substitution_CGrade, subst_tm_tm_lc_tm, CGrade_lc].
  all: try solve [simpl; eapply Eq_SPair; eauto using Grade_substitution_CGrade, subst_tm_tm_lc_tm, CGrade_lc].
  all: try solve [repeat invert_Grade; subst;
    simpl; fresh_apply_DefEq y; eauto 3 using subst_tm_tm_lc_tm, CGrade_lc;
    repeat spec y;
    defeq_subst_ih] .
  all: try solve [simpl; eauto 3].
  eapply Eq_Trans; eauto 2.
  all: try solve [simpl; eauto 4 using Grade_substitution_CGrade, Step_substitution, CGrade_lc].
(*  - eapply Eq_PiFst; eauto 1.
    specialize (H _ _ _ _ ltac:(eauto) _ ltac:(eauto)).
    simpl in H. *)
  - repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using CGrade_lc.
    match goal with [H2 : CGrade _ _ _ _|- _ ] =>
    specialize (H0 _ _ _ _ ltac:(eauto) _ H2);
    specialize (H _ _ _ _ ltac:(eauto) _ H2) end. simpl in H0.
    eapply Eq_PiSnd; eauto 3 using Grade_substitution_CGrade, subst_tm_tm_lc_tm, CGrade_lc.
(*  - repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using CGrade_lc.
    specialize (H _ _ _ _ ltac:(eauto) _ H1); simpl in H; eauto. *)
  - repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using CGrade_lc.
    specialize (H _ _ _ _ ltac:(eauto) _ H1); simpl in H.
    eapply Eq_WSigmaSnd; eauto using Grade_substitution_CGrade.
(*  - specialize (H _ _ _ _ ltac:(eauto) _ H1); simpl in H.
    eapply Eq_SSigmaFst; eauto using Grade_substitution_CGrade. *)
  - repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using CGrade_lc.
    specialize (H _ _ _ _ ltac:(eauto) _ H2); simpl in H.
    eapply Eq_SSigmaSnd; eauto using Grade_substitution_CGrade.
(*  - eapply Eq_SumFst; eauto 1.
    specialize (H _ _ _ _ ltac:(eauto) _ ltac:(eauto));
    simpl in H; eauto.
  - eapply Eq_SumSnd; eauto 1.
    specialize (H _ _ _ _ ltac:(eauto) _ ltac:(eauto));
    simpl in H; eauto. *)
  - simpl.
    eapply Eq_Case; eauto.
  - repeat invert_Grade; subst;
    simpl.
    repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using CGrade_lc.
    pick fresh y and apply Eq_SubstIrrel; eauto 2.
    eauto using subst_tm_tm_lc_tm, CGrade_lc.
    eauto using subst_tm_tm_lc_tm, CGrade_lc.
    repeat spec y.
    specialize (H2 P1 ([(y, psi)] ++ P2) x psi0).
    simpl_env in H2. specialize (H2 ltac:(auto)).
    specialize (H2 _ ltac:(eassumption)).
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H2; eauto 2 using CGrade_lc.
    rewrite subst_tm_tm_var_neq in H2. auto.
    auto.
  - eapply CDefEq_Nleq; eauto using subst_tm_tm_lc_tm, CGrade_lc.
Qed.

Lemma DefEq_substitution_CGrade :
  (forall P phi b1 b2, DefEq P phi b1 b2 -> forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a, CGrade P1 phi psi a
       -> DefEq (P2 ++ P1) phi (subst_tm_tm a x b1) (subst_tm_tm a x b2)).
Proof.
  intros.
  eapply CDefEq_DefEq_substitution_CGrade; eauto.
Qed.

Lemma DefEq_substitution_same :
  (forall P phi b1 b2, DefEq P phi b1 b2 -> forall P1 P2 x psi,
        P = P2 ++ [(x,psi)] ++ P1
       -> forall a, Grade P1 phi a
       -> DefEq (P2 ++ P1) phi (subst_tm_tm a x b1) (subst_tm_tm a x b2)).
Proof.
  intros.
  eapply DefEq_substitution_CGrade; eauto.
Qed.

Lemma DefEq_substitution_irrel : forall (P : econtext) (psi : grade) (b1 b2 : tm),
       DefEq P psi b1 b2 ->
       forall (P1 P2 : list (atom * grade)) (x : atom) (phi : grade),
       P = P2 ++ [(x, phi)] ++ P1 ->
       not (phi <= psi) ->
       forall a : tm, lc_tm a -> DefEq (P2 ++ P1) psi (subst_tm_tm a x b1) (subst_tm_tm a x b2).
Proof.
  intros.
  eapply DefEq_substitution_CGrade; eauto.
  subst. apply DefEq_uniq in H. destruct_uniq.
  auto.
Qed.

Lemma DefEq_renaming : forall y x psi0 P psi b1 b2,
    x `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 ->
    y `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 \u {{x}} ->
    DefEq ([(y, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f y)) (open_tm_wrt_tm b2 (a_Var_f y)) ->
    DefEq ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x)).
Proof.
  intros.
  rewrite (subst_tm_tm_intro y b1); auto.
  rewrite (subst_tm_tm_intro y b2); auto.
  move: (DefEq_uniq H1) => u.
  destruct (q_leb psi0 psi) eqn:LE.
  - eapply DefEq_substitution_same with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); simpl_env. 2: eauto.
    eapply DefEq_weakening_middle; eauto.
    eapply G_Var; eauto.
    solve_uniq.
  - eapply DefEq_substitution_irrel  with (P2 := nil) (P1 := ([(x, psi0)] ++ P)); simpl_env. 2: eauto.
    eapply DefEq_weakening_middle; eauto.
    rewrite LE. done.
    auto.
Qed.

Ltac exists_apply_DefEq x :=
  let y := fresh in
  fresh_apply_DefEq y; eauto;
  eapply (@DefEq_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm; auto.

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

Local Ltac par_subst2_ih :=
    match goal with
      | [H3 : forall P3 x0 phi0 P4,
            (?y, ?psi0) :: ?P2 ++ (?x, ?phi) :: ?P1 = P3 ++ (x0, phi0) ::  P4 -> _ |- _ ] =>
    specialize (H3 ([(y, psi0)] ++ P2) x phi P1 ltac:(reflexivity) _ ltac:(eassumption));
    simpl_env in H3;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto 3 using CGrade_lc, Par_lc1, Par_lc2;
    repeat rewrite subst_tm_tm_var_neq in H3
    end.

Lemma CPar_Par_substitution_CGrade : (forall P psi psi0 a a',
  CPar P psi psi0 a a' -> forall P2 x phi P1, P = (P2 ++ [(x, phi)] ++ P1) ->
  forall b, CGrade P1 psi phi b ->
  CPar (P2 ++ P1) psi psi0 (subst_tm_tm b x a) (subst_tm_tm b x a')) /\ (forall P psi a a',
  Par P psi a a' -> forall P2 x phi P1, P = (P2 ++ [(x, phi)] ++ P1) ->
  forall b, CGrade P1 psi phi b ->
  Par (P2 ++ P1) psi (subst_tm_tm b x a) (subst_tm_tm b x a')).
Proof.
  apply CPar_Par_mutual.
  all: simpl; intros; subst.
  all: simpl; eauto using Grade_substitution_CGrade, GEq_substitution_same, GEq_substitution_irrel.
  (* 9 subgoals *)
  all: repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CGrade_lc.
  all: try solve [fresh_apply_Par y; eauto; repeat spec y;
            par_subst2_ih; eauto].
  (* 2 subgoals *)
  - simpl_env in *. eapply Par_Refl; eauto using Grade_substitution_CGrade.
  - simpl_env in *. eapply CPar_Nleq; eauto using CGrade_lc, subst_tm_tm_lc_tm.
Qed.

Lemma Par_substitution_CGrade : forall P2 x phi P1 psi a a',
  Par (P2 ++ [(x, phi)] ++ P1) psi a a' ->
  forall b, CGrade P1 psi phi b ->
  Par (P2 ++ P1) psi (subst_tm_tm b x a) (subst_tm_tm b x a').
Proof. intros. eapply CPar_Par_substitution_CGrade; eauto. Qed.

Lemma subst2 : forall x phi P1 psi a a' b,
  Par ([(x, phi)] ++ P1) psi a a' ->
  Grade P1 psi b ->
  Par P1 psi (subst_tm_tm b x a) (subst_tm_tm b x a').
Proof. intros. eapply Par_substitution_CGrade with (P2:=nil); eauto. Qed.

Lemma subst2_irrel : forall x phi P1 psi a a',
  Par ([(x, phi)] ++ P1) psi a a' ->
  forall b, not (phi <= psi) ->
  lc_tm b ->
  Par P1 psi (subst_tm_tm b x a) (subst_tm_tm b x a').
Proof.
  intros.
  eapply Par_substitution_CGrade with (P2:=nil); eauto.
  apply Par_uniq in H. destruct_uniq.
  eapply CG_Nleq; eauto.
Qed.

Lemma Par_renaming : forall y x psi0 P psi b1 b2,
    x `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 ->
    y `notin` dom P \u fv_tm_tm b1 \u fv_tm_tm b2 \u {{x}} ->
    Par ([(y, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f y)) (open_tm_wrt_tm b2 (a_Var_f y)) ->
    Par ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x)).
Proof.
  intros.
  rewrite (subst_tm_tm_intro y b1); auto.
  rewrite (subst_tm_tm_intro y b2); auto.
  move: (Par_uniq H1) => u.
  destruct (q_leb psi0 psi) eqn:LE.
  - eapply subst2; eauto.
    eapply Par_weakening_middle; eauto.
    eapply G_Var; eauto.
    solve_uniq.
  - eapply subst2_irrel; eauto.
    eapply Par_weakening_middle; eauto.
    rewrite LE. done.
Qed.

Ltac exists_apply_Par x :=
  let y := fresh in
  fresh_apply_Par y; eauto;
  eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm; auto.

(* Par / CPar substitution *)

Local Ltac subst5_ih :=
    match goal with
      | [H3 : forall P3 P4 x0 phi0,
            [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?phi)] ++ ?P1 ~= P4 ++ [(x0, phi0)] ++ P3 -> _ |- _ ] =>
    specialize (H3 P1 ([(y, psi0)] ++ P2) x phi ltac:(reflexivity) _ _ ltac:(eassumption));
    simpl_env in H3;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto 3 using Grade_lc, CPar_lc1, CPar_lc2;
    repeat rewrite subst_tm_tm_var_neq in H3
    end.

Lemma subst5_full :
 (forall P psi psi0 a a',
  CEq P psi psi0 a a' ->  forall P1 P2 x phi,
        P = P2 ++ [(x,phi)] ++ P1
       -> forall b b', CPar P1 psi phi b b'
       -> CPar (P2 ++ P1) psi psi0 (subst_tm_tm b x a) (subst_tm_tm b' x a')) /\
  (forall P psi a a',
  GEq P psi a a' -> forall P1 P2 x phi,
        P = P2 ++ [(x,phi)] ++ P1
       -> forall b b', CPar P1 psi phi b b'
       -> Par (P2 ++ P1) psi (subst_tm_tm b x a) (subst_tm_tm b' x a')).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; subst; simpl; eauto.

  destruct (x == x0); subst;
  [  inversion H0; subst; eapply Par_weakening; eauto;
    apply binds_mid_eq in b; auto; subst; done
  | eauto].

  all: try move: (CEq_uniq c) => U; destruct_uniq.

  all : try solve [
  fresh_apply_Par y; eauto 3; repeat spec y;
  match goal with
      | [H3 : forall P3 P4 x0 phi0,
            [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?phi)] ++ ?P1 = P4 ++ [(x0, phi0)] ++ P3 -> _ |- _ ] =>
    specialize (H3 P1 ([(y, psi0)] ++ P2) x phi ltac:(reflexivity) _ _ ltac:(eassumption));
    simpl_env in H3;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto 3 using Grade_lc, CPar_lc1, CPar_lc2;
    repeat rewrite subst_tm_tm_var_neq in H3 end; eauto 3 ].
  eapply CPar_Nleq; eauto 3 using CPar_lc1, CPar_lc2, subst_tm_tm_lc_tm.
Qed.

Lemma Par_subst3_full : forall P1 psi phi b b',
    CPar P1 psi phi b b' ->
    ((forall P psi1 psi0 a a', CPar P psi1 psi0 a a' -> forall P2 x, P = (P2 ++ [(x,phi)] ++ P1) -> psi = psi1 ->
    CPar (P2 ++ P1) psi1 psi0 (subst_tm_tm b x a) (subst_tm_tm b' x a'))) /\
    (forall P psi1 a a', Par P psi1 a a' -> forall P2 x, P = (P2 ++ [(x,phi)] ++ P1) -> psi = psi1 ->
    Par (P2 ++ P1) psi1 (subst_tm_tm b x a) (subst_tm_tm b' x a')).
Proof.
  intros.
  apply CPar_Par_mutual.
  all: intros; subst; simpl; eauto 4.
  (* refl case *)
  move: (subst5_full) => [_ h].
  eapply h; eauto using GEq_refl.

  all: repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using  CPar_lc1, CPar_lc2.
  all: eauto.
(*  all: try (eapply_ParIrrel; eauto 3 using CPar_lc1, CPar_lc2, subst_tm_tm_lc_tm).   *)

  all: try solve [
  fresh_apply_Par y; eauto 3; repeat spec y;
  match goal with
      | [H3 : forall P3 x0,
            [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?phi)] ++ ?P1 = P3 ++ [(x0, ?phi0)] ++ ?P5 -> _ |- _ ] =>
    specialize (H3 ([(y, psi0)] ++ P2) x ltac:(reflexivity) ltac:(reflexivity));
    simpl_env in H3;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto 3 using Grade_lc, CPar_lc1, CPar_lc2;
    repeat rewrite subst_tm_tm_var_neq in H3 end; eauto 3].

  destruct_uniq.
 eapply CPar_Nleq; eauto 3 using CPar_lc1, CPar_lc2, subst_tm_tm_lc_tm.
Qed.

(*
Lemma Par_subst3_full : forall P2 phi P1 b psi b' x,
    CPar P1 psi phi b b' ->
    forall a a', Par (P2 ++ [(x,phi)] ++ P1) psi a a' ->
    Par (P2 ++ P1) psi (subst_tm_tm b x a) (subst_tm_tm b' x a').
Proof.
  intros.
  dependent induction H0; simpl; eauto 4.

  (* refl case *)
  move: (subst5_full) => [_ h].
  eapply h; eauto using GEq_refl.

  all: repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto 2 using  CPar_lc1, CPar_lc2.
  all: eauto.
  all: try (eapply_ParIrrel; eauto 3 using CPar_lc1, CPar_lc2, subst_tm_tm_lc_tm).

  all: try solve [
  fresh_apply_Par y; eauto 3; repeat spec y;
  match goal with
      | [H3 : forall P3 phi0 P4 x0,
            CPar P4 ?psi ?phi0 ?b ?b' ->
            [(?y, ?psi0)] ++ ?P2 ++ [(?x, ?phi)] ++ ?P1 ~= P3 ++ [(x0, phi0)] ++ P4 -> _ |- _ ] =>
    specialize (H3  ([(y, psi0)] ++ P2) phi P1 x ltac:(eassumption) ltac:(reflexivity));
    simpl_env in H3;
    repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto 3 using Grade_lc, CPar_lc1, CPar_lc2;
    repeat rewrite subst_tm_tm_var_neq in H3 end; eauto 3].

  eapply Par_Proj1Beta; eauto.
  eapply IHPar; eauto.

  eapply Par_Proj2Beta; eauto.
  eapply IHPar; eauto.
Qed.
*)

Lemma Par_subst3 : forall P1 phi b psi b' x,
    CPar P1 psi phi b b' ->
    forall a a', Par ([(x,phi)] ++ P1) psi a a' ->
    Par P1 psi (subst_tm_tm b x a) (subst_tm_tm b' x a').
Proof.
  intros.
  eapply Par_subst3_full with (P2 := nil); eauto.
Qed.

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