(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export per_props_pertype.
Require Export sequents_equality.
Require Export list. (* why *)

(* [15] ============ PERTYPE ELIMINATION ============ *)

(**

  We can state the pertype elimination rule as follows:
<<
   H, x : t1 = t2 in pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : t1 = t2 in pertype(R), [z : R t1 t2], J |- C ext e
     H |- R t1 t2 in Type(i)
>>
 *)

Definition rule_pertype_elimination {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        H
        (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
                            (mk_hhyp z (mk_apply2 R t1 t2)) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      H
                      (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hypa ].
  destruct hyp2 as [ ws2 hypb ].
  destseq; allsimpl; proof_irr; GC.
  clear hyps.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J))) as cs.
  { clear hypa hypb.
    dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp. }

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  {
    clear hypa hypb.
    dwfseq.
    sp;
      try (complete (discover; allrw in_snoc; sp));
      try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
      try (complete (generalize (wfh7 z); allrw in_snoc; sp));
      try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
      try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
      try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                     allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                     generalize (subvars_hs_vars_hyps H); intros;
                     generalize (subvars_hs_vars_hyps J); intros;
                     allrw subvars_prop; apply_in_hyp p; sp)).
  }

  destruct vhyps as [ nixr  vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_pertype in sim0; repnd.

  vr_seq_true in hypa.
  unfold inhabited_type in sim7; exrepnd.
  pose proof (hypa ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b)) as hypa.
  repeat (autodimp hypa hyp); exrepnd.

  {
    (* hyps_functionality *)
    introv sim.
    rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
    apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
      try (complete (allrw; sp)).
    rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
    lsubst_tac.
    generalize (eqh (s2a1 ++ s2b0)); intro j.
    autodimp j hyp.

    rw @similarity_app; simpl.
    exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
    rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

    rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
    apply app_split in j0; repnd; subst; repeat (rw length_snoc);
      try (complete (allrw; sp)).
    apply app_split in j2; repnd; subst; repeat (rw length_snoc);
      try (complete (allrw; sp)).

    duplicate j5 as dup_eqhyps_snoc.
    rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
    lsubst_tac.

    rw @eq_hyps_app; simpl.
    exists (snoc (snoc s1a (x, t6)) (z, t4))
           s1b
           (snoc (snoc s2a1 (x, t7)) (z, t5))
           s2b1;
      repeat (rw length_snoc); dands;
        try (complete sp);
        try (complete (apply sub_eq_hyps_snoc_weak; sp));[].

    assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
      as cv
        by (apply cover_vars_apply2; sp;
            try (apply cover_vars_var);
            repeat (apply cover_vars_snoc_weak); sp;
            repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 w3 p0 cv;
      dands; try (complete sp).

    lsubst_tac.

    vr_seq_true in hypb.
    pose proof (hypb s1a s2a1) as hypb.
    repeat (autodimp hypb hyp); exrepnd.

    { pose proof (hyps_functionality_init_seg_snoc
                    lib
                    s1a t6 t7 H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) w4 p1) as k.
      simpl in *; lsubst_tac.
      apply k; sp.

      { apply hyps_functionality_init_seg with (s3 := s2b1) in eqh; sp.
        rw @substitute_hyps_snoc_sub_weak in sim10; sp. }

      rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
      lsubst_tac; sp. }

    { rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx. }

    lsubst_tac.
    allrw @member_eq.
    allrw <- @member_member_iff.
    apply tequality_mkc_member_implies_sp in hypb0; auto;[].
    apply equality_in_uni in hypb0; sp.
  }

  {
    (* similarity *)
    rw @similarity_app; simpl.
    exists (snoc (snoc s1a0 (x, t0)) (z, t))
           s1b
           (snoc (snoc s2a0 (x, t3)) (z, t))
           s2b; repeat (rw length_snoc); sp;
      try (complete (rewrite substitute_hyps_snoc_sub_weak; sp));[].

    assert (wf_term (mk_apply2 R t1 t2))
      as wfap by (apply wf_apply2; sp).

    assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
      as cvap
        by (apply cover_vars_snoc_weak; rw @cover_vars_apply2; sp).

    rw @similarity_snoc; simpl.
    exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp;[].

    lsubst_tac.
    rw @member_eq; sp.
  }

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hypa0.
  rw eq1 in hypa1.
  rw eq2 in hypa0.
  rw eq3 in hypa1.
  rw eq4 in hypa1.
  sp.
Qed.

Lemma rule_pertype_elimination_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    @rule_true_if
      o lib
      (rule_pertype_elimination
         R t1 t2 C e
         x z
         i
         H J).
Proof.
  intros.
  generalize (rule_pertype_elimination_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(**

  This is a variant of [rule_pertype_elimination] but where the
  well-formedness goal is stated using a ``type'' sequent.  Also it
  allows one to use all the hypotheses:
<<
   H, x : t1 = t2 in pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : t1 = t2 in pertype(R), [z : R t1 t2], J |- C ext e
     H, x : t1 = t2 in pertype(R), J |- R t1 t2 is a type
>>
 *)

Definition rule_pertype_elimination_t {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
        (mk_concl_t (mk_apply2 R t1 t2))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination_t_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination_t
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination_t, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars R) (vars_hyps J)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh13; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (allunfold @disjoint; introv k;
                   discover; allrw in_app_iff; allrw in_snoc; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_pertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a  (x, t6) ++ s1b)
                   (snoc s2a1 (x, t7) ++ s2b));
    clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  rw @similarity_app; simpl.
  exists (snoc s1a (x,t6)) s1b (snoc s2a1 (x,t7)) s2b; repeat (rw length_snoc); sp.
  lsubst_tac.
  auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

Lemma rule_pertype_elimination_t_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_pertype_elimination_t
                    o
                    R t1 t2 C e
                    x z
                    i
                    H J).
