Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.
Require Import RL.hr.invertibility.
Require Import RL.hr.M_elim.
Require Import RL.hr.hr_perm_lemmas.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** L is the list (((r_i, s_i), (r'_i, s'_i)), T_i) *)

Lemma hrr_atomic_can_elim_gen : forall L n,
    Forall_inf (fun x => sum_vec (fst (fst (fst x))) - sum_vec (snd (fst (fst x))) = sum_vec (fst (snd (fst x))) - sum_vec (snd (snd (fst x)))) L ->
    HR_T (map (fun x => (vec (fst (fst (fst x))) (RS_covar n) ++ vec (snd (fst (fst x))) (RS_var n) ++ snd x)) L) ->
    HR_T (map (fun x => (vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x)) L).
Proof.
  intros L n H.
  remember (map (fun x => (vec (fst (fst (fst x))) (RS_covar n) ++ vec (snd (fst (fst x))) (RS_var n) ++ snd x)) L) as G.
  assert (Allperm G (map (fun x => (vec (fst (fst (fst x))) (RS_covar n) ++ vec (snd (fst (fst x))) (RS_var n) ++ snd x)) L)) by (rewrite <- HeqG; clear; induction G; try now constructor).
  clear HeqG.
  intro pi; revert L H X; induction pi; intros L Hsum Hperm.
  - destruct L; [ | destruct L]; inversion Hperm; try inversion X0; subst.
    apply Permutation_Type_nil in X; destruct p as [[[s1 r1] [s2 r2]] T1]; destruct s1; destruct r1; destruct T1; inversion X; simpl.
    apply hrr_ID.
    { inversion Hsum; simpl in *.
      nra. }
    apply hrr_INIT.
  - destruct L; inversion Hperm; subst.
    simpl.
    apply hrr_W.
    apply IHpi.
    + inversion Hsum; assumption.
    + assumption.
  - destruct L; inversion Hperm; subst.
    simpl.
    apply hrr_C; try assumption.
    change ((vec (fst (snd (fst p))) (RS_covar n) ++ vec (snd (snd (fst p))) (RS_var n) ++ snd p)
              :: (vec (fst (snd (fst p))) (RS_covar n) ++ vec (snd (snd (fst p))) (RS_var n) ++ snd p)
              :: map
              (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x)
              L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x)
           (p :: p :: L)).
    apply IHpi.
    + inversion Hsum.
      repeat (apply Forall_inf_cons); assumption.
    + simpl.
      do 2 (apply Forall2_inf_cons; try assumption).
  - destruct L; [ | destruct L]; inversion Hperm; try inversion X0; subst.
    destruct p as [[[p1 p2] [p3 p4]] p5];
      destruct p0 as [[[p1' p2'] [p3' p4']] p5'];
      simpl in *;
      remember ((((p1 ++ p1'), (p2 ++ p2')) , ((p3 ++ p3') , (p4 ++ p4'))), (p5 ++ p5')) as p'';
      apply hrr_S;
      (apply hrr_ex_seq with (vec (fst (snd (fst p''))) (RS_covar n) ++ vec (snd (snd (fst p''))) (RS_var n) ++snd p'') ; [ rewrite Heqp''; simpl; rewrite ? vec_app; Permutation_Type_solve | ]);
      change ((vec (fst (snd (fst p''))) (RS_covar n) ++ vec (snd (snd (fst p''))) (RS_var n) ++snd p'') :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) (L))
        with (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) (p'' :: L));
      (apply IHpi ;
       [ subst;
           inversion Hsum; inversion X3;
           repeat (try apply Forall_inf_cons);
           try assumption;
           simpl in *;
           rewrite ? sum_vec_app;
           nra | ]);
      simpl; apply Forall2_inf_cons;
           [ rewrite Heqp'';simpl; rewrite ? vec_app ; Permutation_Type_solve |  assumption].
  - inversion f.
  - destruct L; inversion Hperm; subst.
    simpl.
    apply hrr_T with r; try assumption.
    destruct p as ([[r1 r2] [s1 s2]] , T'); simpl in *.
    apply hrr_ex_seq with (vec (mul_vec r s1) (RS_covar n) ++ vec (mul_vec r s2) (RS_var n) ++ seq_mul r T').
    { rewrite <- ? seq_mul_vec_mul_vec.
      rewrite ? seq_mul_app.
      reflexivity. }
    change ((vec (mul_vec r s1) (RS_covar n) ++ vec (mul_vec r s2) (RS_var n) ++ seq_mul r T') :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((((mul_vec r r1, mul_vec r r2) , (mul_vec r s1 , mul_vec r s2)), seq_mul r T') :: L)).
    apply IHpi.
    + subst; inversion Hsum; subst; simpl in *.
      apply Forall_inf_cons ; try assumption; simpl.
      rewrite ? mul_vec_sum_vec; nra.
    + simpl.
      apply Forall2_inf_cons; [ | try assumption].
      rewrite <- ? seq_mul_vec_mul_vec; rewrite <- ? seq_mul_app.
      apply seq_mul_perm; assumption.
  - destruct L; inversion Hperm; subst.
    simpl.
    case (term.V_eq n n0); [intros Heqn | intros Hneqn].
    + subst.
      destruct p as [[[s1 r1] [s1' r1']] T1]; simpl in *.
      destruct (perm_decomp_vec_eq_2 T T1 r1 s1 r s (RS_var n0) (RS_covar n0)) as [[[[[[[[a1 b1] c1] a2] b2] c2] T'] D'] [H1' [[[[[H2' H3'] H4'] H5'] H6']]]]; [ now auto | apply X | ].
      apply hrr_ex_seq with (vec (c2 ++ s1') (RS_covar n0) ++ vec (c1 ++ r1') (RS_var n0) ++ T').
      { rewrite ? vec_app.
        transitivity (vec s1' (RS_covar n0) ++ vec r1' (RS_var n0) ++ (vec c2 (RS_covar n0) ++ vec c1 (RS_var n0) ++ T')); try Permutation_Type_solve. }
      change ((vec (c2 ++ s1') (RS_covar n0) ++ vec (c1 ++ r1') (RS_var n0) ++ T')
                :: map
                (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                   vec (fst (snd (fst x))) (RS_covar n0) ++ vec (snd (snd (fst x))) (RS_var n0) ++ snd x)
                L)
        with
          (map (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                   vec (fst (snd (fst x))) (RS_covar n0) ++ vec (snd (snd (fst x))) (RS_var n0) ++ snd x)
               ((((a2,a1),(c2 ++ s1', c1 ++ r1')), T')::L)).
      apply IHpi.
      * inversion Hsum; simpl in*.
        apply Forall_inf_cons ; [ | try assumption].
        simpl; rewrite ? sum_vec_app.
        transitivity (sum_vec c2 + sum_vec s1 - (sum_vec c1 + sum_vec r1)); try nra.
        replace (sum_vec s1) with (sum_vec (a2 ++ b2)).
        2:{ apply sum_vec_perm; Permutation_Type_solve. }
        replace (sum_vec r1) with (sum_vec (a1 ++ b1)) by (apply sum_vec_perm; Permutation_Type_solve).
        rewrite ? sum_vec_app.
        replace (sum_vec r) with (sum_vec (b1 ++ c1)) in e by (apply sum_vec_perm; Permutation_Type_solve).
        replace (sum_vec s) with (sum_vec (b2 ++ c2)) in e by (apply sum_vec_perm; Permutation_Type_solve).
        rewrite ? sum_vec_app in e.
        nra.
      * simpl; apply Forall2_inf_cons; [ | try assumption].
        Permutation_Type_solve.
    + destruct p as [[[s1 r1] [s1' r1']] T1]; simpl in *.
      subst.
      destruct (perm_decomp_vec_neq_2_2 T T1 r s r1 s1 (RS_covar n0) (RS_var n0) (RS_covar n) (RS_var n)) as [[T' D'] [H1' [H2' H3']]]; try (intros H; inversion H; apply Hneqn; auto); try apply X.
      apply hrr_ex_seq with (vec s (RS_covar n0) ++ vec r (RS_var n0) ++ vec s1' (RS_covar n) ++ vec r1' (RS_var n) ++ T').
      { Permutation_Type_solve. }
      apply hrr_ID; try assumption.
      change ((vec s1' (RS_covar n) ++ vec r1' (RS_var n) ++ T')
                :: map
                (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                   vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x)
                L)
        with
          (map
             (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x)
             ((((s1,r1),(s1',r1')),T')::L)).
      apply IHpi.
      * inversion Hsum.
        apply Forall_inf_cons ; [ | try assumption].
        simpl in *; nra.
      * simpl; apply Forall2_inf_cons; [ | try assumption].
        Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    simpl.
    destruct p as [r1 T1]; simpl in *.
    assert (RS_zero <> RS_covar n) as Hnc by now auto.
    assert (RS_zero <> RS_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_neq_2 _ _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r RS_zero ++ vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db).
    { etransitivity; [ apply Permutation_Type_app_comm | ].
      rewrite <- ? app_assoc.
      repeat (try apply Permutation_Type_app; try reflexivity).
      etransitivity; [ apply Permutation_Type_app_comm | ].
      etransitivity ; [ | symmetry; apply H1'].
      apply Permutation_Type_app; Permutation_Type_solve. }
    apply hrr_Z; try assumption.
    change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, Db) :: L)).
    apply IHpi.
    + inversion Hsum.
      apply Forall_inf_cons; simpl in *; try assumption.
    + simpl.
      apply Forall2_inf_cons; [ | assumption].
      Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    simpl.
    destruct p as [r1 T1]; simpl in *.
    assert (A +S B <> RS_covar n) as Hnc by now auto.
    assert (A +S B <> RS_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_neq_2 _ _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r (A +S B) ++ vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db).
    { etransitivity ; [ apply Permutation_Type_app_comm | ]; rewrite <- ? app_assoc; repeat (try apply Permutation_Type_app; try reflexivity).
      etransitivity ; [ | symmetry; apply H1' ].
      etransitivity ; [ apply Permutation_Type_app_comm | ].
      Permutation_Type_solve. }
    apply hrr_plus; try assumption.
    apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ vec r B ++ Db); [ Permutation_Type_solve | ].
    change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ vec r B ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, vec r A ++ vec r B ++ Db) :: L)).
    apply IHpi.
    + inversion Hsum.
      apply Forall_inf_cons; simpl in *; try assumption.
    + simpl.
      apply Forall2_inf_cons; [ | assumption].
      Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    simpl.
    destruct p as [r1 T1]; simpl in *.
    assert (r0 *S A <> RS_covar n) as Hnc by now auto.
    assert (r0 *S A <> RS_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_neq_2 _ _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r (r0 *S A) ++ vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db).
    { etransitivity ; [ apply Permutation_Type_app_comm | ]; rewrite <- ? app_assoc; repeat (try apply Permutation_Type_app; try reflexivity).
      etransitivity ; [ | symmetry; apply H1' ].
      etransitivity ; [ apply Permutation_Type_app_comm | ].
      Permutation_Type_solve. }
    apply hrr_mul; try assumption.
    apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec (mul_vec r0 r) A ++ Db).
    { Permutation_Type_solve. }
    change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec (mul_vec r0 r) A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, vec (mul_vec r0 r) A ++ Db) :: L)).
    apply IHpi.
    + inversion Hsum.
      apply Forall_inf_cons; simpl in *; try assumption.
    +  simpl.
       apply Forall2_inf_cons; [ | assumption].
       Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    simpl.
    destruct p as [r1 T1]; simpl in *.
    assert (A \/S B <> RS_covar n) as Hnc by now auto.
    assert (A \/S B <> RS_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_neq_2 _ _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r (A \/S B) ++ vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db).
    { etransitivity ; [ apply Permutation_Type_app_comm | ]; rewrite <- ? app_assoc; repeat (try apply Permutation_Type_app; try reflexivity).
      etransitivity ; [ | symmetry; apply H1' ].
      etransitivity ; [ apply Permutation_Type_app_comm | ].
      Permutation_Type_solve. }
    apply hrr_max; try assumption.
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ Db).
    { Permutation_Type_solve. }
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r B ++  Db).
    { Permutation_Type_solve. }
    change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r B ++ Db) :: (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, vec r B ++ Db) :: (r1, vec r A ++ Db) :: L)).
    apply IHpi.
    + inversion Hsum.
      repeat (try apply Forall_inf_cons); simpl in *; try assumption.
    + simpl.
      apply Forall2_inf_cons; [ | apply Forall2_inf_cons ; [ | assumption] ]; Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    simpl.
    destruct p as [r1 T1]; simpl in *.
    assert (A /\S B <> RS_covar n) as Hnc by now auto.
    assert (A /\S B <> RS_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_neq_2 _ _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r (A /\S B) ++ vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ Db).
    { etransitivity ; [ apply Permutation_Type_app_comm | ]; rewrite <- ? app_assoc; repeat (try apply Permutation_Type_app; try reflexivity).
      etransitivity ; [ | symmetry; apply H1' ].
      etransitivity ; [ apply Permutation_Type_app_comm | ].
      Permutation_Type_solve. }
    apply hrr_min; try assumption.
    + apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ Db).
      { Permutation_Type_solve. }
      change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
        with
          (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, vec r A ++ Db) :: L)).
      apply IHpi1.
      * inversion Hsum.
        repeat (try apply Forall_inf_cons); simpl in *; try assumption.
      * simpl.
        apply Forall2_inf_cons; [ | assumption]; Permutation_Type_solve.
    + apply hrr_ex_seq with (vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r B ++ Db).
      { Permutation_Type_solve. }
      change ((vec (fst (snd r1)) (RS_covar n) ++ vec (snd (snd r1)) (RS_var n) ++ vec r B ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L)
        with
          (map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ((r1, vec r B ++ Db) :: L)).
      apply IHpi2.
      * inversion Hsum.
        repeat (try apply Forall_inf_cons); simpl in *; try assumption.
      * simpl.
        apply Forall2_inf_cons; [ | try assumption]; Permutation_Type_solve.
  - destruct L; inversion Hperm; subst.
    apply IHpi; try assumption.
    simpl; apply Forall2_inf_cons; try assumption.
    transitivity T2; assumption.
  - destruct (Permutation_Type_Forall2_inf (Permutation_Type_sym p) Hperm).
    destruct (Permutation_Type_map_inv _ _ (Permutation_Type_sym p0)) as [L' Heq Hperm1].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_map; symmetry; apply Hperm1 | ].
    apply IHpi; [ | rewrite Heq in f; apply f].
    clear - Hperm1 Hsum.
    revert Hsum; induction Hperm1; intros Hsum.
    + apply Forall_inf_nil.
    + inversion Hsum; subst.
      apply Forall_inf_cons; [ | apply IHHperm1];try assumption.
    + inversion Hsum; inversion X; subst.
      apply Forall_inf_cons ; [ | apply Forall_inf_cons]; try assumption.
    + apply IHHperm1_2; apply IHHperm1_1; apply Hsum.
  - inversion f.
Qed.

Lemma hrr_atomic_can_elim : forall G T n r s,
    sum_vec r = sum_vec s ->
    HR_T ((vec s (RS_covar n) ++ vec r (RS_var n) ++ T) :: G) ->
    HR_T (T :: G).
Proof.
  intros G T n r s Heq pi.
  assert ({ L & prod
                  ( G = map (fun x  => vec (fst (fst (fst x))) (RS_covar n) ++ vec (snd (fst (fst x))) (RS_var n) ++ snd x) L)
                  (( G =  map (fun x  => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L) *
                   (Forall_inf
                      (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) => sum_vec (fst (fst (fst x))) - sum_vec (snd (fst (fst x))) = sum_vec (fst (snd (fst x))) - sum_vec (snd (snd (fst x))))  L))}) as [L [H1 [H2 H3]]].
  { clear - G ; induction G.
    - split with nil; repeat split; try reflexivity.
      apply Forall_inf_nil.
    - destruct IHG as [ L [ H1 [H2 H3]] ].
      split with ((((nil,nil),(nil,nil)), a) :: L).
      repeat split; simpl; [rewrite H1 | rewrite H2 | ]; try reflexivity.
      apply Forall_inf_cons; try assumption.
      simpl; nra. }
  rewrite H2.
  change (T :: map (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) L) with
      (map (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) => vec (fst (snd (fst x))) (RS_covar n) ++ vec (snd (snd (fst x))) (RS_var n) ++ snd x) ( (((s , r) , (nil, nil)) , T) :: L)).
  apply hrr_atomic_can_elim_gen.
  - simpl; apply Forall_inf_cons; try assumption; simpl; nra.
  - simpl; rewrite <- H1.
    apply pi.
Qed.

Lemma hrr_can_2 : forall G T A r s,
    sum_vec r = sum_vec s ->
    HR_T ((vec s (-S A) ++ vec r A ++ T) :: G) ->
    HR_T (T :: G).
Proof.
  intros G T A; revert G T; induction A; intros G T r1 s1 Heq pi.
  - apply hrr_atomic_can_elim with v r1 s1; try assumption.
  - apply hrr_atomic_can_elim with v s1 r1; try nra.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_M_elim.
    apply hrr_Z_inv with r1.
    apply hrr_Z_inv with s1.
    apply HR_le_frag with (hr_frag_T); auto.
    repeat split.
  - apply (IHA1 G T r1 s1 Heq).
    apply (IHA2 G (vec s1 (-S A1) ++ vec r1 A1 ++ T) r1 s1 Heq).
    apply hrr_M_elim.
    apply hrr_ex_seq with (vec r1 A1 ++ vec r1 A2 ++ vec s1 (-S A2) ++ vec s1 (-S A1) ++ T); [ Permutation_Type_solve | ].
    apply hrr_plus_inv.
    apply hrr_ex_seq with (vec s1 (-S A1) ++ vec s1 (-S A2) ++ vec r1 (A1 +S A2) ++ T); [ Permutation_Type_solve | ].
    apply hrr_plus_inv.
    apply HR_le_frag with hr_frag_T; try assumption.
    repeat split.
  - apply (IHA G T (mul_vec r r1) (mul_vec r s1)).
    { rewrite ? mul_vec_sum_vec; nra. }
    apply hrr_M_elim.
    apply hrr_mul_inv.
    apply hrr_ex_seq with (vec (mul_vec r r1) A ++ vec s1 (r *S (-S A)) ++ T) ; [ Permutation_Type_solve | ].
    apply hrr_mul_inv.
    apply HR_le_frag with hr_frag_T; try (repeat split).
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_C; try reflexivity.
    apply (IHA2 (T :: G) T r1 s1 Heq).
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply (IHA1 ((vec s1 (-S A2) ++ vec r1 A2 ++ T) :: G) T r1 s1 Heq).
    apply hrr_M_elim.
    apply hrr_min_inv_l with (-S A2).
    apply hrr_ex_seq with (vec r1 A1 ++ vec s1 (-S (A1 \/S A2)) ++ T); [Permutation_Type_solve | ].
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply hrr_min_inv_r with (-S A1).
    apply hrr_ex_seq with (vec r1 A2 ++ vec s1 (-S (A1 \/S A2)) ++ T); [Permutation_Type_solve | ].
    apply hrr_max_inv.
    apply HR_le_frag with hr_frag_T; try (repeat split).
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_C; try reflexivity.
    apply (IHA2 (T :: G) T r1 s1 Heq).
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply (IHA1 ((vec s1 (-S A2) ++ vec r1 A2 ++ T) :: G) T r1 s1 Heq).
    apply hrr_M_elim.
    apply hrr_ex_seq with (vec r1 A1 ++ vec s1 (-S A1) ++ T); [ Permutation_Type_solve | ].
    apply hrr_min_inv_l with A2.
    apply hrr_ex_seq with (vec s1 (-S A1) ++ vec r1 (A1 /\S A2) ++ T); [Permutation_Type_solve | ].
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply hrr_ex_seq with (vec r1 A2 ++ vec s1 (-S A2) ++ T); [ Permutation_Type_solve | ].
    apply hrr_min_inv_r with A1.
    apply hrr_ex_seq with (vec s1 (-S A2) ++ vec r1 (A1 /\S A2) ++ T); [Permutation_Type_solve | ].
    apply hrr_max_inv.
    apply HR_le_frag with hr_frag_T; try (repeat split).
    apply pi.
Qed.

Lemma hrr_can_elim : forall G,
    HR_full G ->
    HR_T_M G.
Proof.
  intros G pi; induction pi; try now constructor.
  - now apply hrr_T with r.
  - now apply hrr_ex_seq with T1.
  - now apply hrr_ex_hseq with G.
  - apply HR_le_frag with hr_frag_T; try repeat split.
    apply hrr_can_2 with A r s; try assumption.
    apply hrr_M_elim.
    apply IHpi.
Qed.


Require Import FOL Peano Tarski Deduction CantorPairing NumberTheory Synthetic Formulas DecidabilityFacts Church Coding.
Require Import Lia.
Require Import Equations.Equations Equations.Prop.DepElim.

Import Vector.VectorNotations.

Notation "x 'el' A" := (List.In x A) (at level 70).
Notation "A '<<=' B" := (List.incl A B) (at level 70).
Notation "x ∣ y" := (exists k, x * k = y) (at level 50).

Section Model.

  Context {Δ1 : Delta1}.

  Variable D : Type.
  Variable I : interp D.
  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).
  Variable axioms : forall ax, PA ax -> ⊨ ax.

  Notation "N⊨ phi" := (forall rho, @sat _ _ nat interp_nat _ rho phi) (at level 40).
  Notation "x 'i⧀' y" := (exists d : D, y = iσ (x i⊕ d) ) (at level 40).

  (* We also assume the existence of a formula which represents the prime number function *)
  Variable ψ : form.
  Variable Hψ : bounded 2 ψ /\ (forall x, Q ⊢I ∀ ψ[up (num x)..] <--> $0 == num (Irred x) ).

  Definition div e d := exists k : D, e i⊗ k = d.
  Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
  Definition Div_nat (d : D) := fun n => div_num n d.
  Definition div_pi n a :=  (inu n .: (fun _ => a)) ⊨ (∃ (ψ ∧ ∃ $1 ⊗ $0 == $3)).

  Variable surj_form_ : { Φ : nat -> form & surj Φ }.
  Variable enumerable_Q_prv : forall Φ : nat -> form, enumerable (fun n => Q ⊢I (Φ n)).

  Definition Φ := projT1 surj_form_.
  Definition surj_form := projT2 (surj_form_).
  Definition A n := Q ⊢I ¬(Φ n)[(num n)..].
  Definition B n := Q ⊢I (Φ n)[(num n)..].

  Lemma Disjoint_AB : forall n, ~(A n /\ B n).
  Proof.
    unfold A, B. intros n [A_n B_n].
    apply Q_consistent.
    eapply IE; eauto.
  Qed.

  (** Recursively inseparable predicates.  *)

  Definition Insep' :=
    exists A B : nat -> Prop,
      enumerable A /\ enumerable B /\
      (forall n, ~ (A n /\ B n) ) /\
      (forall D, Dec D ->
        (forall n, A n -> D n) ->
        (forall n, ~ (B n /\ D n)) -> False).

  Definition Insep :=
    exists α β,
      bounded 3 α /\ inhabited(delta1 α) /\ bounded 3 β /\ inhabited(delta1 β) /\
      (forall n, ~ Q ⊢I ((∃∃α) ∧ (∃∃β))[(num n)..] ) /\
      (forall G, Dec G -> (forall n, Q ⊢I (∃∃α)[(num n)..] -> G n) ->
        (forall n, ~ (Q ⊢I (∃∃β)[(num n)..] /\ G n)) -> False).

  Lemma Insep_ :
    RT_strong -> Insep'.
  Proof.
    intros rt.
    exists A, B. repeat split; auto.
    1,2 : apply enumerable_Q_prv.
    { apply Disjoint_AB. }
    intros G Dec_G.
    destruct (rt G Dec_G) as [γ [? [? []]]],
      (surj_form (∃ γ)) as [c Hc].
    rewrite <-Hc in *.
    unfold A, B in *; fold Φ in *.
    intros ? ?%(fun h => h c).
    enough (~ G c); auto.
  Qed.

  Lemma CT_Inseparable :
    CT_Q -> Insep.
  Proof.
    intros ct.
    destruct (Insep_ (CT_RTs ct)) as (A & B & HA & HB & disj & H).
    destruct ((CT_RTw ct) A HA) as [α (Ha0 & [Ha1] & Hα)],
            ((CT_RTw ct) B HB) as [β (Hb0 & [Hb1] & Hβ)].
    exists α, β. do 4 (split; auto).
    repeat split; auto; unfold weak_repr in *.
    - intros n h%soundness. apply (disj n).
      rewrite Hα, Hβ.
      split; apply sigma1_ternary_complete; auto.
      all: intros rho; specialize (h _ interp_nat rho);
            apply h; apply Q_std_axioms.
    - setoid_rewrite <-Hα.
      setoid_rewrite <-Hβ.
      apply H.
  Qed.

  Lemma WInsep_ :
    WRT_strong -> Insep'.
  Proof.
    intros wrt.
    exists A, B. repeat split; auto.
    1,2 : apply enumerable_Q_prv.
    { apply Disjoint_AB. }
    intros G Dec_G.
    intros H.
    apply (DN_remove (wrt G Dec_G)).
    intros [γ [? [? []]]].
    destruct (surj_form (∃ γ)) as [c Hc].
    rewrite <-Hc in *.
    unfold A, B in *; fold Φ in *.
    intros ?%(fun h => h c).
    enough (~ G c); auto.
  Qed.

  Lemma WCT_Inseparable :
    WCT_Q -> ~~ Insep.
  Proof.
    intros wct.
    destruct (WInsep_ (WCT_WRTs wct)) as (A & B & HA & HB & disj & H).
    apply (DN_chaining ((WCT_WRTw wct) B HB)), (DN_chaining ((WCT_WRTw wct) A HA)), DN.
    intros [α (Ha0 & [Ha1] & Hα)] [β (Hb0 & [Hb1] & Hβ)].
    exists α, β. do 4 (split; auto).
    repeat split; unfold weak_repr in *.
    - intros n h%soundness. apply (disj n).
      rewrite Hα, Hβ.
      split; apply sigma1_ternary_complete; auto.
      all: intros rho; specialize (h _ interp_nat rho);
            apply h; apply Q_std_axioms.
    - setoid_rewrite <-Hα.
      setoid_rewrite <-Hβ.
      apply H.
  Qed.

  Lemma delta1_ternary_definite phi :
    delta1 phi -> bounded 3 phi -> ⊨ ∀∀∀ phi ∨ ¬ phi.
  Proof.
    intros d0 b3.
    intros rho. cbn. intros ???.
    specialize (delta1_HA phi d0) as d0'.
    refine (let H := tsoundness d0' _  in _).
    apply H. intros ??.
    now apply axioms.
  Qed.

  Lemma LEM_bounded_exist_ternary' phi :
    (⊨ ∀∀∀ phi ∨ ¬ phi) -> bounded 3 phi -> ⊨ ∀∀∀ (∃ $0 ⧀ $3 ∧ phi) ∨ ¬ (∃ $0 ⧀ $3 ∧ phi).
  Proof.
    intros def b3.
    pose (Phi := ∀∀ (∃ $0 ⧀ $3 ∧ phi) ∨ ¬ (∃ $0 ⧀ $3 ∧ phi)).
    assert (H : forall d rho, (d.:rho) ⊨ Phi).
    apply induction.
    - apply axioms.
    - repeat solve_bounds.
      eapply bounded_up. apply b3. lia.
      eapply bounded_up. apply b3. lia.
    - intros rho y. cbn. right.
      now intros (? & ?%nolessthen_zero & ?).
    - intros n IHN rho y x. cbn.
      destruct (IHN rho y x) as [IH|IH]; fold sat in *; cbn in IH.
      + left. destruct IH as [d Hd]. exists d. split.
        ++ destruct Hd as [[k ->] _]. exists (iσ k).
          now rewrite add_rec_r.
        ++ eapply bound_ext. apply b3.
          2 : apply Hd.
          intros [|[|[]]]; solve_bounds.
      + destruct (def (fun _ => i0) y x n) as [HN|HN]; fold sat in *.
        ++ left. exists n. split.
          exists i0. now rewrite add_zero_r.
          eapply bound_ext. apply b3.
          2 : apply HN.
          intros [|[|[]]]; solve_bounds.
        ++ right. intros H. apply IH.
          destruct H as (k & Hk1%lt_S & Hk2 ).
          exists k. split.
          destruct Hk1 as [| ->]. assumption.
          exfalso. apply HN.
          eapply bound_ext. apply b3.
          2 : apply Hk2.
          intros [|[|[]]]; solve_bounds.
          eapply bound_ext. apply b3.
          2 : apply Hk2.
          intros [|[|[]]]; solve_bounds.
          apply axioms.
      - intros rho y. apply H.
  Qed.

  Lemma LEM_bounded_exist_ternary {phi} sigma :
    delta1 phi -> bounded 3 phi -> forall b x, (x .: b .: sigma) ⊨ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ phi) \/ ~ (x .: b .: sigma) ⊨ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ phi).
  Proof.
    intros d0 b3 b y.
    unshelve refine (let D' := LEM_bounded_exist_ternary' (∃ $0 ⧀ $3 ∧ phi) _ _ in _); auto.
    - apply LEM_bounded_exist_ternary'; auto.
      now apply delta1_ternary_definite.
    - repeat solve_bounds. eapply bounded_up; eauto.
    - specialize (D' sigma b b y); fold sat in *.
      destruct D' as [H|nH].
      + left. cbn in H. destruct H as [x1 [H1 [x2 [H2 H]]]].
        exists x1, x2. cbn. repeat split; try tauto.
        eapply bound_ext. 3 : apply H. eauto.
        intros [|[|[]]]; solve_bounds.
      + right; cbn. intros (x1 & x2 & H). apply nH; fold sat; cbn.
        exists x1. split; try tauto.
        exists x2. split; try tauto.
        eapply bound_ext. 3 : apply H. eauto.
        intros [|[|[]]]; solve_bounds.
  Qed.

  (** Potential existence of undecidable predicates. *)

  Lemma nonDecDiv :
    Insep -> Stable std -> nonStd D -> ~ ~ exists d : D, ~ Dec (fun n => div_pi n d).
  Proof.
    intros (α & β & Ha1 & [Ha0] & Hb1 & [Hb0] & Disj & Insepa) Stab [d Hd].
    pose (phi := (∀ $0 ⧀ $1 --> ∀ $0 ⧀ $2 --> ∀ $0 ⧀ $3 --> ∀ $0 ⧀ $4 --> ∀ $0 ⧀ $5 --> ¬ (α[$3..][$1..] ∧ β[$5..][$3..]) ) ).
    enough (forall n rho, ((inu n).:rho) ⊨ phi ) as H.
    eapply Overspill_DN in H; eauto.
    - refine (DN_chaining (Coding_nonstd_binary_Definite _ _ _ _ _ _ _ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ α) _ _) _); eauto.
    {apply nonStd_notStd. now exists d. }
    { repeat solve_bounds.
      eapply bounded_up; eauto; lia. }
    { intros b u.
      specialize (LEM_bounded_exist_ternary (fun _ => i0) Ha0 Ha1 b (inu u)) as [h|h].
      - left. intros ?. eapply bound_ext with (N := 2).
        3 : apply h.
        repeat solve_bounds. eapply bounded_up; eauto.
        intros [|[]]; try reflexivity; lia.
      - right. intros nh. apply h.
        eapply bound_ext with (N := 2).
        3 : apply nh.
        repeat solve_bounds. eapply bounded_up; eauto.
        intros [|[]]; try reflexivity; lia.
    }
    apply (DN_chaining H).
    apply DN. clear H.
    intros [e [? He]] [c Hc]%(fun h => h e).
    exists c. intros Dec_div_c.
    eapply (Insepa _ Dec_div_c).
    + intros n A_n. unfold Div_nat.
      specialize (Hc n (fun _ => e)) as [Hc _].
      cbn in Hc. destruct Hc as [ d' [H1 H2] ].
      * assert (N⊨ (∃∃α)[(num n)..]) as A_n'.
        { intros rho. eapply soundness.
          - apply A_n.
          - apply Q_std_axioms.
        }
        apply sigma1_ternary_complete' in A_n'; auto.
        destruct A_n' as (a & b & Hab).
        exists (inu a), (inu b). repeat split; [apply num_lt_nonStd; auto|apply num_lt_nonStd; auto| ].
        apply soundness in Hab.
        specialize (Hab D I (fun _ => i0)). rewrite !sat_comp in Hab.
        eapply bound_ext. apply Ha1. 2: apply Hab.
        intros [|[|[]]] ?; cbn; try now rewrite ?num_subst, ?eval_num; try lia.
        intros ??. apply axioms. now constructor.
      * exists d'. split.
        eapply bound_ext. apply Hψ. 2: apply H1.
        intros [|[]]; try reflexivity; try lia.
        cbn. apply H2.
    + intros n [B_n C_n].
      assert (N⊨ (∃∃β)[(num n)..]) as B_n'.
      { intros rho. eapply soundness.
        - apply B_n.
        - apply Q_std_axioms.
      }
      apply sigma1_ternary_complete' in B_n'; auto.
      destruct B_n' as (a & b & Hab).
      apply soundness in Hab.
      assert ((fun _ => e) ⊨ (∃∃ $0 ⧀ $2 ∧ $1 ⧀ $2 ∧ β[up (up (num n)..)] )) as Heβ.
      { cbn. exists (inu a), (inu b). repeat split; [apply num_lt_nonStd; auto|apply num_lt_nonStd; auto| ].
        specialize (Hab D I (fun _ => i0)). rewrite !sat_comp in Hab.
        rewrite sat_comp.
        eapply bound_ext. apply Hb1. 2: apply Hab.
        intros [|[|[]]] ?; cbn; try now rewrite ?num_subst, ?eval_num; try lia.
        intros ??. apply axioms. now constructor. }
      specialize (Hc n (fun _ => e)) as [_ Hc].
      destruct Hc as (k1 & k2 & [Hk2 Hk1] & Hk12); fold sat in *.
      * destruct C_n as [d' Hd']. exists d'. split.
        eapply bound_ext. apply Hψ. 2 : apply Hd'.
        intros [|[]]; solve_bounds.
        apply Hd'.
      * cbn in Heβ, Hk12, Hk1, Hk2. destruct Heβ as (k3 & k4 & [Hk4 Hk3] & Hk34).
        rewrite sat_comp in Hk34.
        eapply He; fold sat; cbn.
        apply Hk4.
        apply Hk3.
        apply Hk2.
        apply Hk1.
        apply num_lt_nonStd with (n:=n); auto.
        rewrite !sat_comp.
        split.
        **  eapply bound_ext.
            apply Ha1. 2: apply Hk12.
            intros [|[|[]]] ?; try reflexivity; try lia.
        **  eapply bound_ext.
            apply Hb1. 2: apply Hk34.
            intros [|[|[]]] ?; cbn; try reflexivity; try lia.
            now rewrite !num_subst, eval_num.
        Unshelve. exact (fun _ => i0).
    - repeat solve_bounds.
      eapply subst_bound with (N:=4).
      eapply subst_bound with (N:=4). eapply bounded_up; eauto.
      intros [|[|[|[|[]]]]]; solve_bounds.
      intros [|[|[|[|[]]]]]; solve_bounds.
      eapply subst_bound with (N:=6).
      eapply subst_bound with (N:=6). eapply bounded_up; eauto.
      intros [|[|[|[|[|[]]]]]]; solve_bounds.
      intros [|[|[|[|[|[]]]]]]; solve_bounds.
    - apply nonStd_notStd. now exists d.
    - intros n rho. cbn.
      intros d4 H4 d3 H3 d2 H2 d1 H1 d0 H0 [H31 H53].
      apply lessthen_num in H4; auto.
      apply lessthen_num in H3; auto.
      apply lessthen_num in H2; auto.
      apply lessthen_num in H1; auto.
      apply lessthen_num in H0; auto.
      destruct H4 as (k4 & H4 & ->).
      destruct H3 as (k3 & H3 & ->).
      destruct H2 as (k2 & H2 & ->).
      destruct H1 as (k1 & H1 & ->).
      destruct H0 as (k0 & H0 & ->).
      apply (Disj k0).
      change (Q ⊢I ((∃∃ α)[(num k0)..] ∧ (∃∃ β)[(num k0)..])).
      apply CI.
      + apply sigma1_ternary_complete; auto.
        intros sigma. rewrite <-switch_num in H31.
        exists k1, k2.
        assert ((inu k1 .: inu k2 .: inu k3 .: inu k4 .: inu n .: rho) ⊨ α[up (up (num k0)..)][(num k2)..][(num k1)..]).
        eapply bound_ext with (N:=0).
        eapply subst_bound with (N:=1).
        eapply subst_bound with (N:=2).
        eapply subst_bound with (N:=3); auto.
        intros [|[|[|[]]]]; cbn; solve_bounds.
        rewrite ?num_subst. apply closed_num.
        intros [|[|[]]]; cbn; solve_bounds.
        apply closed_num.
        intros [|[]]; cbn; solve_bounds.
        apply closed_num.
        lia.
        rewrite !sat_comp. rewrite !sat_comp in H31.
        eapply bound_ext. apply Ha1. 2 : apply H31.
        intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num; try reflexivity; try lia.
        eapply delta1_absolutness' in H.
        rewrite !switch_nat_num in H.
        apply H.
        * eapply subst_bound with (N:=1).
          eapply subst_bound with (N:=2).
          eapply subst_bound; eauto.
          intros[|[|[]]]; cbn; solve_bounds.
          rewrite !num_subst. apply closed_num.
          intros[|[]]; cbn; solve_bounds. apply closed_num.
          intros[]; cbn; solve_bounds. apply closed_num.
        * rewrite !subst_comp. now apply delta1_subst.
        * apply axioms.
        * intros ??. now apply PA_std_axioms.
      + apply sigma1_ternary_complete; auto.
        intros sigma. rewrite <-switch_num in H53.
        exists k3, k4.
        assert ((inu k1 .: inu k2 .: inu k3 .: inu k4 .: inu n .: rho) ⊨ β[up (up (num k0)..)][(num k4)..][(num k3)..]).
        eapply bound_ext with (N:=0).
        eapply subst_bound with (N:=1).
        eapply subst_bound with (N:=2).
        eapply subst_bound with (N:=3); auto.
        intros [|[|[|[]]]]; cbn; solve_bounds.
        rewrite ?num_subst. apply closed_num.
        intros [|[|[]]]; cbn; solve_bounds.
        apply closed_num.
        intros [|[]]; cbn; solve_bounds.
        apply closed_num.
        lia.
        rewrite !sat_comp. rewrite !sat_comp in H53.
        eapply bound_ext. apply Hb1. 2 : apply H53.
        intros [|[|[]]]; cbn; rewrite ?num_subst, ?eval_num; try reflexivity; try lia.
        eapply delta1_absolutness' in H.
        rewrite !switch_nat_num in H.
        apply H.
        * eapply subst_bound with (N:=1).
          eapply subst_bound with (N:=2).
          eapply subst_bound; eauto.
          intros[|[|[]]]; cbn; solve_bounds.
          rewrite !num_subst. apply closed_num.
          intros[|[]]; cbn; solve_bounds. apply closed_num.
          intros[]; cbn; solve_bounds. apply closed_num.
        * rewrite !subst_comp. now apply delta1_subst.
        * apply axioms.
        * intros ??. now apply PA_std_axioms.
    Unshelve. all: auto.
  Qed.

End Model.


Require Import ListSet.
Require Import Ascii.

Parameter nonce: Type.
Parameter bytes: Type.
Parameter hostname: Type.
Parameter key: Type.

Inductive event: Type :=
    | MsgRequest: hostname -> hostname -> bytes -> (nat * nat)%type -> event
    | MsgResponse: hostname -> hostname -> bytes -> bytes -> event
    | ChallengeRequest: hostname -> hostname -> bytes -> nonce -> event
    | ChallengeReply: hostname -> hostname -> nonce -> event
    | Corrupted: hostname -> event.

Definition log := set event.
Definition asn := log -> Prop.

Axiom Level_Low : forall A, A -> asn.
Arguments Level_Low [_] a.

Definition Logged (e: event) (L: log): Prop := set_In e L.

Definition isEvent (e: event): asn :=
    fun L => Logged e L.

Definition RecvMsg (a b: hostname) (pc_b index_b: nat) (msg: bytes): asn :=
    fun L => Logged (MsgRequest a b msg (pc_b, index_b)) L \/ Logged (Corrupted b) L.

Inductive Sig: Type -> Type :=
(* Assertions *)
| Assume: asn -> Sig unit
| Assert: asn -> Sig unit
(* Cryptographic operations *)
| MAC: forall A, key -> A -> Sig bytes
| Verify: forall A, key -> A -> bytes -> Sig unit
| Fresh_key: hostname -> hostname -> Sig key
(* Protocol operations *)
| Fresh_nonce: hostname -> Sig nat
| Verify_nonce: nonce -> nonce -> Sig unit
| Incr_PC: hostname -> Sig nat
| Modify_PC_index: hostname -> set nat -> hostname -> (nat * nat)%type -> Sig unit
| Fresh_index: hostname -> Sig nat
| Verify_PC_index: hostname -> (nat * nat)%type -> set nat -> Sig bool
(* Network I/O *)
| Send: forall A, hostname -> A -> Sig unit
| Receive: forall A, Sig A.

Arguments MAC [_] k a.
Arguments Verify [_] k a b.
Arguments Send [_] h msg.

Inductive M (X: Type) :=
    | ret: X -> M X
    | op: forall O, Sig O -> (O -> M X) -> M X.

Arguments ret [_] v.
Arguments op [_] [_] s k.

Notation "'assume!' a" := (op (Assume a) (@ret _)) (at level 10).
Notation "'assert!' a" := (op (Assert a) (@ret _)) (at level 10).
Notation "'mac!' k m" := (op (MAC k m) (@ret _)) (at level 10, k,m at next level).
Notation "'verify!' k v m" := (op (Verify k v m) (@ret _)) (at level 10, k,v,m at next level).
Notation "'fresh_key!' a b" := (op (Fresh_key a b) (@ret _)) (at level 10, a, b at next level).
Notation "'fresh_nonce!' h" := (op (Fresh_nonce h) (@ret _)) (at level 10, h at next level).
Notation "'verify_nonce!' n0 n" := (op (Verify_nonce n0 n) (@ret _)) (at level 10, n0,n at next level).
Notation "'incr_pc!' h" := (op (Incr_PC h) (@ret _)) (at level 10, h at next level).
Notation "'fresh_index!' h" := (op (Fresh_index h) (@ret _)) (at level 10, h at next level).
Notation "'verify_pc_index! h inds t" := (op (Verify_PC_index h inds t) (@ret _)) (at level 10, h,inds,t at next level).
Notation "'send!' a m" := (op (Send a m) (@ret _)) (at level 10, a, m at next level).
Notation "'receive!' T" := (op (Receive T) (@ret _)) (at level 10, T at next level).

Fixpoint bind {X Y} (m: M X) (mf: X -> M Y): M Y :=
    match m with
    | ret v => mf v
    | op s k => op s (fun o => bind (k o) mf)
    end.

Notation "'let!' x := c1 'in' c2" := (@bind _ _ c1 (fun x => c2))
    (at level 61, x pattern, c1 at next level, right associativity).

Notation "e1 ;; e2" := (@bind _ _ e1 (fun _ => e2))
    (at level 61, right associativity).

Inductive messageMac := Msg (msg: bytes) (index pc: nat).
Inductive challengeReplyMAC := ChallReply (msg: bytes) (index pc: nat).

Parameter TagChallengeRequest: ascii.
Parameter TagChallengeReply: ascii.

Definition client (a b: hostname) (k: key) (index pc: nat) (msg: bytes): M unit :=
    let! mac := mac! k (Msg msg index pc) in
    send! a (msg, index, pc, mac) ;;
    incr_pc! b ;;
    let! (tagChallReq, n) := receive! (ascii * nat) in
    let! index' := fresh_index! b in
    let! mac := mac! k (ChallReply index' pc) in
    send! a (TagChallengeReply, msg, n, index', pc, mac).

Definition server (a b: hostname) (k: key) (t: set nat): M unit :=
    let! (msg, mac) := receive! (bytes * bytes) in
    verifiy! k (Msg msg index pc) mac ;;
    if verify_pc_index! a (index, pc) t then (
        modify_pc_index! a t b (index, pc)
    ) else (
        let! n0 := fresh_nonce! a in
        send! b (TagChallengeRequest, n0) ;;
        let! (tagChallReply, msg, n, index, pc, mac) :=
            receive! (ascii * bytes * nonce * nat * nat * bytes) in
        verify! k (ChallReply index' pc) mac ;;
        verify_nonce! n0 n ;;
        modify_pc_index! a t b (index', pc)
    ).


Require Import Notations.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FinFun.
Require Import Coq.Program.Basics.
Require Import Cand.
Require Import Keys.
Import ListNotations.
Open Scope Z.

Notation "'existsT' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'") : type_scope.

(* https://stackoverflow.com/questions/8869678/polymorphic-type-inside-a-module-ocaml *)
(* The reason for moving these abstract types is precisly the reason explaned in above link *)
Module Type Abstype.

  (* Ciphertext is abstract type *)
  Parameter ciphertext : Type.

  (* Pedersan's commitment for a given permutation *)
  Parameter Commitment : Type.

  (* Permutation Zero Knowledge Proof. *)
  Parameter PermZkp : Type.

  (* Randomeness added during the commitment computation *)
  Parameter S : Type.

  (* Randomeness needed for shuffling the row/column *)
  Parameter R : Type.

  (* Zero knowledge proof of Shuffle *)
  Parameter ShuffleZkp : Type.

  (* Honest Decryption Zero knowledge Proof *)
  Parameter DecZkp : Type.

End Abstype.

(* This module type is interface for all the data, and functions. The axioms about
   these functions are assumed in CAxioms module *)
Module Type Crypto (Import C : Cand) (Import K : Keys) (Import Abst : Abstype).

  (* Plain text is integer. *)
  Definition plaintext := Z.

  (* ballot is plain text value *)
  Definition pballot := cand -> cand -> plaintext.

  (* eballot is encrypted value *)
  Definition eballot := cand -> cand -> ciphertext.

  Definition Group := (Prime * Generator * Pubkey)%type.

  (* Construct a instance of group *)
  Let grp := (prime, gen, publickey).

  (* This function encrypts the message. It will be instantiated
     by Crypto library function. In our case, Unicrypt library functions *)
  Parameter encrypt_message :
    Group ->  plaintext -> ciphertext.

  (* This function decrypts the message *)
  Parameter decrypt_message :
    Group -> Prikey -> ciphertext -> plaintext.

  (* This function returns zero knowledge proof of encrypted message (c1, c2) *)
  Parameter construct_zero_knowledge_decryption_proof :
    Group -> Prikey -> ciphertext -> DecZkp.

  (* This function verifies the zero knowledge proof of plaintext, m, is honest decryption
     of ciphertext *)
  Parameter verify_zero_knowledge_decryption_proof :
    Group -> plaintext -> ciphertext -> DecZkp -> bool.

  (* permutation is Bijective function *)
  Definition Permutation := existsT (pi : cand -> cand), (Bijective pi).

  (* The idea is for each ballot u, we are going to count
       we generate pi, cpi, and zkpcpi. We call row permute function
       u and pi and it returns v. Then We call column permutation
       on v and pi and it returns w. We decryp w as b with zero knowledge
       proof. *)

  (* We call a java function which returns permutation. Basically java function returns
       array which is converted back to function in OCaml land *)
  Parameter generatePermutation :
    Group -> (* group *)
    nat -> (* length  *)
    list cand -> (* cand_all *)
    Permutation.

  (* Generate randomness used in permutation commitment.
       Tuple s = pcs.getRandomizeSpace().getrandomElement() *)
  Parameter generateS : Group -> nat -> S.

  (* Pass the permutation and randomness, it returns commitment. The S used here
     will be used in zero knowledge proof *)
  Parameter generatePermutationCommitment :
    Group -> (* group *)
    nat -> (* length *)
    list cand -> (* cand_all *)
    Permutation -> (* pi *)
    S -> (*randomness *)
    Commitment. (* cpi *)

  (* This function takes Permutation Commitment and S and returns ZKP *)
  Parameter zkpPermutationCommitment :
    Group -> (* group *)
    nat -> (* length *)
    list cand -> (* cand_all *)
    Permutation -> (* pi *)
    Commitment -> (* cpi *)
    S -> (* randomness *)
    PermZkp.

  Parameter verify_permutation_commitment :
    Group -> (* group *)
    nat -> (* length *)
    Commitment -> (* cpi *)
    PermZkp -> (* zero knowledge proof *)
    bool. (* pcps.verify offlineProof offlinePublicInpu *)

  Parameter homomorphic_addition :
    Group -> ciphertext -> ciphertext -> ciphertext.

  (* Start of Shuffle code *)
  (* Generate Randomness R by passing group and length of candidate list*)
  Parameter generateR : Group -> nat -> R.

  (* We need List.length cand_all because mixer object is created using
     elGamal, publickey and n *)
  Parameter shuffle :
    Group -> (* group *)
    nat -> (* Length of list cand *)
    list cand -> (* cand_all because we need to convert function into list *)
    (forall n m : cand, {n = m} + {n <> m}) -> (* This is need because we want to construct the ballot *)
    (cand -> ciphertext) -> (* ciphertext *)
    Permutation -> (* pi *)
    R -> (* Randomness R *)
    (cand -> ciphertext).

  (* Construct zero knowledge proof from original and shuffled ballot *)
  (* Each row of ballot is represented by function *)
  Parameter shuffle_zkp :
    Group -> (* group *)
    nat -> (* length *)
    list cand -> (* cand_all *)
    (cand -> ciphertext) -> (* cipertext *)
    (cand -> ciphertext) -> (* shuffle cipertext *)
    Permutation -> (* pi *)
    Commitment -> (* cpi *)
    S -> (* s, permutation commitment randomness *)
    R -> (* r, shuffle randomness *)
    ShuffleZkp. (* zero knowledge proof of shuffle *)

  (* verify shuffle. This function checks the claim about a shuffled ciphertext is
       shuffling of a given ciphertext by a permutation whose commitment is given *)
  Parameter verify_shuffle:
    Group -> (* group *)
    nat -> (* length *)
    list cand ->
    (cand -> ciphertext) -> (* cipertext *)
    (cand -> ciphertext) -> (* shuffled cipertext *)
    Commitment -> (* permutation commitment *)
    ShuffleZkp -> (* zero knowledge proof of shuffle *)
    bool. (* true or false *)

End Crypto.

(* The reason for separating the Axioms from functions is that these axioms
   no longer need to instantiate for extraction *)
Module CAxioms  (Import C : Cand) (Import K : Keys) (Import Abst : Abstype)
       (Import Crp : Crypto C K Abst).

  (* Relation between Public and Private key. This axiom enforces that
       publickey and privatekey are generated in pair according to
       key generation protocol.  *)
  Axiom Keypair : Pubkey -> Prikey -> Prop.

  (* Coherence Axiom that states that publickey and privatekey are related *)
  Axiom keypair : Keypair publickey privatekey.

  (* Coherence axiom about honest decryption zero knowledge proof *)
  Axiom verify_honest_decryption_zkp :
    forall (pt : plaintext) (ct : ciphertext)
      (H : pt = decrypt_message Crp.grp privatekey ct),
      verify_zero_knowledge_decryption_proof
        Crp.grp pt ct
        (construct_zero_knowledge_decryption_proof Crp.grp privatekey ct) = true.

  (* Decryption is left inverse, and we can only decrypt when the keys are
     related  *)
  Axiom decryption_deterministic :
    forall (pt : plaintext),
      decrypt_message Crp.grp privatekey (encrypt_message Crp.grp pt) = pt.

  Axiom permutation_commitment_axiom :
    forall (pi : Permutation) (cpi : Commitment) (s : S) (zkppermcommit : PermZkp)
      (H1 : cpi = generatePermutationCommitment Crp.grp (List.length cand_all) cand_all pi s)
      (H2 : zkppermcommit = zkpPermutationCommitment
                              Crp.grp (List.length cand_all) cand_all pi cpi s),
      verify_permutation_commitment Crp.grp (List.length cand_all)
                                    cpi zkppermcommit = true.

  (* Property of Homomorphic addition *)
  Axiom homomorphic_addition_axiom :
    forall (c d : ciphertext),
      decrypt_message Crp.grp privatekey (homomorphic_addition Crp.grp c d) =
      decrypt_message Crp.grp privatekey c + decrypt_message Crp.grp privatekey d.

   (* Coherence Axiom about shuffle. If every thing is
       followed according to protocol then verify_shuffle function
       returns true *)
  Axiom verify_shuffle_axiom :
    forall (pi : Permutation) (cpi : Commitment) (s : S)
      (cp shuffledcp : cand -> ciphertext)
      (r : R) (zkprowshuffle : ShuffleZkp)
      (H1 : cpi = generatePermutationCommitment Crp.grp (List.length cand_all) cand_all pi s)
      (H2 : shuffledcp = shuffle Crp.grp (List.length cand_all) cand_all dec_cand cp pi r)
      (H3 : zkprowshuffle = shuffle_zkp Crp.grp (List.length cand_all)
                                        cand_all cp shuffledcp pi cpi s r),
      verify_shuffle Crp.grp (List.length cand_all)
                     cand_all cp shuffledcp cpi zkprowshuffle = true.

  (* Coherence about shuffle introducing reencryption *)
  Axiom shuffle_perm :
    forall n f pi r g,
      shuffle Crp.grp n cand_all dec_cand (f : cand -> ciphertext) (pi : Permutation) r = g ->
      forall c, decrypt_message Crp.grp privatekey (g c) =
           decrypt_message Crp.grp privatekey (compose f (projT1 pi) c).
  (* end of axioms about shuffle. *)

  (* This axiom states that
       if verify_zero_knowledge_decryption_proof grp d c zkp = true then
       d is honest decryption of c *)
  Axiom decryption_from_zkp_proof :
    forall c d zkp,
      verify_zero_knowledge_decryption_proof Crp.grp d c zkp = true ->
      d = decrypt_message Crp.grp privatekey c.

  (* Coherence axiom about Permutation *)
  Axiom perm_axiom :
    forall cpi zkpcpi,
      verify_permutation_commitment Crp.grp (Datatypes.length cand_all) cpi zkpcpi = true ->
      existsT (pi : Permutation), forall (f g : cand -> ciphertext) (zkppf : ShuffleZkp),
    verify_shuffle Crp.grp (Datatypes.length cand_all) cand_all f g cpi zkppf = true ->
    forall c, decrypt_message Crp.grp privatekey (g c) =
         decrypt_message Crp.grp privatekey (compose f (projT1 pi) c).

  (* End of Axioms *)
End CAxioms.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Fixpoint table_maps_block_loop0 n i ret table base_pa level ipa_state adt :=
    match n with
    | O => Some (i, ret)
    | S n' =>
      match table_maps_block_loop0 n' i ret table base_pa level ipa_state adt with
      | Some (i, ret) =>
        rely is_int64 i; rely is_int ret;
        when' pgte == pgte_read_spec table (VZ64 i) adt;
        rely is_int64 pgte;
        let expected_pa := base_pa + i * GRANULE_SIZE in
        rely is_int64 expected_pa;
        if PTE_TO_IPA_STATE pgte =? ipa_state then
          when' phys == entry_to_phys_spec (VZ64 pgte) (VZ64 level) adt;
          rely is_int64 phys;
          if phys =? expected_pa then
            Some (i + 1, ret)
          else
            Some (i + 1, 0)
        else Some (i + 1, 0)
      | _ => None
      end
    end.

  Definition table_maps_block_spec0 (table: Pointer) (level: Z64) (ipa_state: Z64) (adt: RData) : option Z :=
    match level, ipa_state with
    | VZ64 level, VZ64 ipa_state =>
      rely is_int64 level; rely is_int64 ipa_state;
      when' pgte == pgte_read_spec table (VZ64 0) adt;
      rely is_int64 pgte;
      when' base_pa == entry_to_phys_spec (VZ64 pgte) (VZ64 level) adt;
      rely is_int64 base_pa; rely is_int64 (level - 1);
      when aligned == addr_is_level_aligned_spec (VZ64 base_pa) (VZ64 (level - 1)) adt;
      rely is_int aligned;
      if aligned =? 0 then Some 0 else
        match table_maps_block_loop0 (Z.to_nat PGTES_PER_TABLE) 0 1 table base_pa level ipa_state adt with
        | Some (i, ret) =>
          rely is_int64 i; rely is_int ret;
          Some ret
        | _ => None
        end
    end.

End SpecLow.