From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import frac.
From cap_machine Require Import machine_base.
From cap_machine Require Export rules_base.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Definition denote (i: instr) (n1 n2: Z): Z :=
    match i with
    | Add _ _ _ => (n1 + n2)%Z
    | Sub _ _ _ => (n1 - n2)%Z
    | Lt _ _ _ => (Z.b2z (n1 <? n2)%Z)
    | _ => 0%Z
    end.

  Definition is_AddSubLt (i: instr) (r: RegName) (arg1 arg2: Z + RegName) :=
    i = Add r arg1 arg2 ∨
    i = Sub r arg1 arg2 ∨
    i = Lt r arg1 arg2.

  Lemma regs_of_is_AddSubLt i r arg1 arg2 :
    is_AddSubLt i r arg1 arg2 →
    regs_of i = {[ r ]} ∪ regs_of_argument arg1 ∪ regs_of_argument arg2.
  Proof.
    intros HH. destruct_or! HH; subst i; reflexivity.
  Qed.

  Inductive AddSubLt_failure (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg) :=
  | AddSubLt_fail_nonconst1:
      z_of_argument regs rv1 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_nonconst2:
      z_of_argument regs rv2 = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'
  | AddSubLt_fail_incrPC n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := WInt (denote i n1 n2) ]> regs) = None ->
      AddSubLt_failure i regs dst rv1 rv2 regs'.

  Inductive AddSubLt_spec (i: instr) (regs: Reg) (dst: RegName) (rv1 rv2: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | AddSubLt_spec_success n1 n2:
      z_of_argument regs rv1 = Some n1 ->
      z_of_argument regs rv2 = Some n2 ->
      incrementPC (<[ dst := WInt (denote i n1 n2) ]> regs) = Some regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' NextIV
  | AddSubLt_spec_failure:
      AddSubLt_failure i regs dst rv1 rv2 regs' ->
      AddSubLt_spec i regs dst rv1 rv2 regs' FailedV.

  Local Ltac iFail Hcont get_fail_case :=
    cbn; iFrame; iApply Hcont; iFrame; iPureIntro;
    econstructor; eapply get_fail_case; eauto.

  Lemma wp_AddSubLt Ep i pc_p pc_b pc_e pc_a w dst arg1 arg2 regs :
    decodeInstrW w = i →
    is_AddSubLt i dst arg1 arg2 →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    regs !! PC = Some (WCap pc_p pc_b pc_e pc_a) →
    regs_of i ⊆ dom regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ AddSubLt_spec (decodeInstrW w) regs dst arg1 arg2 regs' retv ⌝ ∗
          pc_a ↦ₐ w ∗
          [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hdecode Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ns l1 l2 nt) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iIntros "_".
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.
    unfold exec in Hstep.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    erewrite regs_of_is_AddSubLt in Hri, Dregs; eauto.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (z_of_argument regs arg1) as [n1|] eqn:Hn1;
      pose proof Hn1 as Hn1'; cycle 1.
    (* Failure: arg1 is not an integer *)
    { unfold z_of_argument in Hn1. destruct arg1 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { rewrite Hr'0 in Hn1.
        destruct_word r0v; try congruence.
        all: destruct_or! Hinstr; rewrite Hinstr /= in Hstep.
        all: rewrite Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst1. }
    apply (z_of_arg_mono _ r) in Hn1; auto.

    destruct (z_of_argument regs arg2) as [n2|] eqn:Hn2;
      pose proof Hn2 as Hn2'; cycle 1.
    (* Failure: arg2 is not an integer *)
    { unfold z_of_argument in Hn2. destruct arg2 as [| r0]; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      {
        rewrite Hr'0 in Hn2. destruct_word r0v; try congruence.
        all: destruct_or! Hinstr; rewrite Hinstr /= Hn1 in Hstep; cbn in Hstep.
        all: rewrite Hr0 in Hstep. all: repeat case_match; simplify_eq; eauto. }
      iFail "Hφ" AddSubLt_fail_nonconst2. }
    apply (z_of_arg_mono _ r) in Hn2; auto.

    assert (exec_opt i (r, m) = updatePC (update_reg (r, m) dst (WInt (denote i n1 n2)))) as HH.
    { all: destruct_or! Hinstr; rewrite Hinstr /= /update_reg /= in Hstep |- *; auto.
      all: by rewrite Hn1 Hn2; cbn. }
    rewrite HH in Hstep. rewrite /update_reg /= in Hstep.

    destruct (incrementPC (<[ dst := WInt (denote i n1 n2) ]> regs))
      as [regs'|] eqn:Hregs'; pose proof Hregs' as H'regs'; cycle 1.
    (* Failure: Cannot increment PC *)
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      rewrite Hregs' in Hstep. inversion Hstep.
      iFail "Hφ" AddSubLt_fail_incrPC. }

    (* Success *)

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & HuPC & ->).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto. rewrite HuPC in Hstep.
    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  (* Derived specifications *)

  Lemma wp_add_sub_lt_success_z_z E dst pc_p pc_b pc_e pc_a w wdst ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite insert_commute // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "[? ?]"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_z E dst pc_p pc_b pc_e pc_a w wdst ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ WInt n1
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WInt n1
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_r E dst pc_p pc_b pc_e pc_a w wdst ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ WInt n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ WInt n2
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r E dst pc_p pc_b pc_e pc_a w wdst ins r1 n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ WInt n1
        ∗ r2 ↦ᵣ WInt n2
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WInt n1
          ∗ r2 ↦ᵣ WInt n2
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr1 & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_4 with "HPC Hr1 Hr2 Hdst") as "[Hmap (%&%&%&%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ r1 dst) // (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_4 with "Hmap") as "(?&?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_r_same E dst pc_p pc_b pc_e pc_a w wdst ins r n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r) (inr r) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r ↦ᵣ WInt n
        ∗ dst ↦ᵣ wdst
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r ↦ᵣ WInt n
          ∗ dst ↦ᵣ WInt (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_z E dst pc_p pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inl n2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ WInt n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_z_dst E dst pc_p pc_b pc_e pc_a w ins n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ WInt n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_r E dst pc_p pc_b pc_e pc_a w ins n1 r2 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr r2) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r2 ↦ᵣ WInt n2
        ∗ dst ↦ᵣ WInt n1
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ WInt n2
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r2 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_r_dst E dst pc_p pc_b pc_e pc_a w ins r1 n1 n2 pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr r1) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ r1 ↦ᵣ WInt n1
        ∗ dst ↦ᵣ WInt n2
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ WInt n1
          ∗ dst ↦ᵣ WInt (denote ins n1 n2)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hr2 & Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr2 Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r1 dst) //
              (insert_commute _ PC dst) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  Lemma wp_add_sub_lt_success_dst_dst E dst pc_p pc_b pc_e pc_a w ins n pc_a' :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inr dst) (inr dst) →
    (pc_a + 1)%a = Some pc_a' →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) ->

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ pc_a ↦ₐ w
        ∗ dst ↦ᵣ WInt n
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ WInt (denote ins n n)
      }}}.
  Proof.
    iIntros (Hdecode Hinstr Hpc_a Hvpc ϕ) "(HPC & Hpc_a & Hdst) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.

  (* Slightly generalized: fails in all cases where r2 does not contain an integer. *)
  Lemma wp_add_sub_lt_fail_z_r E ins dst n1 r2 w w2 wdst pc_p pc_b pc_e pc_a :
    decodeInstrW w = ins →
    is_AddSubLt ins dst (inl n1) (inr r2) →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    is_z w2 = false →
    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a ∗ pc_a ↦ₐ w ∗ dst ↦ᵣ wdst ∗ r2 ↦ᵣ w2 }}}
      Instr Executable
            @ E
    {{{ RET FailedV; pc_a ↦ₐ w }}}.
  Proof.
    iIntros (Hdecode Hinstr Hvpc Hisnz φ) "(HPC & Hpc_a & Hdst & Hr2) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hdst Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
      by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.
    destruct Hspec as [* Hsucc |].
    { (* Success (contradiction) *)  destruct w2; simplify_map_eq. }
    { (* Failure, done *) by iApply "Hφ". }
  Qed.

End cap_lang_rules.