Proof.
  intros.
  generalize (rule_pertype_elimination_t_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.


(** This file provides the unbounded fractional authoritative camera: a version
of the fractional authoritative camera that can be used with fractions [> 1].

Most of the reasoning principles for this version of the fractional
authoritative cameras are the same as for the original version. There are two
difference:

- We get the additional rule that can be used to allocate a "surplus", i.e.
  if we have the authoritative element we can always increase its fraction
  and allocate a new fragment.

  <<<
  ✓ (a ⋅ b) → ●U{p} a ~~> ●U{p + q} (a ⋅ b) ⋅ ◯U{q} b
  >>>

- We no longer have the [◯U{1} a] is the exclusive fragmental element (cf.
  [frac_auth_frag_validN_op_1_l]).
*)
From iris.algebra Require Export auth frac updates local_updates.
From iris.algebra Require Import ufrac proofmode_classes.
From iris.prelude Require Import options.

Definition ufrac_authR (A : cmra) : cmra :=
  authR (optionUR (prodR ufracR A)).
Definition ufrac_authUR (A : cmra) : ucmra :=
  authUR (optionUR (prodR ufracR A)).

(** Note in the signature of [ufrac_auth_auth] and [ufrac_auth_frag] we use
[q : Qp] instead of [q : ufrac]. This way, the API does not expose that [ufrac]
is used internally. This is quite important, as there are two canonical camera
instances with carrier [Qp], namely [fracR] and [ufracR]. When writing things
like [ufrac_auth_auth q a ∧ ✓ q] we want Coq to infer the type of [q] as [Qp]
such that the [✓] of the default [fracR] camera is used, and not the [✓] of
the [ufracR] camera. *)
Definition ufrac_auth_auth {A : cmra} (q : Qp) (x : A) : ufrac_authR A :=
  ● (Some (q : ufracR,x)).
Definition ufrac_auth_frag {A : cmra} (q : Qp) (x : A) : ufrac_authR A :=
  ◯ (Some (q : ufracR,x)).

Typeclasses Opaque ufrac_auth_auth ufrac_auth_frag.

Global Instance: Params (@ufrac_auth_auth) 2 := {}.
Global Instance: Params (@ufrac_auth_frag) 2 := {}.

Notation "●U{ q } a" := (ufrac_auth_auth q a) (at level 10, format "●U{ q }  a").
Notation "◯U{ q } a" := (ufrac_auth_frag q a) (at level 10, format "◯U{ q }  a").

Section ufrac_auth.
  Context {A : cmra}.
  Implicit Types a b : A.

  Global Instance ufrac_auth_auth_ne q : NonExpansive (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_auth_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_ne q : NonExpansive (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.

  Global Instance ufrac_auth_auth_discrete q a : Discrete a → Discrete (●U{q} a).
  Proof. intros. apply auth_auth_discrete; [apply Some_discrete|]; apply _. Qed.
  Global Instance ufrac_auth_frag_discrete q a : Discrete a → Discrete (◯U{q} a).
  Proof. intros. apply auth_frag_discrete; apply Some_discrete; apply _. Qed.

  Lemma ufrac_auth_validN n a p : ✓{n} a → ✓{n} (●U{p} a ⋅ ◯U{p} a).
  Proof. by rewrite auth_both_validN. Qed.
  Lemma ufrac_auth_valid p a : ✓ a → ✓ (●U{p} a ⋅ ◯U{p} a).
  Proof. intros. by apply auth_both_valid_2. Qed.

  Lemma ufrac_auth_agreeN n p a b : ✓{n} (●U{p} a ⋅ ◯U{p} b) → a ≡{n}≡ b.
  Proof.
    rewrite auth_both_validN=> -[/Some_includedN [[_ ? //]|Hincl] _].
    move: Hincl=> /pair_includedN=> -[/ufrac_included Hincl _].
    by destruct (irreflexivity (<)%Qp p).
  Qed.
  Lemma ufrac_auth_agree p a b : ✓ (●U{p} a ⋅ ◯U{p} b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=> n. by eapply ufrac_auth_agreeN, cmra_valid_validN.
  Qed.
  Lemma ufrac_auth_agree_L `{!LeibnizEquiv A} p a b : ✓ (●U{p} a ⋅ ◯U{p} b) → a = b.
  Proof. intros. by eapply leibniz_equiv, ufrac_auth_agree. Qed.

  Lemma ufrac_auth_includedN n p q a b : ✓{n} (●U{p} a ⋅ ◯U{q} b) → Some b ≼{n} Some a.
  Proof. by rewrite auth_both_validN=> -[/Some_pair_includedN [_ ?] _]. Qed.
  Lemma ufrac_auth_included `{CmraDiscrete A} q p a b :
    ✓ (●U{p} a ⋅ ◯U{q} b) → Some b ≼ Some a.
  Proof. rewrite auth_both_valid_discrete=> -[/Some_pair_included [_ ?] _] //. Qed.
  Lemma ufrac_auth_includedN_total `{CmraTotal A} n q p a b :
    ✓{n} (●U{p} a ⋅ ◯U{q} b) → b ≼{n} a.
  Proof. intros. by eapply Some_includedN_total, ufrac_auth_includedN. Qed.
  Lemma ufrac_auth_included_total `{CmraDiscrete A, CmraTotal A} q p a b :
    ✓ (●U{p} a ⋅ ◯U{q} b) → b ≼ a.
  Proof. intros. by eapply Some_included_total, ufrac_auth_included. Qed.

  Lemma ufrac_auth_auth_validN n q a : ✓{n} (●U{q} a) ↔ ✓{n} a.
  Proof.
    rewrite auth_auth_dfrac_validN Some_validN. split.
    - by intros [?[]].
    - intros. by split.
  Qed.
  Lemma ufrac_auth_auth_valid q a : ✓ (●U{q} a) ↔ ✓ a.
  Proof. rewrite !cmra_valid_validN. by setoid_rewrite ufrac_auth_auth_validN. Qed.

  Lemma ufrac_auth_frag_validN n q a : ✓{n} (◯U{q} a) ↔ ✓{n} a.
  Proof.
    rewrite auth_frag_validN. split.
    - by intros [??].
    - by split.
  Qed.
  Lemma ufrac_auth_frag_valid q a : ✓ (◯U{q} a) ↔ ✓ a.
  Proof.
    rewrite auth_frag_valid. split.
    - by intros [??].
    - by split.
  Qed.

  Lemma ufrac_auth_frag_op q1 q2 a1 a2 : ◯U{q1+q2} (a1 ⋅ a2) ≡ ◯U{q1} a1 ⋅ ◯U{q2} a2.
  Proof. done. Qed.

  Global Instance ufrac_auth_is_op q q1 q2 a a1 a2 :
    IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯U{q} a) (◯U{q1} a1) (◯U{q2} a2).
  Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.

  Global Instance ufrac_auth_is_op_core_id q q1 q2 a :
    CoreId a → IsOp q q1 q2 → IsOp' (◯U{q} a) (◯U{q1} a) (◯U{q2} a).
  Proof.
    rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
    by rewrite -ufrac_auth_frag_op -core_id_dup.
  Qed.

  Lemma ufrac_auth_update p q a b a' b' :
    (a,b) ~l~> (a',b') → ●U{p} a ⋅ ◯U{q} b ~~> ●U{p} a' ⋅ ◯U{q} b'.
  Proof.
    intros. apply: auth_update.
    apply: option_local_update. by apply: prod_local_update_2.
  Qed.

  Lemma ufrac_auth_update_surplus p q a b :
   ✓ (a ⋅ b) → ●U{p} a ~~> ●U{p + q} (a ⋅ b) ⋅ ◯U{q} b.
  Proof.
    intros Hconsistent. apply: auth_update_alloc.
    intros n m; simpl; intros [Hvalid1 Hvalid2] Heq.
    split.
    - split; by apply cmra_valid_validN.
    - rewrite pair_op Some_op Heq comm.
      destruct m; simpl; [rewrite left_id | rewrite right_id]; done.
  Qed.
End ufrac_auth.


From Undecidability.L Require Import Tactics Encodings DecidableRecognisable.
Implicit Type p : term -> Prop.
Implicit Types s t u : term.

(** * Reduction lemma and Rice’s theorem *)

(** ** Closedness is decidable *)

Definition Leb := Eval cbn in
      rho (.\ "leb", "m", "n"; "m" !T (.\ "m'"; "n" !F (.\ "n'"; "leb" "m'" "n'"))).

Hint Unfold Leb: cbv.

Lemma Leb_correct m n : Leb (enc m) (enc n) ≡ benc (leb m n).
Proof.
  destruct m.
  - solveeq.
  - revert m; induction n; intros m.
    + solveeq.
    + destruct m. solveeq. specialize (IHn m). solveeq.
Qed.

Hint Rewrite Leb_correct : Lcorrect.

Definition Lt : term := .\ "m", "n"; !Leb (!Succ "m") "n".

Lemma Lt_correct n k : Lt (enc n) (enc k) ≡ benc (Nat.ltb n k).
Proof.
  unfold Nat.ltb. rewrite <- Leb_correct.
  transitivity (Leb (Succ (enc n)) (enc k)). solveeq.
  now rewrite Succ_correct.
Qed.

Definition Bound := Eval cbn in
      rho (.\ "d", "k", "t";
           "t" (.\ "n"; !Lt "n" "k")
               (.\ "s", "t"; ("d" "k" "s") ("d" "k" "t") !F)
               (.\ "s"; "d" (!Succ "k") "s")).

Lemma Bound_correct k s : Bound (enc k) (tenc s) ≡ benc (bound k s).
Proof.
  revert k; induction s; intros k.
  - transitivity (Lt (enc n) (enc k)). solveeq. rewrite Lt_correct. unfold bound.
    destruct (Nat.ltb_spec0 n k); decide (n < k); try now omega. reflexivity. reflexivity.
  - transitivity ((Bound (enc k) (tenc s1)) (Bound (enc k) (tenc s2)) F). solveeq.
    rewrite IHs1, IHs2. cbn.
    destruct (bound _ s1), (bound _ s2); solveeq.
  - transitivity (Bound (Succ (enc k)) (tenc s)). solveeq. now rewrite Succ_correct, IHs.
Qed.

Definition Closed := Bound (enc 0).

Lemma decidable_closed : decidable closed.
Proof.
  exists (lambda (Closed 0)). split; value.
  intros s.
  assert ((lambda (Closed 0)) (tenc s) ≡ benc (bound 0 s)).
  transitivity (Bound (enc 0) (tenc s)). solveeq. now rewrite Bound_correct.
  rewrite H.

  destruct (bound 0 s) eqn:E.
  - firstorder econstructor.
  - right. split. intros C. congruence. econstructor.
Qed.

Definition Lambda := lambda (0 (lambda F) (lambda (lambda F)) (lambda T)).

Hint Unfold Lambda : cbv.

Lemma Lambda_correct s : Lambda (tenc s) ▷ T /\ lam s \/
                         Lambda (tenc s) ▷ F /\ ~ lam s.
Proof.
  destruct s.
  + right. split. solveeq. intros [x H]; inv H.
  + right. split. solveeq. intros [x H]; inv H.
  + left. split. solveeq. value.
Qed.

Lemma decidable_lam : decidable lam.
Proof.
  exists Lambda. split; value. intros s.
  assert (H := Lambda_correct s). firstorder.
Qed.

Lemma decidable_proc : decidable proc.
Proof.
  eapply decidable_intersection.
  - eapply decidable_closed.
  - eapply decidable_lam.
Qed.

(** ** Reduction lemma *)

Notation "s '≈' t" := (forall u v, t (tenc u) ▷ v <-> s (tenc u) ▷ v) (at level 50).

Lemma equiv_semantic s t : s ≡ t -> s ≈ t.
Proof.
  intros H ? ?; now rewrite H.
Qed.

Definition closed_under_proc R p := forall s t , proc s -> proc t -> p s -> R s t -> p t.
Definition semantic p := closed_under_proc (fun s t => s ≈ t) p.

Lemma unrecognisable_russell : ~ recognisable (fun s => closed s /\ ~ eva (s (tenc s))).
Proof.
  intros [u [[cls_u lam_u] H]]. specialize (H u). tauto.
Qed.

Lemma Reduction p f v :
  proc v ->
  (forall s, closed s -> p (f s) <-> ~ eva (s (tenc s))) ->
  (forall s, v (tenc s) ≡ tenc (f s)) ->
  ~ recognisable p.
Proof.
  intros proc_v  spec_f spec_v (u & proc_u & Hu).
  assert (recognisable closed) as (C & proc_C & HC). {
    eapply dec_recognisable. eapply decidable_closed. }
  pose (w := lambda (F (C 0) (u (v 0)))).
  eapply unrecognisable_russell. exists w; split; value. intros s.

  assert (w (tenc s) ≡ F (C (tenc s)) (u (tenc (f s)))). {
    transitivity (F (C (tenc s)) (u (v (tenc s)))). solveeq. now rewrite spec_v. }
   intuition; [ | rewrite H, F_eva, <- HC, <- Hu, spec_f in H0; tauto..].
  rewrite H, F_eva, <- HC, <- Hu, spec_f; eauto.
Qed.

(** ** Rice's lemma and Rice's theorem *)

Lemma D_pi u : pi D u <-> False.
Proof.
  unfold pi. firstorder using eva_D.
Qed.

Lemma Rice p N :
  semantic p ->
  proc N -> ~ p N ->
  p D ->
  ~ recognisable p.
Proof with eauto; try now intuition.
  intros p_sem proc_N pN pD [u [[cls_u lam_u] Hu]].
  pose (f := fun s => lambda (F (s (tenc s)) N 0)).
  pose (v := lambda (Lam (App (App (App (tenc F) (App 0 (Q 0))) (tenc N)) (tenc 0)))).

  eapply Reduction with (p := p) (f := f) (v := v).
  - value.
  - intros. assert (Hf : forall t, f s (tenc t) ≡ F (s (tenc s)) N (tenc t)) by (intros; solvered).
    intuition.
    + eapply p_sem in H0; value. eapply pN, H0. intros t t'. rewrite Hf.
      destruct H1 as (s' & [] % evaluates_equiv). rewrite H1, F_correct; value. tauto.
    + eapply p_sem with (s := D); value. eauto. intros t t'. rewrite Hf.
      intuition.
      * destruct H0. eapply F_eva with (t := N). eapply app_eva with (t := tenc t). firstorder.
      * exfalso. eapply D_pi. exists t'. eassumption.
  - intros. transitivity (Lam ((App ((App ((App (tenc F)) ((App (tenc s)) (Q (tenc s))))) (tenc N))) (tenc 0))). solveeq.
    now rewrite Q_correct, !App_correct, Lam_correct.
  - exists u. firstorder.
Qed.

Lemma Rice_pi p :
  closed_under_proc (fun s t => (forall u, pi s u <-> pi t u)) p ->
 (exists u, proc u /\ ~ p u) ->
 p (lambda Omega) -> ~ recognisable p.
Proof with eauto; try now intuition.
  intros. destruct H0 as [u [H0 H0']]. eapply Rice.
  - intros. hnf. intuition. eapply H. exact H2. eauto. eauto. split; intros (? & ?); exists x; firstorder.
  - eauto.
  - eauto.
  - firstorder.
Qed.

Lemma rec_total : ~ recognisable (fun s => ~forall t, pi s t).
Proof.
  eapply Rice_pi.
  - hnf; intuition. eapply H1. intros. rewrite H2. eauto.
  - exists (lambda I). repeat split; value. intros H. eapply H. intros t. exists I. solveeq.
  - intros A. eapply (D_pi I); eauto.
Qed.

Lemma rec_total_cls : ~ recognisable (fun s => closed s /\ ~forall t, pi s t).
Proof.
  eapply Rice_pi.
  - hnf; intuition. eapply H4. intros. rewrite H2. eauto.
  - exists (lambda I). repeat split; value. intros H. eapply H. intros t. exists I. solveeq.
  - split; value. intros A. eapply (D_pi I); eauto.
Qed.

Lemma rec_total_proc : ~ recognisable (fun s => proc s /\ ~forall t, pi s t).
Proof.
  eapply Rice_pi.
  - hnf; intuition. eapply H4. intros. rewrite H2. eauto.
  - exists (lambda I). repeat split; value. intros H. eapply H. intros t. exists I. solveeq.
  - split; value. intros A. eapply (D_pi I); eauto.
Qed.

Theorem Rice_Theorem p :
  closed_under_proc (fun s t => s ≈ t) p ->
 (exists u, proc u /\ ~ p u) -> (exists u, proc u /\ p u) ->
  ~ decidable p.
Proof.
  intros. intros A. assert (B : decidable p) by eassumption. destruct A as [u [proc_u Hu]].
  destruct H0 as (? & ? & ?), H1 as (? & ? & ?).
  destruct (Hu D).
  - eapply Rice. exact H. exact H0. tauto. firstorder. eapply dec_recognisable. exists u; tauto.
  - eapply Rice with (p := complement p).
    + unfold complement. hnf. intuition. eapply H8.  eapply H; eauto. intuition; now eapply H9.
    + exact H1.
    + firstorder.
    + firstorder.
    + now eapply dec_recognisable, decidable_complement.
Qed.

Lemma dec_total : ~ decidable (fun s => proc s /\ forall t, pi s t).
Proof.
  eapply Rice_Theorem.
  - hnf; intuition. destruct (H4 t0). firstorder.
  - exists D. repeat split; value. intros A. eapply (D_pi I); eauto.  firstorder.
  - exists (lambda I). repeat split; value. intros H. exists I. solveeq.
Qed.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.
From caml5.std Require Import
  record2.

Section heapGS.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.
  Implicit Types v w t hd tl dst : val.

  Notation "t '.(head)'" := t.(0)%E
  ( at level 5
  ) : expr_scope.
  Notation "t '.(tail)'" := t.(1)%E
  ( at level 5
  ) : expr_scope.

  Definition chain_cons : val :=
    record2_make.

  Definition chain_head : val :=
    λ: "t",
      !"t".(head).
  Definition chain_tail : val :=
    λ: "t",
      !"t".(tail).

  Definition chain_set_head : val :=
    λ: "t" "v",
      "t".(head) <- "v".
  Definition chain_set_tail : val :=
    λ: "t" "v",
      "t".(tail) <- "v".

  Definition chain_advance : val :=
    rec: "chain_advance" "t" "i" :=
      if: "i" = #0 then (
        "t"
      ) else (
        "chain_advance" (chain_tail "t") ("i" - #1)
      ).

  Definition chain_get : val :=
    λ: "t" "i",
      chain_head (chain_advance "t" "i").
  Definition chain_set : val :=
    λ: "t" "i" "v",
      chain_set_head (chain_advance "t" "i") "v".

  #[local] Definition chain_node l dq hd tl :=
    record2_model l dq hd tl.
  Fixpoint chain_model t dq vs dst : iProp Σ :=
    match vs with
    | [] =>
        ⌜t = dst⌝
    | v :: vs =>
        ∃ l t',
        ⌜t = #l⌝ ∗
        chain_node l dq v t' ∗ chain_model t' dq vs dst
    end.

  #[global] Instance chain_model_timeless t dq vs dst :
    Timeless (chain_model t dq vs dst).
  Proof.
    revert t. induction vs; apply _.
  Qed.
  #[global] Instance chain_model_persistent t vs dst :
    Persistent (chain_model t DfracDiscarded vs dst).
  Proof.
    rewrite /Persistent.
    iInduction vs as [| v vs] "IH" forall (t); first naive_solver.
    iIntros "(%l & %t' & -> & #Hnode & Hmodel')".
    iDestruct ("IH" with "Hmodel'") as "#?".
    iModIntro. naive_solver.
  Qed.

  #[global] Instance chain_model_fractional t vs dst :
    Fractional (λ q, chain_model t (DfracOwn q) vs dst).
  Proof.
    intros q1 q2. iSplit.
    - iInduction vs as [| v vs] "IH" forall (t); first done.
      iIntros "(%l & %t' & -> & Hnode & Hmodel')".
      iDestruct (fractional_split_1 with "Hnode") as "(Hnode1 & Hnode2)".
      iDestruct ("IH" with "Hmodel'") as "(Hmodel'1 & Hmodel'2)".
      iSplitL "Hnode1 Hmodel'1"; repeat iExists _; auto with iFrame.
    - iInduction vs as [| v vs] "IH" forall (t); first iIntros "(-> & _) //".
      iIntros "((%l & %t' & -> & Hnode1 & Hmodel'1) & (%_l & %_t' & %Heq & Hnode2 & Hmodel'2))". injection Heq as <-.
      iDestruct (record2_model_agree with "Hnode1 Hnode2") as %(_ & <-).
      iDestruct (fractional_merge with "Hnode1 Hnode2") as "Hnode".
      iDestruct ("IH" with "[$Hmodel'1 $Hmodel'2]") as "Hmodel'".
      repeat iExists _. auto with iFrame.
  Qed.
  #[global] Instance chain_model_as_fractional t q vs dst :
    AsFractional (chain_model t (DfracOwn q) vs dst) (λ q, chain_model t (DfracOwn q) vs dst) q.
  Proof.
    split; [done | apply _].
  Qed.

  Lemma chain_model_nil t dq dst :
    ⌜t = dst⌝ ⊣⊢
    chain_model t dq [] dst.
  Proof.
    auto.
  Qed.
  Lemma chain_model_nil_1 v dq :
    ⊢ chain_model v dq [] v.
  Proof.
    auto.
  Qed.
  Lemma chain_model_nil_2 t dq dst :
    chain_model t dq [] dst -∗
    ⌜t = dst⌝.
  Proof.
    auto.
  Qed.

  Lemma chain_model_app_1 dq t1 vs1 t2 vs2 dst :
    chain_model t1 dq vs1 t2 -∗
    chain_model t2 dq vs2 dst -∗
    chain_model t1 dq (vs1 ++ vs2) dst.
  Proof.
    iInduction vs1 as [| v1 vs1] "IH" forall (t1).
    - iIntros "->". naive_solver.
    - iIntros "(%l1 & %t1' & -> & Hnode1 & Hmodel1') Hmodel2".
      rewrite -app_comm_cons.
      iExists l1, t1'. iFrame. iSplit; first done.
      iApply ("IH" with "Hmodel1' Hmodel2").
  Qed.
  Lemma chain_model_app_2 vs1 vs2 t dq vs dst :
    vs = vs1 ++ vs2 →
    chain_model t dq vs dst -∗
      ∃ t',
      chain_model t dq vs1 t' ∗
      chain_model t' dq vs2 dst.
  Proof.
    iInduction vs1 as [| v1 vs1] "IH" forall (t vs); iIntros (->).
    - naive_solver.
    - rewrite -app_comm_cons.
      iIntros "(%l & %t' & -> & Hnode & Hmodel')".
      iDestruct ("IH" with "[//] Hmodel'") as "(%t'' & Hmodel' & Hmodel'')".
      iExists t''. iFrame. iExists l, t'. auto with iFrame.
  Qed.
  Lemma chain_model_app t dq vs1 vs2 dst :
    (∃ t', chain_model t dq vs1 t' ∗ chain_model t' dq vs2 dst) ⊣⊢
    chain_model t dq (vs1 ++ vs2) dst.
  Proof.
    iSplit.
    - iIntros "(%t' & Hmodel & Hmodel')".
      iApply (chain_model_app_1 with "Hmodel Hmodel'").
    - iApply chain_model_app_2; first done.
  Qed.

  Lemma chain_model_persist t dq vs dst :
    chain_model t dq vs dst ==∗
    chain_model t DfracDiscarded vs dst.
  Proof.
    iInduction vs as [| v vs] "IH" forall (t); first done.
    iIntros "(%l & %t' & -> & Hnode & Hmodel')".
    iMod (record2_model_persist with "Hnode") as "Hnode".
    iMod ("IH" with "Hmodel'") as "Hmodel'".
    repeat iExists _. naive_solver.
  Qed.

  Lemma chain_model_valid t dq vs dst :
    0 < length vs →
    chain_model t dq vs dst -∗
    ⌜✓ dq⌝.
  Proof.
    intros. destruct vs as [| v vs]; first naive_solver lia.
    iIntros "(%l & %t' & -> & Hnode & Hmodel')".
    iApply (record2_model_valid with "Hnode").
  Qed.
  Lemma chain_model_combine t dq1 vs1 dst1 dq2 vs2 dst2 :
    length vs1 ≤ length vs2 →
    chain_model t dq1 vs1 dst1 -∗
    chain_model t dq2 vs2 dst2 -∗
      chain_model t (dq1 ⋅ dq2) vs1 dst1 ∗
      chain_model dst1 dq2 (drop (length vs1) vs2) dst2 ∗
      ⌜vs1 = take (length vs1) vs2⌝.
  Proof.
    iInduction vs1 as [| v1 vs1] "IH" forall (t vs2);
      destruct vs2 as [| v2 vs2].
    - iIntros "_ -> -> //".
    - iIntros "_ -> (%l & %t' & -> & Hnode & Hmodel')".
      repeat iSplit; try done. iExists l, t'. auto with iFrame.
    - iIntros "%Hlength". simpl in Hlength. lia.
    - iIntros "%Hlength (%l & %t' & -> & Hnode1 & Hmodel'1) (%_l & %_t' & %Heq & Hnode2 & Hmodel'2)". injection Heq as <-.
      simpl in Hlength. eapply le_S_n in Hlength.
      iDestruct (record2_model_combine with "Hnode1 Hnode2") as "(Hnode & <- & <-)".
      iDestruct ("IH" with "[] Hmodel'1 Hmodel'2") as "(Hmodel' & Hmodel'2 & ->)"; first done.
      iFrame. iSplit; last rewrite /= take_length min_l //.
      iExists l, t'. auto with iFrame.
  Qed.
  Lemma chain_model_combine' t dq1 vs1 dst1 dq2 vs2 dst2 :
    length vs1 = length vs2 →
    chain_model t dq1 vs1 dst1 -∗
    chain_model t dq2 vs2 dst2 -∗
      chain_model t (dq1 ⋅ dq2) vs1 dst1 ∗
      ⌜vs1 = vs2 ∧ dst1 = dst2⌝.
  Proof.
    iIntros "%Hlength Hmodel1 Hmodel2".
    iDestruct (chain_model_combine with "Hmodel1 Hmodel2") as "($ & Hmodel2 & ->)"; first lia.
    rewrite Hlength take_length min_l; last lia.
    rewrite drop_all. iDestruct "Hmodel2" as %->.
    rewrite take_ge //.
  Qed.
  Lemma chain_model_valid_2 t dq1 vs1 dst1 dq2 vs2 dst2 :
    0 < length vs1 ≤ length vs2 →
    chain_model t dq1 vs1 dst1 -∗
    chain_model t dq2 vs2 dst2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ vs1 = take (length vs1) vs2⌝.
  Proof.
    iIntros "% Hmodel1 Hmodel2".
    iDestruct (chain_model_combine with "Hmodel1 Hmodel2") as "(Hmodel & _ & %)"; first lia.
    iDestruct (chain_model_valid with "Hmodel") as %?; first lia.
    done.
  Qed.
  Lemma chain_model_valid_2' t dq1 vs1 dst1 dq2 vs2 dst2 :
    0 < length vs1 →
    length vs1 = length vs2 →
    chain_model t dq1 vs1 dst1 -∗
    chain_model t dq2 vs2 dst2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ vs1 = vs2 ∧ dst1 = dst2⌝.
  Proof.
    iIntros "% % Hmodel1 Hmodel2".
    iDestruct (chain_model_combine' with "Hmodel1 Hmodel2") as "(Hmodel & <- & <-)"; first done.
    iDestruct (chain_model_valid with "Hmodel") as %?; done.
  Qed.
  Lemma chain_model_agree t dq1 vs1 dst1 dq2 vs2 dst2 :
    length vs1 = length vs2 →
    chain_model t dq1 vs1 dst1 -∗
    chain_model t dq2 vs2 dst2 -∗
    ⌜vs1 = vs2 ∧ dst1 = dst2⌝.
  Proof.
    iIntros "% Hmodel1 Hmodel2".
    iDestruct (chain_model_combine' with "Hmodel1 Hmodel2") as "(_ & <- & <-)"; done.
  Qed.
  Lemma chain_model_dfrac_ne t1 dq1 vs1 dst1 t2 dq2 vs2 dst2 :
    0 < length vs1 ≤ length vs2 →
    ¬ ✓ (dq1 ⋅ dq2) →
    chain_model t1 dq1 vs1 dst1 -∗
    chain_model t2 dq2 vs2 dst2 -∗
    ⌜t1 ≠ t2⌝.
  Proof.
    iIntros "% % Hmodel1 Hmodel2" (->).
    iDestruct (chain_model_valid_2 with "Hmodel1 Hmodel2") as %?; naive_solver.
  Qed.
  Lemma chain_model_ne t1 vs1 dst1 t2 dq2 vs2 dst2 :
    0 < length vs1 ≤ length vs2 →
    chain_model t1 (DfracOwn 1) vs1 dst1 -∗
    chain_model t2 dq2 vs2 dst2 -∗
    ⌜t1 ≠ t2⌝.
  Proof.
    intros. iApply chain_model_dfrac_ne; [done | intros []%exclusive_l; apply _].
  Qed.
  Lemma chain_model_exclusive t vs1 dst1 vs2 dst2 :
    0 < length vs1 ≤ length vs2 →
    chain_model t (DfracOwn 1) vs1 dst1 -∗
    chain_model t (DfracOwn 1) vs2 dst2 -∗
    False.
  Proof.
    iIntros "% Hmodel1 Hmodel2".
    iDestruct (chain_model_ne with "Hmodel1 Hmodel2") as %?; naive_solver.
  Qed.

  Lemma chain_cons_spec t dq vs dst v :
    ✓ dq →
    {{{ chain_model t dq vs dst }}}
      chain_cons v t
    {{{ t', RET t'; chain_model t' dq (v :: vs) dst }}}.
  Proof.
    iIntros "% %Φ Hmodel HΦ".
    iApply wp_fupd. wp_apply (record2_make_spec with "[//]"). iIntros "%l' (Hnode' & _)".
    iMod (record2_dfrac_relax with "Hnode'") as "Hnode'"; first done.
    iApply "HΦ". iExists l', t. auto with iFrame.
  Qed.

  Lemma chain_head_spec t dq v vs dst :
    {{{ chain_model t dq (v :: vs) dst }}}
      chain_head t
    {{{ RET v; chain_model t dq (v :: vs) dst }}}.
  Proof.
    iIntros "%Φ (%l & %t' & -> & Hnode & Hmodel') HΦ".
    wp_rec. wp_pures.
    wp_apply (record2_get0_spec with "Hnode"). iIntros "Hnode".
    iApply "HΦ". iExists l, t'. auto with iFrame.
  Qed.
  Lemma chain_tail_spec t dq v vs dst :
    {{{ chain_model t dq (v :: vs) dst }}}
      chain_tail t
    {{{ t', RET t'; chain_model t dq [v] t' ∗ chain_model t' dq vs dst }}}.
  Proof.
    iIntros "%Φ (%l & %t' & -> & Hnode & Hmodel') HΦ".
    wp_rec. wp_pures.
    wp_apply (record2_get1_spec with "Hnode"). iIntros "Hnode".
    iApply "HΦ". iFrame. iExists l, t'. auto with iFrame.
  Qed.

  Lemma chain_set_head_spec t v vs dst w :
    {{{ chain_model t (DfracOwn 1) (v :: vs) dst }}}
      chain_set_head t w
    {{{ RET #(); chain_model t (DfracOwn 1) (w :: vs) dst }}}.
  Proof.
    iIntros "%Φ (%l & %t' & -> & Hnode & Hmodel') HΦ".
    wp_rec. wp_pures.
    wp_apply (record2_set0_spec with "Hnode"). iIntros "Hnode".
    iApply "HΦ". iExists l, t'. auto with iFrame.
  Qed.
  Lemma chain_set_tail_spec t v vs dst w :
    {{{ chain_model t (DfracOwn 1) (v :: vs) dst }}}
      chain_set_tail t w
    {{{ t',
      RET #();
      chain_model t (DfracOwn 1) [v] w ∗
      chain_model t' (DfracOwn 1) vs dst
    }}}.
  Proof.
    iIntros "%Φ (%l & %t' & -> & Hnode & Hmodel') HΦ".
    wp_rec. wp_pures.
    wp_apply (record2_set1_spec with "Hnode"). iIntros "Hnode".
    iApply "HΦ". iFrame. iExists l, w. auto with iFrame.
  Qed.

  Lemma chain_advance_spec t dq vs dst (i : Z) :
    (0 ≤ i ≤ length vs)%Z →
    {{{ chain_model t dq vs dst }}}
      chain_advance t #i
    {{{ t',
      RET t';
      chain_model t dq (take (Z.to_nat i) vs) t' ∗
      chain_model t' dq (drop (Z.to_nat i) vs) dst
    }}}.
  Proof.
    intros (Hi1 & Hi2). revert Hi2.
    rename i into _i. edestruct Z_of_nat_complete as (i & ->); first done. clear.
    rewrite -Nat2Z.inj_le Nat2Z.id.
    iInduction i as [| i] "IH" forall (t vs); iIntros "%Hi %Φ Hmodel HΦ"; wp_rec; wp_pures.
    - iApply "HΦ". auto with iFrame.
    - destruct vs as [| v vs]; simpl in Hi; first lia.
      wp_apply (chain_tail_spec with "Hmodel"). iIntros "%t' (Hmodel & Hmodel')".
      assert (S i - 1 = i)%Z as -> by lia.
      wp_apply ("IH" with "[] Hmodel'"); first (iPureIntro; lia). iIntros "%t'' (Hmodel' & Hmodel'')".
      iApply "HΦ". iFrame.
      iApply (chain_model_app_1 with "Hmodel Hmodel'").
  Qed.

  Lemma chain_get_spec t dq vs dst (i : Z) v :
    (0 ≤ i)%Z →
    vs !! Z.to_nat i = Some v →
    {{{ chain_model t dq vs dst }}}
      chain_get t #i
    {{{ RET v; chain_model t dq vs dst }}}.
  Proof.
    intros Hi. rename i into _i. edestruct Z_of_nat_complete as (i & ->); first done. clear.
    iIntros "%Hlookup %Φ Hmodel HΦ".
    rewrite Nat2Z.id in Hlookup. pose proof (lookup_lt_Some vs i v Hlookup).
    wp_rec. wp_pures.
    wp_apply (chain_advance_spec with "Hmodel"); first lia.
    iIntros "%t' (Hmodel & Hmodel')".
    rewrite Nat2Z.id.
    rewrite -(take_drop i vs) lookup_app_r in Hlookup; last (rewrite take_length; lia).
    rewrite take_length min_l in Hlookup; last lia.
    rewrite Nat.sub_diag in Hlookup.
    destruct (drop i vs) as [| _v vs'] eqn:Heq; first done. apply (inj Some) in Hlookup as ->.
    wp_apply (chain_head_spec with "Hmodel'"). iIntros "Hmodel'".
    iApply "HΦ".
    iEval (rewrite -(take_drop i vs) Heq). iApply (chain_model_app_1 with "Hmodel Hmodel'").
  Qed.
  Lemma chain_set_spec t vs dst (i : Z) v w :
    (0 ≤ i)%Z →
    vs !! Z.to_nat i = Some v →
    {{{ chain_model t (DfracOwn 1) vs dst }}}
      chain_set t #i w
    {{{ RET #(); chain_model t (DfracOwn 1) (<[Z.to_nat i := w]> vs) dst }}}.
  Proof.
    intros Hi. rename i into _i. edestruct Z_of_nat_complete as (i & ->); first done. clear.
    iIntros "%Hlookup %Φ Hmodel HΦ".
    rewrite Nat2Z.id in Hlookup. pose proof (lookup_lt_Some vs i v Hlookup).
    wp_rec. wp_pures.
    wp_apply (chain_advance_spec with "Hmodel"); first lia.
    iIntros "%t' (Hmodel & Hmodel')".
    rewrite Nat2Z.id.
    rewrite -(take_drop i vs) lookup_app_r in Hlookup; last (rewrite take_length; lia).
    rewrite take_length min_l in Hlookup; last lia.
    rewrite Nat.sub_diag in Hlookup.
    destruct (drop i vs) as [| _v vs'] eqn:Heq; first done. apply (inj Some) in Hlookup as ->.
    wp_apply (chain_set_head_spec with "Hmodel'"). iIntros "Hmodel'".
    iApply "HΦ".
    iEval (rewrite -(take_drop i vs) Heq).
    rewrite insert_app_r_alt; last (rewrite take_length; lia).
    rewrite take_length min_l; last lia.
    rewrite Nat.sub_diag.
    iApply (chain_model_app_1 with "Hmodel Hmodel'").
  Qed.

  Lemma chain_unboxed t dq v vs dst :
    chain_model t dq (v :: vs) dst -∗
    ⌜val_is_unboxed t⌝.
  Proof.
    iIntros "(%l & %_ & -> & _) //".
  Qed.
End heapGS.

#[global] Opaque chain_cons.
#[global] Opaque chain_head.
#[global] Opaque chain_tail.
#[global] Opaque chain_set_head.
#[global] Opaque chain_set_tail.
#[global] Opaque chain_advance.
#[global] Opaque chain_get.
#[global] Opaque chain_set.

#[global] Opaque chain_model.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Import Lia.
Require Export CoRN.algebra.CMonoids.
Require Export CoRN.model.monoids.Nmonoid.

Section p71E1.

(**
** A function from the natural numbers to a cyclic monoid
%\begin{convention}%
Let [M:CMonoid], [c:M] and
[is_generated_by: forall(m:M),{n:nat | (power_CMonoid c n)[=]m}].
%\end{convention}%
*)

Variable M:CMonoid.
Variable c:M.

Definition power_CMonoid_CSetoid: M-> nat_as_CSetoid -> M.
Proof.
 simpl.
 exact (@power_CMonoid M).
Defined.

Variable is_generated_by: forall(m:M),{n:nat | (power_CMonoid c n)[=]m}.

Let f:= fun (H:forall(m:M),{n:nat | (power_CMonoid c n)[=]m})=>
  fun (n:nat_as_CMonoid)=> power_CMonoid c n.

Lemma f_strext: (fun_strext (f is_generated_by)).
Proof.
 unfold fun_strext; simpl.
 induction x; destruct y.
 - intros ? ?.
   pose proof (ax_ap_irreflexive M (@cs_eq  M) (@cs_ap M)) as H_irreflexive.
   unfold irreflexive, Not in H_irreflexive.
   elim H_irreflexive with (cm_unit M); auto using CSetoid_is_CSetoid.
 - firstorder lia.
 - firstorder lia.
 - unfold f.
   simpl.
   elim (@csg_op M).
   simpl.
   intros op op_strext H1.
   pose proof (op_strext c c (power_CMonoid c _) (power_CMonoid c _) H1) as [ H3 | ].
   + destruct (ap_irreflexive_unfolded M c H3).
   + firstorder.
Qed.

Definition f_as_CSetoid_fun:=
(Build_CSetoid_fun nat_as_CMonoid M (f is_generated_by) f_strext).

Lemma surjective_f: (surjective f_as_CSetoid_fun).
Proof.
 unfold surjective.
 simpl.
 intro b.
 elim (is_generated_by b).
 intros m H.
 exists m.
 unfold f.
 exact H.
Qed.

End p71E1.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (n0:natural) (y:lst) (IHy:@eq natural (len (qreva (Cons n x) y)) (plus (len (Cons n x)) (len y))):@eq natural (plus (len x) (Succ (Succ (len y))))
  (Succ (Succ (plus (len y) (len x)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal7_theorem0_55_plus_comm/".
QCInclude ".".
Extract Constant defNumTests => "50".
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.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (n0:natural) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x n0 y.
QuickChick collect_data.
Success.


Require Import Kami.AllNotations ProcKami.FU ProcKami.Div.
Require Import ProcKami.RiscvIsaSpec.Insts.Alu.AluFuncs.
Require Import List.

Section Alu.
  Context `{procParams: ProcParams}.

  Definition DivRemInputType
    := STRUCT_TYPE {
         "arg1"         :: Bit Xlen;
         "arg2"         :: Bit Xlen;
         "not_neg_quo?" :: Bool;
         "not_neg_rem?" :: Bool
       }.

  Definition DivRemOutputType
    := STRUCT_TYPE {
         "div" :: Bit Xlen ;
         "rem" :: Bit Xlen
       }.

  Local Open Scope kami_expr.

  Section Ty.
    Variable ty: Kind -> Type.

    Definition pos (n : nat) (x : Bit n @# ty)
      :  Bool @# ty
      := ZeroExtendTruncMsb 1 x == $0.

    Definition abs (n : nat) (x : Bit n @# ty)
      :  Bit n @# ty
      := ITE (pos x) x (neg x).

    Definition div_rem_pkt (x y : Bit Xlen @# ty) (not_neg_quo not_neg_rem : Bool @# ty)
      :  DivRemInputType ## ty
      := RetE
           (STRUCT {
             "arg1"         ::= x;
             "arg2"         ::= y;
             "not_neg_quo?" ::= not_neg_quo;
             "not_neg_rem?" ::= not_neg_rem
           } : DivRemInputType @# ty).

    Definition divu_remu_pkt (x y : Bit Xlen @# ty)
      :  DivRemInputType ## ty
      := div_rem_pkt x y ($$true) ($$true).

    Definition divs_rems_pkt (x y : Bit Xlen @# ty)
      :  DivRemInputType ## ty
      := div_rem_pkt
           (abs x)
           (abs y)
           (((pos x) == pos (y)) || (y == $0))
           (pos x).
  End Ty.

  Definition DivRem : FUEntry
    := {|
      fuName := "divRem";
      fuFunc
        := (fun ty (sem_in_pkt_expr : DivRemInputType ## ty)
            => LETE sem_in_pkt : DivRemInputType <- sem_in_pkt_expr;
                 LETE res <- div_rem_final (#sem_in_pkt @% "arg1")
                      (#sem_in_pkt @% "arg2");
                 RetE
                   ((STRUCT {
                       "div" ::= IF #sem_in_pkt @% "not_neg_quo?" then #res @% "quo" else neg (#res @% "quo");
                       "rem" ::= IF #sem_in_pkt @% "not_neg_rem?" then #res @% "rem" else neg (#res @% "rem")
                     }) : DivRemOutputType @# ty));
      fuInsts
      := {|
             instName   := "div";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01100") ::
                  fieldVal funct3Field ('b"100")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divs_rems_pkt
                          (xlen_sign_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg1"))
                          (xlen_sign_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg2")));
             outputXform
               := fun ty (res_expr : DivRemOutputType ## ty)
                    => LETE res <- res_expr;
                       RetE (intRegTag (SignExtendTruncLsb Rlen (#res @% "div")));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "divu";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01100") ::
                  fieldVal funct3Field ('b"101")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divu_remu_pkt
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg1"))
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg2")));
             outputXform
             := (fun ty (res_expr : DivRemOutputType ## ty)
                 => LETE res <- res_expr;
                      RetE (intRegTag (SignExtendTruncLsb Rlen (#res @% "div"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "divw";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01110") ::
                  fieldVal funct3Field ('b"100")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divs_rems_pkt
                         (sign_extend_trunc 32 Xlen (#context_pkt @% "reg1"))
                         (sign_extend_trunc 32 Xlen (#context_pkt @% "reg2")));
             outputXform
             := (fun ty (res_expr : DivRemOutputType ## ty)
                => LETE res <- res_expr;
                     RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "div"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "divuw";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01110") ::
                  fieldVal funct3Field ('b"101")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divu_remu_pkt
                          (zero_extend_trunc 32 Xlen (#context_pkt @% "reg1"))
                          (zero_extend_trunc 32 Xlen (#context_pkt @% "reg2")));
             outputXform
             :=
               (fun ty (res_expr : DivRemOutputType ## ty)
                => LETE res <- res_expr;
                     RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "div"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "rem";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01100") ::
                  fieldVal funct3Field ('b"110")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divs_rems_pkt
                          (xlen_sign_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg1"))
                          (xlen_sign_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg2")));
             outputXform
               := (fun ty (res_expr : DivRemOutputType ## ty)
                   => LETE res <- res_expr;
                        RetE (intRegTag (SignExtendTruncLsb Rlen (#res @% "rem"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "remu";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01100") ::
                  fieldVal funct3Field ('b"111")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divu_remu_pkt
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg1"))
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg2")));
             outputXform
               := (fun ty (res_expr : DivRemOutputType ## ty)
                   => LETE res <- res_expr;
                        RetE (intRegTag (SignExtendTruncLsb Rlen (#res @% "rem"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "remw";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01110") ::
                  fieldVal funct3Field ('b"110")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divs_rems_pkt
                          (sign_extend_trunc 32 Xlen (#context_pkt @% "reg1"))
                          (sign_extend_trunc 32 Xlen (#context_pkt @% "reg2")));
             outputXform
               := (fun ty (res_expr : DivRemOutputType ## ty)
                   => LETE res <- res_expr;
                        RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "rem"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           {|
             instName   := "remuw";
             xlens      := xlens_all;
             extensions := "M" :: nil;
             ext_ctxt_off := nil;
             uniqId
               := fieldVal instSizeField ('b"11")  ::
                  fieldVal opcodeField ('b"01110") ::
                  fieldVal funct3Field ('b"111")   ::
                  fieldVal funct7Field ('b"0000001") ::
                  nil;
             inputXform
               := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                   => LETE context_pkt <- context_pkt_expr;
                        divu_remu_pkt
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg1"))
                          (xlen_zero_extend Xlen (cfg_pkt @% "xlen") (#context_pkt @% "reg2")));
             outputXform
               := (fun ty (res_expr : DivRemOutputType ## ty)
                   => LETE res <- res_expr;
                        RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "rem"))));
             optMemParams := None;
             instHints   := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
           |} ::
           nil
      |}.

  Local Close Scope kami_expr.
End Alu.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype seq.
From mathcomp Require Import fintype choice ssrfun bigop poly ssralg.
From mathcomp Require Import ssrint finalg fingroup mxpoly countalg.

Require Import SsrMultinomials.freeg.
Require Import ec ecpoly eceval ecorder ecdiv ecrr ecdivlr.

(* -------------------------------------------------------------------- *)
Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Notation simpm := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Section ECGroup.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Import PreClosedField.

  Hint Resolve closedK.

  Local Notation "\- x"   := (@ECGroup.neg _ x).
  Local Notation "x \+ y" := (@ECGroup.add _ E x y).
  Local Notation "x \- y" := (x \+ (\- y)).

  Lemma addeA: associative (@ECGroup.addec K E).
  Proof.
    move=> [p oncve_p] [q oncve_q] [r oncve_r] /=.
    apply/eqP; rewrite !eqE /=; apply/eqP.
    rewrite -[p](lrpi _ oncve_p) // -[q](lrpi _ oncve_q) // -[r](lrpi _ oncve_r) //.
    have oncveD (D1 D2 : {freeg (point K)}):
      all oncurve (dom D1) -> all oncurve (dom D2) -> all oncurve (dom (D1 + D2)).
      move=> oncveD1 oncveD2; apply/allP=> s /domD_subset.
      rewrite mem_cat => /orP [];
        by [move/allP/(_ s): oncveD1 | move/allP/(_ s): oncveD2].
    rewrite -!lrD ?(degD, degN, degU, subrr) //;
      try by solve [ by apply: oncurve_lrpi
                   | by apply: oncveD; apply: oncurve_lrpi].
    by rewrite addrA.
  Qed.

  Definition ec_zmodMixin :=
    (ZmodMixin
       addeA (ECGroup.addeC (E := E))
       (ECGroup.add0e (E := E)) (ECGroup.addNe (E := E))).

  Definition ec_zmodType := ZmodType (ec E) ec_zmodMixin.
End ECGroup.

(* -------------------------------------------------------------------- *)
Section ECLift.
  Variable K   : ecuFieldType.
  Variable L   : fieldType.
  Variable E   : ecuType K.
  Variable f   : {rmorphism K -> L}.

  Local Notation "\- x"   := (@ECGroup.negec _ x).
  Local Notation "x \+ y" := (@ECGroup.addec _ _ x y).
  Local Notation "x \- y" := (x \+ (\- y)).

  Local Notation rmorphE :=
    (rmorph0, rmorph1, rmorphMn,rmorphX,
     fmorphV, rmorphM, rmorphB, rmorphD, rmorphN).

  Lemma eclift_inj: injective f.
  Proof. by apply/fmorph_inj. Qed.

  Lemma eclift_chi2: 2%:R != 0 :> L.
  Proof. by move: (ecu_chi2 K); rewrite -(inj_eq eclift_inj) !rmorphE. Qed.

  Lemma eclift_chi3: 3%:R != 0 :> L.
  Proof. by move: (ecu_chi3 K); rewrite -(inj_eq eclift_inj) !rmorphE. Qed.

  Lemma eclift_DN0: 4%:R * (f (E#a))^+3 + 27%:R * (f (E#b))^+2 != 0.
  Proof. by case: E=> a b /=; rewrite -(inj_eq eclift_inj) !rmorphE. Qed.

 (* curve parameters in the extension L *)
  Definition eclift : ecuType L := locked (Build_ecuType eclift_DN0).

  Lemma ecliftA: eclift#a = f (E#a).
  Proof. by rewrite /eclift; unlock. Qed.

  Lemma ecliftB: eclift#b = f (E#b).
  Proof. by rewrite /eclift; unlock. Qed.

  Definition eclift_point (p : point K) : point L :=
    if p is (|x, y|) then (|f x, f y|) else ∞.

  Lemma eclift_point_inj: injective eclift_point.
  Proof.
    case=> [|x1 y1]; case=> [|x2 y2] //= [].
    by move=> /eclift_inj -> /eclift_inj ->.
  Qed.

  Lemma eclift_oncurve (p : point K):
    oncurve E p = oncurve eclift (eclift_point p).
  Proof.
    case: p=> [|x y] //=; rewrite -(inj_eq eclift_inj).
    by rewrite !rmorphE -ecliftA -ecliftB.
  Qed.

  Lemma oncurve_eclift (p : point K):
    oncurve E p -> oncurve eclift (eclift_point p).
  Proof. by rewrite eclift_oncurve. Qed.

  (* takes a point of E(K) and uses oncurve_eclift to construct the
     proof that is also on E(L) and finally returns a point of E(L) *)
  Definition eclift_ec (p : ec E): ec eclift := locked (
    let: EC _ oncve := p in EC (oncurve_eclift oncve)).

  Lemma eclift_ecE (p : ec E): eclift_ec p = eclift_point p :> point L.
  Proof. by rewrite /eclift_ec; unlock; case: p. Qed.

  Lemma eclift_ec_inj: injective eclift_ec.
  Proof.
    move=> p1 p2 /eqP; rewrite eqE /= !eclift_ecE.
    move/eqP=> /eclift_point_inj eq; apply/eqP.
    by rewrite eqE /= eq.
  Qed.

  Lemma eclift_oncurve_ec (p : ec E):
    oncurve E p = oncurve eclift (eclift_ec p).
  Proof. by case: p=> p oncve /=; rewrite eclift_ecE /= eclift_oncurve. Qed.

  Definition ECULiftFieldMixin := ECUFieldMixin (eclift_chi2) (eclift_chi3).
  Definition ECULiftFieldType  := ECUFieldType L ECULiftFieldMixin.

  Local Notation LC := ECULiftFieldType.

  Lemma eclift_ec_add:
    {morph eclift_ec : p1 p2 / p1 \+ p2 >-> @ECGroup.addec LC eclift p1 p2}.
  Proof.
    move=> p1 p2 /=; apply/eqP; rewrite eqE /=.
    rewrite !eclift_ecE /= /ECGroup.add /=.
    rewrite -!eclift_oncurve !oncurve_ec.
    case: p1 p2=> [[|x1 y1]] oncve1 [[|x2 y2]] oncve2 //=.
    rewrite -[X in f y1 != X](rmorph0 f) !(inj_eq eclift_inj).
    case: (x1 == x2)=> /=; first case: (_ && _); move=> //=.
    + by rewrite !rmorphE -?(ecliftA, ecliftB) eqxx.
    + by rewrite !rmorphE -?(ecliftA, ecliftB) eqxx.
  Qed.
End ECLift.

(* -------------------------------------------------------------------- *)
Section ECGroupOfFin.
  Variable K : finECUFieldType.
  Variable E : ecuType K.

  Local Notation "\- x"   := (@ECGroup.negec _ x).
  Local Notation "x \+ y" := (@ECGroup.addec _ _ x y).
  Local Notation "x \- y" := (x \+ (\- y)).

  Lemma addeA_fin: associative (@ECGroup.addec K E).
  Proof.
    case (countable_algebraic_closure [countFieldType of K]) => L /= [i ir].
    have closedL: GRing.ClosedField.axiom L by apply/solve_monicpoly.
    pose LFT := ECULiftFieldType i.
    pose LDM := closed_field.closed_fields_QEMixin closedL.
    pose LDT := EcuDecFieldType LFT LDM.
    have h := (@addeA LDT (eclift E i) closedL) => p1 p2 p3.
    pose q1 := eclift_ec i p1; pose q2 := eclift_ec i p2; pose q3 := eclift_ec i p3.
    have {h}/eqP := (h q1 q2 q3); rewrite -!eclift_ec_add.
    by rewrite (inj_eq (eclift_ec_inj (f := i))) => /eqP ->.
  Qed.

  Definition finec_zmodMixin :=
    (ZmodMixin
       addeA_fin (ECGroup.addeC (E := E))
       (ECGroup.add0e (E := E)) (ECGroup.addNe (E := E))).

  Canonical finec_zmodType := Eval hnf in (ZmodType (@ec K E) finec_zmodMixin).
End ECGroupOfFin.

(* -------------------------------------------------------------------- *)
Section ECFinZModType.
  Variable K : finECUFieldType.
  Variable E : ecuType K.

  Canonical ec_finZmodType := Eval hnf in [finZmodType of ec E].
End ECFinZModType.

(* -------------------------------------------------------------------- *)
Section ECFinGroup.
  Variable K : finECUFieldType.
  Variable E : ecuType K.

  Canonical ec_baseFinGroupType := [baseFinGroupType of (ec E) for +%R].
  Canonical ec_finGroupType := [finGroupType of (ec E) for +%R].
End ECFinGroup.


(** Asymmetric encryption schemes

  In the stateful and probabilistic setting.
  This module defines:

    1. CPA_security    "security under chosen plaintext attacks"
    2. CPA_rnd_cipher  "cipher looks random"
    3. OT_secrecy      "one-time secrecy"
    4. OT_rnd_cipher   "cipher looks random when the key is used only once"

    4. -> 3. -> 2. -> 1

*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb
  pkg_core_definition choice_type pkg_composition pkg_rhl
  Package Prelude.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.

Import PackageNotation.

Local Open Scope ring_scope.

(* ASymmetric Schemes *)
Module Type AsymmetricSchemeParams.

  Parameter SecurityParameter : choiceType.
  Parameters Plain Cipher PubKey SecKey : finType.
  Parameter plain0 : Plain.
  Parameter cipher0 : Cipher.
  Parameter pub0 : PubKey.
  Parameter sec0 : SecKey.

End AsymmetricSchemeParams.

(** algorithms for Key Generation, Encryption and Decryption  **)
Module Type AsymmetricSchemeAlgorithms (π : AsymmetricSchemeParams).

  Import π.

  Local Open Scope package_scope.

  (* chX is the choice_type in bijection with X  *)
  (* Parameters chPlain chCipher chPubKey chSecKey : choice_type. *)
  Parameter Plain_pos : Positive #|Plain|.
  Parameter Cipher_pos : Positive #|Cipher|.
  Parameter PubKey_pos : Positive #|PubKey|.
  Parameter SecKey_pos : Positive #|SecKey|.

  #[local] Existing Instance Plain_pos.
  #[local] Existing Instance Cipher_pos.
  #[local] Existing Instance PubKey_pos.
  #[local] Existing Instance SecKey_pos.

  Definition chPlain := 'fin #|Plain|.
  Definition chCipher := 'fin #|Cipher|.
  Definition chPubKey := 'fin #|PubKey|.
  Definition chSecKey := 'fin #|SecKey|.

  Definition counter_loc : Location := ('nat ; 0%N).
  Definition pk_loc : Location := (chPubKey ; 1%N).
  Definition sk_loc : Location := (chSecKey ; 2%N).
  Definition m_loc  : Location := (chPlain ; 3%N).
  Definition c_loc  : Location := (chCipher ; 4%N).

  Definition kg_id : nat := 5.
  Definition enc_id : nat := 6.
  Definition dec_id : nat := 7.
  Definition challenge_id : nat := 8. (*challenge for LR *)
  Definition challenge_id' : nat := 9. (*challenge for real rnd *)
  Definition getpk_id : nat := 42. (* routine to get the public key *)

  (* Key Generation *)
  Parameter KeyGen :
    ∀ {L : {fset Location}},
      code L [interface] (chPubKey × chSecKey).

  (* Encryption algorithm *)
  Parameter Enc :
    ∀ {L : {fset Location}} (pk : chPubKey) (m : chPlain),
      code L [interface] chCipher.

  (* Decryption algorithm *)
  Parameter Dec_open :
    ∀ {L : {fset Location}} (sk : chSecKey) (c : chCipher),
      code L [interface] chPlain.

  Notation " 'plain " := chPlain (in custom pack_type at level 2).
  Notation " 'cipher " :=  chCipher (in custom pack_type at level 2).
  Notation " 'pubkey " :=  chPubKey (in custom pack_type at level 2).

End AsymmetricSchemeAlgorithms.

(* A Module for Asymmetric Encryption Schemes, inspired to Joy of Crypto *)
Module AsymmetricScheme (π : AsymmetricSchemeParams)
                        (Alg : AsymmetricSchemeAlgorithms π).

  Import π.
  Import Alg.

  (* Compatibitlity *)
  Definition i_plain := #|Plain|.
  Definition i_cipher := #|Cipher|.
  Definition i_pk := #|PubKey|.
  Definition i_sk := #|SecKey|.
  Definition i_bool := 2.

  Local Open Scope package_scope.

   (* Define what it means for an asymmetric encryption scheme to be: *)
   (** SECURE AGAINST CHOSEN-PLAINTEXT ATTACKS **)

  Definition L_locs : { fset Location } := fset [:: pk_loc ; sk_loc ].

  (* TODO INVESTIGATE:
    If I put _ instead of L_locs, the following loops.
    So probably some problem with how I try to infer \in?
   *)
  Definition L_pk_cpa_L :
    package
      L_locs
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain × 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id] ( mL_mR : 'plain × 'plain ) : 'cipher
      {
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk (fst mL_mR) ;;
        ret c
      }
    ].

  Definition L_pk_cpa_R :
    package
      L_locs
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain × 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id] ( mL_mR : 'plain × 'plain ) : 'cipher
      {
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk (snd mL_mR) ;;
        ret c
      }
    ].

  Definition cpa_L_vs_R :
    loc_GamePair [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id] : 'plain × 'plain → 'cipher
    ] :=
    λ b, if b then {locpackage L_pk_cpa_L} else {locpackage L_pk_cpa_R}.

  (** [The Joy of Cryptography] Definition 15.1

    A public-key encryption scheme is secure against chosen-plaintext attacks
    when the following holds.
  *)

  Definition CPA_security : Prop :=
    ∀ LA A,
      ValidPackage LA [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain × 'plain → 'cipher
      ] A_export A →
      fdisjoint LA (cpa_L_vs_R true).(locs) →
      fdisjoint LA (cpa_L_vs_R false).(locs) →
      Advantage cpa_L_vs_R A = 0.

  (* Define what it means for an asymmetric encryption scheme to: *)
  (** HAVE PSEUDORND CIPHERTEXT IN PRESENCE OF CHOSEN PLAINTEXT ATTACKS **)

  Definition L_pk_cpa_real :
    package L_locs
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id] (m : 'plain) : 'cipher
      {
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk m ;;
        ret c
      }
    ].

  Definition L_pk_cpa_rand :
    package L_locs
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id] (m : 'plain) : 'cipher
      {
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← sample uniform i_cipher ;;
        ret c
      }
    ].

  Definition cpa_real_vs_rand :
    loc_GamePair [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id] : 'plain → 'cipher
    ] :=
    λ b, if b then {locpackage L_pk_cpa_real } else {locpackage L_pk_cpa_rand }.

  (** [The Joy of Cryptography] Definition 15.2

    A public-key encryption scheme has pseudornd ciphertext against
    chosen-plaintext attacks when the following holds.
  *)

  Definition CPA_rnd_cipher : Prop :=
    ∀ LA A,
      ValidPackage LA [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain → 'cipher
      ] A_export A →
      fdisjoint LA (cpa_real_vs_rand true).(locs) →
      fdisjoint LA (cpa_real_vs_rand false).(locs) →
      Advantage cpa_real_vs_rand A = 0.

  (* Define what it means for an asymmetric encryption scheme to have: *)
  (** ONE-TIME SECRECY **)

  Definition L_locs_counter := fset [:: counter_loc ; pk_loc ; sk_loc ].

  Definition L_pk_ots_L :
    package L_locs_counter
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain × 'plain → 'cipher
      ]
    :=
    [package
      #def #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;
      #def #[challenge_id] (mL_mR : 'plain × 'plain) : 'cipher
      {
        count ← get counter_loc ;;
        #put counter_loc := (count + 1)%N;;
        #assert (count == 0)%N ;;
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk (fst mL_mR) ;;
        ret c
      }
    ].

  Definition L_pk_ots_R :
    package L_locs_counter
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] : 'plain × 'plain → 'cipher
      ]
    :=
    [package
      #def #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;
      #def #[challenge_id] (mL_mR :  'plain × 'plain) : 'cipher
      {
        count ← get counter_loc ;;
        #put counter_loc := (count + 1)%N;;
        #assert (count == 0)%N ;;
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk (snd mL_mR) ;;
        ret c
      }
    ].

  Definition ots_L_vs_R :
    loc_GamePair [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id] :'plain × 'plain → 'cipher
    ] :=
    λ b, if b then {locpackage L_pk_ots_L } else {locpackage L_pk_ots_R }.

  (** [The Joy of Cryptography] Definition 15.4

    A public-key encryption scheme is secure against chosen-plaintext attacks
    when the following holds.
  *)

  Definition OT_secrecy : Prop :=
    ∀ LA A,
      ValidPackage LA [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id] :'plain × 'plain → 'option 'cipher
      ] A_export A →
      fdisjoint LA (ots_L_vs_R true).(locs) →
      fdisjoint LA (ots_L_vs_R false).(locs) →
      Advantage ots_L_vs_R A = 0.

  (*  *)

  Definition L_pk_ots_real :
    package L_locs_counter
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id'] : 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id'] (m : 'plain) : 'cipher
      {
        count ← get counter_loc ;;
        #put counter_loc := (count + 1)%N;;
        #assert (count == 0)%N ;;
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← Enc pk m ;;
        ret c
      }
    ].

  Definition L_pk_ots_rnd :
    package L_locs_counter
      [interface]
      [interface
        #val #[getpk_id] : 'unit → 'pubkey ;
        #val #[challenge_id'] : 'plain → 'cipher
      ]
    :=
    [package
      #def  #[getpk_id] (_ : 'unit) : 'pubkey
      {
        pk ← get pk_loc ;;
        ret pk
      } ;

      #def #[challenge_id'] (m : 'plain) : 'cipher
      {
        count ← get counter_loc ;;
        #put counter_loc := (count + 1)%N;;
        #assert (count == 0)%N ;;
        '(pk, sk) ← KeyGen ;;
        #put pk_loc := pk ;;
        #put sk_loc := sk ;;
        c ← sample uniform i_cipher ;;
        ret c
      }
    ].

  Definition ots_real_vs_rnd :
    loc_GamePair [interface
      #val #[getpk_id] : 'unit → 'pubkey ;
      #val #[challenge_id'] : 'plain → 'cipher
    ] :=
    λ b, if b then {locpackage L_pk_ots_real } else {locpackage L_pk_ots_rnd }.

End AsymmetricScheme.


Require Import SystemState.
Require Import Objects.
Require Import ObjectLabels.
Require Import ObjectTypes.
Require Import ObjectSchedules.
Require Import OrderedTypeEx.
Require Import OrderedType.
Require Import FMapList2.
Require Import References.
Require Import Indices.
Require Import Capabilities.

Module MakePairSystemState (Ref: ReferenceType) (Cap:CapabilityType Ref) (Ind:IndexType) (Obj:ObjectType Ref Cap Ind) : SystemStateType Ref Cap Ind Obj.

  Module MapS := Make_fun Ref.
  Module P3 := PairOrderedType Obj ObjectLabel.
  Module P2 := PairOrderedType P3 ObjectType.
  Module P := PairOrderedType P2 ObjectSchedule.

  Module SysSt := Make_ord_fun Ref MapS P.

  Include SysSt.

  Module SysStFMapList_OT := MOT_to_OT SysSt.
  Definition eq_dec := SysStFMapList_OT.eq_dec.

End MakePairSystemState.