From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require Import ssrbool Ensembles.
Local Set Warnings "-notation-overridden".
From PolyAI Require Export PFunc LSSA AbstractDomain RelationalAbstractDomain ssrseq.
From mathcomp Require Import ssrnat eqtype.

Local Open Scope string_scope.

Module PFuncMap (FPI: FPresburgerImpl).
  Import FPI.
  Module PFI := PFuncImpl FPI.
  Import PFI.

  Definition concrete_state := prod_eqType RegisterMap RegisterMap.

  Definition to_var_values_seq (p: Program) (R: RegisterMap) :=
    [ seq R v | v <- vars_in_program p ].

  Theorem to_var_values_seqP :
    forall p R v, v \in vars_in_program p ->
      nth 0%Z (to_var_values_seq p R) (index v (vars_in_program p)) = R v.
  Proof.
    move => p R v Hin.
    rewrite (nth_map ""); last by rewrite index_mem.
    by rewrite nth_index.
  Qed.

  Theorem to_var_values_seq_update_neq :
    forall p R v c i, i <> index v (vars_in_program p) ->
      nth 0%Z (to_var_values_seq p (v !-> c; R)) i =
      nth 0%Z (to_var_values_seq p R) i.
  Proof.
    move => p R v c i Hindex.
    case Hi: (size (vars_in_program p) <= i).
      rewrite !nth_default => [ // | | ]; by rewrite size_map.
    rewrite leqNgt in Hi. move => /negb_false_iff in Hi.
    rewrite !(nth_map ""); try (by []).
    apply t_update_neq.
    apply /eqP => Hv. subst. rewrite index_uniq in Hindex; autossr.
      by [].
      by apply uniq_vars_in_program.
  Qed.

  Fixpoint to_var_values_map_ (p: Program) (pairs: seq (string_eqType * Z)) :=
    match pairs with
    | [::] => TDefault 0%Z
    | (k,v)::pairs' => (k !-> v; to_var_values_map_ p pairs')
    end.

  Theorem to_var_values_map_inbounds :
    forall p pairs i,
      uniq (unzip1 pairs) ->
      i < size pairs ->
      (to_var_values_map_ p pairs) (nth "" (unzip1 pairs) i) = nth 0%Z (unzip2 pairs) i.
  Proof.
    move => p. elim => [ // | ].
    move => [k v] pairs Hind [|i] /= /andP[Hknotin Huniq] Hi; first by simpl_map.
    rewrite t_update_neq. auto.
    apply /eqP => Hk.
    move => /negP in Hknotin. apply Hknotin.
    rewrite Hk. apply mem_nth.
    rewrite ltnS in Hi. by rewrite size_map.
  Qed.

  Theorem to_var_values_map_outbounds :
    forall p keys values i,
      i >= size values ->
      i < size keys ->
      uniq keys ->
      (to_var_values_map_ p (zip keys values)) (nth "" keys i) = 0%Z.
  Proof.
    move => p. elim => [ [|k v] // | k keys Hind values i Hikeys Hivalues Huniq].
    case: values Hikeys => [// | v values Hikeys].
    case: i Hikeys Hivalues => [ // | i /= Hikeys Hivalues]. rewrite !ltnS in Hikeys Hivalues.
    move: Huniq => /= /andP[Hkey Huniq].
    rewrite /= t_update_neq; auto.
    apply /eqP => Hknth. move => /negP in Hkey. apply Hkey.
    eapply (mem_nth "") in Hivalues. by rewrite -Hknth in Hivalues.
  Qed.

  Definition to_var_values_map (p: Program) (s: seq Z) :=
    let vars := vars_in_program p in
    to_var_values_map_ p (zip vars s).

  Theorem to_var_values_map_index :
    forall p s i, i < size (vars_in_program p) ->
             (to_var_values_map p s) (nth "" (vars_in_program p) i) =
             nth 0%Z s i.
  Proof.
    move => p s i Hi.
    move: (uniq_vars_in_program p) => Huniq.
    move: (zip_uniq _ _ "" 0%Z (vars_in_program p) s Huniq) => Huniq_zip.
    case Hsize: (i < size s).
    - move: (to_var_values_map_inbounds p (zip (vars_in_program p) s) i).
      rewrite /unzip1. have Huniq_map: (uniq [seq i.1 | i <- zip (vars_in_program p) s]).
      + move Hsez: (unzip1 (zip (vars_in_program p) s)) => sez.
        rewrite map_inj_in_uniq => [// | [x1 x2] [y1 y2] Hx Hy].
        move: (index_uniq_zip _ _ _ _ _ _ Huniq Hx) => Hxindex.
        move: (index_uniq_zip _ _ _ _ _ _ Huniq Hy) => Hyindex.
        move => /= Heq. subst. rewrite -Hxindex in Hyindex.
        rewrite -(nth_index ("",0%Z) Hx).
        rewrite -(nth_index ("",0%Z) Hy).
        by rewrite Hyindex.
      + move => /(_ Huniq_map).
        have: (i < size (zip (vars_in_program p) s)). rewrite size_zip leq_min. by autossr.
        move => Hi' /(_ Hi'). rewrite /to_var_values_map.
        rewrite (nth_map ("", 0%Z)) => //. rewrite nth_zip_cond Hi' /= => ->.
        rewrite (nth_map ("", 0%Z)) => //. by rewrite nth_zip_cond Hi' /=.
    - rewrite [in X in _ = X]nth_default; last first. rewrite leqNgt. by rewrite Hsize.
      rewrite /to_var_values_map.
      rewrite to_var_values_map_outbounds => //.
      rewrite leqNgt. by rewrite Hsize.
  Qed.

  Theorem to_var_values_mapP :
    forall p s v, v \in (vars_in_program p) ->
                   (to_var_values_map p s) v =
                   nth 0%Z s (index v (vars_in_program p)).
  Proof.
    move => p s v Hin.
    rewrite <-(to_var_values_map_index p); last by rewrite index_mem.
    by rewrite nth_index.
  Qed.

  Theorem to_var_values_map_equality :
    forall p s, point_equality (size (vars_in_program p)) s (to_var_values_seq p (to_var_values_map p s)).
  Proof.
    move => p s. apply /allP => i Hiota. simplssr.
    rewrite /to_var_values_seq (nth_map "") => //.
    by rewrite to_var_values_map_index.
  Qed.

  Theorem to_var_values_map_equality_sym :
    forall p s, point_equality (size (vars_in_program p)) (to_var_values_seq p (to_var_values_map p s)) s.
  Proof.
    move => p s. rewrite point_equality_sym.
    apply to_var_values_map_equality.
  Qed.

  Hint Resolve to_var_values_map_equality to_var_values_map_equality_sym : core.

  Ltac rewrite_to_var_values_map_equality p s :=
    move: (to_var_values_map_equality p s);
    let Htmp := fresh "tmp" in
    intros Htmp;
    rewrite_point_H Htmp;
    move: Htmp => _.

  Ltac rewrite_to_var_values_map_equality_sym p s :=
    move: (to_var_values_map_equality_sym p s);
    let Htmp := fresh "tmp" in
    intros Htmp;
    rewrite_point_H Htmp;
    move: Htmp => _.

  Theorem to_var_values_seq_update :
    forall p v c x,
      v \in vars_in_program p ->
      point_equality (size (vars_in_program p)) (to_var_values_seq p (v !-> c; to_var_values_map p x))
                     (set_nth 0%Z x (index v (vars_in_program p)) c).
  Proof.
    move => p v c x Hv_in. apply /allP => i Hiota.
    rewrite (nth_map ""); last by autossr.
    rewrite nth_set_nth /=.
    case: (i =P index v (vars_in_program p)) => Hi.
    - subst. rewrite nth_index; auto_map.
    - rewrite t_update_neq; last first. apply /eqP => Hv. subst.
        rewrite index_uniq in Hi. by []. by simplssr. by apply uniq_vars_in_program.
      rewrite to_var_values_map_index; by autossr.
  Qed.

  Definition PFuncMap (p: Program) :=
    let n := size (vars_in_program p) in
    { x: seq (PFunc_eqType n) | size x == n}.

  Program Definition nseq_pfuncmap (p: Program) (pf: PFunc (size (vars_in_program p))) : PFuncMap p :=
    nseq (size (vars_in_program p)) pf.
  Next Obligation.
    by rewrite size_nseq.
  Defined.

  Definition bot_PFuncMap (p: Program) : PFuncMap p :=
    let n := size (vars_in_program p) in
    nseq_pfuncmap p (constant_pfunc n VBot).

  Definition top_PFuncMap (p: Program) : PFuncMap p :=
    let n := size (vars_in_program p) in
    nseq_pfuncmap p (constant_pfunc n VTop).

  Program Definition join_PFuncMap {p: Program} (p1 p2: PFuncMap p) : PFuncMap p :=
    [ seq join_pfunc x.1 x.2 | x <- zip p1 p2].
  Next Obligation.
    rewrite size_map size_zip.
    case: p1. case: p2.
    move => x /eqP -> x0 /eqP ->.
      by rewrite ssrnat.minnn.
  Qed.

  Definition gamma_seq_PFuncMap {p: Program} (pf: PFuncMap p) (x: seq Z * seq Z) :=
    let n := size (vars_in_program p) in
    all (fun i => nth 0%Z x.2 i \in (eval_pfunc (nth (constant_pfunc _ VTop) (sval pf) i) x.1)) (iota 0 n).

  Theorem gamma_seq_PFuncMap_equality :
    forall p pf x y,
      let n := size (vars_in_program p) in
      point_equality n x.1 y.1 ->
      point_equality n x.2 y.2 ->
      @gamma_seq_PFuncMap p pf x = @gamma_seq_PFuncMap p pf y.
  Proof.
    move => p pf x y n Heq1 Heq2. apply eq_in_all => i Hiota.
    rewrite -/n in Hiota. rewrite /eval_pfunc.
    rewrite_point x.1 y.1.
    by rewrite_point x.2 y.2.
  Qed.

  Definition gamma_PFuncMap {p: Program} (pf: PFuncMap p) (x: concrete_state) :=
    gamma_seq_PFuncMap pf (to_var_values_seq p x.1, to_var_values_seq p x.2).

  Theorem gamma_top_PFuncMap :
    forall p x, Ensembles.In _ (gamma_PFuncMap (top_PFuncMap p)) x.
  Proof.
    move => p x. rewrite /In /gamma_PFuncMap /gamma_seq_PFuncMap /=.
    apply /allP => i Hi. rewrite nth_nseq. rewrite mem_iota in Hi. move: Hi. move => /andP[_ Hi].
    rewrite add0n in Hi. rewrite Hi /eval_pfunc.
      by auto_pfunc.
  Qed.

  Theorem gamma_bot_PFuncMap :
    forall p x, ~ Ensembles.In _ (gamma_PFuncMap (bot_PFuncMap p)) x.
  Proof.
    rewrite /In /gamma_PFuncMap /gamma_seq_PFuncMap /bot_PFuncMap => p x /allP /(_ 0).
    have Hiniota: (0 \in iota 0 (size (vars_in_program p))). rewrite mem_iota. apply /andP. split; auto. rewrite add0n. apply size_vars_in_program.
    move => /(_ Hiniota). rewrite nth_nseq. rewrite size_vars_in_program.
    by simpl_pfunc.
  Qed.

  Theorem join_sound_l_PFuncMap :
    forall p a1 a2, Included _ (@gamma_PFuncMap p a1) (gamma_PFuncMap (join_PFuncMap a1 a2)).
  Proof.
    rewrite /Included /In /gamma_PFuncMap /gamma_seq_PFuncMap /join_PFuncMap /= => p [a1 size_a1] [a2 size_a2] x.
    apply sub_all_in => i /=. case Hin: (i \in iota _ _) => //. rewrite !implyTb.
    erewrite nth_map. erewrite nth_zip. rewrite /= join_pfuncP. apply le_V_spec. apply join_V_leftP.
    by move: size_a1 size_a2 => /eqP -> /eqP ->.
    rewrite size_zip. move: size_a1 size_a2 => /eqP -> /eqP ->. rewrite minnn.
    move: Hin. rewrite mem_iota => /andP[_]. by rewrite add0n.
    Unshelve. eapply constant_pfunc. apply VTop.
  Qed.

  Theorem join_sound_r_PFuncMap :
    forall p a1 a2, Included _ (@gamma_PFuncMap p a2) (gamma_PFuncMap (join_PFuncMap a1 a2)).
  Proof.
    rewrite /Included /In /gamma_PFuncMap /gamma_seq_PFuncMap /join_PFuncMap /= => p [a1 size_a1] [a2 size_a2] x.
    apply sub_all_in => i /=. case Hin: (i \in iota _ _) => //. rewrite !implyTb.
    erewrite nth_map. erewrite nth_zip. rewrite /= join_pfuncP. apply le_V_spec. apply join_V_rightP.
    by move: size_a1 size_a2 => /eqP -> /eqP ->.
    rewrite size_zip. move: size_a1 size_a2 => /eqP -> /eqP ->. rewrite minnn.
    move: Hin. rewrite mem_iota => /andP[_]. by rewrite add0n.
    Unshelve. eapply constant_pfunc. apply VTop.
  Qed.

    Definition PFuncMap_eqMixin (p: Program) :=
      let n := size (vars_in_program p) in
      @sig_eqMixin (seq_eqType (PFunc_eqType n)) (fun x => size x == n).
    Canonical PFuncMap_eqType (p: Program) := Eval hnf in EqType (PFuncMap p) (PFuncMap_eqMixin p).

  Instance adom_pmap (p: Program) : adom concrete_state (PFuncMap_eqType p) p :=
    {
      bot := bot_PFuncMap p;
      top := top_PFuncMap p;
      join := join_PFuncMap;

      gamma := gamma_PFuncMap;

      gamma_top := gamma_top_PFuncMap p;
      gamma_bot := gamma_bot_PFuncMap p;
      join_sound_l := join_sound_l_PFuncMap p;
      join_sound_r := join_sound_r_PFuncMap p;
    }.

  Program Definition id_relation_PFuncMap (p: Program) : PFuncMap p :=
    let n := size (vars_in_program p) in
    mkseq (fun var => constant_var_pfunc n var) n.
  Next Obligation.
      by rewrite size_mkseq.
  Qed.

  Theorem id_relation_PFuncMapP (p: Program) :
    forall x, In _ (gamma_PFuncMap (id_relation_PFuncMap p)) (x, x).
  Proof.
    move => x.
    rewrite /gamma_PFuncMap /In /gamma_seq_PFuncMap /=.
    apply /allP => i. rewrite mem_iota add0n => /andP[_ Hi]. rewrite nth_mkseq => [ | //].
    auto_pfunc.
  Qed.

  Theorem id_relation_PFuncMap_precise :
    forall p x y, In _ (gamma_PFuncMap (id_relation_PFuncMap p)) (x, y) ->
             point_equality (size (vars_in_program p)) (to_var_values_seq p x) (to_var_values_seq p y).
  Proof.
    move => p x y. rewrite /In /gamma_PFuncMap /gamma_seq_PFuncMap => HIn.
    apply /allP => i Hi. move => /allP /(_ i Hi) /= in HIn.
    rewrite nth_mkseq in HIn; last by autossr.
    move: HIn. simpl_pfunc. by rewrite eq_sym.
  Qed.

  Definition get_intersected_assumed_set {n: nat} (pf: seq (PFunc n)) : PSet n :=
    foldl (fun acc val => f_intersect_set acc val) (f_universe_set _) [seq Assumed val | val <- pf].

  Theorem get_intersected_assumed_setP :
    forall n pf x, x \in (@get_intersected_assumed_set n pf) = all (fun pfunc => x \in (Assumed pfunc)) pf.
  Proof.
    move => n pf x. rewrite /get_intersected_assumed_set.
    pose A := fun (s: PSet n) => (x \in s).
    have HA : forall s, A s = (x \in s). by rewrite /A.
    rewrite -HA fold_intersection.
    - rewrite /A. simpl_pfunc. by rewrite all_map /=.
    - move => acc a. rewrite /A. by simpl_pfunc.
  Qed.

  Definition get_intersected_assumed_set_with_involves {p: Program} (pf: PFuncMap p) (pfunc: PFunc (size (vars_in_program p))) :=
    let zip_seq := zip [ seq f_involves_dim_pfunc pfunc x | x <- iota 0 (size (vars_in_program p)) ] (sval pf) in
    let seq := unzip2 (filter (fun x => x.1) zip_seq) in
    get_intersected_assumed_set seq.

  Theorem get_intersected_assumed_set_with_involvesP :
    forall p (pf: PFuncMap p) pfunc i,
      i < size (vars_in_program p) ->
      f_involves_dim_pfunc pfunc i ->
      forall x, x \in get_intersected_assumed_set_with_involves pf pfunc ->
           forall default, x \in (Assumed (nth default (sval pf) i)).
  Proof.
    move => p pf pfunc i Hi Hinvolves x Hin default.
    rewrite /get_intersected_assumed_set_with_involves in Hin.
    rewrite get_intersected_assumed_setP in Hin.
    move => /allP in Hin. apply Hin.
    apply /mapP. exists (true, nth default (sval pf) i) => //.
    rewrite mem_filter /=.
    set zip' := zip _ _.
    have -> : (true, nth default (sval pf) i) = nth (true, default) zip' i.
    - rewrite nth_zip; last first. rewrite size_map size_iota. by case: (pf) => [x_pf /= /eqP ->].
      erewrite (nth_map 0); last by rewrite size_iota.
      rewrite nth_iota => //. by rewrite add0n Hinvolves.
    - apply mem_nth. rewrite /zip' size_zip size_map size_iota leq_min.
      rewrite Hi. move: (pf) => [x_pf /= /eqP ->]. by apply Hi.
  Qed.

  Definition get_unioned_bot_set {n: nat} (pf: seq (PFunc n)) :=
    foldl (fun acc val => f_union_set acc val) (f_empty_set _) [seq pfunc_get_bot_set val | val <- pf ].

  Theorem get_unioned_bot_setP :
    forall n pf x, x \in (@get_unioned_bot_set n pf) = has (fun pfunc => x \in (pfunc_get_bot_set pfunc)) pf.
  Proof.
    move => n pf x.
    pose A := fun (s: PSet n) => (x \in s).
    have HA : forall s, A s = (x \in s). by rewrite /A.
    rewrite -HA fold_union /=.
    - rewrite /A. simpl_pfunc. by rewrite has_map.
    - move => acc a. rewrite /A. by simpl_pfunc.
  Qed.

  Theorem get_unioned_bot_set_indexP :
    forall n (pf: seq (PFunc n)) x,
      x \in (get_unioned_bot_set pf) =
      has (fun i => x \in (pfunc_get_bot_set (nth (constant_pfunc _ VTop) pf i))) (iota 0 (size pf)).
  Proof.
    move => n pf x. rewrite get_unioned_bot_setP.
    apply /idP/idP.
    - move => /hasP [pfunc Hin Hin_bot]. apply /hasP.
      exists (index pfunc pf). simplssr.
      + by rewrite -index_mem in Hin.
      + by rewrite nth_index.
    - move => /hasP [i Hiota Hin_bot]. apply /hasP.
      exists (nth (constant_pfunc _ VTop) pf i) => //.
      apply mem_nth. by autossr.
  Qed.

  Theorem get_unioned_bot_set_pfuncmapP :
    forall p pf x_in, (to_var_values_seq p x_in) \in (get_unioned_bot_set (sval pf)) <-> forall x_out, ~ (In _ (@gamma_PFuncMap p pf) (x_in, x_out)).
  Proof.
    move => p [x_pf H_pf] x_in /=. rewrite /In /gamma_PFuncMap /gamma_seq_PFuncMap /=. move => /eqP in H_pf.
    set top_pfunc := {| Val := _ |}.
    split => [ HIn x_out /= | HIn ].
    - apply /negP /allPn.
      move: HIn. rewrite get_unioned_bot_setP => /hasP [pfunc /nthP Hpfunc_in x_in_in].
      move => /(_ top_pfunc) in Hpfunc_in. move: Hpfunc_in => [i Hi Hnth].
      exists i. rewrite mem_iota. apply /andP. split; auto. by rewrite add0n -H_pf.
      rewrite Hnth.
      rewrite pfunc_get_bot_setP in x_in_in. move => /eqP in x_in_in. by rewrite x_in_in.
    - rewrite get_unioned_bot_setP. apply /hasP.
      set x_out := ([ seq match eval_pfunc pfunc (to_var_values_seq p x_in) with | VTop | VBot => 0%Z | VVal v => v end | pfunc <- x_pf ]).
      set x_out_map := to_var_values_map p x_out.
      move: HIn => /(_ x_out_map) /negP /allPn [i Hi Hnotin].
      move: Hi. rewrite mem_iota => /andP[_ Hi]. rewrite add0n in Hi.
      rewrite {1}/to_var_values_seq (nth_map "") in Hnotin => //.
      rewrite /x_out_map to_var_values_map_index /x_out in Hnotin => //.
      erewrite (nth_map top_pfunc) in Hnotin; last by rewrite H_pf.
      move: Hnotin. case Heval: (eval_pfunc _ _) => [ // | n | ]. by simpl_pfunc.
      move => _. exists (nth top_pfunc x_pf i). apply mem_nth. by rewrite H_pf.
        by rewrite pfunc_get_bot_setP Heval.
  Qed.

  Theorem get_unioned_bot_set_pfuncmap_intro :
    forall p pf x_in x_out, (In _ (@gamma_PFuncMap p pf) (x_in, x_out)) ->
                       (to_var_values_seq p x_in) \notin (get_unioned_bot_set (sval pf)).
  Proof.
    move => p pf x_in x_out HIn.
    apply /negP => Hin.
    apply get_unioned_bot_set_pfuncmapP in HIn => //.
  Qed.

  Theorem get_unioned_bot_set_pw_aff_some :
    forall p (pf: PFuncMap p) x_in_map,
      let default := constant_pfunc _ VTop in
      let x_in := to_var_values_seq p x_in_map in
      (x_in \notin (get_unioned_bot_set (sval pf))) ->
      forall i, i < size (vars_in_program p) ->
        x_in \in Assumed (nth default (sval pf) i) ->
        exists x_out, f_eval_pw_aff (Val (nth default (sval pf) i)) (x_in) = Some x_out.
  Proof.
    move => p pf x_in_map default x_in Hx_notin i Hi Hassumed.
    exists (match f_eval_pw_aff (Val (nth default (sval pf) i)) x_in with | Some v => v | _ => 0%Z end).
    case_match => //.
    move => /negP /get_unioned_bot_set_pfuncmapP in Hx_notin.
    have Hiota: (i \in iota 0 (size (vars_in_program p))). autossr.
    exfalso. apply Hx_notin => x_out /allP /(_ i Hiota) /=.
    rewrite /eval_pfunc. by rewrite Hassumed H.
  Qed.

  Definition get_result_pfuncmap {p: Program} (pf: PFuncMap p) (x_in: seq Z) :=
    [seq if eval_pfunc pfunc x_in is VVal v then v else 0%Z | pfunc <- sval pf].

  Theorem get_result_pfuncmapP :
    forall p pf x_in,
      ~~(x_in \in get_unioned_bot_set (sval pf)) ->
      let x_out := @get_result_pfuncmap p pf x_in in
      In _ (gamma_seq_PFuncMap pf) (x_in, x_out).
  Proof.
    move => p pf x_in Hnot_bot x_out. rewrite /In /gamma_seq_PFuncMap.
    apply /allP => i. rewrite mem_iota add0n => /andP [_ Hi] /=.
    rewrite /x_out /get_result_pfuncmap /eval_pfunc /=.
    set top_pfunc := {| Val := _ |}.
    erewrite (nth_map top_pfunc); last by case: (pf) => /= Hpf /eqP ->.
    case_if => [ /= | // ].
    case Heval: (f_eval_pw_aff _ _) => [ v | ]. by simpl_pfunc.
    rewrite get_unioned_bot_setP in Hnot_bot.
    have Hin: (nth top_pfunc (sval pf) i) \in sval pf. apply mem_nth. by case: (pf) => /= Hpf /eqP ->.
    move => /hasPn /(_ _ Hin) in Hnot_bot.
      by rewrite pfunc_get_bot_setP /eval_pfunc H Heval in Hnot_bot.
  Qed.

  Program Definition pfuncmap_to_map {p: Program} (pf: PFuncMap p) :
    PMap (size (vars_in_program p)) (size (vars_in_program p)) :=
    if pf == bot_PFuncMap p then
      f_empty_map _ _
    else
      let map := f_concat_map [seq pfunc_to_map x | x <- sval pf] in
      f_cast_map (Logic.eq_refl _) _ map.
  Next Obligation.
    case: pf => x /eqP H /=.
      by rewrite size_map H.
  Defined.

  Theorem pfuncmap_to_mapP :
    forall p (pf: PFuncMap p) x_in x_out,
      gamma_seq_PFuncMap pf (x_in, x_out) =
      ((x_in, x_out) \in (pfuncmap_to_map pf)).
  Proof.
    move => p pf x_in x_out. rewrite /gamma_seq_PFuncMap /pfuncmap_to_map.
    case: (pf =P bot_PFuncMap p) => Hbot.
    - set n := size (vars_in_program p).
      move: (f_empty_mapP n n x_in x_out) => /negb_true_iff ->.
      rewrite Hbot /=. apply /allP => Hall.
      have Hiota: 0 \in iota 0 n. rewrite mem_iota add0n. apply /andP. split; auto. apply size_vars_in_program.
      move => /(_ 0 Hiota) in Hall. move: Hall.
      rewrite nth_nseq /eval_pfunc. by simpl_pfunc.
    - simpl_pfunc. apply eq_in_all => i Hiota.
      erewrite nth_map; last by case: (pf) => /= [x_pf /eqP ->]; autossr.
        by rewrite -pfunc_to_mapP.
  Qed.

  Program Definition map_to_pfuncmap {p: Program} (map: PMap (size (vars_in_program p)) (size (vars_in_program p))) : PFuncMap p :=
    [ seq map_to_pfunc (f_extract_dimension_map map i) | i <- iota 0 (size (vars_in_program p))].
  Next Obligation.
    by rewrite size_map size_iota.
  Defined.

  Theorem map_to_pfuncmapP :
    forall p map x_in x_out, ((to_var_values_seq p x_in, to_var_values_seq p x_out) \in map) ->
                        In _ (@gamma_PFuncMap p (map_to_pfuncmap map)) (x_in, x_out).
  Proof.
    move => p map x_in x_out Hinmap.
    rewrite /In /gamma_PFuncMap /gamma_seq_PFuncMap.
    apply /allP => i Hiota /=.
    rewrite (nth_map 0); last by rewrite size_iota; autossr.
    rewrite map_to_pfuncP. left.
    rewrite f_extract_dimension_mapP.
    exists (to_var_values_seq p x_out).
    split; auto. rewrite nth_iota; auto. autossr.
  Qed.

  Theorem map_to_pfuncmap_le :
    forall p map1 map2,
      f_is_subset_map map1 map2 ->
      le (@map_to_pfuncmap p map1) (@map_to_pfuncmap p map2).
  Proof.
    move => p map1 map2 Hsubset x.
    rewrite /In /gamma /= /gamma_PFuncMap /gamma_seq_PFuncMap /= => HIn.
    apply /allP => i Hiota. move => /allP /(_ i Hiota) in HIn.
    rewrite !(nth_map 0) in HIn *; try (by rewrite size_iota; autossr).
    move: (map_to_pfunc_le). setoid_rewrite le_V_spec. apply; eauto.
      by apply f_extract_dimension_map_le.
  Qed.

  Program Definition compose_relation_PFuncMap {p: Program} (pf1 pf2: PFuncMap p) : PFuncMap p :=
    let n := size (vars_in_program p) in
    let map1 := pfuncmap_to_map pf1 in
    let map2 := pfuncmap_to_map pf2 in
    let app_map := f_apply_range_map map1 map2 in
    map_to_pfuncmap app_map.

  Theorem compose_relation_PFuncMapP :
    forall p x1 x0 x2 (a1 a2: PFuncMap p),
      In _ (gamma_PFuncMap a1) (x0, x1) ->
      In _ (gamma_PFuncMap a2) (x1, x2) ->
      In _ (gamma_PFuncMap (compose_relation_PFuncMap a1 a2)) (x0, x2).
  Proof.
    move => p x1 x0 x2 a1 a2 HIn1 HIn2.
    rewrite /In /gamma_PFuncMap in HIn1 HIn2 *.
    rewrite !pfuncmap_to_mapP /= in HIn1 HIn2.
    apply /allP => i Hiota /=.
    rewrite (nth_map 0); last by rewrite size_iota; by autossr.
    rewrite map_to_pfuncP. left.
    rewrite f_extract_dimension_mapP.
    exists (to_var_values_seq p x2).
    split; last first. rewrite nth_iota; by autossr.
    rewrite f_apply_range_mapP. eexists. apply /andP. eauto.
  Qed.

  Theorem compose_relation_bot_PFuncMap :
    forall p (pf: PFuncMap p),
      compose_relation_PFuncMap pf (bot_PFuncMap p) = bot_PFuncMap p.
  Proof.
    move => p pf.
    rewrite /compose_relation_PFuncMap.
    apply val_inj. rewrite /bot_PFuncMap /=.
    eapply eq_from_nth. by rewrite size_map size_iota size_nseq.
    rewrite size_map size_iota => i Hi.
    rewrite (nth_map 0); last by rewrite size_iota.
    rewrite nth_nseq Hi. rewrite nth_iota => [ | //]. rewrite add0n.
    rewrite /map_to_pfunc.
    set val := f_extract_dimension_map _ _.
    set assumed := f_complement_set _.
    have Hval: val = f_empty_map _ _.
      rewrite /val. apply f_empty_map_uniq => [[x_in x_out]]. apply /negP.
      have Heq: (point_equality 1 x_out [::nth 0%Z x_out 0]). apply /allP. by case.
      rewrite_point_H Heq.
      rewrite f_extract_dimension_mapP => [[x_out']].
      rewrite f_apply_range_mapP => [[[x_mid] /andP [_]]].
      rewrite_to_var_values_map_equality p x_mid.
      rewrite_to_var_values_map_equality p x_out'.
      rewrite -pfuncmap_to_mapP => HIn.
      move: (gamma_bot_PFuncMap p (to_var_values_map p x_mid, to_var_values_map p x_out')).
      by move => /(_ HIn).
    rewrite Hval in assumed *.
    have ->: assumed = f_universe_set _.
      apply f_universe_set_uniq => x.
      rewrite /assumed. simpl_pfunc.
      apply /negP. rewrite f_get_domain_mapP => [[x_out]].
      rewrite f_subtract_mapP => /andP [Hempty].
      move: (f_empty_mapP (size (vars_in_program p)) 1 x x_out).
      by rewrite Hempty.
    have ->: f_map_witness (f_empty_map _ _) = f_empty_pw_aff _.
      move => n. apply f_empty_pw_aff_uniq => x.
      rewrite f_map_witness_none => x_out.
      by apply f_empty_mapP.
    by [].
  Unshelve.
    apply (constant_pfunc _ VTop).
  Qed.

  Theorem compose_relation_le_PFuncMapP :
    forall p (a a1 a2: PFuncMap p),
      le a1 a2 ->
      le (compose_relation_PFuncMap a a1) (compose_relation_PFuncMap a a2).
  Proof.
    move => p a a1 a2. rewrite /le /Included => Hle [x_in x_out].
    rewrite /In /gamma /= /gamma_PFuncMap /gamma_seq_PFuncMap => HIn.
    apply /allP => i Hiota. move: HIn => /allP /(_ i Hiota) /=.
    rewrite !(nth_map 0); try (rewrite size_iota; autossr).
    rewrite !map_to_pfuncP. move => [HIn | [x_out1 [x_out2 [Hne [HIn1 HIn2]]]]].
    - left. move: HIn => /f_extract_dimension_mapP [x_out' [/f_apply_range_mapP [x_mid /andP [Ha Ha1] Hnth]]].
      apply f_extract_dimension_mapP. exists x_out'. split; auto.
      apply f_apply_range_mapP. exists x_mid. apply /andP. split; auto.
      rewrite -!pfuncmap_to_mapP in Ha1 *.
      move => /(_ (to_var_values_map p x_mid, to_var_values_map p x_out')) in Hle.
      rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
      rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid, x_out')) in Hle; simpl; auto.
      move => /(_ Ha1) in Hle.
      rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid, x_out')) in Hle; simpl; auto.
    - right. exists x_out1. exists x_out2. split; auto.
      move: HIn1 => /f_extract_dimension_mapP [x_out1' [/f_apply_range_mapP [x_mid1 /andP [Ha1 Ha1'] Hnth1]]].
      move: HIn2 => /f_extract_dimension_mapP [x_out2' [/f_apply_range_mapP [x_mid2 /andP [Ha2 Ha2'] Hnth2]]].
      split.
      + apply /f_extract_dimension_mapP. exists x_out1'. split; auto.
        rewrite f_apply_range_mapP. exists x_mid1. apply /andP. split; auto.
        move => /(_ (to_var_values_map p x_mid1, to_var_values_map p x_out1')) in Hle.
        rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid1, x_out1')) in Hle; simpl; eauto.
        rewrite -pfuncmap_to_mapP in Ha1'. move => /(_ Ha1') in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid1, x_out1')) in Hle; simpl; eauto.
          by rewrite -pfuncmap_to_mapP.
      + apply /f_extract_dimension_mapP. exists x_out2'. split; auto.
        rewrite f_apply_range_mapP. exists x_mid2. apply /andP. split; auto.
        move => /(_ (to_var_values_map p x_mid2, to_var_values_map p x_out2')) in Hle.
        rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid2, x_out2')) in Hle; simpl; eauto.
        rewrite -pfuncmap_to_mapP in Ha2'. move => /(_ Ha2') in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (x_mid2, x_out2')) in Hle; simpl; eauto.
          by rewrite -pfuncmap_to_mapP.
  Qed.

  Theorem compose_relation_le_left_PFuncMapP :
    forall p (a1 a2 a: PFuncMap p),
      le a1 a2 ->
      le (compose_relation_PFuncMap a1 a) (compose_relation_PFuncMap a2 a).
  Proof.
    move => p a1 a2 a. rewrite /le /Included => Hle [x_in x_out].
    rewrite /In /gamma /= /gamma_PFuncMap /gamma_seq_PFuncMap => HIn.
    apply /allP => i Hiota. move: HIn => /allP /(_ i Hiota) /=.
    rewrite !(nth_map 0); try (rewrite size_iota; autossr).
    rewrite !map_to_pfuncP. move => [HIn | [x_out1 [x_out2 [Hne [HIn1 HIn2]]]]].
    - left. move: HIn => /f_extract_dimension_mapP [x_out' [/f_apply_range_mapP [x_mid /andP [Ha Ha1] Hnth]]].
      apply f_extract_dimension_mapP. exists x_out'. split; auto.
      apply f_apply_range_mapP. exists x_mid. apply /andP. split; auto.
      rewrite -!pfuncmap_to_mapP in Ha *.
      move => /(_ (x_in, to_var_values_map p x_mid)) in Hle.
      rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
      rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid)) in Hle; simpl; auto; last by apply point_equality_refl.
      move => /(_ Ha) in Hle.
      rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid)) in Hle; simpl; auto; last by apply point_equality_refl.
    - right. exists x_out1. exists x_out2. split; auto.
      move: HIn1 => /f_extract_dimension_mapP [x_out1' [/f_apply_range_mapP [x_mid1 /andP [Ha1 Ha1'] Hnth1]]].
      move: HIn2 => /f_extract_dimension_mapP [x_out2' [/f_apply_range_mapP [x_mid2 /andP [Ha2 Ha2'] Hnth2]]].
      split.
      + apply /f_extract_dimension_mapP. exists x_out1'. split; auto.
        rewrite f_apply_range_mapP. exists x_mid1. apply /andP. split; auto.
        move => /(_ (x_in, to_var_values_map p x_mid1)) in Hle.
        rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid1)) in Hle; simpl; auto; last by apply point_equality_refl.
        rewrite -pfuncmap_to_mapP in Ha1. move => /(_ Ha1) in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid1)) in Hle; simpl; auto; last by apply point_equality_refl.
          by rewrite -pfuncmap_to_mapP.
      + apply /f_extract_dimension_mapP. exists x_out2'. split; auto.
        rewrite f_apply_range_mapP. exists x_mid2. apply /andP. split; auto.
        move => /(_ (x_in, to_var_values_map p x_mid2)) in Hle.
        rewrite /In /gamma /= /gamma_PFuncMap /= in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid2)) in Hle; simpl; auto; last by apply point_equality_refl.
        rewrite -pfuncmap_to_mapP in Ha2. move => /(_ Ha2) in Hle.
        rewrite (gamma_seq_PFuncMap_equality _ _ _ (to_var_values_seq p x_in, x_mid2)) in Hle; simpl; auto; last by apply point_equality_refl.
          by rewrite -pfuncmap_to_mapP.
  Qed.

  Definition compose_transitive_closure_PFuncMap {p: Program} (pf1 pf2: PFuncMap p) :=
    let map1 := pfuncmap_to_map pf1 in
    let map2 := pfuncmap_to_map pf2 in
    map_to_pfuncmap (f_apply_range_map (f_transitive_closure_map map1) map2).

  Theorem compose_transitive_closure_id_PFuncMap :
    forall p (pf: PFuncMap p),
      le (compose_transitive_closure_PFuncMap pf pf) (compose_transitive_closure_PFuncMap pf (id_relation_PFuncMap p)).
  Proof.
    move => p pf.
    rewrite /compose_transitive_closure_PFuncMap.
    apply map_to_pfuncmap_le.
    eapply f_is_subset_map_trans. apply f_transitive_closure_map_ge_compose.
    apply f_is_subset_mapP => x y HIn.
    apply f_apply_range_mapP. exists y. apply /andP. split; auto.
    rewrite -pfuncmap_to_mapP.
    move: (id_relation_PFuncMapP p (to_var_values_map p y)).
    rewrite /In /gamma_PFuncMap /= => Hgamma.
    erewrite gamma_seq_PFuncMap_equality; eauto; simpl; auto.
  Qed.

  Theorem compose_transitive_closure_ge_id_PFuncMap :
    forall p (pf: PFuncMap p),
      le (id_relation_PFuncMap p) (compose_transitive_closure_PFuncMap pf (id_relation_PFuncMap p)).
  Proof.
    move => p pf [x y] HIn.
    apply id_relation_PFuncMap_precise in HIn.
    rewrite /compose_transitive_closure_PFuncMap.
    apply map_to_pfuncmapP.
    apply f_apply_range_mapP. exists (to_var_values_seq p y).
    apply /andP. rewrite_point_H HIn.
    split.
    - move :f_transitive_closure_map_ge_id. setoid_rewrite f_is_subset_mapP. apply. auto_pfunc. apply point_equality_refl.
    - rewrite -pfuncmap_to_mapP. by move: (id_relation_PFuncMapP p y).
  Qed.

  Theorem compose_transitive_closure_bot_PFuncMap :
    forall p pf, @compose_transitive_closure_PFuncMap p pf (bot_PFuncMap p) = (bot_PFuncMap p).
  Proof.
    move => p pf.
    rewrite /compose_transitive_closure_PFuncMap.
    rewrite /pfuncmap_to_map. simplssr.
    rewrite f_apply_range_map_empty.
    rewrite /map_to_pfuncmap /bot_PFuncMap.
    apply val_inj => /=.
    eapply eq_from_nth. by rewrite size_nseq size_map size_iota.
    rewrite size_map size_iota => i Hi.
    rewrite (nth_map 0); last by rewrite size_iota.
    rewrite nth_nseq Hi.
    rewrite /map_to_pfunc.
    set val := f_map_witness _.
    set assumed := f_complement_set _.
    have Hval: (val = f_empty_pw_aff _).
      apply f_empty_pw_aff_uniq => x.
      rewrite /val. rewrite f_map_witness_none => x_out.
      apply /negP.
      have Hx_out: point_equality 1 x_out [::nth 0%Z x_out 0]. apply /allP. case => //.
      rewrite_point_H Hx_out.
      rewrite f_extract_dimension_mapP => [[x_out' [HIn _]]].
      by move: (f_empty_mapP (size (vars_in_program p)) (size (vars_in_program p)) x x_out') => /negP.
    rewrite Hval.
    have Hassumed: (assumed = f_universe_set _).
      apply f_universe_set_uniq => x. rewrite /assumed.
      simpl_pfunc. apply /negP. rewrite f_get_domain_mapP => [[x_out]].
      simpl_pfunc. move => /andP [Hextract Heval].
      have Hx_out: point_equality 1 x_out [::nth 0%Z x_out 0]. apply /allP. case => //.
      rewrite_point_in Hextract x_out [:: nth 0%Z x_out 0].
      move => /f_extract_dimension_mapP in Hextract.
      move: Hextract => [x_out' [Hempty _]].
      move: (f_empty_mapP (size (vars_in_program p)) (size (vars_in_program p)) x x_out').
      autossr.
    by rewrite Hassumed.
  Unshelve.
    apply constant_pfunc. apply VTop.
  Qed.

  Theorem compose_transitive_closure_le_PFuncMap :
    forall p (pf pf1 pf2: PFuncMap p),
      le pf1 pf2 ->
      le (compose_transitive_closure_PFuncMap pf pf1) (compose_transitive_closure_PFuncMap pf pf2).
  Proof.
    move => p pf pf1 pf2 Hle [x_in x_out].
    apply (map_to_pfuncmap_le).
    apply f_apply_range_map_le.
    apply f_is_subset_mapP => x y.
    rewrite_to_var_values_map_equality p x.
    rewrite_to_var_values_map_equality p y.
    rewrite -!pfuncmap_to_mapP => HIn.
    rewrite /le /Included in Hle.
    by apply (Hle (to_var_values_map p x, to_var_values_map p y)).
  Qed.

  Instance adom_relational_PFuncMap (p: Program) : adom_relational (adom_pmap p) :=
    {
      id_relation := (id_relation_PFuncMap p);
      id_relation_spec := (id_relation_PFuncMapP p);

      compose_relation := compose_relation_PFuncMap;
      compose_relation_spec := (compose_relation_PFuncMapP p);

      compose_bot := (compose_relation_bot_PFuncMap p);
      compose_relation_le := (compose_relation_le_PFuncMapP p);
      compose_relation_quotient_right := (compose_relation_le_PFuncMapP p);
      compose_relation_quotient_left := (compose_relation_le_left_PFuncMapP p);

      compose_transitive_closure := compose_transitive_closure_PFuncMap;
      compose_transitive_closure_id := (compose_transitive_closure_id_PFuncMap p);
      compose_transitive_closure_ge_id := (compose_transitive_closure_ge_id_PFuncMap p);
      compose_transitive_closure_bot := (compose_transitive_closure_bot_PFuncMap p);
      compose_transitive_closure_le := (compose_transitive_closure_le_PFuncMap p);
    }.

End PFuncMap.


Require Import RelationClasses.

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 DenseOrder.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import MemoryDomain.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import Cover.

Require Import SimMemory.

Set Implicit Arguments.

Module SimPromises.
  Include MemoryDomain.

  Definition none_if_released loc ts (pview:t) (released:option View.t): option View.t :=
    if mem loc ts pview
    then None
    else released.

  Definition none_if loc ts (pview:t) (msg:Message.t): Message.t :=
    match msg with
    | Message.concrete val released =>
      Message.concrete val (none_if_released loc ts pview released)
    | Message.reserve => Message.reserve
    end.

  Lemma none_if_bot loc ts msg:
    none_if loc ts bot msg = msg.
  Proof.
    destruct msg; ss.
  Qed.

  Ltac none_if_tac :=
    repeat
      (try match goal with
           | [ |- context[none_if _ _ _ (Message.concrete ?val ?released)]] =>
             unfold none_if; ss
           | [ |- context[none_if _ _ _ ?msg]] =>
             unfold none_if; destruct msg; ss
           | [ |- context[none_if_released _ _ ?msg]] =>
             unfold none_if_released; condtac; ss
           end).

  Definition mem_le_transf (pview:t) (lhs rhs:Memory.t): Prop :=
    forall loc to from msg
      (LHS: Memory.get loc to lhs = Some (from, msg)),
      Memory.get loc to rhs = Some (from, none_if loc to pview msg).

  Definition kind_transf loc ts (pview:t) (kind:Memory.op_kind): Memory.op_kind :=
    match kind with
    | Memory.op_kind_add => Memory.op_kind_add
    | Memory.op_kind_split ts msg => Memory.op_kind_split ts (none_if loc ts pview msg)
    | Memory.op_kind_lower msg => Memory.op_kind_lower (none_if loc ts pview msg)
    | Memory.op_kind_cancel => Memory.op_kind_cancel
    end.

  Lemma kind_transf_bot loc ts kind:
    kind_transf loc ts bot kind = kind.
  Proof.
    destruct kind; ss; rewrite none_if_bot; ss.
  Qed.

  Inductive sem (pview:t) (inv:t) (promises_src promises_tgt:Memory.t): Prop :=
  | sem_intro
      (LE: mem_le_transf pview promises_tgt promises_src)
      (PVIEW: forall l t (MEM: mem l t pview), exists f val released, Memory.get l t promises_tgt = Some (f, Message.concrete val released))
      (SOUND: forall l t (INV: mem l t inv),
          Memory.get l t promises_tgt = None /\
          exists f m, Memory.get l t promises_src = Some (f, m))
      (COMPLETE: forall l t f m
                   (SRC: Memory.get l t promises_src = Some (f, m))
                   (TGT: Memory.get l t promises_tgt = None),
          mem l t inv)
  .

  Lemma promise
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt mem2_tgt
        kind_tgt
        (PROMISE_TGT: Memory.promise promises1_tgt mem1_tgt loc from to msg promises2_tgt mem2_tgt kind_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt):
    exists promises2_src mem2_src,
      <<PROMISE_SRC: Memory.promise promises1_src mem1_src loc from to (none_if loc to pview msg) promises2_src mem2_src (kind_transf loc to pview kind_tgt)>> /\
      <<INV2: sem pview inv promises2_src promises2_tgt>> /\
      <<SIM2: sim_memory mem2_src mem2_tgt>>.
  Proof.
    inv PROMISE_TGT.
    - exploit (@Memory.add_exists mem1_src loc from to msg);
        try by inv MEM; inv ADD.
      { eapply covered_disjoint.
        - apply SIM1.
        - inv MEM. inv ADD. auto. }
      i. des.
      exploit Memory.add_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_add; try apply SIM1; try refl; eauto. i.
      esplits; eauto.
      + none_if_tac.
        * inv INV1. exploit PVIEW; eauto. i. des.
          hexploit Memory.add_get0; try exact PROMISES; eauto. i. des. congr.
        * econs 1; eauto; try congr.
          i. exploit sim_memory_get_inv; try exact GET; eauto.
          { apply MEM1_SRC. }
          { apply MEM1_TGT. }
          i. des. inv FROM; cycle 1.
          { inv H. eauto. }
          exploit Memory.add_get0; try exact MEM. i. des.
          exploit Memory.add_get1; try exact GET_TGT; eauto. i.
          exploit Memory.get_ts; try exact GET1. i. des.
          { subst. inv H. }
          exploit Memory.get_ts; try exact x3. i. des.
          { subst. inv TO; inv H0.
            exploit Memory.get_ts; try exact GET. i. des; timetac. inv x5. }
          exploit Memory.get_disjoint; [exact GET1|exact x3|..]. i. des.
          { subst. congr. }
          apply (x6 to); econs; ss; try refl.
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. eauto. }
          { etrans; eauto. econs. ss. }
        * econs 1; eauto; ss.
      + econs.
        * ii. erewrite Memory.add_o; eauto.
          erewrite (@Memory.add_o promises2_tgt) in LHS; try exact PROMISES. revert LHS.
          condtac; ss.
          { i. des. inv LHS. none_if_tac.
            inv INV1. exploit PVIEW; eauto. i. des.
            exploit Memory.add_get0; try exact PROMISES; eauto. i. des. congr. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. i. des.
          erewrite Memory.add_o; eauto. condtac; eauto.
          ss. des. subst. exploit LE; eauto. i.
          inv x1. inv ADD. exfalso.
          eapply DISJOINT; eauto; econs; eauto; try refl. ss.
          exploit Memory.get_ts; try eapply x. i. des; ss.
          subst. inv TO.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.add_o; eauto. erewrite (@Memory.add_o promises2); eauto.
          condtac; ss. des. subst.
          exploit Memory.add_get0; eauto. i. des. congr.
        * i. revert SRC TGT.
          erewrite Memory.add_o; eauto. erewrite (@Memory.add_o promises2_tgt); eauto.
          condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.split_get0; try exact PROMISES; eauto. i. des.
      exploit (@Memory.split_exists promises1_src loc from to ts3 msg (none_if loc ts3 pview msg3));
        try by inv PROMISES; inv SPLIT.
      { apply INV1. eauto. }
      i. des.
      exploit Memory.split_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_split; try apply SIM1; try refl; eauto. i.
      esplits; eauto.
      + unfold none_if. destruct msg; ss.
        unfold none_if_released. condtac; ss.
        * inv INV1. exploit PVIEW; eauto. i. des.
          hexploit Memory.split_get0; try exact PROMISES; eauto. congr.
        * subst. econs 2; eauto. ss. eauto.
      + econs.
        * ii. revert LHS.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); try exact x0.
          repeat condtac; ss.
          { i. des. inv LHS. none_if_tac.
            inv INV1. exploit PVIEW; eauto. i. des.
            exploit Memory.split_get0; try exact PROMISES; eauto. congr. }
          { guardH o. i. des. inv LHS. ss. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. i. des.
          erewrite Memory.split_o; eauto. repeat condtac; eauto.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); eauto.
          exploit Memory.split_get0; try exact x0; eauto. i. des.
          repeat condtac; ss.
          { des. subst. congr. }
          { guardH o. des. subst. congr. }
          esplits; eauto.
        * i. revert SRC TGT.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o promises2_tgt); eauto.
          repeat condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.lower_get0; try exact PROMISES; eauto. i. des.
      exploit (@Memory.lower_exists promises1_src loc from to (none_if loc to pview msg0) (none_if loc to pview msg));
        try by inv MEM; inv LOWER.
      { apply INV1. eauto. }
      { none_if_tac; econs; ss.
        inv MEM. inv LOWER. inv MSG_WF. ss. }
      { none_if_tac; destruct msg0; ss.
        - inv MEM. inv LOWER. inv MSG_LE. econs. refl.
        - inv PROMISES. inv MSG_LE. }
      i. des.
      exploit Memory.lower_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_lower; try exact SIM1; try exact x1; try exact x2; eauto.
      { none_if_tac; try refl. econs. econs. }
      i. esplits; eauto.
      + econs 3; eauto.
        * none_if_tac; viewtac. econs. viewtac.
        * subst. ss. esplits; eauto.
      + econs.
        * ii. revert LHS.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); try exact x0.
          condtac; ss.
          { i. des. inv LHS. ss. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. i. des.
          erewrite Memory.lower_o; eauto. condtac; eauto.
          des. ss. subst. rewrite GET in x. inv x.
          inv MSG_LE. esplits; eauto.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); eauto.
          exploit Memory.lower_get0; try exact x1; eauto. i. des.
          condtac; ss.
          { des. subst. congr. }
          esplits; eauto.
        * i. revert SRC TGT.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o promises2_tgt); eauto.
          repeat condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.remove_get0; try exact PROMISES. i. des.
      exploit (@Memory.remove_exists promises1_src loc from to Message.reserve).
      { inv INV1. exploit LE; eauto. }
      i. des.
      exploit (@Memory.remove_exists mem1_src loc from to Message.reserve).
      { inv INV1. exploit LE; eauto. }
      i. des.
      exploit sim_memory_remove; try exact SIM1; eauto. i.
      esplits; try exact x2; eauto.
      inv INV1. econs; ii.
      + erewrite Memory.remove_o in LHS; eauto.
        erewrite Memory.remove_o; eauto.
        condtac; ss. eauto.
      + exploit PVIEW; eauto. i. des.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst. congr.
      + exploit SOUND; eauto. i. des. split.
        * erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        * erewrite Memory.remove_o; eauto. condtac; ss; eauto.
          des. subst. congr.
      + erewrite Memory.remove_o in SRC; eauto.
        erewrite Memory.remove_o in TGT; eauto.
        des_ifs. eauto.
  Qed.

  Lemma promise_bot
        inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt mem2_tgt
        kind
        (PROMISE_TGT: Memory.promise promises1_tgt mem1_tgt loc from to msg promises2_tgt mem2_tgt kind)
        (INV1: sem bot inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt):
    exists promises2_src mem2_src,
      <<PROMISE_SRC: Memory.promise promises1_src mem1_src loc from to msg promises2_src mem2_src kind>> /\
      <<INV2: sem bot inv promises2_src promises2_tgt>> /\
      <<SIM2: sim_memory mem2_src mem2_tgt>>.
  Proof.
    exploit promise; eauto. i. des.
    rewrite none_if_bot in *.
    rewrite kind_transf_bot in *.
    esplits; eauto.
  Qed.

  Lemma remove_tgt
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
      <<INV2: sem (unset loc to pview) (set loc to inv) promises1_src promises2_tgt>> /\
      <<INV2': mem loc to inv = false>>.
  Proof.
    hexploit Memory.remove_future; eauto. i. des.
    exploit Memory.remove_get0; [eauto|]. i. des.
    inv INV1. exploit LE0; eauto. i.
    esplits.
    - econs.
      + ii. revert LHS.
        erewrite Memory.remove_o; eauto. condtac; ss. i.
        exploit LE0; eauto.
        unfold none_if, none_if_released. repeat condtac; ss.
        * revert COND1. rewrite unset_o. condtac; ss; [|congr].
          guardH o. des. subst. unguardH o. des; congr.
        * revert COND1. rewrite unset_o. condtac; ss. congr.
      + i. revert MEM. rewrite unset_o. condtac; ss. guardH o. i.
        exploit PVIEW; eauto. i. des.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst. unguardH o. des; congr.
      + i. erewrite Memory.remove_o; eauto.
        revert INV. rewrite set_o.
        unfold Time.t, DOSet.elt. condtac; ss; i.
        * des. subst. esplits; eauto.
        * exploit SOUND; eauto.
      + i. revert TGT.
        erewrite Memory.remove_o; eauto. rewrite set_o.
        unfold Time.t, DOSet.elt. condtac; ss; i.
        eapply COMPLETE; eauto.
    - destruct (mem loc to inv) eqn:X; auto.
      exploit SOUND; [eauto|]. i. des. congr.
  Qed.

  Lemma remove_src
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt
        (INV1: sem pview inv promises1_src promises1_tgt)
        (INV1': mem loc to inv)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (GET: Memory.get loc to promises1_src = Some (from, msg))
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to msg promises2_src>> /\
      <<INV2: sem pview (unset loc to inv) promises2_src promises1_tgt>>.
  Proof.
    inv INV1.
    exploit Memory.remove_exists; eauto. i. des.
    esplits; eauto.
    econs.
    - ii. revert LHS.
      erewrite (@Memory.remove_o mem2); eauto. condtac; ss; eauto.
      des. subst. exploit SOUND; eauto. i. des. congr.
    - i. exploit PVIEW; eauto.
    - i. rewrite unset_o in INV. revert INV. condtac; ss.
      guardH o.
      i. exploit SOUND; eauto. i. des. splits; eauto.
      erewrite Memory.remove_o; eauto. condtac; ss; eauto.
      des. subst. unguardH o. des; congr.
    - i. revert SRC.
      erewrite Memory.remove_o; eauto. rewrite unset_o.
      unfold Time.t, DOSet.elt. condtac; ss; i.
      eapply COMPLETE; eauto.
  Qed.

  Lemma remove
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (MSG_WF: Message.wf msg)
        (TIME: Time.lt from to)
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to (none_if loc to pview msg) promises2_src>> /\
      <<INV2: sem (unset loc to pview) inv promises2_src promises2_tgt>>.
  Proof.
    hexploit Memory.remove_future; try apply REMOVE_TGT; eauto. i. des.
    exploit remove_tgt; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    inv INV1. exploit LE0; eauto. i.
    exploit remove_src; try apply set_eq; eauto. i. des.
    esplits; eauto.
    rewrite unset_set in INV0; auto.
  Qed.

  Lemma remove_bot
        inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (MSG_WF: Message.wf msg)
        (TIME: Time.lt from to)
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem bot inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to msg promises2_src>> /\
      <<INV2: sem bot inv promises2_src promises2_tgt>>.
  Proof.
    exploit remove; eauto. i. des.
    rewrite none_if_bot in *.
    esplits; eauto.
    replace bot with (unset loc to bot); ss. apply ext. i.
    rewrite unset_o. condtac; ss.
  Qed.

  Lemma sem_bot promises:
    sem bot bot promises promises.
  Proof.
    econs.
    - ii. rewrite none_if_bot. ss.
    - i. revert MEM. rewrite bot_spec. congr.
    - i. inv INV.
    - i. congr.
  Qed.

  Lemma sem_bot_inv
        promises_src promises_tgt
        (SEM: sem bot bot promises_src promises_tgt):
    promises_src = promises_tgt.
  Proof.
    apply Memory.ext. i.
    destruct (Memory.get loc ts promises_tgt) as [[? []]|] eqn:X.
    - inv SEM. exploit LE; eauto.
    - destruct (Memory.get loc ts promises_src) as [[? []]|] eqn:Y.
      + inv SEM. exploit LE; eauto. s. i. congr.
      + inv SEM. exploit LE; eauto. s. i. congr.
      + inv SEM. exploit LE; eauto. s. i. congr.
    - destruct (Memory.get loc ts promises_src) as [[? []]|] eqn:Y.
      + inv SEM. exploit COMPLETE; eauto. i. inv x.
      + inv SEM. exploit COMPLETE; eauto. i. inv x.
      + ss.
  Qed.
End SimPromises.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

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

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

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import OrdStep.

Set Implicit Arguments.

Module Writes.
  Section Writes.
    Variable L: Loc.t -> bool.

    Definition t: Type := list (Loc.t * Time.t * Ordering.t).

    Definition append (e: ThreadEvent.t) (rels: t): t :=
      match ThreadEvent.is_writing e with
      | Some (loc, from, to, val, released, ord) =>
        if L loc
        then (loc, to, ord) :: rels
        else rels
      | None => rels
      end.

    Variant wf (rels: t) (mem: Memory.t): Prop :=
    | wf_intro
        (SOUND: forall loc to ord (IN: List.In (loc, to, ord) rels),
            L loc /\
            exists from val released,
              Memory.get loc to mem = Some (from, Message.concrete val released))
        (COMPLETE: forall loc from to val released
                     (LOC: L loc)
                     (TO: to <> Time.bot)
                     (GET: Memory.get loc to mem = Some (from, Message.concrete val released)),
            exists ord, List.In (loc, to, ord) rels)
    .

    Lemma append_app e rels1 rels2:
      append e rels1 ++ rels2 = append e (rels1 ++ rels2).
    Proof.
      unfold append. des_ifs.
    Qed.

    Lemma promise_wf
          rels promises1 mem1 loc from to msg promises2 mem2 kind
          (RELS1: wf rels mem1)
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
          (MSG: L loc -> msg = Message.reserve):
      wf rels mem2.
    Proof.
      inv RELS1. econs; i.
      { exploit SOUND; eauto. i. des. split; ss.
        inv PROMISE; ss.
        - exploit Memory.add_get1; try exact x0; eauto.
        - exploit Memory.split_get1; try exact x0; eauto. i. des. eauto.
        - exploit Memory.lower_get1; try exact x0; eauto. i. des. inv MSG_LE. eauto.
        - erewrite (@Memory.remove_o mem2); eauto. condtac; ss; eauto.
          des. subst. exploit Memory.remove_get0; try exact MEM. i. des. congr.
      }
      { revert GET. inv PROMISE; ss.
        - erewrite Memory.add_o; eauto. condtac; ss; eauto.
          i. des. clarify. exploit MSG; ss.
        - erewrite Memory.split_o; eauto. repeat condtac; ss; eauto.
          + i. des. clarify. exploit MSG; ss.
          + guardH o. i. des. clarify. exploit MSG; ss.
        - erewrite Memory.lower_o; eauto. condtac; ss; eauto.
          i. des. clarify. exploit MSG; ss.
        - erewrite Memory.remove_o; eauto. condtac; ss; eauto.
      }
    Qed.

    Lemma write_wf
          ord
          rels promises1 mem1 loc from to msg promises2 mem2 kind
          (RELS1: wf rels mem1)
          (MSG: L loc -> exists val released, msg = Message.concrete val released)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      wf (if L loc then (loc, to, ord) :: rels else rels) mem2.
    Proof.
      condtac; cycle 1.
      { inv WRITE. eapply promise_wf; eauto. rewrite COND. ss. }
      inv RELS1. inv WRITE. econs; i.
      { inv IN.
        { clarify. split; ss.
          exploit MSG; eauto. i. des. subst.
          exploit Memory.promise_get0; try exact PROMISE.
          { destruct kind; ss. inv PROMISE. ss. }
          i. des. eauto.
        }
        exploit SOUND; eauto. i. des. split; ss.
        exploit MSG; eauto. i. des. subst.
        inv PROMISE; ss.
        - exploit Memory.add_get1; try exact x0; eauto.
        - exploit Memory.split_get1; try exact x0; eauto. i. des. eauto.
        - exploit Memory.lower_get1; try exact x0; eauto. i. des. inv MSG_LE. eauto.
      }
      { revert GET. inv PROMISE; ss.
        - erewrite Memory.add_o; eauto. condtac; ss.
          + i. des. clarify. eauto.
          + guardH o. i. exploit COMPLETE; eauto. i. des. eauto.
        - erewrite Memory.split_o; eauto. repeat condtac; ss.
          + i. des. clarify. eauto.
          + guardH o. i. des. clarify.
            exploit Memory.split_get0; try exact MEM. i. des.
            exploit COMPLETE; try exact GET0; eauto. i. des. eauto.
          + guardH o. guardH o0. i.
            exploit COMPLETE; eauto. i. des. eauto.
        - erewrite Memory.lower_o; eauto. condtac; ss.
          + i. des. clarify. eauto.
          + guardH o. i. exploit COMPLETE; eauto. i. des. eauto.
        - exploit MSG; eauto. i. des. subst. ss.
      }
    Qed.

    Lemma write_wf_other
          rels promises1 mem1 loc from to msg promises2 mem2 kind
          (RELS1: wf rels mem1)
          (LOC: ~ L loc)
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind):
      wf rels mem2.
    Proof.
      exploit (@write_wf Ordering.na); try exact WRITE; eauto; ss.
      condtac; ss.
    Qed.

    Lemma write_na_wf
          rels ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind
          (RELS1: wf rels mem1)
          (LOC: ~ L loc)
          (WRITE: Memory.write_na ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind):
      wf rels mem2.
    Proof.
      induction WRITE.
      - exploit write_wf_other; eauto.
      - apply IHWRITE; ss.
        exploit write_wf_other; try exact WRITE_EX; eauto.
    Qed.

    Lemma step_wf
          ordcr ordcw rels lang pf e e1 e2
          (RELS1: wf rels (Thread.memory e1))
          (ORDCW: Ordering.le Ordering.plain ordcw)
          (STEP: @OrdThread.step lang L ordcr ordcw pf e e1 e2):
      wf (append e rels) (Thread.memory e2).
    Proof.
      unfold append.
      inv STEP; inv STEP0; inv LOCAL; try inv LOCAL0; ss.
      - eapply promise_wf; eauto.
      - inv STEP. eapply write_wf; eauto.
      - inv LOCAL1. inv STEP. inv LOCAL2. inv STEP. ss.
        eapply write_wf; eauto.
      - inv STEP. revert ORD. condtac; ss.
        { destruct ord, ordcw; ss. }
        hexploit write_na_wf; eauto. rewrite COND. ss.
      - inv STEP. eapply write_wf; eauto.
    Qed.

    Lemma reserve_step_wf
          rels lang e1 e2
          (RELS1: wf rels (Thread.memory e1))
          (STEP: @Thread.reserve_step lang e1 e2):
      wf rels (Thread.memory e2).
    Proof.
      inv STEP. inv STEP0; inv STEP; inv LOCAL. ss.
      eapply promise_wf; eauto.
    Qed.

    Lemma cancel_step_wf
          rels lang e1 e2
          (RELS1: wf rels (Thread.memory e1))
          (STEP: @Thread.cancel_step lang e1 e2):
      wf rels (Thread.memory e2).
    Proof.
      inv STEP. inv STEP0; inv STEP; inv LOCAL. ss.
      eapply promise_wf; eauto.
    Qed.

    Lemma promise_disjoint
          promises1 mem1 loc from to msg promises2 mem2 kind
          promises
          (PROMISE: Memory.promise promises1 mem1 loc from to msg promises2 mem2 kind)
          (DISJOINT: Memory.disjoint promises1 promises)
          (LE: Memory.le promises mem1):
      Memory.get loc to promises = None.
    Proof.
      destruct (Memory.get loc to promises) as [[]|] eqn:GETP; ss.
      exploit LE; eauto. i.
      inv PROMISE; ss.
      - exploit Memory.add_get0; try exact MEM. i. des. congr.
      - exploit Memory.split_get0; try exact MEM. i. des. congr.
      - exploit Memory.lower_get0; try exact PROMISES. i. des.
        inv DISJOINT. exploit DISJOINT0; eauto. intros x4. des. exfalso.
        exploit Memory.get_ts; try exact GETP. i. des; try congr.
        exploit Memory.get_ts; try exact GET. i. des; try congr.
        apply (x4 to); econs; try refl; ss.
      - exploit Memory.remove_get0; try exact PROMISES. i. des.
        inv DISJOINT. exploit DISJOINT0; eauto. intros x4. des. exfalso.
        exploit Memory.get_ts; try exact GETP. i. des; try congr.
        exploit Memory.get_ts; try exact GET. i. des; try congr.
        apply (x4 to); econs; try refl; ss.
    Qed.

    Lemma write_disjoint
          promises1 mem1 loc from to msg promises2 mem2 kind
          promises
          (WRITE: Memory.write promises1 mem1 loc from to msg promises2 mem2 kind)
          (DISJOINT: Memory.disjoint promises1 promises)
          (LE: Memory.le promises mem1):
      Memory.get loc to promises = None.
    Proof.
      inv WRITE. eauto using promise_disjoint.
    Qed.

    Lemma write_na_disjoint
          ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind
          promises
          (WRITE: Memory.write_na ts promises1 mem1 loc from to msg promises2 mem2 msgs kinds kind)
          (DISJOINT: Memory.disjoint promises1 promises)
          (LE: Memory.le promises mem1):
      Memory.get loc to promises = None.
    Proof.
      induction WRITE; eauto using write_disjoint.
      exploit Memory.write_disjoint; try exact WRITE_EX; eauto. i. des. eauto.
    Qed.

    (* Lemma step_disjoint *)
    (*       ordrc ordwc rels lang pf e e1 e2 promises *)
    (*       (RELS1: wf rels (Local.promises (Thread.local e1)) (Thread.memory e1)) *)
    (*       (STEP: @OrdThread.step lang L ordrc ordwc pf e e1 e2) *)
    (*       (DISJOINT: Memory.disjoint (Local.promises (Thread.local e1)) promises) *)
    (*       (LE: Memory.le promises (Thread.memory e1)) *)
    (*       (RELS: wf rels promises (Thread.memory e1)): *)
    (*   wf (append e rels) promises (Thread.memory e2). *)
    (* Proof. *)
    (*   hexploit step_wf; eauto. ii. *)
    (*   exploit H; eauto. i. des. esplits; eauto. *)
    (*   unfold append in *. *)
    (*   inv STEP; inv STEP0; inv LOCAL; ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - inv LOCAL0. inv STEP. ss. revert IN. *)
    (*     repeat condtac; ss; i; des; try by (exploit RELS; eauto; i; des; ss). *)
    (*     inv IN. eapply write_disjoint; eauto. *)
    (*   - inv LOCAL1. inv STEP. inv LOCAL2. inv STEP. ss. revert IN. *)
    (*     repeat condtac; ss; i; des; try by (exploit RELS; eauto; i; des; ss). *)
    (*     inv IN. eapply write_disjoint; eauto. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - inv LOCAL0. inv STEP. ss. revert IN. *)
    (*     repeat condtac; ss; i; des; try by (exploit RELS; eauto; i; des; ss). *)
    (*     inv IN. eapply write_na_disjoint; eauto. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (*   - exploit RELS; eauto. i. des. ss. *)
    (* Qed. *)

    Lemma cap_wf
          rels mem cap
          (CLOSED: Memory.closed mem)
          (CAP: Memory.cap mem cap)
          (WF: wf rels mem):
      wf rels cap.
    Proof.
      inv WF. econs; i.
      - exploit SOUND; eauto. i. des.
        inv CAP. exploit SOUND0; eauto.
      - exploit Memory.cap_inv; try exact GET; eauto. i. des; ss. eauto.
    Qed.
  End Writes.
End Writes.


Require Export parser.
Require Export refine.

Definition server: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7,s8] (s1)
[admin_md,usr,pass,value,query] [connected,error,service] []
[s1->(usr)s2, s2->(pass)s3, s3->(connected)s4, s4->(value)s5,
s5->(query)s6, s6->(service)s1, s1->(admin_md)s7,
s7->(usr)s8, s8->(error)s1]".

Definition server_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement server (&"tau") (ASet.GenActs [&"query",&"value"]) )
 (ASet.GenActs [&"service"]).

