Require Import RelationClasses.
Require Import Coq.Logic.PropExtensionality.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Global.
Require Import Local.
Require Import Thread.

Require Import Cover.
Require Import Mapping.
Require Import PFConsistent.
Require Import Certify.

Require Import SrcToIRThread.

Set Implicit Arguments.

Module FutureCertify.
Section FutureCertify.
  Variable lang: language.

  Lemma future_get_inv
        mem1 mem2
        loc from to msg
        (FUTURE: Memory.future mem1 mem2)
        (GET2: Memory.get loc to mem2 = Some (from, msg)):
    forall f m
           (GET1: Memory.get loc to mem1 = Some (f, m)),
      f = from /\ m = msg \/ m = Message.reserve.
  Proof.
    induction FUTURE; i.
    { rewrite GET1 in *. inv GET2. auto. }
    destruct m; auto.
    exploit Memory.future_get1; try exact GET1.
    { econs 2; try exact H. refl. }
    i. des.
    exploit IHFUTURE; eauto.
  Qed.

  Lemma future_get
        rsv mem1 mem2
        loc from to msg
        (FUTURE: Memory.messages_le mem1 mem2)
        (LE1: Memory.le rsv mem1)
        (LE2: Memory.le rsv mem2)
        (GET1: Memory.get loc to mem1 = Some (from, msg))
        (MSG: msg <> Message.reserve \/
                exists f m, Memory.get loc to rsv = Some (f, m)):
    Memory.get loc to mem2 = Some (from, msg).
  Proof.
    des.
    - destruct msg; ss. eauto.
    - exploit LE1; eauto. i.
      rewrite x0 in GET1. inv GET1. eauto.
  Qed.

  Lemma map_get_merge
        rsv mem loc ts
        (LE: Memory.le rsv mem)
        (GET: (exists from to val released na,
                  Memory.get loc to mem = Some (from, Message.message val released na) /\
                  __guard__ (ts = from \/ ts = to)) \/
              (exists from to msg,
                  Memory.get loc to rsv = Some (from, msg) /\
                   __guard__ (ts = from \/ ts = to))):
    exists from to msg,
      Memory.get loc to mem = Some (from, msg) /\
      __guard__ (ts = from \/ ts = to).
  Proof.
    des; eauto. exploit LE; eauto.
  Qed.

  Lemma future_map
        rsv mem mem_future fmem
        mem_cap
        (ONLY: Memory.reserve_only rsv)
        (LE: Memory.le rsv mem)
        (CLOSED: Memory.closed mem)
        (FUTURE: Memory.messages_le mem mem_future)
        (FUTURE_LE: Memory.le rsv mem_future)
        (SIM: SrcToIRThread.sim_memory fmem mem_future)
        (CAP: Memory.cap mem mem_cap):
    exists f,
      (<<F: f = fun loc ts fts =>
                  ts = fts /\
                  ((exists from to val released na,
                       Memory.get loc to mem = Some (from, Message.message val released na) /\
                       __guard__ (ts = from \/ ts = to)) \/
                   (exists from to msg,
                       Memory.get loc to rsv = Some (from, msg) /\
                       __guard__ (ts = from \/ ts = to))) \/
                  ts = Time.incr (Memory.max_ts loc mem) /\
                  fts = Time.join
                          (Time.incr (Memory.max_ts loc mem))
                          (Time.incr (Memory.max_ts loc fmem))>>) /\
      (<<MAP_WF: map_wf f>>) /\
      (<<MAP: memory_map f rsv mem_cap fmem>>).
  Proof.
    esplits; [refl|..].
    { (* map_wf *)
      econs; ii; subst.
      { left. splits; ss. left.
        esplits; try eapply CLOSED; ss. left. ss.
      }
      { exists ((Time.incr (Memory.max_ts loc mem)) ::
                (List.concat
                   (List.map (fun e => [fst e; fst (snd e)]) (DOMap.elements (Cell.raw (mem loc)))))).
        i. des.
        - right. exploit DOMap.elements_correct; eauto. i.
          remember (DOMap.elements (Cell.raw (mem loc))) as l.
          clear - l x0 MAP1.
          revert ts from to val released na MAP1 x0.
          induction l; ss; i. des; eauto.
          subst. ss. unguard. des; auto.
        - right. exploit LE; eauto. i. clear MAP0.
          exploit DOMap.elements_correct; eauto. i.
          remember (DOMap.elements (Cell.raw (mem loc))) as l.
          clear - l x1 MAP1.
          revert ts from to msg MAP1 x1.
          induction l; ss; i. des; eauto.
          subst. ss. unguard. des; auto.
        - left. subst. ss.
      }
      { inv MAP1; inv MAP2; try by (des; subst; ss).
        - exfalso.
          inv H. exploit map_get_merge; try exact H2; ss. i. clear H2. des. subst.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts; eauto. i. des.
            { exploit Time.incr_spec. rewrite x1. i. timetac. }
            eapply Time.lt_strorder.
            etrans; [|exact x1].
            eapply TimeFacts.le_lt_lt; [|apply Time.incr_spec]. ss.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; eauto. apply Time.incr_spec.
        - exfalso.
          inv H0. exploit map_get_merge; try exact H2; ss. i. clear H2. des. subst.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts; eauto. i. des.
            { exploit Time.incr_spec. rewrite x1. i. timetac. }
            eapply Time.lt_strorder.
            etrans; [|exact x1].
            eapply TimeFacts.le_lt_lt; [|apply Time.incr_spec]. ss.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; eauto. apply Time.incr_spec.
      }
      { inv MAP1; inv MAP2; try by (des; subst; ss).
        - exfalso. inv H. inv H0.
          exploit map_get_merge; try exact H2; ss. i. clear H2. des.
          exploit Memory.max_ts_spec; eauto. i. des.
          unguard. des; subst.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; try exact MAX.
            exploit Memory.get_ts; try exact x0. i. des.
            { rewrite x2, <- x1.
              eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
              apply Time.incr_spec.
            }
            etrans; eauto.
            eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
            apply Time.incr_spec.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; try exact MAX.
            eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
            apply Time.incr_spec.
        - exfalso. inv H. inv H0.
          exploit map_get_merge; try exact H1; ss. i. clear H1. des.
          exploit Memory.max_ts_spec; eauto. i. des.
          unguard. des; subst.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; try exact MAX.
            exploit Memory.get_ts; try exact x0. i. des.
            { rewrite x2, <- x1.
              eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
              apply Time.incr_spec.
            }
            etrans; eauto.
            eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
            apply Time.incr_spec.
          + eapply Time.lt_strorder.
            eapply TimeFacts.le_lt_lt; try exact MAX.
            eapply TimeFacts.lt_le_lt; [|apply Time.join_l].
            apply Time.incr_spec.
      }
      { inv MAP1; inv MAP2; try by (des; subst; ss).
        - inv H. inv H0.
          exploit map_get_merge; try exact H2; ss. i. clear H2. des.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts_le; eauto. i.
            ett; try exact x1.
            ett; try exact MAX.
            tet; try apply Time.join_l.
            apply Time.incr_spec.
          + ett; try exact MAX.
            tet; try apply Time.join_l.
            apply Time.incr_spec.
        - exfalso. inv H. inv H0.
          exploit map_get_merge; try exact H1; ss. i. clear H1. des.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts_le; eauto. i.
            eapply Time.lt_strorder.
            ett; try exact x1.
            ett; try exact MAX.
            etrans; eauto.
            apply Time.incr_spec.
          + eapply Time.lt_strorder.
            ett; try exact MAX.
            etrans; eauto.
            apply Time.incr_spec.
        - des. subst. timetac.
      }
      { inv MAP1; inv MAP2; try by (des; subst; ss).
        - inv H. inv H0.
          exploit map_get_merge; try exact H2; ss. i. clear H2. des.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts_le; eauto. i.
            ett; try exact x1.
            ett; try exact MAX.
            apply Time.incr_spec.
          + ett; try exact MAX.
            apply Time.incr_spec.
        - exfalso. inv H. inv H0.
          exploit map_get_merge; try exact H1; ss. i. clear H1. des.
          exploit Memory.max_ts_spec; eauto. i. des. clear GET.
          unguard. des; subst.
          + exploit Memory.get_ts_le; eauto. i.
            eapply Time.lt_strorder.
            ett; try exact x1.
            ett; try exact MAX.
            etrans; eauto.
            tet; try apply Time.incr_spec.
            apply Time.join_l.
          + eapply Time.lt_strorder.
            ett; try exact MAX.
            etrans; eauto.
            tet; try apply Time.incr_spec.
            apply Time.join_l.
        - des. subst. timetac.
      }
    }

    { (* memory_map *)
      econs; i.
      { destruct msg; auto. right.
        exploit Memory.cap_inv; try exact GET; eauto. i. des; ss.
        exploit Memory.future_get1; try exact x0; eauto. i. des.
        inv SIM. exploit COMPLETE; eauto. i.
        esplits; try exact x2.
        - left. splits; ss.
          left. esplits; eauto. left. ss.
        - left. splits; ss.
          left. esplits; eauto. right. ss.
        - inv CLOSED. exploit CLOSED0; eauto. i. des.
          eapply closed_message_map; eauto. i.
          left. splits; ss.
          left. esplits; eauto. right. ss.
      }

      { destruct fmsg; cycle 1.
        { inv SIM. exploit GRESERVES; eauto. ss. }
        inv SIM. exploit SOUND; eauto. intro GET_FUTURE.
        specialize (Memory.min_exists
                      (fun to =>
                         Time.le fto to /\
                         (exists from msg,
                             Memory.get loc to mem = Some (from, msg) /\
                             __guard__ (
                                 msg <> Message.reserve \/
                                 exists f m, Memory.get loc to rsv = Some (f, m))))
                      loc mem). i. des.
        { (* future message after lastest *)
          specialize (Memory.max_exists
                        (fun to =>
                           (exists from msg,
                             Memory.get loc to mem = Some (from, msg) /\
                             __guard__ (
                                 msg <> Message.reserve \/
                                 exists f m, Memory.get loc to rsv = Some (f, m))))
                        loc mem). i. des.
          { exfalso. eapply NONE0; try apply CLOSED.
            esplits; try apply CLOSED. left. ss.
          }
          rewrite SAT in GET. inv GET.
          destruct (TimeFacts.le_lt_dec fto to_max).
          { exploit NONE; try exact SAT; ss. esplits; eauto. }
          exists to_max.
          exists (Time.join
                    (Time.incr (Memory.max_ts loc mem))
                    (Time.incr (Memory.max_ts loc fmem))).
          exists to_max.
          exists (Time.incr (Memory.max_ts loc mem)).
          splits.
          - exploit future_get; try exact SAT; eauto. i.
            exploit Memory.lt_get; try exact l; try exact x0; eauto.
          - exploit Memory.max_ts_spec; try exact FGET. i. des.
            etrans; eauto. etrans; [|apply Time.join_r].
            econs. apply Time.incr_spec.
          - left. split; ss. unguard. des.
            + left. destruct msg_max; ss. esplits; try exact SAT. auto.
            + right. esplits; try exact SAT0. auto.
          - right. ss.
          - i. eapply cap_covered; eauto.
            eapply Interval.le_mem; try exact ITV.
            econs; s; try refl. apply Time.bot_spec.
          - i. exploit LE; try exact GET. i.
            exploit MAX; try exact x0.
            { esplits; try exact x0. right. eauto. }
            ii. inv LHS. inv RHS. ss.
            exploit TimeFacts.lt_le_lt; try exact FROM0; try exact TO. i. timetac.
        }

        (* future message before latest *)
        rewrite SAT0 in GET. inv GET. inv SAT; cycle 1.
        { inv H. exploit future_get; try exact SAT0; eauto. i.
          exploit SOUND; eauto. i.
          rewrite x0 in *. inv x1.
          unguard. des; cycle 1.
          { exploit ONLY; eauto. i. subst.
            exploit LE; eauto. i. congr.
          }
          esplits; [refl|refl|..].
          - left. split; try refl. left. esplits; eauto.
          - left. split; try refl. left. esplits; eauto.
          - inv CAP. exploit SOUND0; eauto. i. econs; eauto.
          - i. exploit ONLY; eauto. i. subst.
            exploit LE; eauto. i.
            exploit Memory.get_disjoint; [exact x1|exact SAT0|]. i. des; ss.
        }
        exploit Memory.lt_get; try apply H; i.
        { eapply SOUND; eauto. }
        { eapply future_get; eauto. }
        specialize (Memory.max_exists
                      (fun to =>
                         Time.lt to fto /\
                         (exists from msg,
                             Memory.get loc to mem = Some (from, msg) /\
                             __guard__ (
                                 msg <> Message.reserve \/
                                 exists f m, Memory.get loc to rsv = Some (f, m))))
                      loc mem). i. des.
        { exfalso.
          destruct (Time.eq_dec fto Time.bot); subst.
          - exploit MIN; try apply CLOSED.
            { esplits; try refl; try apply CLOSED. left. ss. }
            i. exploit TimeFacts.lt_le_lt; try exact H; try exact x1. timetac.
          - eapply NONE; try apply CLOSED.
            esplits; try apply CLOSED; try (left; ss).
            specialize (Time.bot_spec fto). i. inv H0; ss. congr.
        }
        rewrite SAT2 in GET. inv GET; i.
        exploit Memory.lt_get; try exact SAT.
        { eapply future_get; try exact SAT2; eauto. }
        { eapply SOUND; eauto. }
        exists to_max, from_min, to_max, from_min.
        splits; ss.
        - left. split; ss. unguardH SAT3. des.
          + left. destruct msg_max; ss.
            esplits; try exact SAT2. right. ss.
          + right. esplits; try exact SAT3. right. ss.
        - left. split; ss. unguardH SAT1. des.
          + left. destruct msg_min; ss.
            esplits; try exact SAT0. left. ss.
          + exploit LE; eauto. i.
            rewrite x2 in *. inv SAT0.
            right. esplits; try exact SAT1. left. ss.
        - i. eapply cap_covered; eauto.
          eapply Interval.le_mem; try exact ITV.
          econs; s; try apply Time.bot_spec.
          exploit Memory.max_ts_spec; try exact SAT0. i. des.
          etrans; [|econs; apply Time.incr_spec].
          etrans; try exact MAX0.
          exploit Memory.get_ts; try exact SAT0. i. des; timetac.
        - ii. inv LHS. inv RHS. ss.
          exploit LE; eauto. i.
          destruct (TimeFacts.le_lt_dec fto t).
          + exploit MIN; try exact x3.
            { split; ss. esplits; eauto. right. eauto. }
            i. inv x4.
            * exploit Memory.lt_get; try exact H0; eauto. i.
              exploit TimeFacts.lt_le_lt; try exact FROM; try exact TO0. i.
              exploit Memory.get_ts; try exact SAT0. i. des; timetac.
              rewrite x6 in x5. timetac.
            * inv H0. rewrite x3 in *. inv SAT0. timetac.
          + exploit MAX; try exact x3.
            { split; ss. esplits; eauto. right. eauto. }
            i. exploit TimeFacts.lt_le_lt; try exact FROM0; try exact TO. i. timetac.
      }
    }
  Qed.

  Lemma future_certify
        fth
        th loc mem_future
        (STATE: Thread.state th = Thread.state fth)
        (TVIEW: Local.tview (Thread.local th) = Local.tview (Thread.local fth))
        (FPROMISES: Local.promises (Thread.local fth) = BoolMap.bot)
        (FUTURE: Memory.messages_le (Global.memory (Thread.global th)) mem_future)
        (SIM: SrcToIRThread.sim_memory (Global.memory (Thread.global fth)) mem_future)
        (LC_WF: Local.wf (Thread.local th) (Thread.global th))
        (GL_WF: Global.wf (Thread.global th))
        (LE_FUTURE: Memory.le (Local.reserves (Thread.local th)) mem_future)
        (FLC_WF: Local.wf (Thread.local fth) (Thread.global fth))
        (FGL_WF: Global.wf (Thread.global fth))
        (CERTIFY: certify loc (Thread.cap_of th)):
    @pf_certify lang loc fth.
  Proof.
    exploit Thread.cap_wf; try exact LC_WF; eauto. i. des.
    exploit future_map; try exact FUTURE; try exact SIM;
      try apply LC_WF; try apply GL_WF; ss.
    { apply Memory.cap_of_cap. }
    i. des.
    eapply map_certify; try exact CERTIFY; eauto.
    econs; ss.
    econs. rewrite <- TVIEW.
    eapply closed_tview_map; try apply LC_WF; eauto.
    i. subst. left. split; ss.
    left. esplits; eauto. right. ss.
  Qed.