(* Hints to automate proofs of is_AddSubLt *)
Lemma is_AddSubLt_Add dst arg1 arg2 :
  is_AddSubLt (Add dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Sub dst arg1 arg2 :
  is_AddSubLt (Sub dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.
Lemma is_AddSubLt_Lt dst arg1 arg2 :
  is_AddSubLt (Lt dst arg1 arg2) dst arg1 arg2.
Proof. intros; unfold is_AddSubLt; eauto. Qed.

Global Hint Resolve is_AddSubLt_Add : core.
Global Hint Resolve is_AddSubLt_Sub : core.
Global Hint Resolve is_AddSubLt_Lt : core.


Require Export Categories.Parallel.
Require Export Limit.

Section Eq2Limit.
Context (C: EqCategory).

Program Definition EqLim: Fun Parallel C ~> C := {|
  fobj F := Eqz (fmap F (Parallel.arr false)) (fmap F (Parallel.arr true));
  fmap F G η := eqz_med (fmap G (Parallel.arr false)) (fmap G (Parallel.arr true)) (η false ∘ eqz (fmap F (Parallel.arr false)) (fmap F (Parallel.arr true))) _;
|}.
Next Obligation.
  rewrite !comp_assoc.
  rewrite <- !naturality.
  rewrite <- !comp_assoc.
  f_equal.
  apply eqz_comm.
Qed.
Next Obligation.
  apply eqz_med_unique.
  rewrite comp_id_l.
  apply comp_id_r.
Qed.
Next Obligation.
  apply eqz_med_unique.
  rewrite comp_assoc.
  rewrite eqz_med_comm.
  rewrite <- !comp_assoc.
  f_equal.
  apply eqz_med_comm.
Qed.

Program Definition EqUnit: id C ~> EqLim ∘ Δ := {|
  transform x := eqz_med (id x) (id x) (id x) _;
|}.
Next Obligation.
  set @eqz_med_comm.
  unfold fprod.
  rewrite !fork_comp.
  f_equal.
  all: rewrite <- comp_assoc.
  1: rewrite pi1_fork.
  2: rewrite pi2_fork.
  all: rewrite comp_id_r.
  all: apply comp_id_l.
Qed.

Program Definition ProdCounit: FreeProd ∘ ProdLim ~> id (C × C) := {|
  transform p := (π₁, π₂);
  naturality p q f := _;
|}.
Next Obligation.
  apply Prod.hom_eq; simpl.
  split.
  all: unfold fprod.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Lemma prod_adjoint_by: adjoint_by FreeProd ProdLim ProdCounit ProdUnit.
Proof.
  apply adjoint_by_alt; simpl; split.
  intros x.
  apply Prod.hom_eq; simpl.
  split.
  apply pi1_fork.
  apply pi2_fork.
  intros [x y]; simpl.
  rewrite <- fprod_id at 3.
  unfold fprod.
  rewrite fork_comp.
  f_equal.
  all: rewrite comp_id_l, <- comp_id_r.
  all: rewrite <- comp_assoc.
  all: f_equal.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Lemma prod_adjoint: FreeProd -| ProdLim.
Proof.
  exists ProdCounit, ProdUnit.
  exact prod_adjoint_by.
Qed.

Lemma prod_ex_lim: ex_lim ((1: Cat) + 1) C.
Proof.
  exists (ProdLim ∘ (Fun1C C (×) Fun1C C) ∘ FunPlusC 1 1 (C: Category)).
  red.
  rewrite <- comp_assoc.
  replace (@Δ C ((1: Category) + 1)) with ((FunPlusC 1 1 (C: Category))⁻¹ ∘ ((Fun1C C)⁻¹ (×) (Fun1C C)⁻¹) ∘ FreeProd).
  apply adjoint_comp.
  exact prod_adjoint.
  apply adjoint_comp.
  1, 2: apply iso_adjoint.
  fun_eq x y f.
  fun_eq a b f.
  now destruct x0.
  destruct a as [[] | []], b as [[] | []], f.
  1, 2: now rewrite !eq_iso_refl.
  natural_eq p.
  destruct p as [[] | []].
  all: etransitivity.
  1, 3: etransitivity.
  1, 3: apply (f_equal (fun f => f ∘ _)).
  5, 6: apply f_equal.
  5, 6: symmetry.
  1, 2, 5, 6: apply is_eq_refl.
  1: apply (transform_is_eq (eq_iso H0) (inl tt)).
  2: apply (transform_is_eq (eq_iso H0) (inr tt)).
  3: apply (transform_is_eq (eq_iso H) (inl tt)).
  4: apply (transform_is_eq (eq_iso H) (inr tt)).
  1, 2, 3, 4: apply eq_iso_is_eq.
  all: rewrite comp_id_r.
  all: apply comp_id_l.
Qed.
End Prod2Limit.

Section Limit2Prod.
Context (C: Category) (Lim: C × C ~> C) (η: FreeProd ∘ Lim ~> id (C × C)) (ɛ: id C ~> Lim ∘ FreeProd) (adj: adjoint_by FreeProd Lim η ɛ).

Program Definition Limit2Prod_mixin: ProdCategory.mixin_of C :=
  ProdCategory.Mixin C (fun x y => Lim (x, y)) (fun x y z f g => fmap Lim (f, g) ∘ ɛ x) (fun x y => fst (η (x, y))) (fun x y => snd (η (x, y))) _.
Next Obligation.
  apply adjoint_by_alt in adj.
  simpl in adj.
  destruct adj as [adj1 adj2].
  clear adj.
  split.
  intros H.
  2: intros [Hf Hg].
  subst h.
  2: subst f g.
  split.
  + rewrite comp_assoc.
    change (fst (η (b, c) ∘ fmap (FreeProd ∘ Lim) ((f, g): (_, _) ~> (_, _))) ∘ ɛ a = f).
    rewrite naturality.
    simpl.
    rewrite <- comp_assoc.
    change (f ∘ fst (η (a, a) ∘ ((ɛ a, ɛ a): (_, _) ~> (_, _))) = f).
    rewrite adj1.
    apply comp_id_r.
  + rewrite comp_assoc.
    change (snd (η (b, c) ∘ fmap (FreeProd ∘ Lim) ((f, g): (_, _) ~> (_, _))) ∘ ɛ a = g).
    rewrite naturality.
    simpl.
    rewrite <- comp_assoc.
    change (g ∘ snd (η (a, a) ∘ ((ɛ a, ɛ a): (_, _) ~> (_, _))) = g).
    rewrite adj1.
    apply comp_id_r.
  + change (h = fmap Lim (η (b, c) ∘ fmap FreeProd h) ∘ ɛ a).
    rewrite fmap_comp.
    change (h = fmap Lim (η (b, c)) ∘ fmap (Lim ∘ FreeProd) h ∘ ɛ a).
    rewrite <- comp_assoc.
    setoid_rewrite <- (naturality ɛ h).
    rewrite comp_assoc.
    setoid_rewrite (adj2 (b, c)).
    symmetry.
    apply comp_id_l.
Qed.

Definition Limit2Prod: ProdCategory :=
  ProdCategory.Pack C Limit2Prod_mixin.
End Limit2Prod.

Lemma prod_limit (C: Category): ex_lim ((1: Category) + 1) C <-> inhabited (ProdCategory.mixin_of C).
Proof.
  split.
  + intros [L adj].
    red in adj.
    assert (exists Lim: C × C ~> C, Lim ∘ (Fun1C C (×) Fun1C C) ∘ FunPlusC 1 1 C = L).
    exists (L ∘ (FunPlusC 1 1 C)⁻¹ ∘ ((Fun1C C)⁻¹ (×) (Fun1C C)⁻¹)).
    rewrite <- (comp_assoc (L ∘ _)).
    rewrite fprod_comp.
    rewrite inv_l, fprod_id, comp_id_r.
    rewrite <- comp_assoc.
    rewrite inv_l.
    apply comp_id_r.
    destruct H as [Lim H].
    subst L.
    replace (@Δ C ((1: Category) + 1)) with ((FunPlusC 1 1 C)⁻¹ ∘ ((Fun1C C)⁻¹ (×) (Fun1C C)⁻¹) ∘ FreeProd) in adj.
    rewrite <- comp_assoc in adj.
    apply adjoint_comp_iso_r in adj.
    apply (adjoint_comp_iso_r _ _ (iprod (Fun1C C) (Fun1C C))) in adj.
    destruct adj as [η [ɛ adj]].
    constructor.
    exact (Limit2Prod_mixin C Lim η ɛ adj).
    clear.
    fun_eq x y f.
    fun_eq a b f.
    now destruct x0.
    destruct a as [[] | []], b as [[] | []], f.
    1, 2: now rewrite !eq_iso_refl.
    natural_eq a.
    destruct a as [[] | []].
    all: etransitivity.
    1, 3: etransitivity.
    1, 3: apply (f_equal (fun f => f ∘ _)).
    5, 6: apply f_equal.
    5, 6: symmetry.
    1, 2, 5, 6: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso H0) (inl tt)).
    2: apply (transform_is_eq (eq_iso H0) (inr tt)).
    3: apply (transform_is_eq (eq_iso H) (inl tt)).
    4: apply (transform_is_eq (eq_iso H) (inr tt)).
    1, 2, 3, 4: apply eq_iso_is_eq.
    all: rewrite comp_id_r.
    all: apply comp_id_l.
  + intros [m].
    exact (prod_ex_lim (ProdCategory.Pack C m)).
Qed.


Require Import Helpers.
Require Import Library.
(*
*** Warning: in file Predefs.v,
    required library Definitions matches several files in path
    (found Definitions.v in ../lambda2Gmu and ../../dot-calculus/src/extensions/paths; used the latter)
 *)

Definition type_map := nat -> nat * typ_label.
Definition empty_map : type_map := fun x => (x, GenT).
Definition skip1 : type_map -> type_map :=
  fun f x =>
    let (n, l) := f x in
    (1 + n, l).
Definition open1 : type_map -> typ_label -> type_map :=
  fun f l x =>
    match x with
    | 0 => (0, l)
    | S n =>
      let (n', l') := f n in
      (n' + 1, l')
    end.

Fixpoint translateType
         (T : Source.typ)
         (ty_map : type_map)
         {struct T}
  : Target.typ :=
  match T with
  | typ_bvar J =>
    let (n, l) := ty_map J in
    (ref n) ↓ l
  | typ_fvar X =>
    typ_path (pvar X) GenT
  | typ_unit =>
    (pvar lib) ↓ Unit
  | T1 ** T2 =>
    let T1' := translateType T1 ty_map in
    let T2' := translateType T2 ty_map in
    TupleT T1' T2'
  | T1 ==> T2 =>
    let T1' := translateType T1 ty_map in
    let T2' := translateType T2 (skip1 ty_map) in
    typ_all T1' T2'
  | Source.typ_all T =>
    let T1 := translateType T (open1 ty_map GenT) in
    typ_all GenArgT T1
  | typ_gadt Ts g =>
    let Ts' := List.map (fun t => translateType t ty_map) Ts in
    let base := pvar env ↓ (GN g) in
    let res :=
        List.fold_left
          (fun acc T => match acc with
                     | (i, rest) =>
                       (
                         1+i,
                         (rest ∧ typ_rcd { Ai i == T })
                       )
                     end)
          Ts'
          (1, base) in
    snd res
  end.

Definition translateTyp0 (T : Source.typ) : Target.typ := translateType T empty_map.


(* ** Reduction from H10 *)

Require Import Undecidability.Synthetic.Definitions.
From Undecidability.FOL Require Import Syntax.Facts Deduction.FullNDFacts Semantics.Tarski.FullFacts Semantics.Tarski.FullSoundness.
Require Import Undecidability.FOL.PA.
From Undecidability.FOL.Arithmetics Require Import TarskiFacts DeductionFacts NatModel.
From Undecidability.H10 Require Import H10p.
Require Import List Lia.

Fixpoint embed_poly p : term :=
    match p with
    | dp_nat_pfree n => num n
    | dp_var_pfree k => $k
    | dp_comp_pfree do_add_pfree a b => (embed_poly a) ⊕ (embed_poly b)
    | dp_comp_pfree do_mul_pfree a b => (embed_poly a) ⊗ (embed_poly b)
    end.

(* We translate h10 problems to formulas in PA *)
Definition embed_problem (E : H10p_PROBLEM) : form :=
  let (a, b) := E in embed_poly a == embed_poly b.

Definition H10p_sem E sigma := dp_eval_pfree sigma (fst E) = dp_eval_pfree sigma (snd E).

Definition poly_bound p := proj1_sig (find_bounded_t (embed_poly p)).
Definition problem_bound (E : H10p_PROBLEM) :=
  let (a, b) := E in proj1_sig (find_bounded (embed_poly a == embed_poly b) ).

Definition embed E := exist_times (problem_bound E) (embed_problem E).

Lemma embed_is_closed E : bounded 0 (embed E).
Proof.
  unfold embed. rewrite exists_close_form.
  unfold problem_bound. destruct E as [a b]; cbn.
  apply (proj2_sig (find_bounded _)).
Qed.

Fact numeral_subst_invariance n rho : subst_term rho (num n) = num n.
Proof.
  induction n.
  - reflexivity.
  - cbn. now rewrite IHn.
Qed.

Lemma prv_poly {p : peirce} sigma q Gamma :
  incl FAeq Gamma -> Gamma ⊢ ( (embed_poly q)`[sigma >> num] == num (dp_eval_pfree sigma q) ).
Proof.
  intros H.
  induction q; cbn.
  - change ((num n)`[sigma >> num]) with (subst_term (sigma >> num) (num n)).
    rewrite numeral_subst_invariance.
    now apply reflexivity.
  - now apply reflexivity.
  - destruct d; cbn.
    + eapply transitivity. assumption.
      apply (eq_add H IHq1 IHq2).
      now apply num_add_homomorphism.
    + eapply transitivity. assumption.
      apply (eq_mult H IHq1 IHq2).
      now apply num_mult_homomorphism.
Qed.

Lemma problem_to_prv {p : peirce} :
  forall E sigma, H10p_sem E sigma -> FAeq ⊢ (embed_problem E)[sigma >> num].
Proof.
  intros [a b] sigma HE. cbn -[FAeq].
  eapply transitivity; firstorder.
  apply prv_poly; firstorder.
  apply symmetry; firstorder.
  unfold H10p_sem in *. cbn in HE. rewrite HE.
  apply prv_poly; firstorder.
Qed.

Theorem H10p_to_FA_prv' {p : peirce} E :
  H10p E -> FAeq ⊢ embed E.
Proof.
  intros [sigma HE].
  eapply subst_exist_prv.
  apply problem_to_prv, HE.
  rewrite <-exists_close_form; apply embed_is_closed.
Qed.

Section FA_ext_Model.

  Context {D : Type}.
  Context {I : interp D}.

  Hypothesis ext_model : extensional I.
  Hypothesis FA_model : forall ax rho, In ax FA -> rho ⊨ ax.

  Notation "'iO'" := (i_func (f:=Zero) (Vector.nil D)) (at level 2) : PA_Notation.

  Fact eval_poly sigma p : eval (sigma >> iμ) (embed_poly p) = iμ (dp_eval_pfree sigma p).
    Proof using ext_model FA_model.
      induction p; cbn.
      - now rewrite eval_num.
      - reflexivity.
      - destruct d; cbn.
        + now rewrite IHp1, IHp2, add_hom.
        + now rewrite IHp1, IHp2, mult_hom.
    Qed.

    Lemma problem_to_ext_model : forall E sigma, H10p_sem E sigma -> (sigma >> iμ) ⊨ embed_problem E.
    Proof using ext_model FA_model.
      intros [a b] sigma Hs. cbn -[sat].
      unfold H10p_sem in *. cbn -[FA] in *.
      apply ext_model. rewrite !eval_poly. congruence.
    Qed.

    Theorem H10p_to_FA_ext_model' E rho : H10p E -> rho ⊨ embed E.
    Proof using ext_model FA_model.
      intros [sigma HE].
      eapply subst_exist_sat.
      apply problem_to_ext_model.
      - apply HE.
      - rewrite <-exists_close_form; apply embed_is_closed.
    Qed.