Definition server_hid: IA :=
 IAutomaton.hiding server (ASet.GenActs [&"query",&"value",&"service"]).

Eval compute in SMENI_refinement server_rep server_hid. (*false*)


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon BBConst BBAnd BBAdd BBShl.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_mul ===== *)

Fixpoint bit_blast_mul_rec g ls1 ls2 (i : N) : generator * cnf * word :=
  match ls2 with
  | [::] => bit_blast_const g (from_nat (size ls1) 0)
  | ls2_hd :: ls2_tl =>
    let '(g_tl, cs_tl, lrs_tl) := bit_blast_mul_rec g ls1 ls2_tl (i + 1)%num in
    if ls2_hd == lit_tt then
      let '(g_hd, cs_hd, lrs_hd) := bit_blast_shl_int g_tl ls1 i in
      let '(g_add, cs_add, lrs_add) := bit_blast_add g_hd lrs_tl lrs_hd in
      (g_add, catrev (catrev cs_tl cs_hd) cs_add, lrs_add)
    else if ls2_hd == lit_ff then
           (g_tl, cs_tl, lrs_tl)
         else
           let '(g_hd, cs_hd, lrs_hd) := bit_blast_shl_int g_tl ls1 i in
           let '(g_and, cs_and, lrs_and) := bit_blast_and g_hd (copy (size ls1) ls2_hd) lrs_hd in
           let '(g_add, cs_add, lrs_add) := bit_blast_add g_and lrs_tl lrs_and in
           (g_add, catrev (catrev (catrev cs_tl cs_hd) cs_and) cs_add, lrs_add)
  end.

