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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj3synthconj3 : forall  (lv0 : lst), (@eq natural (len (Cons Zero lv0)) (Succ (len lv0))).
Admitted.
QuickChick conj3synthconj3.