End FA_ext_Model.

Section FA_Model.

  (* Model of FA with equality. *)

  Context {D : Type}.
  Context {I : interp D}.

  Hypothesis FA_model : forall rho ax, In ax FAeq -> rho ⊨ ax.

  Notation "'iO'" := (i_func (f:=Zero) (Vector.nil D)) (at level 2) : PA_Notation.

  Lemma problem_to_model E sigma : H10p_sem E sigma -> (sigma >> iμ) ⊨ embed_problem E.
  Proof using FA_model.
    intros HE%(problem_to_prv (p:=intu))%soundness.
    specialize (HE D I).
    setoid_rewrite sat_comp in HE.
    eapply sat_ext. 2: apply HE.
    intros x. unfold ">>". now rewrite eval_num.
    intros. instantiate (1 := (fun _ => iO)).
    now apply FA_model.
  Qed.

  Definition standard :=
    extensional I /\ exists f : D -> nat, (forall d, iμ (f d) = d) /\ (forall n, f (iμ n) = n).

  Fact standard_embed_poly rho p f :
    extensional I -> (forall d, iμ (f d) = d) -> eval rho (embed_poly p) = iμ (dp_eval_pfree (rho >> f) p).
  Proof using FA_model.
    intros HI Hf. induction p; try destruct d; cbn.
    - apply eval_num.
    - unfold funcomp. now rewrite Hf.
    - rewrite IHp1, IHp2. rewrite add_hom; trivial. firstorder.
    - rewrite IHp1, IHp2. rewrite mult_hom; trivial. firstorder.
  Qed.

  Lemma standard_embed_problem' E rho f :
    extensional I -> (forall d, iμ (f d) = d) -> (forall n, f (iμ n) = n) -> rho ⊨ embed_problem E -> H10p_sem E (rho >> f).
  Proof using FA_model.
    intros HI Hf1 Hf2 H. destruct E as [p q]. apply HI in H.
    unfold H10p_sem. cbn. rewrite <- Hf2 at 1. setoid_rewrite <- Hf2 at 3.
    f_equal. now rewrite <- !standard_embed_poly.
  Qed.

  Lemma standard_embed_problem E :
    standard -> (exists rho, rho ⊨ embed_problem E) -> H10p E.
  Proof using FA_model.
    intros (HI & f & Hf1 & Hf2) [rho Hr]. exists (rho >> f). now apply standard_embed_problem'.
  Qed.

  Lemma standard_embed E rho :
    standard -> rho ⊨ (embed E) -> H10p E.
  Proof using FA_model.
    intros HS H. apply standard_embed_problem; trivial. eapply subst_exist_sat2, H.
  Qed.

End FA_Model.

Arguments standard _ _ : clear implicits.

Lemma nat_standard :
  standard nat interp_nat.
Proof.
  split; try reflexivity. exists (fun n => n).
  setoid_rewrite <- (eval_num _ (fun n => n)).
  setoid_rewrite nat_eval_num.
  split; reflexivity.
Qed.

Fact nat_eval_poly (sigma : env nat) p :
  @eval _ _ _ interp_nat sigma (embed_poly p) = dp_eval_pfree sigma p.
Proof.
  induction p; cbn.
  - now rewrite nat_eval_num.
  - reflexivity.
  - destruct d; cbn.
    + now rewrite IHp1, IHp2.
    + now rewrite IHp1, IHp2.
Qed.

Lemma nat_H10 E :
  (forall rho, sat interp_nat rho (embed E)) -> H10p E.
Proof.
  destruct E as [a b]. unfold embed in *.
  intros H. specialize (H (fun _ => 0)).
  apply subst_exist_sat2 in H as [sigma H].
  exists sigma. unfold H10p.H10p_sem. cbn.
  rewrite <- !nat_eval_poly. apply H.
Qed.

Lemma nat_sat :
  forall E rho, sat interp_nat rho (embed_problem E) <-> H10p_sem E rho.
Proof.
  intros E rho. split.
  - destruct E as [a b]. unfold H10p_sem. cbn.
    now rewrite !nat_eval_poly.
  - intros. eapply (@sat_ext _ _ _ _ _ (rho >> @iμ nat interp_nat)).
    intros x. change ((rho >> iμ) x) with (@iμ nat interp_nat (rho x)).
    induction (rho x). reflexivity. cbn. now rewrite IHn.
    eapply problem_to_model.
    apply nat_is_FA_model.
    assumption.
Qed.

Lemma nat_sat' E :
  (exists sigma, sat interp_nat sigma (embed_problem E)) <-> H10p E.
Proof.
  split; intros [sigma ]; exists sigma; now apply nat_sat.
Qed.

Theorem H10p_to_FA_ext_sat E :
  H10p E <-> ext_entailment_PA (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho Hext H.
    eapply subst_exist_sat.
    apply problem_to_ext_model.
    + apply Hext.
    + intros. apply H. now constructor.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id nat_extensional).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
    apply nat_is_PA_model.
Qed.

Theorem H10p_to_FA_sat E :
  H10p E <-> valid_ctx FAeq (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. eapply sat_closed.
      2: now apply H.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      inversion Hax.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id (nat_is_FA_model id)).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_Q_sat E :
  H10p E <-> valid_ctx Qeq (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. eapply sat_closed.
      2: apply H.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      1: inversion Hax.
      firstorder.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id (nat_is_Q_model id)).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_PA_sat E :
  H10p E <-> forall D (I : interp D) rho, (forall psi rho, PAeq psi -> rho ⊨ psi) -> rho ⊨ (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. apply sat_closed with rho.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      1:inversion Hax.
      apply H. now constructor.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id nat_is_PAeq_model).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_FA_prv E :
  H10p E <-> FAeq ⊢I embed E.
Proof.
  split.
  - intros [sigma HE].
    eapply subst_exist_prv.
    apply problem_to_prv,  HE.
    rewrite <-exists_close_form; apply embed_is_closed.
  - intros H%soundness.
    now apply H10p_to_FA_sat.
Qed.

Theorem H10p_to_Q_prv E :
  H10p E <-> Qeq ⊢I embed E.
Proof.
  split.
  - intros.
    apply Weak with FAeq.
    now apply H10p_to_FA_prv.
    firstorder.
  - intros H%soundness.
    now apply H10p_to_Q_sat.
Qed.

Theorem H10p_to_PA_prv E :
  H10p E <-> PAeq ⊢TI embed E.
Proof.
  split.
  - intros [sigma HE].
    exists FAeq. split. intros. now constructor.
    apply H10p_to_FA_prv.
    now exists sigma.
  - intros H. apply nat_sat'.
    eapply subst_exist_sat2.
    eapply (tsoundness H (rho:=id)).
    intros. now apply nat_is_PAeq_model.
Qed.

(* ** Reduction for the axiomatisation PA assuming extensionality of models. *)

Theorem H10_to_ext_entailment_PA :
  H10p ⪯ ext_entailment_PA.
Proof.
  exists embed. intros E. apply H10p_to_FA_ext_sat.
Qed.

(* ** Reductions for the axiomatisations FAeq, Qeq and PAeq, which include the axioms for equatlity. *)

Theorem H10_to_entailment_FA :
  H10p ⪯ entailment_FA.
Proof.
  exists embed; intros E. apply H10p_to_FA_sat.
Qed.

Corollary H10_to_entailment_Q :
  H10p ⪯ entailment_Q.
Proof.
  exists embed; intros E. apply H10p_to_Q_sat.
Qed.

Corollary H10_to_entailment_PA :
  H10p ⪯ entailment_PA.
Proof.
  exists embed; intros E. apply H10p_to_PA_sat.
Qed.

Theorem H10_to_deduction_FA :
  H10p ⪯ deduction_FA.
Proof.
  exists embed; intros E. apply H10p_to_FA_prv.
Qed.

Theorem H10_to_deduction_Q :
  H10p ⪯ deduction_Q.
Proof.
  exists embed; intros E. apply H10p_to_Q_prv.
Qed.

Corollary H10_to_deduction_PA :
  H10p ⪯ deduction_PA.
Proof.
  exists embed; intros E. apply H10p_to_PA_prv.
Qed.


Require Import RelationClasses.
Require Import List.
Require Import Omega.
Require Import sflib.
From Paco Require Import paco.
Require Import Basics.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import Language.
Require Import ZArith.
Require Import Maps.

Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.
Require Import Kildall.
Require Import Coqlib.

Require Import Integers.
Require Import LibTactics.
Set Implicit Arguments.

(** * Value Analysis *)

(** This file is the implementation of the value analysis,
    whose result is the values of registers and variables in each program point.  *)

Module LVal <: SEMILATTICE_WITH_TOP.
  Inductive t' := vtop | VAL (n:int) | vbot.
  Definition t := t'.

  Definition eq (x y:t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@eq_refl t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans t).

  Definition beq (x y: t): bool :=
    match x, y with
    | vtop, vtop => true
    | vbot, vbot => true
    | VAL v1, VAL v2 => if Int.eq_dec v1 v2 then true else false
    | _, _ => false
    end.

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    ii. destruct x, y; ss.
    des_ifH H; ss. subst. econs; eauto.
  Qed.

  Definition ge (x y: t): Prop :=
    match x, y with
    | vtop, _ => true
    | _, vbot => true
    | VAL v1, VAL v2 => if Int.eq_dec v1 v2 then true else false
    | _, _ => false
    end.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    ii. destruct x, y; ss; eauto.
    unfold eq in *. inv H.
    des_if; ss; eauto.
  Qed.

  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    ii. destruct x, y, z; ss; tryfalse; eauto.
    des_ifH H; ss; subst.
    des_ifH H0; ss; subst.
  Qed.

  Definition bot := vbot.

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    ii; destruct x; ss.
  Qed.

  Definition top := vtop.

  Lemma ge_top: forall x, ge top x.
  Proof. unfold ge, top; ii; ss. Qed.

  Definition lub (x y: t): t :=
    match x, y with
    | vbot, vbot => vbot
    | VAL v1, VAL v2 => if Int.eq_dec v1 v2 then VAL v1 else vtop
    | _, _ => vtop
    end.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    ii; destruct x, y; ss.
    des_if; subst; ss; eauto.
    des_if; ss.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    ii; destruct x, y; ss.
    des_if; subst; ss; eauto.
    des_if; ss.
  Qed.
End LVal.

Module VALSET := LPMap(LVal).
Definition vreg := VALSET.t.
Definition vmem := VALSET.t.

(** ** Lattices for Value Analysis *)
(** The result of the value analysis of each program point is
    a pair of mapping, where [vreg] maps register to LVal and [vmem] maps memory location to LVal. *)