End FutureCertify.
End FutureCertify.


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 Spec.

  Definition handle_icc_el1_sysreg_trap_spec (rec: Pointer) (esr: Z64) (adt: RData) : option RData :=
    match esr with
    | VZ64 esr =>
      rely is_int64 esr;
      rely (peq (base rec) buffer_loc);
      when gidx == (buffer (priv adt)) @ (offset rec);
      let gn := (gs (share adt)) @ gidx in
      rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
      rely (ref_accessible gn CPU_ID);
      let rt := __ESR_EL2_SYSREG_ISS_RT esr in
      rely is_int rt;
      if __ESR_EL2_SYSREG_IS_WRITE esr then
        Some adt
      else
        let g' := gn {grec: (grec gn) {g_regs: set_reg rt 0 (g_regs (grec gn))}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
    end.

End Spec.


(** * Implementation of Section 3.8 *)
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.

(** Proof of Lemma 3.43

    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))) (HR_covar n) ++ vec (snd (fst (fst x))) (HR_var n) ++ snd x)) L) ->
    HR_T (map (fun x => (vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x)) L).
Proof.
  intros L n H.
  remember (map (fun x => (vec (fst (fst (fst x))) (HR_covar n) ++ vec (snd (fst (fst x))) (HR_var n) ++ snd x)) L) as G.
  assert (Allperm G (map (fun x => (vec (fst (fst (fst x))) (HR_covar n) ++ vec (snd (fst (fst x))) (HR_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))) (HR_covar n) ++ vec (snd (snd (fst p))) (HR_var n) ++ snd p)
              :: (vec (fst (snd (fst p))) (HR_covar n) ++ vec (snd (snd (fst p))) (HR_var n) ++ snd p)
              :: map
              (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x)
              L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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''))) (HR_covar n) ++ vec (snd (snd (fst p''))) (HR_var n) ++snd p'') ; [ rewrite Heqp''; simpl; rewrite ? vec_app; Permutation_Type_solve | ]);
      change ((vec (fst (snd (fst p''))) (HR_covar n) ++ vec (snd (snd (fst p''))) (HR_var n) ++snd p'') :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) (L))
        with (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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) (HR_covar n) ++ vec (mul_vec r s2) (HR_var n) ++ seq_mul r T').
    { rewrite <- ? seq_mul_vec_mul_vec.
      rewrite ? seq_mul_app.
      reflexivity. }
    change ((vec (mul_vec r s1) (HR_covar n) ++ vec (mul_vec r s2) (HR_var n) ++ seq_mul r T') :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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_eq (n =? n0); [intros Heqn; apply Nat.eqb_eq in Heqn | intros Hneqn; apply Nat.eqb_neq in Hneqn].
    + subst.
      destruct p as [[[s1 r1] [s1' r1']] T1]; simpl in *.
      destruct (perm_decomp_vec_eq_2 T T1 r1 s1 r s (HR_var n0) (HR_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') (HR_covar n0) ++ vec (c1 ++ r1') (HR_var n0) ++ T').
      { rewrite ? vec_app.
        transitivity (vec s1' (HR_covar n0) ++ vec r1' (HR_var n0) ++ (vec c2 (HR_covar n0) ++ vec c1 (HR_var n0) ++ T')); try Permutation_Type_solve. }
      change ((vec (c2 ++ s1') (HR_covar n0) ++ vec (c1 ++ r1') (HR_var n0) ++ T')
                :: map
                (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                   vec (fst (snd (fst x))) (HR_covar n0) ++ vec (snd (snd (fst x))) (HR_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))) (HR_covar n0) ++ vec (snd (snd (fst x))) (HR_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 T T1 r s r1 s1 n0 n (not_eq_sym Hneqn) X) as [[T' D'] [H1' [H2' H3']]].
      apply hrr_ex_seq with (vec s (HR_covar n0) ++ vec r (HR_var n0) ++ vec s1' (HR_covar n) ++ vec r1' (HR_var n) ++ T').
      { Permutation_Type_solve. }
      apply hrr_ID; try assumption.
      change ((vec s1' (HR_covar n) ++ vec r1' (HR_var n) ++ T')
                :: map
                (fun x : list Rpos * list Rpos * (list Rpos * list Rpos) * list (Rpos * term) =>
                   vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 (HR_zero <> HR_covar n) as Hnc by now auto.
    assert (HR_zero <> HR_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_ID_case _ _ _ _ _ _ _ Hnc Hnv X) as [ [[[Ta Tb] Da ] Db] [H1' [[[H2' H3'] H4'] H5']]].
    apply hrr_ex_seq with (vec r HR_zero ++ vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 <> HR_covar n) as Hnc by now auto.
    assert (A +S B <> HR_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_ID_case _ _ _ _ _ _ _ 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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r A ++ vec r B ++ Db); [ Permutation_Type_solve | ].
    change ((vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r A ++ vec r B ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 <> HR_covar n) as Hnc by now auto.
    assert (r0 *S A <> HR_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_ID_case _ _ _ _ _ _ _ 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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec (mul_vec r0 r) A ++ Db).
    { Permutation_Type_solve. }
    change ((vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec (mul_vec r0 r) A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 <> HR_covar n) as Hnc by now auto.
    assert (A \/S B <> HR_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_ID_case _ _ _ _ _ _ _ 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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r B ++  Db).
    { Permutation_Type_solve. }
    change ((vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r B ++ Db) :: (vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
      with
        (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 <> HR_covar n) as Hnc by now auto.
    assert (A /\S B <> HR_var n) as Hnv by now auto.
    apply Permutation_Type_sym in X.
    destruct (perm_decomp_vec_ID_case _ _ _ _ _ _ _ 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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r A ++ Db).
      { Permutation_Type_solve. }
      change ((vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r A ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
        with
          (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r B ++ Db).
      { Permutation_Type_solve. }
      change ((vec (fst (snd r1)) (HR_covar n) ++ vec (snd (snd r1)) (HR_var n) ++ vec r B ++ Db) :: map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_var n) ++ snd x) L)
        with
          (map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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.

(** Proof of Lemma 3.41 *)
Lemma hrr_atomic_can_elim : forall G T n r s,
    sum_vec r = sum_vec s ->
    HR_T ((vec s (HR_covar n) ++ vec r (HR_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))) (HR_covar n) ++ vec (snd (fst (fst x))) (HR_var n) ++ snd x) L)
                  (( G =  map (fun x  => vec (fst (snd (fst x))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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))) (HR_covar n) ++ vec (snd (snd (fst x))) (HR_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 r' s' Heq pi.
  - apply hrr_atomic_can_elim with n r' s'; try assumption.
  - apply hrr_atomic_can_elim with n s' r'; try nra.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_M_elim.
    apply hrr_Z_inv with r'.
    apply hrr_Z_inv with s'.
    apply HR_le_frag with (hr_frag_T); auto.
    repeat split.
  - apply (IHA1 G T r' s' Heq).
    apply (IHA2 G (vec s' (-S A1) ++ vec r' A1 ++ T) r' s' Heq).
    apply hrr_M_elim.
    apply hrr_ex_seq with (vec r' A1 ++ vec r' A2 ++ vec s' (-S A2) ++ vec s' (-S A1) ++ T); [ Permutation_Type_solve | ].
    apply hrr_plus_inv.
    apply hrr_ex_seq with (vec s' (-S A1) ++ vec s' (-S A2) ++ vec r' (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 r') (mul_vec r s')).
    { rewrite ? mul_vec_sum_vec; nra. }
    apply hrr_M_elim.
    apply hrr_mul_inv.
    apply hrr_ex_seq with (vec (mul_vec r r') A ++ vec s' (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 r' s' Heq).
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply (IHA1 ((vec s' (-S A2) ++ vec r' A2 ++ T) :: G) T r' s' Heq).
    apply hrr_M_elim.
    apply hrr_min_inv_l with (-S A2).
    apply hrr_ex_seq with (vec r' A1 ++ vec s' (-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 r' A2 ++ vec s' (-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 r' s' Heq).
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply (IHA1 ((vec s' (-S A2) ++ vec r' A2 ++ T) :: G) T r' s' Heq).
    apply hrr_M_elim.
    apply hrr_ex_seq with (vec r' A1 ++ vec s' (-S A1) ++ T); [ Permutation_Type_solve | ].
    apply hrr_min_inv_l with A2.
    apply hrr_ex_seq with (vec s' (-S A1) ++ vec r' (A1 /\S A2) ++ T); [Permutation_Type_solve | ].
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply hrr_ex_seq with (vec r' A2 ++ vec s' (-S A2) ++ T); [ Permutation_Type_solve | ].
    apply hrr_min_inv_r with A1.
    apply hrr_ex_seq with (vec s' (-S A2) ++ vec r' (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.

(** Proof of Theorem 3.13 *)
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.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal30.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst):@eq lst (append (rev (append l1 Nil)) (Cons n Nil))
  (append (rev l1) (Cons n Nil)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal30_rev_append_57_append_nil/".
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) (l1:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1.
QuickChick collect_data.
Success.


Require Import Vloc.Lib.core.
Require Import Vloc.Lib.pure.

(* NOTE: I feel like this should exist somewhere? *)
Lemma share_split_nonempty sh:
  sh ≠ emptyshare -> fst (Share.split sh) ≠ emptyshare /\ snd (Share.split sh) ≠ emptyshare.
Proof.
  intros Hne.
  remember ((Share.split sh).1) as shl.
  remember ((Share.split sh).2) as shr.
    split.
    (* weirdly, connecting these via ; instead of 1,2: does not work *)
    1,2: intros Hfalse;
      specialize (Share.split_nontrivial) with shl shr sh; intros Hsnontriv;
      subst;
      specialize surjective_pairing with _ _ (Share.split sh); intros Hspliteq;
      apply Hsnontriv in Hspliteq; last auto;
      contradiction.
Qed.

Section heap.

Context `{ref_ctx: refines_ctx}.
(* Some helper lemmas *)
(* NOTE: what is the equivalent of cmra.included? *)
  Lemma tpool_singleton_included (tp : list iexp) (j : nat) (e : iexp) :
    join_sub {[j := Some e]} (to_tpool tp) → tp !! j = Some e.
  Proof.
    unfold join_sub.
    intros [g Hjoin].
    Set Printing Implicit.
    unfold tpool_ghost in *.
    (* We cannot reach such heights of perfection.  It was not intended for us *)
    (*apply (join_ord (PCM_order := gmap_order (A_order := discrete_order))) in Hjoin.*)
    specialize (Hjoin j).
    rewrite lookup_singleton in Hjoin.
    inv Hjoin; auto.
    inv H2; auto.
    contradiction.
  Qed.
    (*move=> /singleton_included_l [ex [/leibniz_equiv_iff]].*)
    (*rewrite tpool_lookup fmap_Some=> [[e' [-> ->]] /Excl_included ?]. by f_equal.*)
  (*Qed.*)
  Lemma tpool_singleton_included' tp j e :
    join_sub {[j := Some e]} (to_tpool tp) → to_tpool tp !! j = (Some (Some e)).
  Proof. rewrite tpool_lookup. by move=> /tpool_singleton_included=> ->. Qed.

  (* If any part of the tpool has a thread in it, the overall thread pool has that in it *)
  Lemma tpool_ref_sub_lookup j v sh gName (tp' : @G tpool_ghost) (σ' : @G heap_ghost) tp σ:
    ghost_part (P:=spec_ghost) sh (tp', σ') gName
    * ghost_reference (P:=spec_ghost) (to_tpool tp, to_heap (heap σ)) gName
     |-- (!! ((tp' !! j = Some (Some v) -> (to_tpool tp) !! j = Some (Some v)))).
  Proof.
    iIntros  "[Part Ref]".
    iDestruct (ref_sub (P := spec_ghost) with "[$Part $Ref]") as "%Hjoin".
    iPureIntro.
    if_tac in Hjoin.
    - inversion Hjoin; subst; auto.
    - intros Hsome.
      inv Hjoin.
      inv H0.
      specialize (H1 j).
      inv H1.
      (* impossible case *)
      { rewrite Hsome in H3; inv H3. }
      (* actual case *)
      rewrite Hsome in H5; auto.
      (* show that we can't have any other possibility *)
      inv H5.
      + rewrite Hsome in H0; inv H0.
      + rewrite Hsome in H0; rewrite H0 in H4; auto.
      + inv H1.
  Qed.

  (* If a part of the heap has a value in it, the rest of the heap has to as well *)
  Lemma heap_ref_sub_lookup (l : loc) v vsh' gName (sh : Share.t) (tp' : @G tpool_ghost) (σ' : @G heap_ghost) tp σ:
    ghost_part (P:=spec_ghost) sh (tp', σ') gName
    * ghost_reference (P:=spec_ghost) (to_tpool tp, to_heap (heap σ)) gName
     |-- (!! (
      (σ' !! l = Some (Some (vsh', v))) -> (exists vsh, (to_heap (heap σ)) !! l = Some (Some (vsh, v))))).
  Proof.
    iIntros "[Part Ref]".
    iDestruct (ref_sub (P := spec_ghost) with "[$Part $Ref]") as "%Hjoin".
    iPureIntro.
    intros Hsome.
    if_tac in Hjoin.
    (* full share means they agree by default *)
    { exists vsh'; inv Hjoin; subst; auto. }
    (* if we don't have full share, we have to show they agree *)
    inv Hjoin; inv H0.
    specialize (H2 l); inv H2.
    (* same set of cases, essentially *)
    { rewrite Hsome in H3; inv H3. } (* None != Some *)
    { rewrite Hsome in H5; exists vsh'; auto. } (* other joined piece is None, so equal *)

    (* Both x and our ghost_part are pieces and join *)
    (* here we prove that no matter what share we have or what x is, we get the same value v in the heap *)
    destruct a1; [|rewrite Hsome in H0; inv H0]. (* Hone != Some but different *)
    assert (p = (vsh', v)) by (rewrite Hsome in H0; inv H0; auto); subst. (* we already know what p is *)
    (* What values can the overall heap store at l? *)
    destruct a3.
    - destruct p.
      exists s.
      apply eq_sym in H4; rewrite H4.
      destruct a2.
      + destruct p.
        inv H5; destruct H6 as [Hs0NE [Hshjoin Hvjoin]].
        inv Hvjoin.
        reflexivity.
      + inv H5.
        reflexivity.
    (* in this case, we show that we can't somehow get None from Some, but again *)
    - destruct a2.
      + destruct p.
        inv H5.
      + inv H5.
  Qed.

(* taken and modified from theories/logic/spec_rules.v *)
(* Questions:
    - Is (pos_to_Qp 1) equivalent to top?
    -
   Notes:
    ref is notation for (AllocN (Val (LitV 1%Z)))
 *)
  Lemma step_alloc E j K e v :
    IntoVal e v →
    nclose nspace ⊆ E →
    spec_ctx ∗ tpool_mapsto j (fill K (AllocN (Val (LitV (LitInt 1%Z))) e)) ={E}=∗ ∃ l, spec_ctx ∗ tpool_mapsto j (fill K (Val (LitV (LitLoc l)))) ∗ (heapS_mapsto fullshare l v).
  Proof.
    iIntros (<-?) "[#Hinv Hj]". iFrame "Hinv".
    iDestruct "Hj" as (sh) "[Hne Hj]".
    iPure "Hne" as shNE.
    rewrite /spec_ctx /tpool_mapsto /=.
    iDestruct "Hinv" as (ρ) "Hinv".
    iInv nspace as (tp σ) ">[% Hown]" "Hclose".
    destruct (exist_fresh (dom (heap σ))) as [l Hl%not_elem_of_dom].

    (* modification to use VST's update semantics rather than iris *)

    (* we need to know later that j is in the thread pool,
       so we prove it now while we have Hj and Hown around *)
    iDestruct (tpool_ref_sub_lookup j with "[$Hj $Hown]") as "%HhasJ";
      rewrite lookup_singleton in HhasJ;
      specialize (HhasJ eq_refl).

    iCombine "Hj Hown" as "Hown".

    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "Hown") as "Hown".
    (*NOTE: updating heap! *)
    iDestruct ((part_ref_update (P:= spec_ghost) _ _ _ _
      (({[j := Some (fill K (Val (LitV (LitLoc l))))]}), {[ l := Some (fullshare, Some v) ]})
      ((<[ j := Some (fill K (Val (LitV (LitLoc l)))) ]> (to_tpool tp)),
      (* NOTE: We need the "post-to-heap" version of the update here, not the original, so we include the share *)
      (<[l := Some (fullshare, Some v) ]> (to_heap (heap σ)))))
        with "Hown") as ">Hown".
      (* NOTE: This is nearly the same as pure at the start, how do I generalize it? *)
    {
      intros (tp_frame, heap_frame) Hjoin.
      split.
      - destruct Hjoin as [Htp Hheap].
        split; simpl in *.
        * iIntros (k).
          destruct (eq_dec k j).
          + subst.
            rewrite lookup_singleton.
            specialize (Htp j).
            rewrite lookup_singleton in Htp; rewrite lookup_insert.
            inv Htp; constructor.
            inv H4; constructor.
            inv H5.
          + rewrite ! lookup_insert_ne; auto.
            rewrite lookup_empty.
            pose proof Htp k as Htpk.
            rewrite lookup_singleton_ne in Htpk; auto.
        * intros index.
          destruct (decide (index = l)); subst.
          + specialize (Hheap l).
            rewrite lookup_fmap in Hheap.
            rewrite lookup_fmap in Hheap.
            rewrite Hl in Hheap.
            rewrite lookup_singleton lookup_insert.
            (* NOTE: what is the difference here? *)
            inv Hheap; [rewrite H1|]; apply lower_None2.
          + rewrite lookup_singleton_ne.
            rewrite lookup_insert_ne; auto.
            (* This does so much work I didn't believe it *)
            specialize (Hheap index); auto.
            auto.
      - intros Oldg.
        inv Oldg.
        rewrite insert_singleton.
        unfold to_heap.
        setoid_rewrite fmap_empty.
        rewrite insert_empty.
        reflexivity.
    }
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "[$Hown]") as "[Hj Hown]".
    (*iDestruct (own_valid_2 with "Hown Hj")*)
      (*as %[[?%tpool_singleton_included' _]%prod_included ?]%auth_both_valid_discrete.*)
    (*iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".*)
    (*{ by eapply auth_update, prod_local_update_1,*)
        (*singleton_local_update, (exclusive_local_update _ (Excl (fill K (#l)%E))). }*)
    (*iMod (own_update with "Hown") as "[Hown Hl]".*)
    (*{ eapply auth_update_alloc, prod_local_update_2,*)
        (*(alloc_singleton_local_update _ l (1%Qp,to_agree (Some v : leibnizO _))); last done.*)
      (*by apply lookup_to_heap_None. }*)
    iExists l.
    rewrite /UsrGhost /heapS_mapsto.
    destruct (Share.split sh) as [shl shr] eqn:Hshplit.
    (* Split Hj into two pieces, one for the heap and one for the map *)
    (*remember ((Share.split sh).1) as shl.*)
    (*remember ((Share.split sh).2) as shr.*)
    (* prove that the shares can't be empty; we need this fact in multiple places *)
    specialize (share_split_nonempty sh shNE).
    rewrite Hshplit.
    simpl.
    intros HshrsNE; destruct HshrsNE as [HshlNE HshrNE].
    (* now we know the shares are not empty everywhere *)
    iDestruct (ghost_part_join (P:=spec_ghost) shl shr sh
      ({[j := Some (fill K (Val (LitV (LitLoc l))))]}, to_heap gmap_empty)
      (to_tpool [], {[l := Some (fullshare, Some v)]})
      ({[j := Some (fill K (Val (LitV (LitLoc l))))]}, {[l := Some (fullshare, Some v)]})
      gName
    ) as "[_ Himpl ]"; eauto.
    {
      apply split_join.
      auto.
    }
    (* prove that the update joins properly *)
    {
      split; intros index;
      setoid_rewrite fmap_empty; rewrite lookup_empty; simpl.
      - apply lower_None2.
      - apply lower_None1.
    }

    (* Above gives us an implication to follow which we have to apply and break apart *)
    iDestruct ("Himpl" with "Hj") as "[Htp Hheap]".
    iClear "Himpl".

    iApply fupd_frame_l.
    iSplitL "Htp".
    (* not an empty share *)
    { iExists shl; iFrame; auto. }
    rewrite /heapS_mapsto /=.
    iExists shr.
    rewrite /UsrGhost.
    (* also not an empty share *)
    iApply fupd_frame_l; iSplitR; auto.
    iFrame "Hheap".
    iApply "Hclose". iNext.
    iExists (<[j:=fill K (Val (LitV (LitLoc l)))]> tp), (state_upd_heap <[l:=Some v]> σ).

    (* we need the HhasJ here for to_tpool_insert' *)
    rewrite to_heap_insert to_tpool_insert'; last auto.
    iFrame; iSplit; auto. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto.
    rewrite -state_init_heap_singleton. eapply AllocNS; first by lia.
    intros. assert (i = 0) as -> by lia. by rewrite loc_add_0.
  Qed.

  Lemma ref_right_alloc E ctx K e v:
    IntoVal e v →
    nclose nspace ⊆ E →
    refines_right ctx (fill K (AllocN (Val (LitV (LitInt 1%Z))) e))
    |-- |={E}=> EX l, refines_right ctx (fill K (Val (LitV (LitLoc l)))) * l |-> v.
  Proof.
    intros HIV Hnspace.
    iIntros "[Rctx Rtp]".
    rewrite <- fill_app.
    iDestruct (step_alloc with "[Rctx Rtp]") as "Rstepped"; first apply Hnspace.
    { iFrame. }
    iMod "Rstepped".
    iDestruct "Rstepped" as (l) "[Rctx [Rtp Rpt]]".
    iModIntro.
    iExists l.
    iFrame.
    rewrite <- fill_app.
    auto.
  Qed.

  Lemma step_load E j K l hSh v:
    nclose nspace ⊆ E →
    spec_ctx ∗ (tpool_mapsto j (fill K (Load (Val (LitV (LitLoc l)))))) ∗ (heapS_mapsto hSh l v)
    ={E}=∗ (spec_ctx ∗ (tpool_mapsto j (fill K (of_val v))) ∗ (heapS_mapsto hSh l v)).
  Proof.
    iIntros (?) "(#Hinv & [[%sj [Hsjne Hj]] [%sl [Hslne Hl]]])". iFrame "Hinv".
    iDestruct "Hsjne" as %Hsjne.
    iDestruct "Hslne" as %Hslne.
    rewrite /spec_ctx /spec_inv /tpool_mapsto.
    iDestruct "Hinv" as (ρ) "Hinv".
    rewrite /heapS_mapsto /=.
    iInv nspace as (tp σ) ">[% Hown]" "Hclose".
    rewrite /UsrGhost.
    (* before we do any updates, we want to pull out that both things are in the main heap *)
    iDestruct (tpool_ref_sub_lookup j with "[$Hown $Hj]") as "%HtpJ";
      rewrite lookup_singleton in HtpJ;
      specialize (HtpJ eq_refl).
    iDestruct (heap_ref_sub_lookup l with "[$Hown $Hl]") as "%Hheapl";
      rewrite lookup_singleton in Hheapl;
      specialize (Hheapl eq_refl);
      destruct Hheapl as [valueShare Hheapl].

    (* Now we can update the load to the value *)
    iCombine "Hj Hown" as "Hown".
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "Hown") as "Hown".
    iDestruct (part_ref_update (P:= spec_ghost) _ _ _ _
    ({[j := Some (fill K (Val v))]}, to_heap gmap_empty)
     (<[j := Some (fill K (Val v)) ]> (to_tpool tp), to_heap (heap σ)) with "Hown") as ">Hown".
    {
      intros g Hjoin.
      split.
      (* the new values can join *)
      - inv Hjoin; simpl in H1, H2.
        pose proof (H1 j) as Hj.
        rewrite lookup_singleton HtpJ in Hj.
        inv Hj; subst.
        (* g does not cointain j *)
        {
          split; auto.  (* heap doesn't change *)
          intros thread.
          destruct (eq_dec thread j); subst.
          - simpl.
            rewrite lookup_singleton.
            rewrite lookup_insert.
            rewrite <- H5.
            apply lower_None2.
          - simpl.
            rewrite lookup_singleton_ne; auto.
            rewrite lookup_insert_ne; auto.
            pose proof (H1 thread) as Htd.
            inv Htd; first apply lower_None1.
            {
              rewrite lookup_singleton_ne; auto.
              apply lower_None1.
            }
            {
              rewrite lookup_singleton_ne in H3; auto.
              inv H3.
            }
        }
        (* g contains j *)
        {
          split; auto.
          intros thread.
          destruct (decide (thread = j)); subst.
          - simpl.
            rewrite lookup_singleton.
            rewrite lookup_insert.
            inv H6.
            { rewrite <- H4; apply lower_Some; apply lower_None2. }
            { inv H8. }
          - rewrite lookup_singleton_ne; auto.
            rewrite lookup_insert_ne; auto.
            pose proof (H1 thread) as Htd.
            inv Htd.
            { rewrite H8; apply lower_None1. }
            {
              rewrite lookup_singleton_ne in H8; auto.
              (* It didn't want to let me rewrite None = _ equations so we do this *)
              rewrite H8 in H7.
              rewrite H7.
              apply lower_None1.
            }
            inv H8.
            { rewrite H5 in H7; rewrite H7; apply lower_None1. }
            { rewrite lookup_singleton_ne in H3; auto; inv H3. }
            inv H9.
        }
      (* show that if this is the only piece they're equal *)
      - intros Hsub.
        inv Hsub; subst.
        rewrite insert_singleton.
        reflexivity.
    }
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "[$Hown]") as "[Hj Hown]".
    iMod ("Hclose" with "[Hown]") as "_".
    {
    iNext.
    iExists (<[j:=fill K (of_val v)]> tp), σ.
    rewrite to_tpool_insert'; last eauto. iFrame. iPureIntro.
    split; auto.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
    rewrite /to_heap in Hheapl.
    rewrite lookup_fmap in Hheapl.
    destruct (heap σ !! l) eqn:Hpos; rewrite Hpos in Hheapl; simpl; try discriminate.
    simpl in Hheapl.
    inv Hheapl.
    reflexivity.
    }
    iModIntro.
    iSplitL "Hj".
    { iExists sj; iFrame; iPureIntro; auto. }
    iExists sl.
    iSplitR; first (iPureIntro; auto).
    iFrame.
  Qed.

  Lemma ref_right_load E ctx K l sh v:
    nclose nspace ⊆ E →
    (refines_right ctx (fill K (Load (Val (LitV (LitLoc l))))) * (heapS_mapsto sh l v)
     |-- |={E}=> refines_right ctx (fill K (of_val v)) * (heapS_mapsto sh l v))%logic.
  Proof.
    intros Hnspace.
    unfold refines_right.
    iIntros "[[Rctx Rtp] Rlv]".
    iPoseProof (step_load with "[Rctx Rtp Rlv]") as "Rstep"; first apply Hnspace.
    {
      iFrame "Rctx".
      rewrite <- fill_app.
      iSplitL "Rtp".
      iApply "Rtp".
      iApply "Rlv".
    }
    iMod "Rstep".
    iDestruct "Rstep" as "(Rctx & Rtp & Rpt)".
    iModIntro.
    rewrite <- fill_app.
    iFrame.
  Qed.

Lemma step_store E j K l v' e v:
    IntoVal e v →
    nclose nspace ⊆ E →
    spec_ctx ∗ (tpool_mapsto j (fill K (Store (Val (LitV (LitLoc l))) e))) ∗ (heapS_mapsto fullshare l v')
    ={E}=∗ spec_ctx ∗ (tpool_mapsto j (fill K (Val (LitV LitUnit)))) ∗ (heapS_mapsto fullshare l v).
  Proof.
    iIntros (<-?) "(#Hinv & [[%sj [Hsjne Hj]] [%sl [Hslne Hl]]])". iFrame "Hinv".
    iDestruct "Hsjne" as %Hsjne.
    iDestruct "Hslne" as %Hslne.
    rewrite /spec_ctx /tpool_mapsto.
    iDestruct "Hinv" as (ρ) "Hinv".
    iInv nspace as (tp σ) ">[% Hown]" "Hclose".
    rewrite /heapS_mapsto /=.

    (* we probably need the fact that the things in the heap exist *)
    iDestruct (tpool_ref_sub_lookup j with "[$Hown $Hj]") as "%HtpJ";
      rewrite lookup_singleton in HtpJ;
      specialize (HtpJ eq_refl).
    iDestruct (heap_ref_sub_lookup l with "[$Hown $Hl]") as "%Hheapl";
      rewrite lookup_singleton in Hheapl;
      specialize (Hheapl eq_refl);
      destruct Hheapl as [valueShare Hheapl].

    (* we need to update both "Hj" and "Hl" and the heap and thread pool *)
    (* First the "tpool_mapsto" *)
    iCombine "Hj Hown" as "Hown".
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "Hown") as "Hown".
    iDestruct (part_ref_update (P:= spec_ghost) _ _ _ _
    ({[j := Some (fill K (Val (LitV LitUnit)))]}, to_heap gmap_empty)
    (<[j := Some (fill K (Val (LitV LitUnit))) ]> (to_tpool tp), to_heap (heap σ)) with "Hown") as ">Hown".
    {
      intros g Hj.
      split.
      (* these values join properly *)
      {
        destruct Hj as [Htp Hheap].
        split; auto. (* we only changed the thread pool here *)
        simpl.
        clear Hheap.
        (* now we prove this joins for any arbitrary thread *)
        intros thread.
        specialize (Htp thread).
        destruct (eq_dec thread j); subst.
        - rewrite lookup_singleton in Htp.
          rewrite lookup_singleton.
          rewrite lookup_insert.
          inv Htp.
          { apply lower_None2. }
          inv H4.
          { apply lower_Some; apply lower_None2. }
          inv H5.
        - rewrite ? lookup_insert_ne; auto.
          rewrite ? lookup_insert_ne in Htp; auto.
      }
      (* if this is the only piece, it still joins *)
      {
        intros Heq; inv Heq.
        rewrite insert_singleton.
        reflexivity.
      }
    }
    (* don't forget to break up the ghost_part_ref *)
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "[$Hown]") as "[Hj Hown]".

    (* now the "heapS_mapsto" *)
    iCombine "Hl Hown" as "Hown".
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "Hown") as "Hown".
    (* NOTE: we include the prior update in this!!!  We'd be "removing" otherwise if we could even prove it *)
    iDestruct (part_ref_update (P:= spec_ghost) _ _ _ _
    (to_tpool [], {[l := Some (fullshare, Some v)]})
    (<[j:=Some (fill K (Val (LitV LitUnit)))]> (to_tpool tp), <[l := Some (fullshare, Some v)]> (to_heap (heap σ))) with "Hown") as ">Hown".
    {
      intros g Hhp.
      split.
      (* The update joins *)
      {
        destruct Hhp as [Htp Hhp].
        simpl in Htp, Hhp.
        simpl.
        split; auto.
        clear Htp. (* we don't care about the thread pool since it's static *)
        intros loc.
        simpl.
        destruct (decide (loc = l)); subst.
        (* loc = l *)
        - specialize (Hhp l).
          rewrite ? lookup_insert in Hhp.
          rewrite ? lookup_insert.
          inv Hhp.
          { apply lower_None2. }
          apply lower_Some.
          destruct a3.
          {
            destruct p.
            destruct a2.
            - destruct p.
              inv H4.
              destruct H5; destruct H5.
              apply join_Tsh in H5.
              inv H5.
              contradiction.
            - unfold sepalg.join.
              reflexivity.
          }
          {
            destruct a2.
            - destruct p.
              inv H4.
            - inv H4.
          }
        (* loc ≠ l *)
        - specialize (Hhp loc).
          rewrite ? lookup_insert_ne; auto.
          rewrite ? lookup_insert_ne in Hhp; auto.
      }
      (* if this is the only piece it is the full *)
      {
        intros Heq.
        inv Heq.
        rewrite insert_singleton.
        rewrite H2.
        reflexivity.
      }
    }
    iDestruct (ghost_part_ref_join (P:= spec_ghost) with "[$Hown]") as "[Hl Hown]".
    rewrite /UsrGhost.
    iMod ("Hclose" with "[Hown]") as "_".
    {
    iNext.
    rewrite /spec_inv.
    iExists (<[j:=fill K (Val (LitV LitUnit))]> tp), (state_upd_heap <[l:=Some v]> σ).
    rewrite to_heap_insert to_tpool_insert'; last eauto. iFrame. iPureIntro; split; auto.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.

    (* show we *did* in fact have something in the heap *)
    (* NOTE: if I find a better way to do this, update it here too! *)
    rewrite /to_heap in Hheapl.
    rewrite lookup_fmap in Hheapl.
    destruct (heap σ !! l) eqn:Hpos; rewrite Hpos in Hheapl; simpl.
    {
      simpl in Hheapl.
      inv Hheapl.
      auto.
    }
    {
      simpl in Hheapl.
      inv Hheapl.
    }
    }
    iModIntro.
    iSplitL "Hj".
    { iExists sj; iFrame; iPureIntro; auto. }
    iExists sl.
    iSplitR; first (iPureIntro; auto).
    iFrame.
  Qed.

    (*IntoVal e v →*)
    (*nclose nspace ⊆ E →*)
    (*spec_ctx ∗ (tpool_mapsto j (fill K (Store (Val (LitV (LitLoc l))) e))) ∗ (heapS_mapsto fullshare l v')*)
    (*={E}=∗ spec_ctx ∗ (tpool_mapsto j (fill K (Val (LitV LitUnit)))) ∗ (heapS_mapsto fullshare l v).*)

  Lemma ref_right_store E ctx K l e v' v:
    IntoVal e v →
    nclose nspace ⊆ E →
    (refines_right ctx (fill K (Store (Val (LitV (LitLoc l))) e)) * (heapS_mapsto fullshare l v')
     |-- |={E}=> refines_right ctx (fill K (Val (LitV LitUnit))) * (heapS_mapsto fullshare l v))%logic.
  Proof.
    iIntros (Hiv Hnspace) "[[Rctx Rtp] Rlv]".
    unfold refines_right.
    do 2 rewrite <- fill_app.
    iPoseProof (step_store with "[$Rctx $Rtp $Rlv]") as "Rstep"; first apply Hnspace.
    iMod "Rstep".
    iDestruct "Rstep" as "(Rctx & Rtp & Rpt)".
    iModIntro.
    iFrame.
  Qed.

End heap.


Require Import Fiat.Common Fiat.Computation Coq.Sets.Ensembles.
Require Import Fiat.ADT.ADTSig Fiat.ADT.Core Fiat.ADTRefinement.Core.

(** Definitions for integrating [refineADT] into the setoid rewriting
    framework. *)

#[global]
Instance refineConstructor_refl rep Dom
: Reflexive (@refineConstructor rep rep eq Dom).
Proof.
  induction Dom; simpl.
  - intro; simpl; intros; subst; computes_to_econstructor; eauto.
  - intro; simpl; intros; subst; apply IHDom.
Qed.

#[global]
Instance refineMethod_refl rep Dom Cod
: Reflexive (@refineMethod rep rep eq Dom Cod).
Proof.
  unfold refineMethod, methodType; intro; simpl; intros; subst.
  remember (x r_n); clear.
  induction Dom.
  - destruct Cod; intro; simpl; intros; subst;
    repeat computes_to_econstructor; try destruct v; eauto.
  - intro; simpl; intros; subst; apply IHDom.
Qed.

Lemma refineConstructor_trans
      rep rep' rep'' Dom
      AbsR AbsR'
  : forall c c' c'',
    @refineConstructor rep rep' AbsR Dom c c'
    -> @refineConstructor rep' rep'' AbsR' Dom c' c''
    -> refineConstructor
         (fun r_o r_n => exists r_o', AbsR r_o r_o' /\ AbsR' r_o' r_n)
         c c''.
Proof.
  induction Dom.
  - intro; simpl; intros; subst; intros v Comp_v.
    apply H0 in Comp_v; computes_to_inv; subst.
    apply H in Comp_v; computes_to_inv; subst; eauto.
  - simpl; intros; eapply IHDom; simpl in *.
    apply H.
    eapply H0.
Qed.

Lemma refineConstructor_eq_trans
      rep rep' Dom
      AbsR
  : forall c c' c'',
    @refineConstructor rep rep' AbsR Dom c c'
    -> @refineConstructor_eq rep' Dom c' c''
    -> refineConstructor AbsR c c''.
Proof.
  induction Dom.
  - intro; simpl; intros; subst; intros v Comp_v.
    apply H0 in Comp_v; computes_to_inv; subst.
    apply H in Comp_v; computes_to_inv; subst; eauto.
  - simpl; intros; eapply IHDom; simpl in *.
    apply H.
    eapply H0.
Qed.

#[global]
Instance refineConstructor_trans' rep Dom
: Transitive (@refineConstructor rep rep eq Dom).
Proof.
  induction Dom.
  - intro; intros.
    pose proof (refineConstructor_trans nil eq eq x y z H H0);
      unfold refineConstructor, refine; intros.
    eapply H1 in H2; computes_to_inv; subst.
    destruct_ex; intuition; subst; eauto.
  - simpl; intro; intros.
    eapply IHDom.
    apply H.
    apply H0.
Qed.

Lemma refineMethod_trans rep rep' rep'' Dom Cod
      AbsR AbsR'
  : forall m m' m'',
    @refineMethod rep rep' AbsR Dom Cod m m'
    -> @refineMethod rep' rep'' AbsR' Dom Cod m' m''
    -> refineMethod (fun r_o r_n => exists r_o', AbsR r_o r_o' /\ AbsR' r_o' r_n)
                         m m''.
Proof.
  unfold refineMethod, methodType; induction Dom.
  - intro; simpl; intros; destruct Cod; subst; intros v Comp_v.
    + destruct_ex; intuition.
      eapply H0 in Comp_v; eauto; computes_to_inv; subst.
      eapply H in Comp_v; eauto; computes_to_inv; subst; eauto.
      repeat computes_to_econstructor; eauto.
    + destruct_ex; intuition.
      eapply H0 in Comp_v; eauto; computes_to_inv; subst.
      eapply H in Comp_v; eauto; computes_to_inv; subst; eauto.
  - simpl; intros.
    destruct_ex; intuition.
    eapply (IHDom (fun d' => m r_o d)
                  (fun d' => m' x d)
                  (fun d' => m'' r_n d)); eauto.
Qed.

Lemma refineMethod_eq_trans rep rep' Dom Cod
      AbsR
  : forall m m' m'',
    @refineMethod rep rep' AbsR Dom Cod m m'
    -> @refineMethod_eq rep' Dom Cod m' m''
    -> refineMethod AbsR m m''.
Proof.
  unfold refineMethod, methodType; induction Dom.
  - intro; simpl; intros; destruct Cod; subst; intros v Comp_v.
    + destruct_ex; intuition.
      eapply H0 in Comp_v; eauto; computes_to_inv; subst.
      eapply H in Comp_v; eauto; computes_to_inv; subst; eauto.
    + destruct_ex; intuition.
      eapply H0 in Comp_v; eauto; computes_to_inv; subst.
      eapply H in Comp_v; eauto; computes_to_inv; subst; eauto.
  - simpl; intros.
    destruct_ex; intuition.
    unfold refineMethod_eq in *.
    eapply (IHDom (fun r_o => m r_o d)
                  (fun r_n => m' r_n d)
                  (fun r_n => m'' r_n d)); eauto.
    intros; eapply H0.
Qed.

#[global]
Instance refineMethod_trans' rep Dom Cod
: Transitive (@refineMethod rep rep eq Dom Cod).
Proof.
  unfold refineMethod, methodType; subst; induction Dom.
  - intro; intros.
    pose proof (refineMethod_trans H H0);
      unfold refineMethod, refineMethod', refine in *; destruct Cod; intros; subst.
    + eapply H2 in H3; eauto; computes_to_inv; subst.
      destruct_ex; intuition; subst; eauto.
    + eapply H2 in H3; eauto; computes_to_inv; subst.
      destruct_ex; intuition; subst; eauto.
  - intro; simpl; intros; subst.
    eapply (IHDom (fun d' => x r_n d)
                  (fun d' => y r_n d)
                  (fun d' => z r_n d)) with (r_o := r_n); eauto.
Qed.

Global Instance refineADT_PreOrder Sig : PreOrderT (refineADT (Sig := Sig)).
Proof.
  split; compute in *.
  - intro x; destruct x.
    econstructor 1 with
    (AbsR := @eq Rep);
      try reflexivity.
  - intros x y z H H'.
    destruct H as [AbsR ? ?].
    destruct H' as [AbsR' ? ?].
    econstructor 1 with
      (AbsR := fun x z => exists y, AbsR x y /\ AbsR' y z);
      simpl in *; intros.
    + eauto using refineConstructor_trans.
    + eauto using refineMethod_trans.
Qed.

(*Add Parametric Relation Sig : (ADT Sig) refineADT
    reflexivity proved by reflexivity
    transitivity proved by transitivity
      as refineADT_rel.*)

(** Refining the representation type is a valid refinement, as long as
    the new methods are valid refinements.

    If we had dependent setoid relations in [Type], then we could
    write

<<
Add Parametric Morphism : @Build_ADT
  with signature
  (fun oldM newM => newM -> Comp oldM)
    ==> arrow
    ==> arrow
    ==> (pointwise_relation _ (@refineConstructor _ _ _))
    ==> (pointwise_relation _ (@refineMethod _ _ _))
    ==> refineADT
    as refineADT_Build_ADT.
Proof.
  ...
Qed.
>>

    But, alas, Matthieu is still working on those.  So the rewrite
    machinery won't work very well when we're switching reps, and
    we'll instead have to use [etransitivity] and [apply] the
    [refineADT_Build_ADT_Rep] lemma to switch representations.

    The statement of [refineADT_Build_ADT_Rep] mimics the notation for
    registering [Parametric Morphism]s so that it will be easy to
    integrate if dependent setoid relations are added.

 *)

Lemma refineADT_Build_ADT_Rep Sig oldRep newRep
      (AbsR : oldRep -> newRep -> Prop)
:
  (@respectful_heteroT
     (forall idx, constructorType oldRep (ConstructorDom Sig idx))
     (forall idx, constructorType newRep (ConstructorDom Sig idx))
     (fun oldConstrs =>
        (forall idx,
           methodType oldRep (fst (MethodDomCod Sig idx)) (snd (MethodDomCod Sig idx)))
        -> ADT Sig)
     (fun newConstrs =>
        (forall idx,
           methodType newRep (fst (MethodDomCod Sig idx)) (snd (MethodDomCod Sig idx)))
        -> ADT Sig)
     (fun oldConstrs newConstrs =>
        forall mutIdx,
          @refineConstructor oldRep newRep AbsR
                         _
                         (oldConstrs mutIdx)
                         (newConstrs mutIdx))
     (fun x y => @respectful_heteroT
                   (forall idx, methodType oldRep _ _)
                   (forall idx, methodType newRep _ _)
                   (fun _ => ADT Sig)
                   (fun _ => ADT Sig)
                   (fun obs obs' =>
                      forall obsIdx : MethodIndex Sig,
                        @refineMethod oldRep newRep AbsR
                                        (fst (MethodDomCod Sig obsIdx))
                                        (snd (MethodDomCod Sig obsIdx))
                                        (obs obsIdx)
                                        (obs' obsIdx))
                   (fun obs obs' => refineADT)))
    (@Build_ADT Sig oldRep)
    (@Build_ADT Sig newRep).
Proof.
  unfold Proper, respectful_heteroT; intros.
  let A := match goal with |- refineADT ?A ?B => constr:(A) end in
  let B := match goal with |- refineADT ?A ?B => constr:(B) end in
  eapply (@refinesADT Sig A B AbsR);
    unfold id, pointwise_relation in *; simpl in *; intros; eauto.
Qed.

(** Thankfully, we can register a number of different refinements
    which follow from [refineADT_Build_ADT_Rep] as [Parametric
    Morphism]s... or we could, if [refineADT] were in [Prop]. *)

(** Refining Methods is a valid ADT refinement. *)

Lemma refineADT_Build_ADT_Method rep Sig cs
: forall ms ms',
    (forall idx, @refineMethod _ _ eq
                                 (fst (MethodDomCod Sig idx))
                                 (snd (MethodDomCod Sig idx))
                                 (ms idx) (ms' idx))
    -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs ms').
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(** Refining Constructors is also a valid ADT refinement. *)

Lemma refineADT_Build_ADT_Constructors rep Sig ms
: forall cs cs',
    (forall idx, @refineConstructor _ _ eq
                                (ConstructorDom Sig idx)
                                (cs idx) (cs' idx))
    -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs' ms).
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(** Refining observers and mutators at the same time is also a valid
    refinement. [BD: I've come to the conclusion that smaller
    refinement steps are better, so using the previous refinements
    should be the preferred mode. ]*)

Lemma refineADT_Build_ADT_Both rep Sig
: forall ms ms',
    (forall idx, @refineMethod _ _ eq
                                 (fst (MethodDomCod Sig idx))
                                 (snd (MethodDomCod Sig idx))
                                 (ms idx) (ms' idx))
    -> forall cs cs',
         (forall idx, @refineConstructor _ _ eq
                                     (ConstructorDom Sig idx)
                                     (cs idx) (cs' idx))
         -> refineADT (@Build_ADT Sig rep cs ms) (@Build_ADT Sig rep cs' ms').
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.

(* If [refineADT] lived in [Prop], we'd be able to register
   refineADT_Build_ADT_Both as a morphism.

Add Parametric Morphism Sig rep
: (@Build_ADT Sig rep)
    with signature
    (fun mut mut' =>
       forall idx, @refineConstructor _ _ eq
                                   (ConstructorDom Sig idx)
                                   (mut idx) (mut' idx))
      ==> (fun obs obs' =>
       forall idx, @refineMethod _ _ eq
                                   (fst (MethodDomCod Sig idx))
                                   (snd (MethodDomCod Sig idx))
                                   (obs idx) (obs' idx))
      ==> refineADT
      as refineADT_Build_ADT_Both.
Proof.
  intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
Qed.*)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 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: Vincent Rahli

*)

Require Export cequiv_bind.
Require Export sequents2.
Require Export sequents_lib.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export per_can.
Require Export subst_tacs_aeq.
Require Export cequiv_tacs.

(**

<<
   H |- a ~ b
     no subgoals

     if alpha_eq(a,b)
>>
 *)

Definition rule_cequiv_alpha_eq_concl {o} (H : @bhyps o) a b :=
  mk_baresequent H (mk_conclax (mk_cequiv a b)).

Definition rule_cequiv_alpha_eq {o}
           (H : @barehypotheses o)
           (a b : NTerm) :=
  mk_rule (rule_cequiv_alpha_eq_concl H a b) [] [].

Lemma rule_cequiv_alpha_eq_true3 {o} :
  forall lib (H  : @barehypotheses o) (a b : NTerm) (aeq : alpha_eq a b),
    rule_true3 lib (rule_cequiv_alpha_eq H a b).
Proof.
  intros.
  unfold rule_cequiv_alpha_eq, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs hyps.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc by prove_seq
  end.
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  rw <- @member_cequiv_iff; sp.

  - apply tequality_mkc_cequiv; split; intro h; spcast.

    + apply alphaeqc_implies_cequivc.
      unfold alphaeqc; simpl.
      apply lsubst_alpha_congr2; auto.

    + apply alphaeqc_implies_cequivc.
      unfold alphaeqc; simpl.
      apply lsubst_alpha_congr2; auto.

  - spcast.
    apply alphaeqc_implies_cequivc.
    unfold alphaeqc; simpl.
    apply lsubst_alpha_congr2; auto.
Qed.

Lemma rule_cequiv_alpha_eq_true_ext_lib {o} :
  forall lib (H  : @barehypotheses o) (a b : NTerm) (aeq : alpha_eq a b),
    rule_true_ext_lib lib (rule_cequiv_alpha_eq H a b).
Proof.
  introv aeq.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_cequiv_alpha_eq_true3; auto.
Qed.

Lemma rule_cequiv_alpha_eq_wf2 {o} :
  forall (H  : @barehypotheses o) (a b : NTerm),
    wf_rule2 (rule_cequiv_alpha_eq H a b).
Proof.
  introv wf j; allsimpl; repndors; subst; tcsp;
    allunfold @wf_bseq; repnd; allsimpl; wfseq.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * Restriction of a code (only the keys of a message appears)

- Key definitions: [restrict_code]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Import Sorting.Permutation.
From Huffman Require Export Code Frequency ISort UniqueKey PBTree2BTree.

Set Default Proof Using "Type".

Section Restrict.
Variable A : Type.
Variable empty : A.
Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.
Variable m : list A.

(** Restrict the code putting only codes of element in the frequency list *)
Definition restrict_code (m : list A) (c : code A) : code A :=
  map (fun x => (fst x, find_code A_eq_dec (fst x) c))
    (frequency_list A_eq_dec m).

(** The restriction has unique keys *)
Theorem restrict_code_unique_key :
 forall c : code A, unique_key (restrict_code m c).
Proof.
intros c; apply NoDup_unique_key.
unfold restrict_code in |- *.
replace
 (map (fst (B:=_))
    (map (fun x : A * nat => (fst x, find_code A_eq_dec (fst x) c))
       (frequency_list A_eq_dec m))) with
 (map (fst (B:=_)) (frequency_list A_eq_dec m)).
apply unique_key_NoDup; auto.
elim (frequency_list A_eq_dec m); simpl in |- *; auto with datatypes.
intros a l H; apply f_equal2 with (f := cons (A:=A)); auto.
Qed.

(** Doing the restriction does not change the codes *)
Theorem restrict_code_in :
 forall (a : A) (c : code A),
 In a m -> find_code A_eq_dec a c = find_code A_eq_dec a (restrict_code m c).
Proof.
intros a c H.
apply sym_equal; apply find_code_correct2; auto.
apply restrict_code_unique_key.
generalize (in_frequency_map _ A_eq_dec m a H).
unfold restrict_code in |- *; elim (frequency_list A_eq_dec m); simpl in |- *;
 auto with datatypes.
intros a0; case a0; simpl in |- *; auto with datatypes.
intros a1 n l H0 [H1| H1]; try rewrite H1; auto.
Qed.

(**
  The restriction does not change the encoding for messages in
  the same alphabet
*)
Theorem restrict_code_encode_incl :
 forall (m1 : list A) (c : code A),
 incl m1 m -> encode A_eq_dec c m1 = encode A_eq_dec (restrict_code m c) m1.
Proof.
intros m1 c; elim m1; simpl in |- *; auto.
intros a l H H0.
apply f_equal2 with (f := app (A:=bool)); auto with datatypes.
apply restrict_code_in; auto with datatypes.
apply H; apply incl_tran with (2 := H0); auto with datatypes.
Qed.

(** The restriction does not change the encoding of the initial message *)
Theorem restrict_code_encode :
 forall c : code A, encode A_eq_dec c m = encode A_eq_dec (restrict_code m c) m.
Proof.
intros c; apply restrict_code_encode_incl; auto with datatypes.
Qed.

(**
  The restriction does not change the unique prefix property if
  the message is in the alphabet
*)
Theorem restrict_unique_prefix :
 forall c : code A,
 not_null c ->
 in_alphabet m c -> unique_prefix c -> unique_prefix (restrict_code m c).
Proof.
intros c HH HH0 (HH1, HH2); split.
intros a1 a2 lb1 lb2 H0 H1 H2; apply HH1 with (lb1 := lb1) (lb2 := lb2); auto.
unfold restrict_code in H0.
case (proj1 (in_map_iff _ _ _)) with (1 := H0).
intros x; case x; simpl in |- *.
intros a0 n (HP2, HP1).
rewrite <- HP2.
case (HH0 a0); auto.
apply frequency_list_in with (1 := HP1).
intros x0 H; rewrite find_code_correct2 with (2 := H); auto.
unfold restrict_code in H1.
case (proj1 (in_map_iff _ _ _)) with (1 := H1).
intros x; case x; simpl in |- *.
intros a0 n (HP2, HP1).
rewrite <- HP2.
case (HH0 a0); auto.
apply frequency_list_in with (1 := HP1).
intros x0 H; rewrite find_code_correct2 with (2 := H); auto.
unfold restrict_code in |- *.
apply unique_key_map; auto.
Qed.

(** Restricting do not change the frequency list *)
Theorem frequency_list_restric_code_map :
 forall c,
 map (fst (B:=_)) (frequency_list A_eq_dec m) =
 map (fst (B:=_)) (restrict_code m c).
Proof.
intros c; unfold restrict_code in |- *; elim (frequency_list A_eq_dec m);
 simpl in |- *; auto.
intros a0 l H; apply f_equal2 with (f := cons (A:=A)); auto.
Qed.

(** If the message is not null, so is the restriction *)
Theorem restrict_not_null : forall c, m <> [] -> restrict_code m c <> [].
Proof.
case m; simpl in |- *; auto.
unfold restrict_code in |- *.
intros a0 l c H H1.
absurd
 (In
    ((fun x : A * nat => (fst x, find_code A_eq_dec (fst x) c))
       (a0, number_of_occurrences A_eq_dec a0 (a0 :: l))) []);
 auto with datatypes.
rewrite <- H1.
apply
 in_map with (f := fun x : A * nat => (fst x, find_code A_eq_dec (fst x) c)).
apply frequency_number_of_occurrences; auto with datatypes.
Qed.

(**
  The leaves of the build tree from the restrict code are the keys
  of the frequency list
*)
Theorem restrict_code_pbbuild :
 forall c : code A,
 not_null c ->
 unique_prefix c ->
 in_alphabet m c ->
 m <> [] ->
 Permutation (map fst (frequency_list A_eq_dec m))
   (all_pbleaves (pbbuild empty (restrict_code m c))).
Proof.
intros c H H0 H1 H2.
rewrite frequency_list_restric_code_map with (c := c).
apply all_pbleaves_pbbuild; auto.
apply restrict_not_null; auto.
apply restrict_unique_prefix; auto.
Qed.

End Restrict.

Arguments restrict_code [A].