Fixpoint mk_env_mul_rec E g ls1 ls2 (i : N) : env * generator * cnf * word :=
  match ls2 with
  | [::] => mk_env_const E g (from_nat (size ls1) 0)
  | ls2_hd :: ls2_tl =>
    let '(E_tl, g_tl, cs_tl, lrs_tl) := mk_env_mul_rec E g ls1 ls2_tl (i + 1)%num in
    if ls2_hd == lit_tt then
      let '(E_hd, g_hd, cs_hd, lrs_hd) := mk_env_shl_int E_tl g_tl ls1 i in
      let '(E_add, g_add, cs_add, lrs_add) := mk_env_add E_hd g_hd lrs_tl lrs_hd in
      (E_add, g_add, catrev (catrev cs_tl cs_hd) cs_add, lrs_add)
    else if ls2_hd == lit_ff then
           (E_tl, g_tl, cs_tl, lrs_tl)
         else
           let '(E_hd, g_hd, cs_hd, lrs_hd) := mk_env_shl_int E_tl g_tl ls1 i in
           let '(E_and, g_and, cs_and, lrs_and) := mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd in
           let '(E_add, g_add, cs_add, lrs_add) := mk_env_add E_and g_and lrs_tl lrs_and in
           (E_add, g_add, catrev (catrev (catrev cs_tl cs_hd) cs_and) cs_add, lrs_add)
  end.