Module ValLat <: SEMILATTICE_WITH_TOP.

  Definition t := (vreg * vmem)%type.

  Definition eq (x y:t) :=
    VALSET.eq (fst x) (fst y) /\ VALSET.eq (snd x) (snd y).
  Definition eq_refl: forall x, eq x x.
    ii. unfold eq. ss.
  Qed.

  Definition eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    ii. unfold eq in *; ss. des.
    split; eauto; ss.
    destruct x, y; ss.
    eapply VALSET.eq_sym; eauto.
    eapply VALSET.eq_sym; eauto.
  Qed.

  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    ii. unfold eq in *; ss. des.
    split.
    eapply VALSET.eq_trans; eauto.
    eapply VALSET.eq_trans; eauto.
  Qed.

  Definition beq (x y: t): bool :=
    VALSET.beq (fst x) (fst y) && VALSET.beq (snd x) (snd y).

  Definition beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    ii. unfold beq in *. unfold eq.
    destruct (VALSET.beq (fst x) (fst y)) eqn:VALSET_BEQ1; ss.
    split. eapply VALSET.beq_correct; eauto.
    eapply VALSET.beq_correct; eauto.
  Qed.

  Definition ge (x y: t) :=
    VALSET.ge (fst x) (fst y) /\ VALSET.ge (snd x) (snd y).

  Definition ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; destruct x, y; simpl. intros [A B]; split; eapply VALSET.ge_refl; eauto.
  Qed.

  Definition ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; destruct x, y, z; simpl.
    intros [A B] [C D]; split; eapply VALSET.ge_trans; eauto.
  Qed.

  Definition bot := (VALSET.bot, VALSET.bot).

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    ii; destruct x; ss. unfold bot.
    econs; ss; eapply VALSET.ge_bot; eauto.
  Qed.

  Definition top := (VALSET.top, VALSET.top).

  Lemma ge_top: forall x, ge top x.
  Proof.
    unfold ge, top; ii; ss.
    split; eapply VALSET.ge_top; eauto.
  Qed.

  Definition lub (x y: t): t :=
    (VALSET.lub (fst x) (fst y), VALSET.lub (snd x) (snd y)).

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    ii; destruct x, y; ss.
    unfold ge; ss.
    split; eapply VALSET.ge_lub_left; eauto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    ii; destruct x, y; ss.
    unfold ge; ss.
    split; eapply VALSET.ge_lub_right; eauto.
  Qed.
End ValLat.

Fixpoint eval_expr_ae (e: Inst.expr) (aregs: vreg) :=
  match aregs with
  | VALSET.Bot => LVal.bot
  | _ =>
    match e with
    | Inst.expr_val v => LVal.VAL v
    | Inst.expr_reg r => (VALSET.get r aregs)
    | Inst.expr_op2 op e1 e2 =>
      match (eval_expr_ae e1 aregs), (eval_expr_ae e2 aregs) with
      | LVal.VAL v1, LVal.VAL v2 => LVal.VAL (Op2.eval op v1 v2)
      | _, _ => LVal.top
      end
    end
  end.

Definition eval_loc_ae (loc: Loc.t) (amem: vmem) :=
  VALSET.get loc amem.

Definition mem_to_top (amem: vmem) :=
  match amem with
  | VALSET.Bot => VALSET.Bot
  | _ => VALSET.top
  end.

(** ** Transfer Function for the Single Instruction *)
Definition transf_instr (instr: Inst.t) (ae: ValLat.t): ValLat.t :=
  match ae with
  | (aregs, amem) =>
    match instr with
    | Inst.skip => (aregs, amem)
    | Inst.assign r e =>
      (VALSET.set r (eval_expr_ae e aregs) aregs, amem)
    | Inst.load r loc or =>
      if Ordering.le Ordering.acqrel or then
        (VALSET.set r LVal.top aregs, mem_to_top amem)
      else
        (VALSET.set r (eval_loc_ae loc amem) aregs, amem)
    | Inst.store loc e ow =>
      match ow with
      | Ordering.plain =>
        (aregs, VALSET.set loc (eval_expr_ae e aregs) amem)
      | _ => (aregs, amem)
      end
    | Inst.cas r loc er ew or ow =>
      if Ordering.le Ordering.acqrel or then
        (VALSET.set r LVal.top aregs, mem_to_top amem)
      else
        (VALSET.set r LVal.top aregs, VALSET.set loc LVal.top amem)
    | Inst.fence_acq | Inst.fence_sc => (aregs, mem_to_top amem)
    | Inst.fence_rel => (aregs, amem)
    | Inst.print e => (aregs, mem_to_top amem)
    end
  end.

Lemma transf_instr_bot
      instr:
  transf_instr instr ValLat.bot = ValLat.bot.
Proof.
  destruct instr; ss.
  - destruct or; ss.
  - destruct ow; ss.
  - des_if; eauto.
Qed.

Module ValDS := Dataflow_Solver(ValLat)(NodeSetForward).