Definition bit_blast_mul g ls1 ls2 : generator * cnf * word :=
  bit_blast_mul_rec g ls1 ls2 0%num.

Definition mk_env_mul E g ls1 ls2 :env * generator * cnf * word :=
  mk_env_mul_rec E g ls1 ls2 0%num.

Lemma size_copy_literal n (l: literal) : size (copy n l) = n.
Proof. exact : size_nseq. Qed.

Lemma bit_blast_mul_rec_size_ss :
  forall ls2 g ls1 i g' cs lrs,
    bit_blast_mul_rec g ls1 ls2 i = (g', cs, lrs) -> size ls1 = size lrs.
Proof.
  elim => [| ls2_hd ls2_tl IH] g ls1 g' i cs lrs.
  - case => _ _ <-. by rewrite size_map size_from_nat/=.
  - rewrite/=.
    dcase (bit_blast_mul_rec g ls1 ls2_tl (g' + 1)) => [[[g_tl cs_tl] lrs_tl] Hbbmul].
    dcase (bit_blast_shl_int g_tl ls1 g') => [[[g_hd cs_hd] lrs_hd] Hbbshlint].
    dcase (bit_blast_add g_hd lrs_tl lrs_hd) => [[[g_add cs_add] lrs_add] Hbbadd].
    case Hbband: (bit_blast_and g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[g_and cs_and] lrs_and].
    dcase (bit_blast_add g_and lrs_tl lrs_and) => [[[g_add2 cs_add2] lrs_add2] Hbbadd2] Hres.
    move : (IH _ _ _ _ _ _ Hbbmul) => Hszmul. rewrite Hszmul.
    move : (bit_blast_shl_int_size_ss Hbbshlint) => Hszshlint.
    move : (size_nseq (size lrs_hd) ls2_hd) => Hszcopy.
    move : (bit_blast_and_size_ss Hbband). rewrite Hszshlint. move => Hszand.
    apply  Hszand in Hszcopy. rewrite size_nseq in Hszand. move : Hres.
    rewrite Hszmul in Hszshlint.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff); case => _ _ <-; try done; try by rewrite (bit_blast_add_size_ss Hbbadd Hszshlint).
    rewrite (bit_blast_add_size_ss Hbbadd2); [done| by rewrite -Hszand].
Qed.

Lemma bit_blast_mul_size_ss :
  forall ls2 g ls1 g' cs lrs, bit_blast_mul g ls1 ls2 = (g', cs, lrs) -> size ls1 = size lrs.
Proof.
  intros. rewrite /bit_blast_mul. exact: (bit_blast_mul_rec_size_ss H).
Qed.

Lemma mk_env_mul_rec_is_bit_blast_mul_rec :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    bit_blast_mul_rec g ls1 ls2 i = (g', cs, lrs).
Proof.
  elim => [| ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - rewrite /=/bit_blast_const. by case => _ <- <- <-.
  - rewrite /=.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshlint].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand : (mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2].
    rewrite (IH _ _ _ _ _ _ _ _ Hmkmul) (mk_env_shl_int_is_bit_blast_shl_int Hmkshlint) (mk_env_add_is_bit_blast_add Hmkadd) (mk_env_and_is_bit_blast_and Hmkand) (mk_env_add_is_bit_blast_add Hmkadd2).
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff); by  move => [] _<- <- <-.
Qed.

Lemma mk_env_mul_is_bit_blast_mul :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2 = (E', g', cs, lrs) ->
    bit_blast_mul g ls1 ls2 = (g', cs, lrs).
Proof.
  intros.
  rewrite /mk_env_mul/bit_blast_mul (mk_env_mul_rec_is_bit_blast_mul_rec H). done.
Qed.

Lemma mk_env_mul_rec_newer_gen :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    (g <=? g')%positive.
Proof.
  elim  => [| ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - move => [] _ <- _ _.
    exact: Pos.leb_refl.
  - rewrite /=.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshlint].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand : (mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2].
    move : (IH _ _ _ _ _ _ _ _ Hmkmul) => Hgg0.
    move : (mk_env_shl_int_newer_gen Hmkshlint) => Hg0g1.
    move : (mk_env_add_newer_gen Hmkadd) => Hg1g2.
    move : (mk_env_and_newer_gen Hmkand) => Hg1g3.
    move : (mk_env_add_newer_gen Hmkadd2) => Hg3g4.
    move : (pos_leb_trans Hgg0 (pos_leb_trans Hg0g1 Hg1g2)) => Hgg2.
    move : (pos_leb_trans (pos_leb_trans Hgg0 Hg0g1) (pos_leb_trans Hg1g3 Hg3g4)) => Hgg4.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff); (move => [] _ <- _ _; try exact).
Qed.

Lemma mk_env_mul_newer_gen:
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2 = (E', g', cs, lrs) ->
    (g <=? g')%positive.
Proof.
  rewrite/mk_env_mul. intros. exact: (mk_env_mul_rec_newer_gen H).
Qed.

Lemma mk_env_mul_rec_newer_res :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g' lrs.
Proof.
  elim => [| ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - rewrite /=.  move => IH Htt.
    rewrite (mk_env_const_newer_res IH); done.
  - rewrite /mk_env_mul/=.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshlint].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand : (mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2]. move => Hres Htt.
    move : (IH _ _ _ _ _ _ _ _ Hmkmul Htt) => Hg0ls.
    move : (mk_env_add_newer_res Hmkadd) => Hg2ls4.
    move : (mk_env_add_newer_res Hmkadd2) => Hg4ls6.
    move : Hres.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff); move => [] _ <- _ <-; try exact.
Qed.

Lemma mk_env_mul_newer_res :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2 = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g' lrs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_mul. exact : (mk_env_mul_rec_newer_res).
Qed.

Lemma mk_env_mul_rec_newer_cnf :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
Proof.
  elim => [| ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - move => [] _ <- <- _ _ _. done.
  - rewrite /mk_env_mul/=.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshlint].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand : (mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2]. move => Hres Htt Hgls1 Hgls2.
    generalize Htt; rewrite newer_than_lit_tt_ff => Hff .
    move/andP : Hgls2 => [Hgls2hd Hgls2tl].
    move : (IH _ _ _ _ _ _ _ _ Hmkmul Htt Hgls1 Hgls2tl) => Hg0cs0.
    move : (mk_env_mul_rec_newer_gen Hmkmul) => Hgg0.
    move : (mk_env_shl_int_newer_gen Hmkshlint) => Hg0g1.
    move : (mk_env_add_newer_gen Hmkadd) => Hg1g2.
    move : (mk_env_and_newer_gen Hmkand) => Hg1g3.
    move : (mk_env_add_newer_gen Hmkadd2) => Hg3g4.
    move : (mk_env_mul_rec_newer_res Hmkmul Htt) => Hg0ls.
    move : (mk_env_shl_int_newer_res (newer_than_lit_le_newer Htt Hgg0) (newer_than_lits_le_newer Hgls1 Hgg0) Hmkshlint) => Hg1ls3.
    move : (bit_blast_mul_rec_size_ss (mk_env_mul_rec_is_bit_blast_mul_rec Hmkmul)) => Hszmul.
    move : (bit_blast_shl_int_size_ss (mk_env_shl_int_is_bit_blast_shl_int Hmkshlint)) => Hszshl; rewrite Hszmul in Hszshl.
    move : (bit_blast_add_size_ss (mk_env_add_is_bit_blast_add Hmkadd) Hszshl) => Hszadd.
    move : (mk_env_add_newer_cnf Hmkadd (newer_than_lits_le_newer Hg0ls Hg0g1) Hg1ls3 (newer_than_lit_le_newer Htt (pos_leb_trans Hgg0 Hg0g1))) => Hg2cs2.
    move : (pos_leb_trans Hgg0 Hg0g1) => Hgg1.
    move : (pos_leb_trans Hg0g1 Hg1g2) => Hg0g2.
    move : (pos_leb_trans Hg1g3 Hg3g4) => Hg1g4.
    move : (pos_leb_trans Hgg0 (pos_leb_trans Hg0g1 Hg1g3)) => Hgg3.
    move : (pos_leb_trans Hg0g1 Hg1g3) => Hg0g3.
    move : (mk_env_shl_int_newer_cnf Hmkshlint (newer_than_lits_le_newer Hgls1 Hgg0)) => Hg1cs1.
    move : (mk_env_and_newer_res Hmkand) => Hg3ls5.
    move : (Hg3ls5 (newer_than_lit_le_newer Htt Hgg1) (newer_than_lits_copy (size ls1)  (newer_than_lit_le_newer Hgls2hd Hgg1)) Hg1ls3) => {Hg3ls5}Hg3ls5.
    move : (bit_blast_and_size_ss (mk_env_and_is_bit_blast_and Hmkand))=> Hszand.
    rewrite size_nseq Hszmul in Hszand. move : (Hszand Hszshl) => {Hszand}Hszand.
    move : (mk_env_add_newer_cnf Hmkadd2 (newer_than_lits_le_newer Hg0ls Hg0g3) Hg3ls5 (newer_than_lit_le_newer Htt Hgg3)) => Hg4cs4.
    move : (mk_env_and_newer_cnf Hmkand) => Hg3cs3.
    move: (Hg3cs3 (newer_than_lit_le_newer Htt Hgg1) (newer_than_lits_copy (size ls1) (newer_than_lit_le_newer Hgls2hd Hgg1)) Hg1ls3) => {Hg3cs3}Hg3cs3.
    move : Hres.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff); move => [] _ <- <- _; try exact; rewrite !newer_than_cnf_catrev.
    by rewrite (newer_than_cnf_le_newer Hg0cs0 Hg0g2) (newer_than_cnf_le_newer Hg1cs1 Hg1g2) Hg2cs2.
    by rewrite (newer_than_cnf_le_newer Hg0cs0 Hg0g2) (newer_than_cnf_le_newer Hg1cs1 Hg1g2) Hg2cs2.
    by rewrite (newer_than_cnf_le_newer Hg0cs0 (pos_leb_trans Hg0g3 Hg3g4)) (newer_than_cnf_le_newer Hg1cs1 Hg1g4) (newer_than_cnf_le_newer Hg3cs3 Hg3g4) Hg4cs4.
Qed.

Lemma mk_env_mul_newer_cnf :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2 = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_mul. exact : (mk_env_mul_rec_newer_cnf).
Qed.

Lemma bit_blast_mul_rec_correct :
  forall ls2 g bs1 bs2 i E ls1 g' cs lrs,
    bit_blast_mul_rec g ls1 ls2 i = (g', cs, lrs) ->
    enc_bits E ls1 bs1 ->
    enc_bits E ls2 bs2 ->
    interp_cnf E (add_prelude cs) -> (*(size ls1)>0 ->*)
    enc_bits E lrs (mulB bs1 (from_nat (size bs1) (to_nat bs2 * (2^i)))).
Proof.
  elim => [|ls2_hd ls2_tl IH] g bs1 bs2 i E ls1 g' cs lrs.
  - rewrite /bit_blast_mul_rec/bit_blast_const. rewrite enc_bits_nil_l.
    case => _ <- <- Henc1 Henc2 Hcnf /=. rewrite (eqP Henc2)/=mul0n.
    rewrite (enc_bits_size Henc1) mulB0. by rewrite (enc_bits_lit_of_bool (from_nat (size bs1) 0) (add_prelude_enc_bit_tt Hcnf)).
  - rewrite /bit_blast_mul_rec -/bit_blast_mul_rec
            (lock interp_cnf) (lock bit_blast_add) (lock bit_blast_and)
            (lock bit_blast_shl_int) (lock enc_bits) /= -!lock.
    dcase (bit_blast_mul_rec g ls1 ls2_tl (i + 1)) => [[[g_tl cs_tl] lrs_tl] Hbbmul].
    dcase (bit_blast_shl_int g_tl ls1 i) => [[[g_hd cs_hd] lrs_hd] Hbbshl].
    dcase (bit_blast_add g_hd lrs_tl lrs_hd) => [[[g_add cs_add] lrs_add] Hbbadd].
    case Hbband : (bit_blast_and g_hd (copy (size ls1) ls2_hd) lrs_hd) => [[g_and cs_and] lrs_and].
    dcase (bit_blast_add g_and lrs_tl lrs_and) => [[[g_add2 cs_add2] lrs_add2] Hbbadd2].
    case Htt: (ls2_hd == lit_tt); last case Hff: (ls2_hd == lit_ff).
    + rewrite (eqP Htt). case => _ <- <- Henc1 Henc2.
      rewrite 2!add_prelude_catrev. move => Hcnf; split_andb_hyps.
      move : (enc_bits_splitlsb (add_prelude_tt H) Henc2) => /andP[Hls2hd Hls2tl].
      rewrite /splitlsl/= in Hls2tl; rewrite /splitlsl/= in Hls2hd.
      move : (IH _ _ _ _ _ _ _ _ _ Hbbmul Henc1 Hls2tl H) => Henclrstl.
      move : (ltn0Sn ((size ls2_tl))) => Hsz2; move : (enc_bits_size Henc2) => /=Hsz2'.
      rewrite Hsz2' in Hsz2.
      move : (joinlsb_splitlsb  Hsz2) => Hsplitbs2.
      rewrite /splitlsb/= in Hsplitbs2; rewrite -Hsplitbs2.
      rewrite (add_prelude_enc_bit_true (head b0 bs2) H) in Hls2hd.
      rewrite Hls2hd/=.
      apply : (bit_blast_add_correct Hbbadd Henclrstl (bit_blast_shl_int_correct Hbbshl Henc1 H1) _ H0).
      * rewrite mulnDl mul1n -muln2 -mulnA -expnS.
        rewrite nat_of_add_bin /=.
          by rewrite /shlB shlB_mul2exp mulB_addn addBC addn1.
      * by rewrite -(bit_blast_mul_rec_size_ss Hbbmul) -(bit_blast_shl_int_size_ss Hbbshl).
    + rewrite (eqP Hff). case => _ <- <- Henc1 Henc2 Hcnf.
      move : (enc_bits_splitlsb (add_prelude_tt Hcnf) Henc2) => /andP[Hls2hd Hls2tl].
      rewrite /splitlsl/= in Hls2tl; rewrite /splitlsl/= in Hls2hd.
      rewrite (add_prelude_enc_bit_is_false _ Hcnf) in Hls2hd.
      move : (ltn0Sn ((size ls2_tl))) => Hsz2; move : (enc_bits_size Henc2) => /=Hsz2'.
      rewrite Hsz2' in Hsz2.
      move : (joinlsb_splitlsb  Hsz2) => Hsplitbs2.
      rewrite /splitlsb/= in Hsplitbs2; rewrite -Hsplitbs2 (eqP Hls2hd)/=.
      rewrite add0n -muln2 -mulnA -expnS -(addn1 i).
      have: 1 = nat_of_bin 1%num by reflexivity. move=> {2}->. rewrite -nat_of_add_bin.
      exact : (IH _ _ _ _ _ _ _ _ _ Hbbmul Henc1 Hls2tl Hcnf).
    + case => _ <- <- Henc1 Henc2. rewrite 3!add_prelude_catrev; move => Hcnf; split_andb_hyps.
      move : (enc_bits_splitlsb (add_prelude_tt H) Henc2) => /andP[Hls2hd Hls2tl].
      rewrite /splitlsl/= in Hls2tl; rewrite /splitlsl/= in Hls2hd.
      move : (ltn0Sn ((size ls2_tl))) => Hsz2; move : (enc_bits_size Henc2) => /=Hsz2'.
      rewrite Hsz2' in Hsz2.
      move : (joinlsb_splitlsb  Hsz2) => Hsplitbs2.
      rewrite /splitlsb/= in Hsplitbs2; rewrite -Hsplitbs2.
      move : (IH _ _ _ _ _ _ _ _ _ Hbbmul Henc1 Hls2tl H) => Henclrstl.
      move : (bit_blast_shl_int_correct Hbbshl Henc1 H2) => Henclrshd.
      move : (enc_bits_copy (size ls1) Hls2hd) => Hcopy.
      move : (bit_blast_and_correct Hbband Hcopy Henclrshd H1) => Henclrsand.
      apply : (bit_blast_add_correct Hbbadd2 Henclrstl Henclrsand _ H0).
      rewrite /shlB shlB_mul2exp. rewrite (enc_bits_size Henc1).
      have ->: ((copy (size bs1) (head b0 bs2) &&# (bs1 *# (size bs1) -bits of (2 ^ i)))%bits=(mulB (bs1 *# (size bs1) -bits of (2 ^ i)) (from_nat (size bs1) (head b0 bs2)))%bits).
      move : (enc_bits_size Henc1).
      move: (andB_copy_mul (head b0 bs2) (bs1 *# (size bs1) -bits of (2 ^ i))%bits).
      by rewrite size_low.
      rewrite to_nat_cons -mulB_muln -mulB_addn.
      rewrite nat_of_add_bin.
      replace (to_nat (behead bs2) * 2 ^ (i + 1%num) + 2 ^ i * head b0 bs2)
        with ((head b0 bs2) * 2 ^ i + to_nat (behead bs2) * 2^ (i + 1%num)) by ring.
        by rewrite mulnDl -muln2 -mulnA -expnS addn1.
      rewrite -(bit_blast_mul_rec_size_ss Hbbmul) -(bit_blast_and_size_ss Hbband) size_nseq; try done. by rewrite (bit_blast_shl_int_size_ss Hbbshl).
Qed.

Lemma bit_blast_mul_correct :
  forall g (bs1 bs2 : bits) E ls1 ls2 g' cs lrs,
    bit_blast_mul g ls1 ls2 = (g', cs, lrs) ->
    enc_bits E ls1 bs1 ->
    enc_bits E ls2 bs2 ->
    interp_cnf E (add_prelude cs) ->
    size ls1 = size ls2 ->
    enc_bits E lrs (mulB bs1 bs2).
Proof.
  move => g bs1 bs2 E ls1 ls2 g' cs lrs Hmul Henc_bs1 Henc_bs2 Hcnf Hszeq.
  rewrite -(from_nat_to_nat bs2). replace (to_nat bs2) with (to_nat bs2 * (2^ 0)) by ring.
  rewrite -(enc_bits_size Henc_bs2) -Hszeq (enc_bits_size Henc_bs1).
  exact : (bit_blast_mul_rec_correct Hmul Henc_bs1 Henc_bs2 Hcnf ).
Qed.

Lemma mk_env_mul_rec_preserve :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    env_preserve E E' g.
Proof.
  elim => [|ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - by case => <- _ _ _.
  - rewrite /mk_env_mul_rec -/mk_env_mul_rec (lock mk_env_add) (lock mk_env_and) (lock mk_env_shl_int) /= -!lock.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshl].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand :(mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd)=> [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2].
    move : (IH _ _ _ _ _ _ _ _ Hmkmul) => HEE0g.
    move : (mk_env_add_preserve Hmkadd2) => HE3E4g3.
    move : (mk_env_add_preserve Hmkadd) => HE1E2g1.
    move : (mk_env_and_preserve Hmkand) => HE1E3g1.
    move : (mk_env_shl_int_preserve Hmkshl) => HE0E1g1.
    move : (mk_env_mul_rec_newer_gen Hmkmul) => Hgg0.
    move : (mk_env_shl_int_newer_gen Hmkshl) => Hg0g1.
    move : (env_preserve_le HE1E2g1 (pos_leb_trans Hgg0 Hg0g1)) => HE1E2g.
    move : (env_preserve_le HE0E1g1 Hgg0) => HE0E1g.
    move : (env_preserve_le HE1E3g1 (pos_leb_trans Hgg0 Hg0g1)) => HE1E3g.
    move : (mk_env_and_newer_gen Hmkand) => Hg1g3.
    move : (env_preserve_le HE3E4g3 (pos_leb_trans Hgg0 (pos_leb_trans Hg0g1 Hg1g3))) => HE3E4g.
    move : (env_preserve_trans HEE0g (env_preserve_trans HE0E1g (env_preserve_trans HE1E3g HE3E4g))) => HEE4g.
    move : (env_preserve_trans HEE0g (env_preserve_trans HE0E1g HE1E2g)) => HEE2g.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff);
      move => [] <- _ _ _; try exact.
Qed.

Lemma mk_env_mul_preserve :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2 = (E', g', cs, lrs) ->
    env_preserve E E' g.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_mul. move => Hmk. exact (mk_env_mul_rec_preserve Hmk).
Qed.

Lemma mk_env_mul_rec_sat :
  forall ls2 E g ls1 i E' g' cs lrs,
    mk_env_mul_rec E g ls1 ls2 i = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    interp_cnf E' cs.
Proof.
  elim => [|ls2_hd ls2_tl IH] E g ls1 i E' g' cs lrs.
  - by case => _ _ <- _ _ _ _.
  - rewrite /mk_env_mul_rec -/mk_env_mul_rec (lock mk_env_add) (lock mk_env_and) (lock mk_env_shl_int) /= -!lock.
    dcase (mk_env_mul_rec E g ls1 ls2_tl (i + 1)) => [[[[E_tl g_tl] cs_tl] lrs_tl] Hmkmul].
    dcase (mk_env_shl_int E_tl g_tl ls1 i) => [[[[E_hd g_hd] cs_hd] lrs_hd] Hmkshl].
    dcase (mk_env_add E_hd g_hd lrs_tl lrs_hd) => [[[[E_add g_add] cs_add] lrs_add] Hmkadd].
    case Hmkand :(mk_env_and E_hd g_hd (copy (size ls1) ls2_hd) lrs_hd)=> [[[E_and g_and] cs_and] lrs_and].
    dcase (mk_env_add E_and g_and lrs_tl lrs_and) => [[[[E_add2 g_add2] cs_add2] lrs_add2] Hmkadd2].
    move => Hres Htt Hgls1 /andP [Hgls2hd Hgls2tl].
    move : (IH _ _ _ _ _ _ _ _ Hmkmul Htt Hgls1 Hgls2tl) => HE0cs0.
    move : (mk_env_shl_int_preserve Hmkshl) => HE0E1g0.
    move : (mk_env_mul_rec_newer_gen Hmkmul) => Hgg0.
    move : (mk_env_add_preserve Hmkadd) => HE1E2g1.
    move : (mk_env_shl_int_newer_gen Hmkshl) => Hg0g1.
    move : (env_preserve_le HE1E2g1 Hg0g1) => HE1E2g0.
    move : (env_preserve_trans HE0E1g0 HE1E2g0) => HE0E2g0.
    move : (mk_env_mul_rec_newer_cnf Hmkmul Htt Hgls1 Hgls2tl) => Hcnfg0cs0.
    move : (newer_than_cnf_le_newer Hcnfg0cs0 Hg0g1) => Hcnfg1cs0.
    move : (mk_env_mul_rec_newer_res Hmkmul Htt) => Hg0ls.
    move : (newer_than_lits_le_newer Hg0ls Hg0g1) => Hg1ls.
    move : (mk_env_shl_int_newer_res (newer_than_lit_le_newer Htt Hgg0) (newer_than_lits_le_newer Hgls1 Hgg0) Hmkshl) => Hg1ls3.
    move : (mk_env_add_sat Hmkadd Hg1ls Hg1ls3 (newer_than_lit_le_newer Htt (pos_leb_trans Hgg0 Hg0g1))) => HcnfE2cs2.
    move : (mk_env_shl_int_sat Hmkshl (newer_than_lits_le_newer Hgls1 Hgg0)) => HcnfE1cs1.
    move : (mk_env_shl_int_newer_cnf Hmkshl (newer_than_lits_le_newer Hgls1 Hgg0)) => Hg1cs1. move : Hres.
    case (ls2_hd == lit_tt); case (ls2_hd == lit_ff);
    move =>[] <- _ <- _; try rewrite !interp_cnf_catrev;
    try (exact||
         rewrite (env_preserve_cnf HE0E2g0 Hcnfg0cs0) HE0cs0 HcnfE2cs2 (env_preserve_cnf HE1E2g1 Hg1cs1) HcnfE1cs1; done).
    move : (mk_env_and_newer_gen Hmkand) => Hg1g3.
    move : (mk_env_add_newer_gen Hmkadd2) => Hg3g4.
    move : (pos_leb_trans Hgg0 Hg0g1) => Hgg1.
    move : (pos_leb_trans Hg1g3 Hg3g4) => Hg1g4.
    move : (newer_than_lits_le_newer Hg1ls Hg1g3) => Hg3ls.
    move : (newer_than_lits_copy (size ls1) Hgls2hd) => Hgcopyls2.
    move : (mk_env_and_newer_res Hmkand (newer_than_lit_le_newer Htt Hgg1) (newer_than_lits_le_newer Hgcopyls2 Hgg1) Hg1ls3) => Hg3ls5.
    move : (mk_env_add_sat Hmkadd2 Hg3ls Hg3ls5 (newer_than_lit_le_newer Htt (pos_leb_trans Hgg1 Hg1g3))) => HE4cs4.
    move : (mk_env_and_preserve Hmkand) => HE1E3g1.
    move : (mk_env_add_preserve Hmkadd2) => HE3E4g3.
    move : (env_preserve_le HE1E3g1 Hg0g1) => HE1E3g0.
    move : (env_preserve_le HE3E4g3 (pos_leb_trans Hg0g1 Hg1g3)) => HE3E4g0.
    move : (env_preserve_le HE3E4g3 Hg1g3) => HE3E4g1.
    move : (env_preserve_trans HE0E1g0 (env_preserve_trans HE1E3g0 HE3E4g0)) => HE0E4g0.
    rewrite (env_preserve_cnf HE0E4g0 Hcnfg0cs0) HE0cs0 /=.
    move : (env_preserve_trans HE1E3g1 HE3E4g1) => HE1E4g1.
    rewrite (env_preserve_cnf HE1E4g1 Hg1cs1) HcnfE1cs1 /=.
    move : (mk_env_and_newer_cnf Hmkand (newer_than_lit_le_newer Htt Hgg1) (newer_than_lits_le_newer Hgcopyls2 Hgg1) Hg1ls3) => Hg3cs3.
    rewrite (env_preserve_cnf HE3E4g3 Hg3cs3) (mk_env_and_sat Hmkand (newer_than_lit_le_newer Htt Hgg1) (newer_than_lits_le_newer Hgcopyls2 Hgg1) Hg1ls3) HE4cs4.
    done.
Qed.

Lemma mk_env_mul_sat :
  forall E g ls1 ls2 E' g' cs lrs,
    mk_env_mul E g ls1 ls2  = (E', g', cs, lrs) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    interp_cnf E' cs.
Proof.
  move => E g ls1 ls2 E' g' cs lrs.
  rewrite /mk_env_mul. move => Hmk Hgtt Hgls1 Hgls2.
  exact : (mk_env_mul_rec_sat Hmk Hgtt Hgls1 Hgls2).
Qed.

Lemma mk_env_mul_rec_env_equal E1 E2 g ls1 ls2 n E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_mul_rec E1 g ls1 ls2 n = (E1', g1', cs1, lrs1) ->
  mk_env_mul_rec E2 g ls1 ls2 n = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  elim: ls2 E1 E2 g ls1 n E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 =>
  [| l2 ls2 IH] /= E1 E2 g ls1 n E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 Heq.
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - dcase (mk_env_mul_rec E1 g ls1 ls2 (n + 1)) => [[[[E_tl1 g_tl1] cs_tl1] lrs_tl1] Hbb_tl1].
    dcase (mk_env_mul_rec E2 g ls1 ls2 (n + 1)) => [[[[E_tl2 g_tl2] cs_tl2] lrs_tl2] Hbb_tl2].
    move: (IH _ _ _ _ _ _ _ _ _ _ _ _ _ Heq Hbb_tl1 Hbb_tl2) => [Heq1 [? [? ?]]]; subst.
    case: (l2 == lit_tt).
    + dcase (mk_env_shl_int E_tl1 g_tl2 ls1 n) => [[[[E_hd1 g_hd1] cs_hd1] lrs_hd1] Hbb_hd1].
      dcase (mk_env_shl_int E_tl2 g_tl2 ls1 n) => [[[[E_hd2 g_hd2] cs_hd2] lrs_hd2] Hbb_hd2].
      move: (mk_env_shl_int_env_equal Heq1 Hbb_hd1 Hbb_hd2) => [Heq2 [? [? ?]]]; subst.
      dcase (mk_env_add E_hd1 g_hd2 lrs_tl2 lrs_hd2) =>
      [[[[E_add1 g_add1] cs_add1] lrs_add1] Hv_add1].
      dcase (mk_env_add E_hd2 g_hd2 lrs_tl2 lrs_hd2) =>
      [[[[E_add2 g_add2] cs_add2] lrs_add2] Hv_add2].
      move: (mk_env_add_env_equal Heq2 Hv_add1 Hv_add2) => [Heq3 [? [? ?]]]; subst.
      case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
    + case: (l2 == lit_ff).
      * case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
      * dcase (mk_env_shl_int E_tl1 g_tl2 ls1 n) => [[[[E_hd1 g_hd1] cs_hd1] lrs_hd1] Hbb_hd1].
        dcase (mk_env_shl_int E_tl2 g_tl2 ls1 n) => [[[[E_hd2 g_hd2] cs_hd2] lrs_hd2] Hbb_hd2].
        move: (mk_env_shl_int_env_equal Heq1 Hbb_hd1 Hbb_hd2) => [Heq2 [? [? ?]]]; subst.
        dcase (mk_env_and E_hd1 g_hd2 (copy (size ls1) l2) lrs_hd2) =>
        [[[[E_and1 g_and1] cs_and1] lrs_and1] Hv_and1]. rewrite Hv_and1.
        dcase (mk_env_and E_hd2 g_hd2 (copy (size ls1) l2) lrs_hd2) =>
        [[[[E_and2 g_and2] cs_and2] lrs_and2] Hv_and2]. rewrite Hv_and2.
        move: (mk_env_and_env_equal Heq2 Hv_and1 Hv_and2) => [Heq3 [? [? ?]]]; subst.
        dcase (mk_env_add E_and1 g_and2 lrs_tl2 lrs_and2) =>
        [[[[E_add1 g_add1] cs_add1] lrs_add1] Hv_add1].
        dcase (mk_env_add E_and2 g_and2 lrs_tl2 lrs_and2) =>
        [[[[E_add2 g_add2] cs_add2] lrs_add2] Hv_add2].
        move: (mk_env_add_env_equal Heq3 Hv_add1 Hv_add2) => [Heq4 [? [? ?]]]; subst.
        case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.

Lemma mk_env_mul_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_mul E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_mul E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof. exact: mk_env_mul_rec_env_equal. Qed.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_examples.logrel.prelude Require Export base.
From iris.algebra Require Export ofe.
From stdpp Require Import gmap.

Module F_mu_ref.
  Definition loc := positive.

  Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive expr :=
  | Var (x : var)
  | Lam (e : {bind 1 of expr})
  | App (e1 e2 : expr)
  (* Unit *)
  | Unit
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | LamV (e : {bind 1 of expr})
  | TLamV (e : {bind 1 of expr})
  | UnitV
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | FoldV (v : val)
  | LocV (l : loc).

  Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | TLamV e => TLam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | FoldV v => Fold (of_val v)
    | LocV l => Loc l
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | TLam e => Some (TLamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Fold e => v ← to_val e; Some (FoldV v)
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | TAppCtx
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val).

  Notation ectx := (list ectx_item).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | TAppCtx => TApp e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    end.

  Definition state : Type := gmap loc val.

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ [] e σ []
  (* Polymorphic Types *)
  | TBeta e σ :
      head_step (TApp (TLam e)) σ [] e σ []
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ [] (Loc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ [] (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ [] (Unit) (<[l:=v]>σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κ e2 σ2 ef :
    head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom (gset loc) σ) in
    to_val e = Some v → head_step (Alloc e) σ [] (Loc l) (<[l:=v]>σ) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

  Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.

  Canonical Structure stateO := leibnizO state.
  Canonical Structure valO := leibnizO val.
  Canonical Structure exprO := leibnizO expr.
End F_mu_ref.

Canonical Structure F_mu_ref_ectxi_lang := EctxiLanguage F_mu_ref.lang_mixin.
Canonical Structure F_mu_ref_ectx_lang := EctxLanguageOfEctxi F_mu_ref_ectxi_lang.
Canonical Structure F_mu_ref_lang := LanguageOfEctx F_mu_ref_ectx_lang.

Export F_mu_ref.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Local Hint Resolve language.val_irreducible.
Local Hint Resolve to_of_val.
Local Hint Unfold language.irreducible.
Global Instance is_atomic_correct s e : is_atomic e → Atomic s e.
Proof.
  intros Ha; apply strongly_atomic_atomic,  ectx_language_atomic.
  - destruct 1; simpl in *; try tauto; eauto.
  - intros K e' -> Hval%eq_None_not_Some.
    induction K using rev_ind; first done.
    simpl in Ha; rewrite fill_app in Ha; simpl in Ha.
    destruct Hval. apply (fill_val K e'); simpl in *.
    destruct x; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Hint Extern 0 (Atomic _ _) => solve_atomic.
Hint Extern 0 (Atomic _ _) => solve_atomic : typeclass_instances.