(** ** Transfer Function for the Basic Block *)
Fixpoint transf_blk (ae: ValDS.L.t) (bb: BBlock.t) {struct bb}: ValDS.AI.b :=
  match bb with
  | BBlock.blk instr bb' =>
    ValDS.AI.Cons ae (transf_blk (transf_instr instr ae) bb')
  | BBlock.call f fret => ValDS.AI.Cons ae (ValDS.AI.Atom (fst ae, mem_to_top (snd ae)))
  | _ => ValDS.AI.Cons ae (ValDS.AI.Atom ae)
  end.

Lemma transf_blk_first
      l bb:
  ValDS.AI.getFirst (transf_blk l bb) = l.
Proof.
  destruct bb; ss; eauto.
Qed.

Lemma transf_blk_bot:
      forall bb,
        ValDS.AI.getLast (transf_blk ValDS.AI.bot bb) = ValDS.AI.bot.
Proof.
  induction bb; ii; try solve [ss; eauto].
  assert (transf_blk ValDS.AI.bot (c##bb) =
          ValDS.AI.Cons (ValDS.AI.bot) (transf_blk (transf_instr c ValDS.AI.bot) bb)). eauto.
  assert (transf_instr c ValDS.AI.bot = ValDS.AI.bot).
  eapply transf_instr_bot; eauto.
  rewrite H0 in H. rewrite H.
  simpl. eauto.
Qed.

Definition transf (ai: ValDS.L.t) (bb: BBlock.t): ValDS.AI.t :=
  ValDS.AI.getLast (transf_blk ai bb).


Require Export med_mods is_pos_neg_SO_lemmas.
Require Import Modal_syntax p_is_pos ST.

Definition Pred_is_pos_SO (alpha : SecOrder) (P : predicate) : Prop :=
Pred_in_SO alpha P  /\
(forall i : nat, occ_in_SO alpha i -> P = at_pred (preds_in alpha) i -> is_pos_SO alpha i).

(*
Inductive Pred_is_pos_SO (alpha : SecOrder) (P : predicate) : Prop :=
| Pred_is_pos_y : Pred_in_SO alpha P  ->
    (forall i : nat, occ_in_SO alpha i -> P = at_pred (preds_in alpha) i -> is_pos_SO alpha i) -> Pred_is_pos_SO alpha P.
 *)

Lemma Pred_is_pos__in_SO : forall alpha P,
  Pred_is_pos_SO alpha P -> Pred_in_SO alpha P.
Proof. firstorder. Qed.

Lemma Pred_is_pos_SO_allFO  : forall (alpha : SecOrder) (x : FOvariable) (P : predicate),
  Pred_is_pos_SO (allFO x alpha) P <-> Pred_is_pos_SO alpha P.
Proof.
  intros alpha x P; split; intros [H1 H2];
  constructor. erewrite Pred_in_SO_allFO. apply H1.
  intros i H3 H4. rewrite <- is_pos_SO_allFO.
  apply H2. apply occ_in_SO_allFO. auto.
  auto.

  rewrite <- Pred_in_SO_allFO. auto.
  intros i H3 H4. rewrite is_pos_SO_allFO. apply H2.
  erewrite <- occ_in_SO_allFO. apply H3. auto.
Qed.

Lemma Pred_is_pos_SO_exFO  : forall (alpha : SecOrder) (x : FOvariable) (P : predicate),
  Pred_is_pos_SO (exFO x alpha) P <-> Pred_is_pos_SO alpha P.
Proof.
  intros alpha x P; split; intros [H1 H2];
  constructor. erewrite Pred_in_SO_exFO. apply H1.
  intros i H3 H4. rewrite <- is_pos_SO_exFO.
  apply H2. apply occ_in_SO_exFO. auto.
  auto.

  rewrite <- Pred_in_SO_exFO. auto.
  intros i H3 H4. rewrite is_pos_SO_exFO. apply H2.
  erewrite <- occ_in_SO_exFO. apply H3. auto.
Qed.

Lemma Pred_is_pos_SO_conjSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_pos_SO (conjSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [Hpos1 Hpos2]. constructor.
  auto. intros i Hocc Hat. pose proof Hocc as H.
  eapply or_introl in Hocc. eapply occ_in_SO_conjSO2_rev in Hocc.
  apply Hpos2 in Hocc. apply (is_pos_SO_conjSO_l alpha1 alpha2 i) in Hocc;
                         auto. simpl. rewrite at_pred_app_l; firstorder.
Qed.

Lemma Pred_is_pos_SO_conjSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P  ->
  Pred_is_pos_SO (conjSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [Hpos1 Hpos2].
  constructor. auto. intros i Hocc Hat.
  assert (i = (i + length (preds_in alpha1) - length (preds_in alpha1)))
    as Hass. firstorder.
  rewrite Hass in *.
  apply is_pos_SO_conjSO_r. intros H2.
  rewrite PeanoNat.Nat.add_sub in Hocc.
  all : try (solve [firstorder]).
  apply Hpos2.
  apply occ_in_SO_conjSO2_rev. right. auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. simpl in *. rewrite PeanoNat.Nat.sub_diag in Hocc.
  all : firstorder.
Qed.

Lemma Pred_is_pos_SO_disjSO_l : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha1 P ->
  Pred_is_pos_SO (disjSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha1 P.
Proof.
  intros alpha1 alpha2 P Hpocc [Hpos1 Hpos2]. constructor.
  auto. intros i Hocc Hat. pose proof Hocc as H.
  eapply or_introl in Hocc. eapply occ_in_SO_disjSO2_rev in Hocc.
  apply Hpos2 in Hocc. apply (is_pos_SO_disjSO_l alpha1 alpha2 i) in Hocc;
                         auto. simpl. rewrite at_pred_app_l; firstorder.
Qed.

Lemma Pred_is_pos_SO_disjSO_r : forall (alpha1 alpha2 : SecOrder)
                                    (P : predicate),
  Pred_in_SO alpha2 P  ->
  Pred_is_pos_SO (disjSO alpha1 alpha2) P ->
  Pred_is_pos_SO alpha2 P.
Proof.
  intros alpha1 alpha2 P Hpocc [Hpos1 Hpos2].
  constructor. auto. intros i Hocc Hat.
  assert (i = (i + length (preds_in alpha1) - length (preds_in alpha1)))
    as Hass. firstorder.
  rewrite Hass in *.
  apply is_pos_SO_disjSO_r. intros H2.
  rewrite PeanoNat.Nat.add_sub in Hocc.
  all : try (solve [firstorder]).
  apply Hpos2.
  apply occ_in_SO_disjSO2_rev. right. auto.
  simpl. rewrite PeanoNat.Nat.add_comm. rewrite at_pred_app_r.
  rewrite PeanoNat.Nat.add_sub in Hat. auto.
  destruct i. simpl in *. rewrite PeanoNat.Nat.sub_diag in Hocc.
  all : firstorder.
Qed.

Lemma Pred_is_pos_SO_allSO : forall (alpha : SecOrder) (P Q : predicate),
Pred_in_SO alpha P ->
Pred_is_pos_SO (allSO Q alpha) P -> Pred_is_pos_SO alpha P.
Proof.
  intros alpha P Q Hpocc [H1 H2]; constructor. firstorder.
  intros i Hocc Hat. eapply is_pos_SO_allSO. auto. apply H2.
  firstorder. all : try solve [simpl; firstorder].
  simpl. destruct i; firstorder.
Qed.

Lemma Pred_is_pos_SO_exSO : forall (alpha : SecOrder) (P Q : predicate),
Pred_in_SO alpha P ->
Pred_is_pos_SO (exSO Q alpha) P -> Pred_is_pos_SO alpha P.
Proof.
  intros alpha P Q Hpocc [H1 H2]; constructor. firstorder.
  intros i Hocc Hat. eapply is_pos_SO_exSO. auto.
  apply H2. firstorder. all : try solve [simpl; firstorder].
  simpl. destruct i; firstorder.
Qed.

Lemma p_is_pos__SO : forall (phi : Modal) (x : FOvariable)
                            (p : propvar),
  p_is_pos phi p <-> Pred_is_pos_SO (ST phi x) (ST_pv p).
Proof.
  intros phi x p; split; intros [H1 H2].
  constructor. apply p_occ__ST. auto.
  intros i Hocc Hat. apply is_pos__ST. apply H2.
  rewrite occ_in_ST. apply Hocc.
  rewrite <- at_pv_ST_nocon in Hat.
  apply ST_pv_inj in Hat. auto.

  constructor. apply p_occ__ST in H1. auto.
  intros i Hocc Hat. apply (is_pos__ST phi x i). apply H2.
  rewrite occ_in_ST in Hocc. apply Hocc.
  rewrite <- at_pv_ST_nocon. subst. auto.
Qed.

Lemma Pred_is_pos_SO_allSO_neq : forall alpha P Q,
  ~ P = Q ->
  Pred_is_pos_SO (allSO P alpha) Q ->
  Pred_is_pos_SO alpha Q.
Proof.
  intros alpha P Q Hneq [H1 H2].
  inversion H1. subst. contradiction.
  constructor. auto.
  intros i Hocc Hat. simpl in *.
  assert (occ_in_SO (allSO P alpha) (S i)) as Hpocc. apply occ_in_SO_allSO. auto.
  specialize (H2 _ Hpocc). simpl in *. destruct i. firstorder.
  rewrite PeanoNat.Nat.sub_0_r in *. apply H2 in Hat.
  constructor. auto. inversion Hat. simpl in *. destruct P. auto.
Qed.

Lemma Pred_is_pos_SO_exSO_neq : forall alpha P Q,
  ~ P = Q ->
  Pred_is_pos_SO (exSO P alpha) Q ->
  Pred_is_pos_SO alpha Q.
Proof.
  intros alpha P Q Hneq [H1 H2].
  inversion H1. subst. contradiction.
  constructor. auto.
  intros i Hocc Hat. simpl in *.
  assert (occ_in_SO (exSO P alpha) (S i)) as Hpocc. apply occ_in_SO_exSO. auto.
  specialize (H2 _ Hpocc). simpl in *. destruct i. firstorder.
  rewrite PeanoNat.Nat.sub_0_r in *. apply H2 in Hat.
  constructor. auto. inversion Hat. simpl in *. destruct P. auto.
Qed.


From stdpp Require Import numbers countable.
From Formalisation Require Import Span SizeNat Inject IsFresh.
From Classes Require Import Foldable.
Require Import Vector.
From Equations Require Import Equations.
Import disjoint.

Section ZeroCopy.

  Context {M : Type -> Type}.
  Context {foldable : Foldable M}.

  Open Scope N_scope.

  Definition set_span (s : span) := inject (pos s) (pos s + len s).

  Definition scope_in (s t : span) := set_span s ⊆ set_span t.

  Definition Result_in (r : M span) (s : span):=
    forall v, v ∈ M_to_list r -> scope_in v s.

  Definition WeakZC (decode : span -> option (M span)) :=
    forall s (res : M span),
      decode s = Some res ->
      Result_in res s.

  Close Scope N_scope.

End ZeroCopy.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Functor.

Require Import Coq.Structures.DecidableTypeEx.
Require Import Coq.FSets.FMapFacts.
Require Import Category.Lib.FMapExt.
Require Import Coq.Arith.PeanoNat.

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

Module PNN := PairUsualDecidableType Nat_as_DT Nat_as_DT.

Module Metacategory (M : WSfun PNN).

Module Import FMapExt := FMapExt PNN M.
Module P := FMapExt.P.
Module F := P.F.

Definition defined x y := M.In (elt:=nat) (x, y).

Record Metacategory := {

arr := nat;

pairs : M.t arr;

composite (f g h : arr) := M.MapsTo (f, g) h pairs;

identity (u : arr) :=
(∀ (f : arr), composite f u f) ∧ (∀ (g : arr), composite u g g);

composition_law (k g f kg gf : arr) :
composite k g kg ->
composite g f gf ->
∀ kgf, composite kg f kgf ↔ composite k gf kgf;

triple_composition (k g f kg gf : arr) :
composite k g kg ->
composite g f gf -> (exists kgf : arr, composite kg f kgf)%type;

identity_law (g : arr) :
∃ u,  identity u  ->
∃ u', identity u' ->
defined g u pairs ∧ defined u' g pairs;
}.

Definition composite_defined (M : Metacategory) (f g h : arr M) :
composite M f g h -> defined f g (pairs M) := fun H =>
proj2 (@in_mapsto_iff _ _ _) (ex_intro _ h H).

Program Definition defined_composite (M : Metacategory) (f g : arr M) :
defined f g (pairs M) -> ∃ h : arr M, composite M f g h.
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.defined_composite".
intro H.
unfold defined in H.
destruct (M.find (f, g) (pairs M)) eqn:Heqe.
exists n.
apply (M.find_2 Heqe).
apply F.in_find_iff in H.
contradiction.
Defined.

Lemma identity_morphism (M : Metacategory) (i : arr M) :
identity M i -> composite M i i i.
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.identity_morphism". intro H; apply H. Qed.

Lemma identity_composition_between (M : Metacategory) :
∀ f g u,
identity M u ->
defined f u (pairs M) ->
defined u g (pairs M) ->
defined f g (pairs M).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.identity_composition_between".
intros.
destruct H.
pose proof (@triple_composition M f u g f g (c f) (c0 g)) as H3;
simpl in H3.
destruct H3.
apply composite_defined with (h:=x).
exact H.
Defined.

Lemma identity_composition_left (M : Metacategory) :
∀ f g fg u,
identity M u ->
composite M f g fg ->
defined u f (pairs M) ->
defined u fg (pairs M).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.identity_composition_left".
intros.
destruct H.
apply composite_defined with (h:=fg); auto.
Qed.

Lemma identity_composition_right (M : Metacategory) :
∀ f g fg u,
identity M u ->
composite M f g fg ->
defined g u (pairs M) ->
defined fg u (pairs M).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.identity_composition_right".
intros.
destruct H.
apply composite_defined with (h:=fg); auto.
Qed.

Local Obligation Tactic := intros.

Global Program Definition FromArrows (M : Metacategory) : Category := {|

obj := ∃ i : arr M, identity M i;

hom := fun x y =>
∃ f : arr M, defined f ``x (pairs M) ∧ defined ``y f (pairs M);

homset := fun _ _ => {| Setoid.equiv := fun f g => `1 f = `1 g |}
|}.
Next Obligation.
equivalence; simpl in *; subst.
Qed.
Next Obligation.
destruct x as [i [Hil Hir]].
exists i.
split; apply composite_defined with (h:=i); auto.
Defined.
Next Obligation.
destruct x as [x x_id];
destruct y as [y y_id];
destruct z as [z z_id];
destruct f as [f [fl fr]];
destruct g as [g [gl gr]]; simpl in *.
pose proof (identity_composition_between M f g y y_id fl gr).
destruct (defined_composite _ _ _ H) as [fg Hfg].
exists fg; split.
eapply identity_composition_right; eauto.
eapply identity_composition_left; eauto.
Defined.
Next Obligation.
proper.
unfold FromArrows_obligation_3; simpl in *; subst.
destruct (defined_composite _ _ _); reflexivity.
Qed.
Next Obligation.
unfold FromArrows_obligation_3; simpl.
destruct x, y, f, i, i0, p; simpl in *; subst.
destruct (defined_composite _ _ _).
pose proof (c2 x1).
unfold composite in c3, H.
apply (FMapExt.F.MapsTo_fun c3 H).
Qed.
Next Obligation.
unfold FromArrows_obligation_3; simpl.
destruct x, y, f, i, i0, p; simpl in *; subst.
destruct (defined_composite _ _ _).
pose proof (c x1).
unfold composite in c3, H.
apply (FMapExt.F.MapsTo_fun c3 H).
Qed.
Next Obligation.
unfold FromArrows_obligation_3; simpl.
destruct x as [x [xl_id xr_id]];
destruct y as [y [yl_id yr_id]];
destruct z as [z [zl_id zr_id]];
destruct w as [w [wl_id wr_id]];
destruct f as [f [fl fr]];
destruct g as [g [gl gr]];
destruct h as [h [hl hr]];
simpl in *.
repeat destruct (defined_composite _ _ _).
unfold composite in *.
pose proof (fst (composition_law M f g h x2 x0 c1 c x3) c2).
simpl in H.
apply (FMapExt.F.MapsTo_fun c0 H).
Qed.
Next Obligation.
symmetry.
unfold FromArrows_obligation_3; simpl.
destruct x as [x [xl_id xr_id]];
destruct y as [y [yl_id yr_id]];
destruct z as [z [zl_id zr_id]];
destruct w as [w [wl_id wr_id]];
destruct f as [f [fl fr]];
destruct g as [g [gl gr]];
destruct h as [h [hl hr]];
simpl in *.
repeat destruct (defined_composite _ _ _).
unfold composite in *.
pose proof (fst (composition_law M f g h x2 x0 c1 c x3) c2).
simpl in H.
apply (FMapExt.F.MapsTo_fun c0 H).
Qed.

Notation "[map ]" := (M.empty _) (at level 9, only parsing).
Notation "x +=> y" := (M.add x y) (at level 9, only parsing).
Notation "[map  a ; .. ; b ]" := (a .. (b [map]) ..) (only parsing).

Ltac structure :=
simpl in *;
repeat (
match goal with
| [ H : (_, _) = (_, _) |- _ ] => inversion H; clear H; subst
| [ |- ?X = ?Y → False ] =>
let H := fresh "H" in
intro H; inversion H; tauto
| [ H : M.MapsTo _ _ _ |- _ ] => simplify_maps
| [ |- M.MapsTo _ _ _ ] => simplify_maps
| [ |- _ ↔ _ ] => split; intros
| [ |- _ /\ _ ] => split
| [ |- _ \/ _ ] => solve [ left; structure | right; structure ]
end; intuition idtac; try congruence).

Ltac check_structure :=
first [ unfold defined;
repeat (unshelve eexists; try assumption; intros []);
split; apply in_mapsto_iff;
eexists; intuition
| unshelve (structure; eexists; structure); exact 0%nat
| structure ].

Local Obligation Tactic := program_simpl; check_structure.

Program Definition ZeroArrows : Metacategory := {|
pairs := [map]
|}.

Program Definition OneArrow : Metacategory := {|
pairs := [map (0, 0) +=> 0 ]%nat
|}.

Program Definition TwoArrows : Metacategory := {|
pairs := [map (0, 0) +=> 0
;    (1, 1) +=> 1

;    (0, 2) +=> 2
;    (2, 1) +=> 2 ]%nat
|}.

Program Definition ThreeArrows : Metacategory := {|
pairs := [map (0, 0) +=> 0
;    (1, 1) +=> 1
;    (2, 2) +=> 2

;    (0, 3) +=> 3
;    (3, 1) +=> 3

;    (1, 4) +=> 4
;    (4, 2) +=> 4

;    (3, 4) +=> 5

;    (0, 5) +=> 5
;    (5, 2) +=> 5 ]%nat
|}.

Definition Three : Category := FromArrows ThreeArrows.

Definition cardinality (M : Metacategory) : nat :=
M.cardinal (P.filter (fun '(dom, cod) v =>
((dom =? v)%nat && (cod =? v)%nat)%bool)
(pairs M)).

Lemma elements_filter {elt} (m : M.t elt) (P : M.key → elt → bool) :
M.elements (P.filter P m)
= filter (fun p => P (fst p) (snd p)) (M.elements m).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.elements_filter".
unfold P.filter.
apply P.fold_rec; intros.
rewrite (proj1 (P.elements_Empty m0) H); simpl.
apply P.elements_empty.
destruct (P k e) eqn:Heqe.
apply add_equal_iff in H1.
Abort.

Lemma length_elements_filter {elt} (m : M.t elt) k v (P : M.key * elt → bool) :
length (filter P (M.elements (M.add k v m)))
= length (filter P ((k, v) :: M.elements m)).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.length_elements_filter".
Abort.

Theorem elements_rect {elt} (P : list (M.key * elt) -> Type) :
(∀ m1 m2, M.Equal m1 m2 -> P (M.elements m1) -> P (M.elements m2))
-> ∀ m k v, P ((k, v) :: M.elements m) -> P (M.elements (M.add k v m)).
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.elements_rect".
Abort.

Lemma ThreeArrows_card_3 : cardinality ThreeArrows = 3%nat.
Proof. hammer_hook "Metacategory" "Metacategory.Metacategory.ThreeArrows_card_3".

assert (P.transpose_neqkey
M.Equal
(λ (k : M.key) (e : nat) (m : M.t nat),
if (let '(dom, cod) := k in
λ v : nat, (dom =? v)%nat && (cod =? v)%nat) e
then k +=> e m
else m)).
intros ??????.
destruct k, k'.
assert (n ≠ n1 \/ n0 ≠ n2).
destruct (Nat.eq_dec n n1); subst.
right; congruence.
left; assumption.
destruct ((n =? e)%nat && (n0 =? e)%nat) eqn:Heqe.
apply andb_true_iff in Heqe.
destruct Heqe.
apply Nat.eqb_eq in H1.
apply Nat.eqb_eq in H2.
subst.
destruct ((n1 =? e')%nat && (n2 =? e')%nat) eqn:Heqe2.
apply andb_true_iff in Heqe2.
destruct Heqe2.
apply Nat.eqb_eq in H1.
apply Nat.eqb_eq in H2.
subst.
apply add_associative.
intros; congruence.
reflexivity.
destruct ((n1 =? e')%nat && (n2 =? e')%nat) eqn:Heqe2.
apply andb_true_iff in Heqe2.
destruct Heqe2.
apply Nat.eqb_eq in H1.
apply Nat.eqb_eq in H2.
subst.
reflexivity.
reflexivity.

assert (Proper (eq ==> eq ==> M.Equal ==> M.Equal)
(λ (k : M.key) (e : nat) (m : M.t nat),
if (let '(dom, cod) := k in
λ v : nat, (dom =? v)%nat && (cod =? v)%nat) e
then k +=> e m
else m)).
intros ?????????.
destruct x, y; subst.
inversion H0; clear H0; subst.
destruct ((n1 =? y0)%nat && (n2 =? y0)%nat) eqn:Heqe.
apply andb_true_iff in Heqe.
destruct Heqe.
apply Nat.eqb_eq in H0.
apply Nat.eqb_eq in H1.
subst.
rewrite H2; reflexivity.
assumption.

unfold cardinality; simpl.
unfold P.filter; simpl.
repeat (rewrite P.fold_add; eauto; relational; simpl);
try (apply not_in_mapsto_iff; intros;
repeat (unfold not; intros; simplify_maps; try congruence)).
rewrite P.fold_Empty; auto; [| apply M.empty_1 ].

assert (P.transpose_neqkey eq (λ (_ : M.key) (_ : nat), S)) by proper.

rewrite P.cardinal_fold.
repeat (rewrite P.fold_add; eauto; relational; simpl);
try (apply not_in_mapsto_iff; intros;
repeat (unfold not; intros; simplify_maps; try congruence)).
rewrite P.fold_Empty; auto; apply M.empty_1.
Qed.

Local Obligation Tactic := program_simpl.

End Metacategory.


(** * One global message box. *)
Require Import Coq.Lists.List.
Require Import Io.All.
Require Import DeadLockFree.
Require Decide.
Require Model.

Import ListNotations.
Import C.Notations.

Module Command.
  Inductive t (A : Type) : Type :=
  | Send (x : A)
  | Receive.
End Command.

Definition answer {A : Type} (c : Command.t A) : Type :=
  match c with
  | Command.Send x => unit
  | Command.Receive => A
  end.

Definition E (A : Type) : Effect.t :=
  Effect.New (Command.t A) answer.

Definition send {A : Type} (x : A) : C.t (E A) unit :=
  call (E A) (Command.Send A x).

Definition receive {A : Type} : C.t (E A) A :=
  call (E A) (Command.Receive A).

Definition S (A : Type) := option A.

Definition m (A : Type) : Model.t (E A) (S A) :=
  fun c s =>
    match c with
    | Command.Send x =>
      match s with
      | None => Some (tt, Some x)
      | Some _ => None
      end
    | Command.Receive =>
      match s with
      | Some x => Some (x, None)
      | None => None
      end
    end.

Definition ex1 : C.t (E nat) nat :=
  let! x : nat * unit := join receive (send 12) in
  ret (fst x).

Lemma ex1_ok : C.DeadLockFree.t (m nat) None ex1.
  now apply Decide.C.dead_lock_free_ok.
Qed.


(*
 * Copyright 2015-2016 IBM Corporation
 *
 * 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.
 *)

(** This module defines a simple (inefficient) insert sort, used in
various parts of the specification. *)

Require Export Sorting.
Require Import EquivDec.
Require Import List.
Require Import LibUtilsCoqLibAdd.
Require Import LibUtilsListAdd.
Require Import Permutation.
Require Import Eqdep_dec.
Require Import RelationClasses.

Section SortingAdd.

  (** * Insertion sort *)

  Section InsertionSort.
    Context {A:Type}.
    Context {R:A->A->Prop}.
    Context (R_dec : forall a a', {R a a'} + {~R a a'}).

    (* if elements are not comparable, the left one is dropped *)
    Fixpoint insertion_sort_insert a l
      := match l with
         | nil => a :: nil
         | b::xs => if (R_dec a b)
                    then a::b::xs
                    else if (R_dec b a) then
                           b::insertion_sort_insert a xs
                         else b::xs
         end.

    Fixpoint insertion_sort (l:list A)
      := match l with
         | nil => nil
         | a::xs => insertion_sort_insert a (insertion_sort xs)
         end.

    Lemma insertion_sort_insert_Sorted a (l:list A) :
      Sorted R l -> Sorted R (insertion_sort_insert a l).
    Proof.
      Hint Constructors LocallySorted : list.
      repeat rewrite Sorted_LocallySorted_iff.
      induction l; inversion 1; subst; simpl in *;
        repeat match goal with
               | [|- context [R_dec ?x ?y]] => destruct (R_dec x y)
               end; eauto with list.
    Qed.

    Lemma insertion_sort_Sorted (l:list A) : Sorted R (insertion_sort l).
    Proof.
      Hint Resolve insertion_sort_insert_Sorted : list.
      induction l; simpl; eauto with list.
    Qed.

    Fixpoint is_list_sorted (l:list A) :=
      match l with
      | nil => true
      | x::xs => match xs with
                 | nil => true
                 | y::ls => if R_dec x y then is_list_sorted xs else false
                 end
      end.

    Lemma is_list_sorted_Sorted_iff l:
      is_list_sorted l = true <-> Sorted R l.
    Proof.
      induction l; simpl; intuition.
      - destruct l; simpl; eauto.
        destruct (R_dec a a0); simpl; intuition; try discriminate.
      - inversion H1; subst. rewrite H0; auto.
        destruct l; auto.
        inversion H5; subst.
        destruct (R_dec a a0); eauto.
    Qed.

    Lemma is_list_sorted_ext : forall l (p1 p2:is_list_sorted l = true), p1 = p2.
    Proof.
      intros. apply eq_proofs_unicity. decide equality.
    Qed.

    Lemma sorted_StronglySorted `{Transitive A R}:
      forall l, is_list_sorted l = true <-> StronglySorted R l.
    Proof.
      intros.
      rewrite is_list_sorted_Sorted_iff.
      split.
      apply Sorted_StronglySorted.
      red. apply transitivity.
      apply StronglySorted_Sorted.
    Qed.

    Lemma Forall_nin_irr `{Irreflexive A R}:
      forall a l, Forall (R a) l -> ~ In a l.
    Proof.
      induction l; [auto|intros].
      inversion H0; subst; intro.
      inversion H1; subst.
      eapply irreflexivity; eauto.
      elim IHl; auto.
    Qed.

    Lemma StronglySorted_NoDup `{Irreflexive A R}:
      forall l, StronglySorted R l -> NoDup l.
    Proof.
      induction l; intros.
      constructor.
      inversion H0; subst.
      constructor; auto. eapply Forall_nin_irr; eauto.
    Qed.

    Lemma Sorted_NoDup `{StrictOrder A R}:
      forall l, Sorted R l -> NoDup l.
    Proof.
      intros.
      apply StronglySorted_NoDup; eauto.
      apply Sorted_StronglySorted; eauto.
      red; intros; etransitivity; eauto.
    Qed.

    Lemma is_list_sorted_NoDup `{StrictOrder A R} :
      forall l, is_list_sorted l = true -> NoDup l.
    Proof.
      intros.
      eapply Sorted_NoDup; eapply is_list_sorted_Sorted_iff; eauto.
    Defined.

    Lemma is_list_sorted_cons a r :
      is_list_sorted  (a::r) = true
      <->
      (is_list_sorted r = true
       /\ match r with
          | nil => True
          | y::_ => R a y
          end).
    Proof.
      simpl; destruct r; intuition;
        destruct (R_dec a a0); intuition congruence.
    Qed.

    Lemma is_list_sorted_cons_inv {a r} :
      is_list_sorted (a::r) = true ->
      is_list_sorted r = true.
    Proof.
      rewrite is_list_sorted_cons. intuition.
    Qed.

    Lemma StronglySorted_cons_in {x a l} :
      StronglySorted R (a::l) ->
      In x l ->
      R a x.
    Proof.
      inversion 1; subst; intros iin.
      rewrite Forall_forall in H3.
      auto.
    Qed.

    Lemma insertion_sort_sorted_is_id l :
      is_list_sorted l = true ->
      insertion_sort l = l.
    Proof.
      induction l; intros; simpl in *.
      reflexivity.
      assert (is_list_sorted l = true).
      destruct l; simpl in *; try reflexivity.
      destruct (R_dec a a0); congruence.
      specialize (IHl H0).
      rewrite IHl; clear IHl.
      destruct l; simpl in *; try reflexivity.
      revert H.
      destruct (R_dec a a0); intros; trivial.
      destruct (R_dec a0 a); congruence.
    Qed.

    Lemma insertion_sort_idempotent l :
      insertion_sort (insertion_sort l) =
      insertion_sort l.
    Proof.
      apply insertion_sort_sorted_is_id.
      apply is_list_sorted_Sorted_iff.
      apply insertion_sort_Sorted.
    Qed.

    Lemma insertion_sort_insert_not_nil a l :
      insertion_sort_insert a l <> nil.
    Proof.
      induction l; simpl; intuition; try discriminate.
      destruct (R_dec a a0); simpl in *; try discriminate.
      destruct (R_dec a0 a); simpl in *; try discriminate.
    Qed.

    Lemma insertion_sort_nil l :
      insertion_sort l = nil -> l = nil.
    Proof.
      induction l; simpl; intuition.
      apply insertion_sort_insert_not_nil in H; intuition.
    Qed.

    Lemma insertion_sort_insert_swap a a0 l  `{StrictOrder A R}:
      R a a0 ->
      insertion_sort_insert a (insertion_sort_insert a0 l) =
      insertion_sort_insert a0 (insertion_sort_insert a l).
    Proof.
      revert a a0.
      induction l; simpl; intros.
      - destruct (R_dec a a0); simpl; intuition.
        destruct (R_dec a0 a); simpl; intuition.
        rewrite r0 in r. eelim irreflexivity; eauto.
      - destruct (R_dec a1 a).
        + destruct (R_dec a0 a).
          * simpl.
            destruct (R_dec a0 a1); intuition.
            destruct (R_dec a1 a); intuition.
            destruct (R_dec a1 a0); intuition.
            rewrite r3 in H0; eelim irreflexivity; eauto.
          * rewrite r in H0; intuition.
        + destruct (R_dec a0 a); simpl.
          * destruct (R_dec a1 a); intuition.
            destruct (R_dec a0 a1); intuition.
            destruct (R_dec a1 a0).
            rewrite r1 in r0; eelim irreflexivity; eauto.
            destruct (R_dec a a1); simpl;
              destruct (R_dec a0 a); intuition.
          * destruct (R_dec a a1); destruct (R_dec a a0); simpl.
            destruct (R_dec a0 a).
            rewrite r1 in r0; eelim irreflexivity; eauto.
            destruct (R_dec a a0); intuition.
            destruct (R_dec a1 a).
            rewrite r2 in r; eelim irreflexivity; eauto.
            destruct (R_dec a a1); intuition.
            f_equal; eauto.
            destruct (R_dec a a0); intuition.
            destruct (R_dec a1 a).
            rewrite r0 in r; eelim irreflexivity; eauto.
            destruct (R_dec a0 a); intuition.
            destruct (R_dec a a1); intuition.
            rewrite H0 in r; intuition.
            destruct (R_dec a0 a); intuition.
            destruct (R_dec a a0); intuition.
            destruct (R_dec a1 a); intuition.
            destruct (R_dec a a1); intuition.
    Qed.

  End InsertionSort.

  (** * Properties of [filter] on sorted lists *)

  Section Filter.
    Lemma StronglySorted_filter {A} {R} f {l} :
      @StronglySorted A R l -> StronglySorted R (filter f l).
    Proof.
      induction l; simpl; trivial.
      inversion 1; simpl; subst.
      destruct (f a); auto.
      constructor; auto.
      apply Forall_filter; trivial.
    Qed.
  End Filter.

  (** * Properties of [In] on sorted lists *)

  Section In.
    Lemma in_insertion_sort_insert {A R R_dec} {x l a} :
      In x (@insertion_sort_insert A R R_dec a l) -> a = x \/ In x l.
    Proof.
      revert x a. induction l; simpl; [intuition | ].
      intros x a0.
      case_eq (R_dec a0 a); simpl; intros; trivial.
      revert H0.
      case_eq (R_dec a a0); simpl; intros; intuition.
      destruct (IHl _ _ H2); intuition.
    Qed.

    Lemma in_insertion_sort {A R R_dec} {x l} :
      In x (@insertion_sort A R R_dec l) -> In x l.
    Proof.
      induction l; simpl; trivial.
      intros inn. apply in_insertion_sort_insert in inn.
      intuition.
    Qed.

    Hint Resolve asymmetric_over_cons_inv : list.
    Lemma insertion_sort_insert_in_strong {A R R_dec} {x l a}
          (contr:asymmetric_over R (a::l)) :
      a = x \/ In x l -> In x (@insertion_sort_insert A R R_dec a l).
    Proof.
      revert x a contr. induction l; simpl; [intuition | ].
      intros x a0.
      case_eq (R_dec a0 a); simpl; intros; trivial.
      revert H0.
      case_eq (R_dec a a0); simpl; intros; intuition; subst; intuition.
      - right; apply (IHl x x); intuition.
        apply asymmetric_over_swap in contr. eauto with list.
      - right. apply (IHl x a0); intuition.
        apply asymmetric_over_swap in contr. eauto with list.
    Qed.

    Lemma insertion_sort_insert_in {A R R_dec} {x l a}
          (contr:forall x y,  ~R x y -> ~R y x -> x = y) :
      a = x \/ In x l -> In x (@insertion_sort_insert A R R_dec a l).
    Proof.
      apply insertion_sort_insert_in_strong.
      apply asymmetric_asymmetric_over; eauto.
    Qed.

    Lemma insertion_sort_in_strong {A R R_dec} {x l}
          (contr:asymmetric_over R l) :
      In x l -> In x (@insertion_sort A R R_dec l).
    Proof.
      revert x.
      induction l; simpl; trivial; intros.
      specialize (IHl (asymmetric_over_cons_inv contr)).
      apply insertion_sort_insert_in_strong; trivial.
      - apply (asymmetric_over_incl contr). clear. simpl; intuition.
        apply in_insertion_sort in H0; eauto.
      - intuition.
    Qed.

    Hint Resolve asymmetric_asymmetric_over : list.

    Lemma insertion_sort_in {A R R_dec} {x l}
          (contr:forall x y,  ~R x y -> ~R y x -> x = y) :
      In x l -> In x (@insertion_sort A R R_dec l).
    Proof.
      apply insertion_sort_in_strong; intuition.
    Qed.

    Lemma equivlist_insertion_sort_strong {A R} R_dec {l l'}
          (contr:asymmetric_over R l)  :
      equivlist l l' ->
      equivlist (@insertion_sort A R R_dec l) (@insertion_sort A R R_dec l').
    Proof.
      cut (forall l l', (asymmetric_over R l) -> equivlist l l' ->
                        (forall x, In x (@insertion_sort A R R_dec l) -> In x (@insertion_sort A R R_dec l'))).
      - intros C eq x. split; intros inn.
        + specialize (C _ _ contr eq); intuition.
        + eapply C; try eapply inn.
          rewrite <- (asymmetric_over_equivlist eq); trivial.
          symmetry; trivial.
      - clear l l' contr. intros l l' asym incl x inn.
        apply in_insertion_sort in inn. apply incl in inn.
        apply insertion_sort_in_strong; trivial.
        eapply asymmetric_over_equivlist; eauto.
        symmetry. trivial.
    Qed.

    Lemma equivlist_insertion_sort {A R} R_dec {l l'}
          (contr:forall x y,  ~R x y -> ~R y x -> x = y)  :
      equivlist l l' ->
      equivlist (@insertion_sort A R R_dec l) (@insertion_sort A R R_dec l').
    Proof.
      intros.
      eapply equivlist_insertion_sort_strong; trivial.
      apply asymmetric_asymmetric_over; trivial.
    Qed.

    Lemma insertion_sort_insert_insertion_nin  {A:Type} lt dec
          `{StrictOrder A lt}
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a})
          (a:A) a0 l :
      ~ lt a0 a ->
      ~ lt a a0 ->
      insertion_sort_insert dec a0
                            (insertion_sort_insert dec a l)
      = @insertion_sort_insert A lt dec a l.
    Proof.
      revert a a0. induction l; simpl; intros.
      - repeat (match_destr; try congruence).
      - repeat (match_destr; try congruence);
          simpl; repeat (match_destr; try congruence); trivial.
        + rewrite l0 in l1. intuition.
        + rewrite IHl; trivial.
        + destruct (trich a a0) as [[?|?]|?];
            try congruence.
        + destruct (trich a a0) as [[?|?]|?];
            try congruence.
    Qed.

    Lemma insertion_sort_insert_cons_app {A:Type} lt dec
          `{StrictOrder A lt}
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a}) a l l2 :
      insertion_sort dec (insertion_sort_insert dec a l ++ l2) = @insertion_sort A lt dec (a::l ++ l2).
    Proof.
      revert a l2.
      induction l; simpl; trivial; intros.
      destruct (dec a0 a); simpl; trivial.
      destruct (dec a a0); simpl; trivial.
      - rewrite IHl; simpl. apply insertion_sort_insert_swap; eauto.
      - rewrite insertion_sort_insert_insertion_nin; eauto.
    Qed.

    Lemma insertion_sort_insertion_sort_app1 {A} lt dec `{StrictOrder A lt}
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a}) l1 l2 :
      insertion_sort dec (insertion_sort dec l1 ++ l2) =
      @insertion_sort A lt dec (l1 ++ l2).
    Proof.
      revert l2.
      induction l1; simpl; trivial; intros.
      rewrite insertion_sort_insert_cons_app; trivial.
      simpl.
      rewrite IHl1; trivial.
    Qed.

    Lemma insertion_sort_trich_equiv {A:Type} lt dec
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a}) (l:list A)
      : equivlist (@insertion_sort A lt dec l) l.
    Proof.
      intros; split; intros.
      - apply in_insertion_sort in H; trivial.
      - eapply insertion_sort_in in H; eauto.
        intros.
        destruct (trich x0 y) as [[?|?]|?]; intuition.
    Qed.

    Lemma insertion_sort_insert_forall_lt
          {A:Type} lt dec (a:A) (l:list A) :
      Forall (lt a) l ->
      @insertion_sort_insert A lt dec a l = a :: l.
    Proof.
      destruct l; simpl; trivial.
      inversion 1; subst.
      match_destr; intuition.
    Qed.

    Lemma sort_insert_filter_true {A:Type} f lt dec `{StrictOrder A lt}
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a})
          (a:A) (l:list A) :
      StronglySorted lt l ->
      f a = true ->
      filter f (@insertion_sort_insert A lt dec a l)
      = insertion_sort_insert dec a (filter f l).
    Proof.
      revert a.
      induction l; simpl; intros b lsort fb.
      - rewrite fb; trivial.
      - inversion lsort; subst.
        case_eq (f a); simpl; intros fa.
        +  destruct (dec b a); simpl.
           * rewrite fb.
             simpl. match_destr.
           * rewrite <- IHl; trivial.
             match_destr; simpl; rewrite fa; trivial.
        + match_destr.
          * simpl. rewrite fb, fa.
            rewrite insertion_sort_insert_forall_lt; trivial.
            apply Forall_filter.
            revert H3.
            apply Forall_impl_in; intros.
            etransitivity; eauto.
          * rewrite <- IHl; trivial.
            match_destr; simpl; rewrite fa; trivial.
            destruct (trich a b) as [[?|?]|?]; try congruence.
    Qed.

    Lemma sort_insert_filter_false {A:Type} f lt dec (a:A) (l:list A) :
      f a = false ->
      filter f (@insertion_sort_insert A lt dec a l) =
      filter f l.
    Proof.
      revert a.
      induction l; simpl; intros ? fa.
      - rewrite fa; trivial.
      - match_destr; simpl.
        + rewrite fa; trivial.
        + match_destr; simpl.
          rewrite IHl; trivial.
    Qed.

    Lemma sort_filter_commute {A:Type} f lt dec
          `{StrictOrder A lt}
          (trich:forall a b, {lt a b} + {eq a b} + {lt b a})
          (l:list A) :
      filter f (@insertion_sort A lt dec l)
      = insertion_sort dec (filter f l).
    Proof.
      induction l; simpl; trivial.
      case_eq (f a); intros fa; simpl.
      - rewrite <- IHl, sort_insert_filter_true; trivial.
        eapply Sorted_StronglySorted.
        + apply StrictOrder_Transitive.
        + eapply insertion_sort_Sorted.
      - rewrite <- IHl, sort_insert_filter_false; trivial.
    Qed.

    Lemma Forall_insertion_sort {A R R_dec} {P} l :
      Forall P l -> Forall P (@insertion_sort A R R_dec l).
    Proof.
      repeat rewrite Forall_forall.
      intros fp x inx.
      apply in_insertion_sort in inx.
      auto.
    Qed.

  End In.

  (** * Properties of [map] on sorted lists *)

  Section Map.

    Lemma map_insertion_sort_insert {A B}
          {R1 R2}
          (R1_dec : forall a a' : A, {R1 a a'} + {~ R1 a a'})
          (R2_dec : forall b b' : B, {R2 b b'} + {~ R2 b b'})
          (f:A->B)
          (consistent:forall x y, R1 x y <->
                                  R2 (f x) (f y)) a l :
      map f (insertion_sort_insert R1_dec a l) =
      insertion_sort_insert R2_dec (f a) (map f l).
    Proof.
      induction l; simpl; trivial.
      rewrite <- IHl.
      destruct (consistent a a0); destruct (consistent a0 a).
      repeat match_destr; simpl; try tauto.
    Qed.

    Lemma map_insertion_sort {A B}
          {R1 R2}
          (R1_dec : forall a a' : A, {R1 a a'} + {~ R1 a a'})
          (R2_dec : forall b b' : B, {R2 b b'} + {~ R2 b b'})
          (f:A->B)
          (consistent:forall x y, R1 x y <->
                                  R2 (f x) (f y)) l :
      map f (insertion_sort R1_dec l) =
      insertion_sort R2_dec (map f l).
    Proof.
      induction l; simpl; trivial.
      rewrite <- IHl.
      erewrite map_insertion_sort_insert; eauto.
    Qed.

  End Map.

  Lemma insertion_sort_insert_nin_eq_inv {A R} dec (a:A) l₁ l₂ :
    insertion_sort_insert (R:=R) dec a l₁ = insertion_sort_insert dec a l₂ ->
    ~ In a l₁ ->
    ~ In a l₂ ->
    l₁ = l₂.
  Proof.
    revert l₂.
    induction l₁; destruct l₂; simpl; intros eqq; trivial.
    - intuition.
      destruct (dec a a0); simpl in *.
      + invcs eqq.
      + destruct (dec a0 a); invcs eqq; tauto.
    - intuition.
      destruct (dec a a0); simpl in *.
      + invcs eqq.
      + destruct (dec a0 a); invcs eqq; tauto.
    - intuition.
      destruct (dec a a0); simpl in *.
      + invcs eqq.
        destruct (dec a a1); simpl.
        * invcs H4; trivial.
        * destruct (dec a1 a); invcs H4; tauto.
      + destruct (dec a0 a).
        * destruct (dec a a1); invcs eqq; try tauto.
          destruct (dec a1 a); invcs H4; try tauto.
          f_equal; eauto.
        * { destruct (dec a a1).
            - invcs eqq; tauto.
            - destruct (dec a1 a); invcs eqq; try tauto.
          }
  Qed.
End SortingAdd.


Lemma LP1P2P3P4P5P6 : forall P1 P2 P3 P4 P5 P6 ,
rk(P1 :: P2 :: P3 ::  nil) = 2 -> rk(P1 :: P2 :: P3 :: P4 ::  nil) = 3 -> rk(P3 :: P4 :: P5 ::  nil) = 2 ->
rk(P1 :: P4 :: P6 ::  nil) = 2 -> rk(P2 :: P5 :: P6 ::  nil) = 2 -> rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 ::  nil) = 3.
Proof.

intros P1 P2 P3 P4 P5 P6
HP1P2P3eq HP1P2P3P4eq HP3P4P5eq HP1P4P6eq HP2P5P6eq .

assert(HP1P2P3P4P6M3 : rk(P1 :: P2 :: P3 :: P4 :: P6 :: nil) <= 3).
{
	try assert(HP1P2P3eq : rk(P1 :: P2 :: P3 :: nil) = 2) by (apply LP1P2P3 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3Mtmp : rk(P1 :: P2 :: P3 :: nil) <= 2) by (solve_hyps_max HP1P2P3eq HP1P2P3M2).
	try assert(HP1P4P6eq : rk(P1 :: P4 :: P6 :: nil) = 2) by (apply LP1P4P6 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P4P6Mtmp : rk(P1 :: P4 :: P6 :: nil) <= 2) by (solve_hyps_max HP1P4P6eq HP1P4P6M2).
	try assert(HP1eq : rk(P1 :: nil) = 1) by (apply LP1 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1mtmp : rk(P1 :: nil) >= 1) by (solve_hyps_min HP1eq HP1m1).
	assert(Hincl : incl (P1 :: nil) (list_inter (P1 :: P2 :: P3 :: nil) (P1 :: P4 :: P6 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P1 :: P2 :: P3 :: P4 :: P6 :: nil) (P1 :: P2 :: P3 :: P1 :: P4 :: P6 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P1 :: P2 :: P3 :: P1 :: P4 :: P6 :: nil) ((P1 :: P2 :: P3 :: nil) ++ (P1 :: P4 :: P6 :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (P1 :: P2 :: P3 :: nil) (P1 :: P4 :: P6 :: nil) (P1 :: nil) 2 2 1 HP1P2P3Mtmp HP1P4P6Mtmp HP1mtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}
try clear HP1P4P6M1. try clear HP1P4P6M2. try clear HP1P4P6M3. try clear HP1P4P6m4. try clear HP1P4P6m3. try clear HP1P4P6m2. try clear HP1P4P6m1. try clear HP1M1. try clear HP1M2. try clear HP1M3. try clear HP1m4. try clear HP1m3. try clear HP1m2. try clear HP1m1.

assert(HP1P2P3P4P6m2 : rk(P1 :: P2 :: P3 :: P4 :: P6 :: nil) >= 2).
{
	try assert(HP1P2P3eq : rk(P1 :: P2 :: P3 :: nil) = 2) by (apply LP1P2P3 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3mtmp : rk(P1 :: P2 :: P3 :: nil) >= 2) by (solve_hyps_min HP1P2P3eq HP1P2P3m2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (P1 :: P2 :: P3 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (P1 :: P2 :: P3 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil) 2 2 HP1P2P3mtmp Hcomp Hincl);apply HT.
}

assert(HP1P2P3P4P6m3 : rk(P1 :: P2 :: P3 :: P4 :: P6 :: nil) >= 3).
{
	try assert(HP1P2P3P4eq : rk(P1 :: P2 :: P3 :: P4 :: nil) = 3) by (apply LP1P2P3P4 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3P4mtmp : rk(P1 :: P2 :: P3 :: P4 :: nil) >= 3) by (solve_hyps_min HP1P2P3P4eq HP1P2P3P4m3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (P1 :: P2 :: P3 :: P4 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (P1 :: P2 :: P3 :: P4 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil) 3 3 HP1P2P3P4mtmp Hcomp Hincl);apply HT.
}

assert(HP3P4m2 : rk(P3 :: P4 :: nil) >= 2).
{
	try assert(HP1P2P3eq : rk(P1 :: P2 :: P3 :: nil) = 2) by (apply LP1P2P3 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3Mtmp : rk(P1 :: P2 :: P3 :: nil) <= 2) by (solve_hyps_max HP1P2P3eq HP1P2P3M2).
	try assert(HP1P2P3P4eq : rk(P1 :: P2 :: P3 :: P4 :: nil) = 3) by (apply LP1P2P3P4 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3P4mtmp : rk(P1 :: P2 :: P3 :: P4 :: nil) >= 3) by (solve_hyps_min HP1P2P3P4eq HP1P2P3P4m3).
	try assert(HP3eq : rk(P3 :: nil) = 1) by (apply LP3 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP3mtmp : rk(P3 :: nil) >= 1) by (solve_hyps_min HP3eq HP3m1).
	assert(Hincl : incl (P3 :: nil) (list_inter (P1 :: P2 :: P3 :: nil) (P3 :: P4 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P1 :: P2 :: P3 :: P4 :: nil) (P1 :: P2 :: P3 :: P3 :: P4 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P1 :: P2 :: P3 :: P3 :: P4 :: nil) ((P1 :: P2 :: P3 :: nil) ++ (P3 :: P4 :: nil))) by (clear_all_rk;my_inO).
	try rewrite HT1 in HP1P2P3P4mtmp;try rewrite HT2 in HP1P2P3P4mtmp.
	assert(HT := rule_4 (P1 :: P2 :: P3 :: nil) (P3 :: P4 :: nil) (P3 :: nil) 3 1 2 HP1P2P3P4mtmp HP3mtmp HP1P2P3Mtmp Hincl); apply HT.
}
try clear HP3M1. try clear HP3M2. try clear HP3M3. try clear HP3m4. try clear HP3m3. try clear HP3m2. try clear HP3m1.

assert(HP1P2P3P4P5P6m2 : rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) >= 2).
{
	try assert(HP1P2P3eq : rk(P1 :: P2 :: P3 :: nil) = 2) by (apply LP1P2P3 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3mtmp : rk(P1 :: P2 :: P3 :: nil) >= 2) by (solve_hyps_min HP1P2P3eq HP1P2P3m2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (P1 :: P2 :: P3 :: nil) (P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (P1 :: P2 :: P3 :: nil) (P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) 2 2 HP1P2P3mtmp Hcomp Hincl);apply HT.
}
try clear HP1P2P3M1. try clear HP1P2P3M2. try clear HP1P2P3M3. try clear HP1P2P3m4. try clear HP1P2P3m3. try clear HP1P2P3m2. try clear HP1P2P3m1.

assert(HP1P2P3P4P5P6m3 : rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) >= 3).
{
	try assert(HP1P2P3P4eq : rk(P1 :: P2 :: P3 :: P4 :: nil) = 3) by (apply LP1P2P3P4 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3P4mtmp : rk(P1 :: P2 :: P3 :: P4 :: nil) >= 3) by (solve_hyps_min HP1P2P3P4eq HP1P2P3P4m3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (P1 :: P2 :: P3 :: P4 :: nil) (P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (P1 :: P2 :: P3 :: P4 :: nil) (P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) 3 3 HP1P2P3P4mtmp Hcomp Hincl);apply HT.
}
try clear HP1P2P3P4M1. try clear HP1P2P3P4M2. try clear HP1P2P3P4M3. try clear HP1P2P3P4m4. try clear HP1P2P3P4m3. try clear HP1P2P3P4m2. try clear HP1P2P3P4m1.

assert(HP1P2P3P4P5P6M3 : rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) <= 3).
{
	try assert(HP3P4P5eq : rk(P3 :: P4 :: P5 :: nil) = 2) by (apply LP3P4P5 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP3P4P5Mtmp : rk(P3 :: P4 :: P5 :: nil) <= 2) by (solve_hyps_max HP3P4P5eq HP3P4P5M2).
	try assert(HP1P2P3P4P6eq : rk(P1 :: P2 :: P3 :: P4 :: P6 :: nil) = 3) by (apply LP1P2P3P4P6 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP1P2P3P4P6Mtmp : rk(P1 :: P2 :: P3 :: P4 :: P6 :: nil) <= 3) by (solve_hyps_max HP1P2P3P4P6eq HP1P2P3P4P6M3).
	try assert(HP3P4eq : rk(P3 :: P4 :: nil) = 2) by (apply LP3P4 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) ;try assumption).
	assert(HP3P4mtmp : rk(P3 :: P4 :: nil) >= 2) by (solve_hyps_min HP3P4eq HP3P4m2).
	assert(Hincl : incl (P3 :: P4 :: nil) (list_inter (P3 :: P4 :: P5 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: nil) (P3 :: P4 :: P5 :: P1 :: P2 :: P3 :: P4 :: P6 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P3 :: P4 :: P5 :: P1 :: P2 :: P3 :: P4 :: P6 :: nil) ((P3 :: P4 :: P5 :: nil) ++ (P1 :: P2 :: P3 :: P4 :: P6 :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (P3 :: P4 :: P5 :: nil) (P1 :: P2 :: P3 :: P4 :: P6 :: nil) (P3 :: P4 :: nil) 2 3 2 HP3P4P5Mtmp HP1P2P3P4P6Mtmp HP3P4mtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}
try clear HP3P4P5M1. try clear HP3P4P5M2. try clear HP3P4P5M3. try clear HP3P4P5m4. try clear HP3P4P5m3. try clear HP3P4P5m2. try clear HP3P4P5m1. try clear HP1P2P3P4P6M1. try clear HP1P2P3P4P6M2. try clear HP1P2P3P4P6M3. try clear HP1P2P3P4P6m4. try clear HP1P2P3P4P6m3. try clear HP1P2P3P4P6m2. try clear HP1P2P3P4P6m1. try clear HP3P4M1. try clear HP3P4M2. try clear HP3P4M3. try clear HP3P4m4. try clear HP3P4m3. try clear HP3P4m2. try clear HP3P4m1.

assert(HP1P2P3P4P5P6M : rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 ::  nil) <= 4) by (apply rk_upper_dim).
assert(HP1P2P3P4P5P6m : rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 ::  nil) >= 1) by (solve_hyps_min HP1P2P3P4P5P6eq HP1P2P3P4P5P6m1).
intuition.
Qed.