(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
From stdpp Require Import nmap pmap natmap mapset fin_maps.
Require Export type_environment.

Set Warnings "-fragile-hint-constr".

(** * Indexes into the memory *)
(** We define indexes into the memory as binary naturals and use the [Nmap]
implementation to obtain efficient finite maps and finite sets with these
indexes as keys. *)
Definition index := N.
Definition indexmap := Nmap.
Notation indexset := (mapset indexmap).

#[global] Instance index_dec: EqDecision index := _.
#[global] Instance index_inhabited: Inhabited index := populate 0%N.
#[global] Instance indexmap_dec {A} `{EqDecision A} : EqDecision (indexmap A) := _.
#[global] Instance indexmap_empty {A} : Empty (indexmap A) := @empty (Nmap A) _.
#[global] Instance indexmap_lookup {A} : Lookup index A (indexmap A) :=
  @lookup _ _ (Nmap A) _.
#[global] Instance indexmap_partial_alter {A} : PartialAlter index A (indexmap A) :=
  @partial_alter _ _ (Nmap A) _.
#[global] Instance indexmap_to_list {A} : FinMapToList index A (indexmap A) :=
  @map_to_list _ _ (Nmap A) _.
#[global] Instance indexmap_omap: OMap indexmap := @omap Nmap _.
#[global] Instance indexmap_merge: Merge indexmap := @merge Nmap _.
#[global] Instance indexmap_fmap: FMap indexmap := @fmap Nmap _.
#[global] Instance: FinMap index indexmap := _.
#[global] Instance indexmap_dom {A} : Dom (indexmap A) indexset := mapset_dom.
#[global] Instance: FinMapDom index indexmap indexset := mapset_dom_spec.
#[global] Instance index_fresh : Fresh index indexset := _.
#[global] Instance index_infinity: Infinite index := _.
#[global] Instance index_lexico : Lexico index := @lexico N _.
#[global] Instance index_lexico_order : StrictOrder (@lexico index _) := _.
#[global] Instance index_trichotomy: TrichotomyT (@lexico index _) := _.
Typeclasses Opaque index indexmap.

Global Hint Immediate (is_fresh (A:=index) (C:=indexset)): core.
Global Hint Immediate (Forall_fresh_list (A:=index) (C:=indexset)): core.
Global Hint Immediate (fresh_list_length (A:=index) (C:=indexset)): core.

(** * Memory environments *)
Notation memenv K :=
  (indexmap (type K * bool (* false = alive, true = freed *))).
#[global] Instance index_typed {K} : Typed (memenv K) (type K) index := λ Δ o τ,
  ∃ β, Δ !! o = Some (τ,β).
Definition index_alive {K} (Δ : memenv K) (o : index) : Prop :=
  ∃ τ, Δ !! o = Some (τ,false).
#[global] Instance memenv_valid `{Env K} : Valid (env K) (memenv K) := λ Γ Δ,
  ∀ o τ, Δ ⊢ o : τ → ✓{Γ} τ.

#[global] Instance index_typecheck {K} : TypeCheck (memenv K) (type K) index := λ Δ o,
  fst <$> Δ !! o.
#[global] Instance: `{TypeCheckSpec (memenv K) (type K) index (λ _, True)}.
Proof.
  intros ? Δ o τ. split; unfold type_check, typed,index_typecheck, index_typed.
  * destruct (Δ !! o) as [[??]|]; naive_solver.
  * by intros [? ->].
Qed.
#[global] Instance index_alive_dec {K} (Δ : memenv K) o : Decision (index_alive Δ o).
 refine
  match Δ !! o as mβτ return Decision (∃ τ, mβτ = Some (τ,false)) with
  | Some (_,β) => match β with true => right _ | false => left _ end
  | None => right _
  end; abstract naive_solver.
Defined.
Lemma memenv_empty_valid `{Env K} Γ : ✓{Γ} (∅ : memenv K).
Proof. intros ?? [??]; simplify_map_eq. Qed.
Lemma memenv_valid_weaken `{EnvSpec K} Γ1 Γ2 (Δ : memenv K) :
  ✓ Γ1 → ✓{Γ1} Δ → Γ1 ⊆ Γ2 → ✓{Γ2} Δ.
Proof. intros ? HΔ ? o τ ?; eauto using type_valid_weaken. Qed.
Lemma index_typed_valid `{EnvSpec K} Γ (Δ : memenv K) o τ :
  ✓{Γ} Δ → Δ ⊢ o : τ → ✓{Γ} τ.
Proof. eauto. Qed.

(** During the execution of the semantics, the memory environments should only
grow, i.e. new objects may be allocated and current objects may be freed. We
prove that the step relation of the semantics is monotone with respect to the
forward relation below. *)
Record memenv_forward {K} (Δ1 Δ2  : memenv K) := {
  memenv_forward_typed o τ : Δ1 ⊢ o : τ → Δ2 ⊢ o : τ;
  memenv_forward_alive o τ : Δ1 ⊢ o : τ → index_alive Δ2 o → index_alive Δ1 o
}.
Notation "Δ1 ⇒ₘ Δ2" := (memenv_forward Δ1 Δ2)
  (at level 70, format "Δ1  ⇒ₘ  Δ2") : C_scope.
#[global] Instance: `{PartialOrder (@memenv_forward K)}.
Proof.
  split; [split; [|intros ??? [??] [??]]; split; naive_solver|].
  cut (∀ (Δ1 Δ2 : memenv K) o τ β,
    Δ1 ⇒ₘ Δ2 → Δ2 ⇒ₘ Δ1 → Δ1 !! o = Some (τ,β) → Δ2 !! o = Some (τ,β)).
  { intros ? Δ1 Δ2 ??; apply map_eq; intros o.
    apply option_eq; intros [τ β]; naive_solver. }
  intros Δ1 Δ2 o τ β [Htyped Halive1] [_ Halive2] ?.
  destruct (Htyped o τ) as [β' ?]; [by exists β|]; destruct β, β'; auto.
  * destruct (Halive1 o τ). by exists true. by exists τ. naive_solver.
  * destruct (Halive2 o τ). by exists true. by exists τ. naive_solver.
Qed.
Global Hint Extern 0 (?Δ1 ⇒ₘ ?Δ2) => reflexivity: core.
Global Hint Extern 1 (_ ⇒ₘ _) => etransitivity; [eassumption|]: core.
Global Hint Extern 1 (_ ⇒ₘ _) => etransitivity; [|eassumption]: core.
Lemma index_typed_weaken {K} (Δ1 Δ2 : memenv K) o τ :
  Δ1 ⊢ o : τ → Δ1 ⇒ₘ Δ2 → Δ2 ⊢ o : τ.
Proof. eauto using memenv_forward_typed. Qed.
Lemma indexes_typed_weaken {K} (Δ1 Δ2 : memenv K) os τs :
  Δ1 ⊢* os :* τs → Δ1 ⇒ₘ Δ2 → Δ2 ⊢* os :* τs.
Proof. eauto using Forall2_impl, memenv_forward_typed. Qed.
Lemma memenv_subseteq_forward {K} (Δ1 Δ2  : memenv K) :
  Δ1 ⊆ Δ2 → Δ1 ⇒ₘ Δ2.
Proof.
  split.
  * intros o τ [β ?]; exists β; eauto using lookup_weaken.
  * intros o τ [β ?] [τ' ?]; exists τ.
    assert (Δ2 !! o = Some (τ, β)) by eauto using lookup_weaken.
    naive_solver.
Qed.
Lemma memenv_subseteq_alive {K} (Δ1 Δ2  : memenv K) o :
  Δ1 ⊆ Δ2 → index_alive Δ1 o → index_alive Δ2 o.
Proof. intros ? [β ?]; exists β; eauto using lookup_weaken. Qed.

(** * Locked locations *)
Definition lockset : iType :=
  dsig (A:=indexmap natset) (map_Forall (λ _, (.≠ ∅))).
#[global] Instance lockset_eq_dec: EqDecision lockset | 1 := _.
Typeclasses Opaque lockset.

#[global] Instance lockset_elem_of : ElemOf (index * nat) lockset := λ oi Ω,
  ∃ ω, `Ω !! oi.1 = Some ω ∧ oi.2 ∈ ω.
#[global, program] Instance lockset_empty: Empty lockset := dexist ∅ _.
Next Obligation. by intros ??; simpl_map. Qed.
Global Program Instance lockset_singleton: Singleton (index * nat) lockset := λ oi,
  dexist {[ oi.1 := {[ oi.2 ]} ]} _.
Next Obligation.
  intros ???. rewrite lookup_singleton_Some; intros [<- <-];
  apply non_empty_singleton_L.
Qed.
Global Program Instance lockset_union: Union lockset := λ Ω1 Ω2,
  let (Ω1,HΩ1) := Ω1 in let (Ω2,HΩ2) := Ω2 in
  dexist (union_with (λ ω1 ω2, Some (ω1 ∪ ω2)) Ω1 Ω2) _.
Next Obligation.
  intros; apply bool_decide_unpack in HΩ1; apply bool_decide_unpack in HΩ2.
  intros n ω. rewrite lookup_union_with_Some.
  intros [[??]|[[??]|(ω1&ω2&?&?&?)]]; simplify_equality'; eauto.
  apply union_positive_l_alt_L; eauto.
Qed.
Global Program Instance lockset_intersection: Intersection lockset := λ Ω1 Ω2,
  let (Ω1,HΩ1) := Ω1 in let (Ω2,HΩ2) := Ω2 in
  dexist (intersection_with (λ ω1 ω2,
    let ω := ω1 ∩ ω2 in guard (ω ≠ ∅); Some ω) Ω1 Ω2) _.
Next Obligation.
  intros; apply bool_decide_unpack in HΩ1; apply bool_decide_unpack in HΩ2.
  intros n ω. rewrite lookup_intersection_with_Some.
  intros (ω1&ω2&?&?&?); simplify_option_eq; eauto.
Qed.
Global Program Instance lockset_difference: Difference lockset := λ Ω1 Ω2,
  let (Ω1,HΩ1) := Ω1 in let (Ω2,HΩ2) := Ω2 in
  dexist (difference_with (λ ω1 ω2,
    let ω := ω1 ∖ ω2 in guard (ω ≠ ∅); Some ω) Ω1 Ω2) _.
Next Obligation.
  intros; apply bool_decide_unpack in HΩ1; apply bool_decide_unpack in HΩ2.
  intros n ω. rewrite lookup_difference_with_Some.
  intros [[??]|(ω1&ω2&?&?&?)]; simplify_option_eq; eauto.
Qed.
#[global] Instance lockset_elems: Elements (index * nat) lockset := λ Ω,
  let (Ω,_) := Ω in
  map_to_list Ω ≫= λ oω, pair (oω.1) <$> elements (oω.2 : natset).

Lemma lockset_eq (Ω1 Ω2 : lockset) : Ω1 = Ω2 ↔ ∀ o i, (o,i) ∈ Ω1 ↔ (o,i) ∈ Ω2.
Proof.
  revert Ω1 Ω2. cut (∀ (Ω1 Ω2 : indexmap natset) ω o,
    (∀ o i, (∃ ω, Ω1 !! o = Some ω ∧ i ∈ ω) ↔ (∃ ω, Ω2 !! o = Some ω ∧ i ∈ ω)) →
    map_Forall (λ _, (.≠ ∅)) Ω1 → Ω1 !! o = Some ω → Ω2 !! o = Some ω).
  { intros help Ω1 Ω2; split; [by intros ->|]; destruct Ω1 as [Ω1 HΩ1],
       Ω2 as [Ω2 HΩ2]; unfold elem_of, lockset_elem_of; simpl; intros.
     apply dsig_eq; simpl; apply map_eq; intros o.
     apply bool_decide_unpack in HΩ1; apply bool_decide_unpack in HΩ2.
     by apply option_eq; split; apply help. }
  intros Ω1 Ω2 ω o Hoi ??. destruct (set_choose_L ω) as (i&?); eauto.
  destruct (proj1 (Hoi o i)) as (ω'&Ho'&_); eauto; rewrite Ho'.
  f_equal; apply set_eq; intros j; split; intros.
  * by destruct (proj2 (Hoi o j)) as (?&?&?); eauto; simplify_equality'.
  * by destruct (proj1 (Hoi o j)) as (?&?&?); eauto; simplify_equality'.
Qed.
#[global] Instance lockset_elem_of_dec oi (Ω : lockset) : Decision (oi ∈ Ω) | 1.
Proof.
 refine
  match `Ω !! oi.1 as mω return Decision (∃ ω, mω = Some ω ∧ oi.2 ∈ ω) with
  | Some ω => cast_if (decide (oi.2 ∈ ω)) | None => right _
  end; abstract naive_solver.
Defined.
#[global] Instance: FinSet (index * nat) lockset.
Proof.
  split; [split; [split| |]| | ].
  * intros [??] (?&?&?); simplify_map_eq.
  * unfold elem_of, lockset_elem_of, singleton, lockset_singleton.
    intros [o1 i1] [o2 i2]; simpl. setoid_rewrite lookup_singleton_Some. split.
    { by intros (?&[??]&Hi); simplify_equality'; set_solver. }
    intros; simplify_equality'. eexists {[i2]}; set_solver.
  * unfold elem_of, lockset_elem_of, union, lockset_union.
    intros [Ω1 HΩ1] [Ω2 HΩ2] [o i]; simpl.
    setoid_rewrite lookup_union_with_Some. split.
    { intros (?&[[]|[[]|(?&?&?&?&?)]]&?);
        simplify_equality'; set_solver; eauto. }
    intros [(ω1&?&?)|(ω2&?&?)].
    + destruct (Ω2 !! o) as [ω2|]; eauto.
      exists (ω1 ∪ ω2). rewrite elem_of_union. naive_solver.
    + destruct (Ω1 !! o) as [ω1|]; eauto 6.
      exists (ω1 ∪ ω2). rewrite elem_of_union. naive_solver.
  * unfold elem_of, lockset_elem_of, intersection, lockset_intersection.
    intros [m1 Hm1] [m2 Hm2] [o i]; simpl.
    setoid_rewrite lookup_intersection_with_Some. split.
    { intros (?&(l&k&?&?&?)&?);
        simplify_option_eq; set_solver; eauto 6. }
    intros [(ω1&?&?) (ω2&?&?)].
    assert (i ∈ ω1 ∩ ω2) by (by rewrite elem_of_intersection).
    exists (ω1 ∩ ω2); split; [exists ω1, ω2|]; split_and ?; auto.
    by rewrite option_guard_True by set_solver.
  * unfold elem_of, lockset_elem_of, intersection, lockset_intersection.
    intros [Ω1 HΩ1_wf] [Ω2 HΩ2_wf] [o i]; simpl.
    setoid_rewrite lookup_difference_with_Some. split.
    { intros (?&[[??]|(l&k&?&?&?)]&?);
        simplify_option_eq; set_solver; naive_solver. }
    intros [(ω1&?&?) HΩ2]; destruct (Ω2 !! o) as [ω2|] eqn:?; eauto.
    destruct (decide (i ∈ ω2)); [destruct HΩ2; eauto|].
    assert (i ∈ ω1 ∖ ω2) by (by rewrite elem_of_difference).
    exists (ω1 ∖ ω2); split; [right; exists ω1, ω2|]; split_and ?; auto.
    by rewrite option_guard_True by set_solver.
  * unfold elem_of at 2, lockset_elem_of, elements, lockset_elems.
    intros [Ω HΩ_wf] [o i]; simpl. setoid_rewrite elem_of_list_bind. split.
    { intros ([o' ω]&Hoi&Ho'); simpl in *; rewrite elem_of_map_to_list in Ho'.
      setoid_rewrite elem_of_list_fmap in Hoi;
        setoid_rewrite elem_of_elements in Hoi;
        destruct Hoi as (?&?&?); simplify_equality'; eauto. }
    intros (ω&?&?). exists (o, ω); simpl.
    rewrite elem_of_map_to_list, elem_of_list_fmap;
      setoid_rewrite elem_of_elements; eauto.
  * unfold elements, lockset_elems. intros [Ω HΩ]; simpl.
    apply bool_decide_unpack in HΩ. rewrite map_Forall_to_list in HΩ.
    generalize (NoDup_fst_map_to_list Ω).
    induction HΩ as [|[o ω] Ω'];
      csimpl; inversion_clear 1 as [|?? Ho]; [constructor|].
    apply NoDup_app; split_and ?; eauto.
    { eapply (NoDup_fmap_2 _), NoDup_elements. }
    setoid_rewrite elem_of_list_bind; setoid_rewrite elem_of_list_fmap.
    intros [o' i] (?&?&?) ([o'' ω'']&(?&?&?)&?); simplify_equality'.
    destruct Ho; rewrite elem_of_list_fmap. exists (o, ω''); eauto.
Qed.
#[global] Instance: PartialOrder (@subseteq lockset _).
Proof. split; try apply _. intros ????. apply lockset_eq. intuition. Qed.
#[global] Instance: SemiSet (index * nat) lockset := _.
#[global] Instance: Set_ (index * nat) lockset := _.
#[global] Instance: @RelDecision (prod index nat) lockset
  (@elem_of (prod index nat) lockset lockset_elem_of) := lockset_elem_of_dec.
#[global] Instance: @LeibnizEquiv lockset (@set_equiv_instance _ _ lockset_elem_of).
Proof. intros ???; by rewrite lockset_eq. Qed.

#[global] Instance lockset_valid `{Env K} : Valid (env K * memenv K) lockset := λ ΓΔ Ω,
  ∀ o i, (o,i) ∈ Ω → ∃ τ, ΓΔ.2 ⊢ o : τ ∧ ✓{ΓΔ.1} τ ∧ i < bit_size_of (ΓΔ.1) τ.
Local Obligation Tactic := idtac.
Global Program Instance lockset_valid_dec
    `{Env K} Γ Δ (Ω : lockset) : Decision (✓{Γ,Δ} Ω) :=
  cast_if (decide (map_relation (λ τβ ω,
    ✓{Γ} (τβ.1) ∧ length (natmap_car (mapset_car ω)) ≤ bit_size_of Γ (τβ.1)
  ) (λ _, True) (λ _, False) Δ (`Ω))).
Next Obligation.
  intros K ? Γ Δ Ω HΩ o i (ω&?&Hi); specialize (HΩ o); unfold option_relation in HΩ; simplify_option_eq.
  destruct (Δ !! o) as [[τ β]|] eqn:?; intuition; simplify_equality'.
  exists τ; split_and ?; [by exists β|auto|eapply Nat.lt_le_trans; [|eauto]].
  unfold elem_of, mapset_elem_of, lookup, natmap_lookup in Hi.
  destruct ω as [[ω ?]]; simplify_equality'.
  destruct (ω !! i) eqn:?; simplify_equality'; eauto using lookup_lt_Some.
Qed.
Next Obligation.
  intros K ? Γ Δ Ω HΩ; contradict HΩ.
  intros o. unfold option_relation. destruct (`Ω !! o) as [ω|] eqn:Ho; [|by destruct (Δ !! _)].
  set (i:=length (natmap_car (mapset_car ω)) - 1); assert (i ∈ ω).
  { unfold i; clear i; destruct ω as [[ω Hω]]; simplify_equality'.
    unfold elem_of, mapset_elem_of, lookup, natmap_lookup; simpl.
    destruct ω as [|u ω _] using rev_ind.
    { destruct ((bool_decide_unpack _ (proj2_sig Ω) o _) Ho).
      by apply (bool_decide_unpack _). }
    clear Ho; unfold natmap_wf in Hω.
    rewrite last_snoc in Hω; destruct Hω as [[] ->]; simpl.
    by rewrite app_length; simpl; rewrite <-Nat.add_sub_assoc, Nat.sub_diag,
      Nat.add_0_r, lookup_app_r, Nat.sub_diag by done. }
  destruct (HΩ o i) as (τ&[β]&?&?); [by exists ω|]; simplify_option_eq.
  unfold i in *; split_and ?; auto with lia.
Qed.
Lemma lockset_valid_weaken `{EnvSpec K} Γ1 Γ2 Δ1 Δ2 (Ω : lockset) :
  ✓ Γ1 → ✓{Γ1,Δ1} Ω → Γ1 ⊆ Γ2 → Δ1 ⇒ₘ Δ2 → ✓{Γ2,Δ2} Ω.
Proof.
  intros ? HΩ ? [??] o i ?; destruct (HΩ o i) as (τ&?&?&?); eauto.
  exists τ. erewrite <-(bit_size_of_weaken Γ1 Γ2) by eauto.
  eauto using type_valid_weaken.
Qed.
Lemma lockset_empty_valid `{Env K} Γ Δ : ✓{Γ,Δ} (∅ : lockset).
Proof. intros o i; set_solver. Qed.
Lemma lockset_union_valid `{Env K} Γ Δ (Ω1 Ω2 : lockset) :
  ✓{Γ,Δ} Ω1 → ✓{Γ,Δ} Ω2 → ✓{Γ,Δ} (Ω1 ∪ Ω2).
Proof. intros HΩ1 HΩ2 o r; rewrite elem_of_union; naive_solver. Qed.


(**

This file describes the representation of modelling language.

Author: Bowen Zhang.

Date : 2022.10.26
*)

From SLF (* TLC *) Require Export LibCore.
From SLF (* Sep *) Require Export TLCbuffer Var Fmap.

(* ###################### Syntax ###################### *)

Definition loc : Type := nat.
Definition bloc : Type := nat.
Definition floc : Type := nat.

Definition listint : Type := list int.
Definition listbloc : Type := list bloc.

Definition fnull : floc := 0%nat.
Definition bnull : bloc := 0%nat.

(*-- wordcount kvpair (word, times) --*)
Definition wdpair : Type := int * int.

(*-- indexinvert kvpair (word, location, times) --*)
Definition index : Type := int * bloc.
Definition idcnt : Type := index * int.
Definition blcnt : Type := bloc * int.
Definition env : Type := int * list (bloc * int).

(*---------- the block primitive operations ----------*)
Inductive bval : Type :=
(* basic operations *)
  | bval_create : bval
  | bval_append : bval
  | bval_get : bval
  | bval_delete : bval
  | bval_bsize : bval
  | bval_truncate : bval
(* mapper in block level *)
  | bval_wdmap : bval
  | bval_locate : bval
  | bval_iimap : bval.

(*---------- the file primitive operations ----------*)
Inductive fval : Type :=
(* basic operations *)
  | fval_create : fval
  | fval_attach : fval
  | fval_fsize : fval
  | fval_get : fval
  | fval_get_nth_blk : fval
  | fval_set_nth_blk : fval
  | fval_delete : fval
  | fval_truncate : fval
  | fval_buffer: fval
  | fval_buffer_list : fval
  | fval_rev_blist : fval
(* reduer in file level *)
  (*- wordcount cmd -*)
  | fval_wdmerge : fval
  | fval_wdshuffle : fval
  | fval_wdreduce : fval
  (*- invertindex cmd -*)
  | fval_iimerge : fval
  | fval_iishuffle : fval
  | fval_iireduce : fval
  | fval_iiorganize : fval.

(*-------- some auxiliary primitive operations (not important) --------*)
Inductive prim : Type :=
  | val_eq : prim        (*a ?= b*)
  | val_add : prim       (*a + b*)
  | val_min : prim       (*a - b*)
  | val_le : prim       (*a <= b*)
  | val_reform : prim      (*trans list to save*)
  | val_list_rev : prim    (*reverse a list*)
  | val_list_hd  : prim    (*extract list for a block*)
  | val_list_len : prim   (*get the length of content*)
  | val_list_tl  : prim    (*after extraction*)
  | val_list_app : prim    (*append a list*)
  | val_list_cut : prim   (*truncate a list*)
  | val_app_wdlist : prim (*append a word list*)
  | val_app_iilist : prim (*append an indexivert list*)
  | val_app_idxlist : prim. (*append an indexivert list*)

(*---------- the val and the term ----------*)
Inductive val : Type :=
  | val_unit : val
  | val_prim : prim -> val
  | val_bool : bool -> val
  | val_int : int -> val
  | val_listint : list int -> val
  | val_listbloc : list bloc -> val
  | val_listenv : (list env) -> val
  | val_floc : floc -> val
  | val_bloc : bloc -> val
  | val_bval : bval -> val
  | val_fval : fval -> val
  | val_fun : var -> trm -> val
  | val_fix : var -> var -> trm -> val
(* values for wordcount *)
  | val_listwdpair : list wdpair -> val
  | val_Listwd : (list (list wdpair)) -> val
(* values for invertindex *)
  | val_listindex : list index -> val
  | val_Listidx : (list (list index)) -> val
  | val_listiipair : list idcnt -> val
  | val_Listii : (list (list idcnt)) -> val

with trm : Type :=
  | trm_val : val -> trm
  | trm_var : var -> trm
  | trm_fun : var -> trm -> trm
  | trm_fix : var -> var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : var -> trm -> trm -> trm
  | trm_if : trm -> trm -> trm -> trm.

(* ##################### The Definition of CBS heap ##################### *)
(*------- the entire corresponding state -------*)
Definition stateb : Type := fmap bloc listint.
Definition statef : Type := fmap floc listbloc.
Definition state : Type := statef * stateb.

(*------- the part of corresponding state -------*)
Definition heapb : Type := stateb.
Definition heapf : Type := statef.
Definition heap : Type := state.

Notation "'hb_empty'" := (@Fmap.empty bloc listint)
  (at level 0).
Notation "'hf_empty'" := (@Fmap.empty floc listbloc)
  (at level 0).
Notation "'h_empty'" := (hf_empty,hb_empty)
  (at level 0).
Notation "h1 \u h2" := (Fmap.union h1 h2)
  (at level 37, right associativity).

(*** Implicit Types and coercions (to improve the readability) ***)

Implicit Types bp : bloc.
Implicit Types fp : floc.
Implicit Types ln : list int.
Implicit Types n : int.
Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : bool.
Implicit Types hb : heapb.
Implicit Types sb : stateb.
Implicit Types hf : heapf.
Implicit Types sf : statef.

Coercion val_bool : bool >-> val.
Coercion val_floc : floc >-> val.
Coercion val_bloc : bloc >-> val.
Coercion val_prim : prim >-> val.
Coercion val_int : Z >-> val.
Coercion val_bval : bval >-> val.
Coercion val_fval : fval >-> val.

Coercion trm_val : val >-> trm.
Coercion trm_var : var >-> trm.
Coercion trm_app : trm >-> Funclass.

(*** The substitution function ***)
(* -- subst var to val directly -- *)
Fixpoint subst (y:var) (w:val) (t:trm) : trm :=
  let aux t := subst y w t in
  let if_y_eq x t1 t2 := if var_eq x y then t1 else t2 in
  match t with
  | trm_val v => trm_val v
  | trm_var x => if_y_eq x (trm_val w) t
  | trm_fun x t1 => trm_fun x (if_y_eq x t1 (aux t1))
  | trm_fix f x t1 => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (aux t1)))
  | trm_app t1 t2 => trm_app (aux t1) (aux t2)
  | trm_seq t1 t2 => trm_seq  (aux t1) (aux t2)
  | trm_let x t1 t2 => trm_let x (aux t1) (if_y_eq x t2 (aux t2))
  | trm_if t0 t1 t2 => trm_if (aux t0) (aux t1) (aux t2)
  end.

Definition trm_is_val (t:trm) : Prop :=
  match t with trm_val v => True | _ => False end.

Definition droplast (n:nat) {A} (l:list A) : list A :=
  let l' := rev l in
  let l'' := drop n l' in
    rev l''.

(**===================== List Function for MapReduce =============================**)

(*--------------------------- Poly ----------------------------------------*)
Definition mapper {A} {B} (l:list A) (v:B) : list (A*B) :=
  List.map (fun (i:A) => (i,v)) l.

Definition app {A} (l1 l2 : list A) :=
  List.fold_right (fun x (acc:list A) => x::acc) l2 l1.

Definition merge {A} (l:list (list A)) := fold_right app nil l.

Fixpoint classify {A} (f:A->A->bool) (l1 l2:list A) : list (list A) :=
  match l1,l2 with
  | nil,_ => nil
  | _,nil => nil
  | x::l1',l2 => (List.filter (f x) l2) ::
    (classify f l1' l2)
end.

Definition remove {A} (f:A->A->bool) (a:A) (l:list A) : list A :=
  List.filter (f a) l.

Fixpoint remove_duplicates {A} (f:A->A->bool) (l:list A) : list A :=
  match l with
  | nil => nil
  | x::l' => x :: (remove f x (remove_duplicates f l'))
  end.

Definition shuffle {A} (l:list A) (f1 f2:A->A->bool) : list (list A) :=
  let l1 := remove_duplicates f1 l in
    classify f2 l1 l.

Definition init {A} {B} (a:A*B) (b:B) : A*B := ((fst a), b).

Definition exec {A} {B} (f:B->B->B) (a1 a2:A*B) : A*B :=
  ((fst a1), (f (snd a1) (snd a2) )).

Definition combine {A} {B} (a:A*B) (b:B) (f:B->B->B) (l:list (A*B)) : A*B:=
  let p := init a b in
  List.fold_right (exec f) p l.

Definition reducer {A} {B} (a:A*B) (b:B) (f:B->B->B) (L:list (list (A*B))) :list (A*B) :=
  LibList.map (combine a b f) L.

(* =================== For WordCount ==================== *)

Definition wordmapper (lw:list int):= mapper lw 1.

Definition wordmerge (L:list (list wdpair)) := merge L.

Definition eqword (p1 p2: wdpair) := (fst p1) =? (fst p2).

Definition neqword (p1 p2: wdpair) := negb (eqword p1 p2).

Definition wordshuffle (l:list wdpair) := shuffle l neqword eqword.

Definition addint (n1 n2:int) := n1+n2.

Definition wordreducer (L:list (list wdpair)) :=
  let p := (nth_default (0,0) 0 ((nth_default nil 0 L))) in
  reducer p 0 addint L.

Fixpoint filetrans (l:list wdpair) : (list int) :=
  match l with
  | nil => nil
  | (w,n) :: tl => w :: n :: (filetrans tl)
end.

(* =================== For InvertIndex ==================== *)

Definition locate (l : list int) (b: bloc) := List.map (fun (i:int) => (i,b)) l.

Definition iimapper (lw:list index) := mapper lw 1.

Definition iimerge (L:list (list idcnt)) := merge L.

(* Compute iimerge (((((10, 1%nat, 1) :: (8, 1%nat, 1) :: (10, 1%nat, 1) :: nil)
          :: ((10, 2%nat, 1) :: nil) :: nil))). *)

Definition eqindex (p1 p2 : index) :=
  andb ((fst p1) =? (fst p2)) ((snd p1) =? (snd p2)).

Definition eqiikey (p1 p2 : idcnt) := eqindex (fst p1) (fst p2).

Definition neqiikey (p1 p2 : idcnt) := negb (eqiikey p1 p2).

Definition eqid (p1 p2 : idcnt) := (fst (fst p1)) =? (fst (fst p2)).

Definition neqid (p1 p2 : idcnt) := negb (eqid p1 p2).

Definition iishuffle (l:list idcnt) := shuffle l neqiikey eqiikey.

Definition idshuffle (l:list idcnt) := shuffle l neqid eqid.

Definition addidcnt (p1 p2 : idcnt):= ((fst p1), ((snd p1)+(snd p2))).

Definition iireducer (L:list (list idcnt)) :=
  let p := (nth_default (0,0%nat,0) 0 ((nth_default nil 0 L))) in
  reducer p 0 addint L.

Definition appenv (i:idcnt) (e:env) :=
  (fst e, (snd (fst i), (snd i)) :: (snd e)).

Definition organize (l:list idcnt):=
  let p := (nth_default (0,0%nat,0) 0 l) in
  List.fold_right appenv ((fst (fst p)),nil) l.

(* Compute idshuffle ((10, 1%nat, 2) :: (8, 1%nat, 1) :: (10, 2%nat, 1) :: nil). *)

Definition iiorganize (l:list idcnt) :=
  let L := idshuffle l in
  List.map organize L.

(* ########################### The Evaluation Rules ########################### *)
Open Scope liblist_scope.
Open Scope Z_scope.

Inductive eval : heap -> trm -> heap -> val -> Prop :=
  (*===== eval rules for mapreduce======*)

  (*-- mapper --*)
  (* wordcount *)
  | eval_wdmap : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_wdmap bp) (sf, sb)
        (val_listwdpair (wordmapper (Fmap.read sb bp)))

  (* invertindex *)
  | eval_locate : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_locate bp) (sf, sb)
        (val_listindex (locate (Fmap.read sb bp) bp))

  | eval_iimap : forall sf sb l,
      eval (sf, sb) (bval_iimap (val_listindex l)) (sf, sb)
        (val_listiipair (iimapper l))

  | eval_reform : forall s l,
      eval s (val_reform (val_listwdpair l)) s
        (val_listint (filetrans l))

  (*-- reducer --*)
  (* wordcount *)
  | eval_wdmerge : forall s L,
      eval s (fval_wdmerge (val_Listwd L)) s (val_listwdpair (wordmerge L))

  | eval_wdshuffle : forall s l,
      eval s (fval_wdshuffle (val_listwdpair l)) s (val_Listwd (wordshuffle l))

  | eval_wdreduce : forall s L,
      eval s (fval_wdreduce (val_Listwd L)) s (val_listwdpair (wordreducer L))

  (* invertindex *)
  | eval_iimerge : forall s L,
      eval s (fval_iimerge (val_Listii L)) s (val_listiipair (iimerge L))

  | eval_iishuffle : forall s l,
      eval s (fval_iishuffle (val_listiipair l)) s (val_Listii (iishuffle l))

  | eval_iireduce : forall s L,
      eval s (fval_iireduce (val_Listii L)) s (val_listiipair (iireducer L))

  | eval_iiorganize : forall s l,
      eval s (fval_iiorganize (val_listiipair l)) s (val_listenv (iiorganize l))

  (*-- aux rules for list operation --*)
  | eval_app_wdlist : forall s lw L,
      eval s (val_app_wdlist (val_listwdpair lw) (val_Listwd L))
           s (val_Listwd (lw :: L))
  | eval_app_idxlist : forall s l L,
      eval s (val_app_idxlist (val_listindex l) (val_Listidx L))
           s (val_Listidx (l :: L))
  | eval_app_iilist : forall s l L,
      eval s (val_app_iilist (val_listiipair l) (val_Listii L))
           s (val_Listii (l :: L))

(*__________________previous______________________________*)
  (*------ trm eval to its value ------*)
  | eval_val_refine : forall sf sb v,
      eval (sf, sb) (trm_val v) (sf, sb) v
  | eval_val : forall s v,
      eval s (trm_val v) s v
  | eval_fun : forall s x t1,
      eval s (trm_fun x t1) s (val_fun x t1)
  | eval_fix : forall s f x t1,
      eval s (trm_fix f x t1) s (val_fix f x t1)

  (*------   aux prim operation    ------*)
  | eval_add : forall s n1 n2,
      eval s (val_add n1 n2) s (n1 + n2)
  | eval_min : forall s n1 n2,
      eval s (val_min n1 n2) s (n1 - n2)
  | eval_le : forall s n1 n2,
      eval s (val_le n1 n2) s (val_bool (isTrue (n1 <= n2)))
  | eval_eq : forall s n1 n2,
      eval s (val_eq n1 n2) s (val_bool (n1 =? n2))
  | eval_list_rev : forall s l1,
      eval s (val_list_rev (val_listint l1)) s (val_listint (rev l1))
  | eval_list_app : forall s l1 l2,
      eval s (val_list_app (val_listint l1) (val_listint l2))
           s (val_listint (l1 ++ l2))

  | eval_list_hd : forall s l1,
      eval s (val_list_hd (val_listint l1)) s (val_listint (LibList.take 2%nat l1))
  | eval_list_tl : forall s l1,
      eval s (val_list_tl (val_listint l1)) s (val_listint (LibList.drop 2%nat l1))
  | eval_list_len : forall s l1,
      eval s (val_list_len (val_listint l1)) s (LibList.length l1)

  (*--------- block prim operation ---------*)
  | eval_bcreate_list : forall sf sb bp ll,
      ~ Fmap.indom sb bp ->
      eval (sf, sb) (bval_create (val_listint ll))
        (sf, (Fmap.update sb bp ll)) (val_bloc bp)

  | eval_bget : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_get (val_bloc bp)) (sf, sb) (val_listint (Fmap.read sb bp))

  | eval_bdelete : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_delete (val_bloc bp)) (sf, (Fmap.remove sb bp)) val_unit

  | eval_bsize : forall sf sb bp,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_bsize (val_bloc bp))
           (sf, sb) (val_int (List.length (Fmap.read sb bp)))

  | eval_btruncate : forall sf sb bp n,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_truncate (val_bloc bp) n)
        (sf, (Fmap.update sb bp (droplast (Z.to_nat n) (Fmap.read sb bp) )))  val_unit

  | eval_bappend_list : forall sf sb bp ll,
      Fmap.indom sb bp ->
      eval (sf, sb) (bval_append (val_bloc bp) (val_listint ll))
        (sf, (Fmap.update sb bp ((Fmap.read sb bp) ++ ll) ))  val_unit

 (*----------- file prim operation -----------*)
  | eval_fcreate_list : forall sf sb fp bll,
      ~ Fmap.indom sf fp ->
      noduplicates bll ->
      eval (sf, sb) (fval_create (val_listbloc bll))
        ((Fmap.update sf fp bll), sb) (val_floc fp)

  | eval_fget : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_get (val_floc fp)) (sf, sb) (val_listbloc (Fmap.read sf fp))

  | eval_fsize : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_fsize (val_floc fp))
           (sf, sb) (val_int (List.length (Fmap.read sf fp)))

  | eval_fget_nth_blk : forall sf sb fp n,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_get_nth_blk (val_floc fp) n) (sf, sb)
           (val_bloc (nth_default bnull (Z.to_nat n) (Fmap.read sf fp)))

  | eval_fset_nth_blk : forall sf sb fp n bp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_set_nth_blk (val_floc fp) n (val_bloc bp))
           (Fmap.update sf fp (LibList.update (to_nat n) bp (Fmap.read sf fp)), sb) val_unit

  | eval_fattach: forall sf sb fp lb,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_attach (val_floc fp) (val_listbloc lb))
       ((Fmap.update sf fp ( (Fmap.read sf fp) ++ lb )), sb) val_unit

  | eval_fdelete : forall sf sb fp,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_delete (val_floc fp)) ( (Fmap.remove sf fp), sb) val_unit

  | eval_frev_blist : forall sf sb bl,
      eval (sf, sb) (fval_rev_blist (val_listbloc bl)) (sf, sb) (val_listbloc (LibList.rev bl))

  | eval_fbuffer : forall sf sb bp,
      eval (sf, sb) (fval_buffer (val_bloc bp)) (sf, sb) (val_listbloc (bp::nil))

  | eval_fbuffer_list : forall sf sb bp bl,
      eval (sf, sb) (fval_buffer_list (val_bloc bp) (val_listbloc bl)) (sf, sb) (val_listbloc (bp::bl))

  | eval_ftruncate : forall sf sb fp n,
      Fmap.indom sf fp ->
      eval (sf, sb) (fval_truncate (val_floc fp) n)
        ( (Fmap.update sf fp (droplast (Z.to_nat n) (Fmap.read sf fp) )), sb) val_unit

  (*------------ trm rules ------------*)
   | eval_app_args : forall s1 s2 s3 s4 t1 t2 v1 v2 r,
      (~ trm_is_val t1 \/ ~trm_is_val t2) ->
      eval s1 t1 s2 v1 ->
      eval s2 t2 s3 v2 ->
      eval s3 (trm_app v1 v2) s4 r ->
      eval s1 (trm_app t1 t2) s4 r
   | eval_app_fun : forall s1 s2 v1 v2 x t1 v,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) s2 v ->
      eval s1 (trm_app v1 v2) s2 v
   | eval_app_fix : forall s1 s2 v1 v2 f x t1 v,
      v1 = val_fix f x t1 ->
      eval s1 (subst x v2 (subst f v1 t1)) s2 v ->
      eval s1 (trm_app v1 v2) s2 v
   | eval_seq : forall s1 s2 s3 t1 t2 v1 v,
      eval s1 t1 s2 v1 ->
      eval s2 t2 s3 v ->
      eval s1 (trm_seq t1 t2) s3 v
   | eval_let : forall s1 s2 s3 x t1 t2 v1 r,
      eval s1 t1 s2 v1 ->
      eval s2 (subst x v1 t2) s3 r ->
      eval s1 (trm_let x t1 t2) s3 r
   | eval_if : forall s1 s2 b v t1 t2,
      eval s1 (if b then t1 else t2) s2 v ->
      eval s1 (trm_if (val_bool b) t1 t2) s2 v.

(*  --------------- some relation about terms --------------- *)
Definition eval_like (t1 t2:trm) : Prop :=
  forall s s' v, eval s t1 s' v -> eval s t2 s' v.

Definition trm_equiv (t1 t2:trm) : Prop :=
  forall s s' v, eval s t1 s' v <-> eval s t2 s' v.

Lemma eval_like_eta_reduction : forall (t:trm) (x:var),
  eval_like t (trm_let x t x).
Proof using.
  introv R. applys eval_let R.
  simpl. rewrite var_eq_spec. case_if. apply eval_val.
Qed.

Lemma eval_like_eta_expansion : forall (t:trm) (x:var),
  eval_like (trm_let x t x) t.
Proof using.
  introv R. inverts R as. introv R1 R2.
  simpl in R2. rewrite var_eq_spec in R2. case_if.
  inverts R2; apply R1.
Qed.

Lemma trm_equiv_eta : forall (t:trm) (x:var),
  trm_equiv t (trm_let x t x).
Proof using.
  intros. intros s s' v. iff M.
  { applys eval_like_eta_reduction M. }
  { applys eval_like_eta_expansion M. }
Qed.

(* ################### evaluation rule in SL style ############################## *)

Lemma eval_wdmap_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_wdmap (val_bloc bp))
       (sf, sb) (val_listwdpair (wordmapper l)).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_wdmap 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_locate_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_locate (val_bloc bp))
       (sf, sb) (val_listindex (locate l bp)).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_locate 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

(*_________________previous__________________*)

(*--- block prim operations ---*)
Lemma eval_bcreate_sep : forall sf sb1 sb2 l bp,
  sb2 = Fmap.single bp l ->
  Fmap.disjoint sb2 sb1 ->
  eval (sf, sb1) (bval_create (val_listint l))
       (sf, (Fmap.union sb2 sb1)) (val_bloc bp).
Proof.
  introv -> M. forwards Db: Fmap.indom_single bp l.
  rewrite <- Fmap.update_eq_union_single.
  apply~ eval_bcreate_list.
  { intros N. applys~ Fmap.disjoint_inv_not_indom_both M N. }
Qed.

Lemma eval_bget_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_get (val_bloc bp))
       (sf, sb) (val_listint l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_bget 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_bsize_sep : forall sf sb sb2 bp l,
  sb = Fmap.union (Fmap.single bp l) sb2 ->
  eval (sf, sb) (bval_bsize (val_bloc bp))
       (sf, sb) (List.length l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single bp l.
  applys_eq eval_bsize 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_bdelete_sep : forall sf sb1 sb2 bp l,
  sb1 = Fmap.union (Fmap.single bp l) sb2 ->
  Fmap.disjoint (Fmap.single bp l) sb2 ->
  eval (sf, sb1) (bval_delete (val_bloc bp))
       (sf, sb2) val_unit.
Proof.
  introv -> D. forwards Db: Fmap.indom_single bp l.
  applys_eq eval_bdelete 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.remove_union_single_l.
    intros D1. applys~ Fmap.disjoint_inv_not_indom_both D D1. }
Qed.

Lemma eval_btruncate_sep : forall sf sb1 sb2 sb bp l1 n,
  sb1 = Fmap.union (Fmap.single bp l1) sb ->
  sb2 = Fmap.union (Fmap.single bp (droplast (Z.to_nat n) l1)) sb ->
  Fmap.disjoint (Fmap.single bp l1) sb ->
  eval (sf, sb1) (bval_truncate (val_bloc bp) n)
       (sf, sb2) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single bp l1.
  applys_eq eval_btruncate 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single.  }
Qed.

Lemma eval_bappend_sep : forall sf sb1 sb2 sb bp l1 l2,
  sb1 = Fmap.union (Fmap.single bp l1) sb ->
  sb2 = Fmap.union (Fmap.single bp (l1++l2)) sb ->
  Fmap.disjoint (Fmap.single bp l1) sb ->
  eval (sf, sb1) (bval_append (val_bloc bp) (val_listint l2))
       (sf, sb2) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single bp l1.
  applys_eq eval_bappend_list 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single. }
Qed.

(*--- file prim operations ---*)

Lemma eval_fcreate_sep : forall sf1 sb sf2 bll fp,
  sf2 = Fmap.single fp bll ->
  Fmap.disjoint sf2 sf1 ->
  noduplicates bll ->
  eval (sf1, sb) (fval_create (val_listbloc bll))
       ((Fmap.union sf2 sf1), sb) (val_floc fp).
Proof.
  introv -> D. forwards Db: Fmap.indom_single fp bll.
  rewrite <- Fmap.update_eq_union_single.
  apply eval_fcreate_list.
  { intros N. applys~ Fmap.disjoint_inv_not_indom_both D N. }
Qed.

Lemma eval_fsize_sep : forall sf sb sf2 fp l,
  sf = Fmap.union (Fmap.single fp l) sf2 ->
  eval (sf, sb) (fval_fsize (val_floc fp))
       (sf, sb) (List.length l).
Proof.
  introv ->. forwards Dv: Fmap.indom_single fp l.
  applys_eq eval_fsize 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fget_sep : forall sf sb sf2 bll fp,
  sf = Fmap.union (Fmap.single fp bll) sf2 ->
  eval (sf, sb) (fval_get (val_floc fp))
       (sf, sb) (val_listbloc bll).
Proof.
  introv ->. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fget 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fget_nth_blk_sep : forall sf sb sf2 bll fp n,
  sf = Fmap.union (Fmap.single fp bll) sf2 ->
  eval (sf, sb) (fval_get_nth_blk (val_floc fp) n)
       (sf, sb) (val_bloc (nth_default bnull (Z.to_nat n) bll)).
Proof.
  introv ->. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fget_nth_blk 1.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.read_union_l. rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fset_nth_blk_sep : forall sf sb sf1 sf2 bll fp n bp,
  sf1 = Fmap.union (Fmap.single fp bll) sf ->
  sf2 = Fmap.union (Fmap.single fp (LibList.update (to_nat n) bp bll)) sf ->
  Fmap.disjoint (Fmap.single fp bll) sf ->
  eval (sf1, sb) (fval_set_nth_blk (val_floc fp) n (val_bloc bp))
       (sf2, sb) (val_unit).
Proof.
  introv -> -> D. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fset_nth_blk 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single.
    rewrite~ Fmap.read_union_l.
    rewrite~ Fmap.read_single. }
Qed.

Lemma eval_fdelete_sep : forall sf1 sb sf2 bll fp,
  sf1 = Fmap.union (Fmap.single fp bll) sf2 ->
  Fmap.disjoint (Fmap.single fp bll) sf2 ->
  eval (sf1, sb) (fval_delete (val_floc fp))
       (sf2, sb) val_unit.
Proof.
  introv -> D. forwards Df: Fmap.indom_single fp bll.
  applys_eq eval_fdelete 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite~ Fmap.remove_union_single_l. intros D1.
    applys~  Fmap.disjoint_inv_not_indom_both D D1. }
Qed.

Lemma eval_fattach_sep : forall sf sf1 sf2 sb fp bl1 bl2,
  sf1 = Fmap.union (Fmap.single fp bl1) sf ->
  sf2 = Fmap.union (Fmap.single fp (bl1++bl2)) sf ->
  Fmap.disjoint (Fmap.single fp bl1) sf ->
  eval (sf1, sb) (fval_attach (val_floc fp) (val_listbloc bl2))
       (sf2, sb) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single fp bl1.
  applys_eq eval_fattach 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single. }
Qed.

Lemma eval_ftruncate_sep : forall sf sf1 sf2 sb fp bl n,
  sf1 = Fmap.union (Fmap.single fp bl) sf ->
  sf2 = Fmap.union (Fmap.single fp (droplast (Z.to_nat n) bl)) sf ->
  Fmap.disjoint (Fmap.single fp bl) sf ->
  eval (sf1, sb) (fval_truncate (val_floc fp) n)
       (sf2, sb) val_unit.
Proof.
  introv -> -> D. forwards Db: Fmap.indom_single fp bl.
  applys_eq eval_ftruncate 2.
  { applys~ Fmap.indom_union_l. }
  { rewrite Fmap.read_union_l, Fmap.read_single; auto.
    rewrite~ Fmap.update_union_l. fequals.
    rewrite~ Fmap.update_single. }
Qed.

(*==============================================================*)
(* ############ Notations of the language (to improve the readability) #################### *)
Module NotationForTrm.

(* ====== Notation for mapreduce ====== *)

(* -- mapper -- *)
Notation "'wdmap bp" :=
  (bval_wdmap bp)
  (at level 67) : trm_scope.

Notation "'iimap bp" :=
  (bval_iimap bp)
  (at level 67) : trm_scope.

Notation "'locate b" :=
  (bval_locate b)
  (at level 67) : trm_scope.

(* -- reducer -- *)
Notation "'wdmerge l" :=
  (fval_wdmerge l)
  (at level 67) : trm_scope.

Notation "'wdshuffle l" :=
  (fval_wdshuffle l)
  (at level 67) : trm_scope.

Notation "'wdreduce l" :=
  (fval_wdreduce l)
  (at level 67) : trm_scope.

Notation "'iimerge l" :=
  (fval_iimerge l)
  (at level 67) : trm_scope.

Notation "'iishuffle l" :=
  (fval_iishuffle l)
  (at level 67) : trm_scope.

Notation "'iireduce l" :=
  (fval_iireduce l)
  (at level 67) : trm_scope.

Notation "'iiorgan l" :=
  (fval_iiorganize l)
  (at level 67) : trm_scope.

(*-- some aux list operations --*)
Notation "l 'w:: L" :=
  (val_app_wdlist l L)
  (at level 67, format " l ''w::' L") : trm_scope.

Notation "l 'i:: L" :=
  (val_app_idxlist l L)
  (at level 67, format " l ''i::' L") : trm_scope.

Notation "l 'ii:: L" :=
  (val_app_iilist l L)
  (at level 67, format " l ''ii::' L") : trm_scope.

(*_________________previous______________________*)
(** ** Notation for terms *)
Notation "'If_' t0 'Then' t1 'Else' t2" :=
  (trm_if t0 t1 t2)
  (at level 69, t0 at level 0) : trm_scope.

Notation "'If_' t0 'Then' t1 'End'" :=
  (trm_if t0 t1 val_unit)
  (at level 69, t0 at level 0) : trm_scope.

Notation "'Let' x ':=' t1 'in' t2" :=
  (trm_let x t1 t2)
  (at level 69, x at level 0, right associativity,
  format "'[v' '[' 'Let'  x  ':='  t1  'in' ']'  '/'  '[' t2 ']' ']'") : trm_scope.

Notation "t1 '';' t2" :=
  (trm_seq t1 t2)
  (at level 68, right associativity,
   format "'[v' '[' t1 ']'  '';'  '/'  '[' t2 ']' ']'") : trm_scope.

Notation "'Fix' f x1 ':=' t" :=
  (val_fix f x1 t)
  (at level 69, f, x1 at level 0, format "'Fix'  f  x1  ':='  t") : val_scope.

Notation "'Fix' f x1 x2 ':=' t" :=
  (val_fix f x1 (trm_fun x2 t))
  (at level 69, f,x1, x2 at level 0, format "'Fix'  f x1 x2 ':=' t") : val_scope.

Notation "'Fix' f x1 x2 x3 ':=' t" :=
  (val_fix f x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, f,x1, x2, x3 at level 0, format "'Fix'  f x1 x2 x3 ':=' t") : val_scope.

Notation "'Fix_' f x1 ':=' t" :=
  (trm_fix f x1 t)
  (at level 69, f, x1 at level 0, format "'Fix_'  f  x1  ':='  t") : trm_scope.

Notation "'Fun' x1 ':=' t" :=
  (val_fun x1 t)
  (at level 69, x1 at level 0, format "'Fun'  x1  ':='  t") : val_scope.

Notation "'Fun' x1 x2 ':=' t" :=
  (val_fun x1 (trm_fun x2 t))
  (at level 69, x1, x2 at level 0, format "'Fun' x1 x2 ':=' t") : val_scope.

Notation "'Fun' x1 x2 x3 ':=' t" :=
  (val_fun x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, x1, x2, x3 at level 0, format "'Fun' x1 x2 x3 ':=' t") : val_scope.

Notation "'Fun_' x1 ':=' t" :=
  (trm_fun x1 t)
  (at level 69, x1 at level 0, format "'Fun_'  x1  ':='  t") : trm_scope.

Notation "'Fun_' x1 x2 ':=' t" :=
  (trm_fun x1 (trm_fun x2 t))
  (at level 69, x1, x2 at level 0, format "'Fun_' x1 x2 ':=' t") : trm_scope.

Notation "'Fun_' x1 x2 x3 ':=' t" :=
  (trm_fun x1 (trm_fun x2 (trm_fun x3 t)))
  (at level 69, x1, x2, x3 at level 0, format "'Fun_' x1 x2 x3 ':=' t") : trm_scope.

(* ----------Notations of file prim---------------- *)
Notation "'fcreate ll" :=
  (fval_create ll)
  (at level 67) : trm_scope.

Notation "'frev bl" :=
  (fval_rev_blist bl)
  (at level 67) : trm_scope.

Notation "'fbuffer p" :=
  (fval_buffer p)
  (at level 67) : trm_scope.

Notation "'fatt bp l" :=
  (fval_attach bp l)
  (at level 67,bp at level 0,format "''fatt' bp l").

Notation "'set_nth_blk fp n 'As bp" :=
  (fval_set_nth_blk fp n bp)
  (at level 67, fp,bp at level 0,format "''set_nth_blk' fp n ''As' bp") : trm_scope.

Notation "'fsize p" :=
  (fval_fsize p)
  (at level 67) : trm_scope.

Notation "'fdelete fp" :=
  (fval_delete fp)
  (at level 67) : trm_scope.

Notation "'ftrun fp n" :=
  (fval_truncate fp n)
  (at level 67,fp at level 0,format "''ftrun' fp n") : trm_scope.

Notation "'nth_blk fp n" :=
  (fval_get_nth_blk fp n)
  (at level 67, fp at level 0,format "''nth_blk' fp n") : trm_scope.

Notation "bp 'b+ bl" :=
  (fval_buffer_list bp bl)
  (at level 67) : trm_scope.

(* ----------Notations of block prim---------------- *)
Notation "'bcreate ll" :=
  (bval_create ll)
  (at level 67) : trm_scope.

Notation "'bapp bp l" :=
  (bval_append bp l)
  (at level 67,bp at level 0,format "''bapp' bp l") : trm_scope.

Notation "'bsize p" :=
  (bval_bsize p)
  (at level 67) : trm_scope.

Notation "'bget bp" :=
  (bval_get bp)
  (at level 67) : trm_scope.

Notation "'bsize bp" :=
  (bval_bsize bp)
  (at level 67) : trm_scope.

Notation "'bdelete bp" :=
  (bval_delete bp)
  (at level 67) : trm_scope.

Notation "'btrun bp n" :=
  (bval_truncate bp n)
  (at level 67, bp at level 0,format "''btrun' bp n") : trm_scope.

(* ----------Notations of aux prim---------------- *)
Notation "n1 '= n2" :=
  (val_eq n1 n2)
  (at level 67) : trm_scope.

Notation "n1 '+ n2" :=
  (val_add n1 n2)
  (at level 67) : trm_scope.

Notation "n1 '- n2" :=
  (val_min n1 n2)
  (at level 67) : trm_scope.

Notation "n1 '<= n2" :=
  (val_le n1 n2)
  (at level 67) : trm_scope.

Notation "l1 '++ l2" :=
  (val_list_app l1 l2)
  (at level 67) : trm_scope.

Notation "'rev l1" :=
  (val_list_rev l1)
  (at level 67) : trm_scope.

Notation "'hd l1" :=
  (val_list_hd l1)
  (at level 67) : trm_scope.

Notation "'tl l1" :=
  (val_list_tl l1)
  (at level 67) : trm_scope.

Notation "'len l1" :=
  (val_list_len l1)
  (at level 67) : trm_scope.

Notation "'reform l" :=
  (val_reform l)
  (at level 67) : trm_scope.

Notation "'()" := val_unit : trm_scope.

End NotationForTrm.


From Coq Require Import List.
From MetaCoq.Erasure.Typed Require Import ClosedAux.
From MetaCoq.Erasure.Typed Require Import ExAst.
From MetaCoq.Erasure.Typed Require Import Transform.
From MetaCoq.Erasure.Typed Require Import ResultMonad.
From MetaCoq.Erasure.Typed Require Import Utils.
From MetaCoq.Erasure Require Import ELiftSubst.
From MetaCoq.Utils Require Import utils.

Import Kernames.

Definition map_subterms (f : term -> term) (t : term) : term :=
  match t with
  | tEvar n ts => tEvar n (map f ts)
  | tLambda na body => tLambda na (f body)
  | tLetIn na val body => tLetIn na (f val) (f body)
  | tApp hd arg => tApp (f hd) (f arg)
  | tCase p disc brs =>
    tCase p (f disc) (map (on_snd f) brs)
  | tProj p t => tProj p (f t)
  | tFix def i => tFix (map (map_def f) def) i
  | tCoFix def i => tCoFix (map (map_def f) def) i
  | t => t
  end.

Definition bitmask := list bool.

Definition has_bit (n : nat) (bs : bitmask) : bool :=
  nth n bs false.

Definition bitmask_not (bs : bitmask) : bitmask :=
  map negb bs.

Definition count_zeros (bs : bitmask) : nat :=
  List.length (filter negb bs).

Definition count_ones (bs : bitmask) : nat :=
  List.length (filter id bs).

Fixpoint bitmask_or (bs1 bs2 : bitmask) : bitmask :=
  match bs1, bs2 with
  | b1 :: bs1, b2 :: bs2 => (b1 || b2) :: bitmask_or bs1 bs2
  | _, _ => []
  end.

Fixpoint bitmask_and (bs1 bs2 : bitmask) : bitmask :=
  match bs1, bs2 with
  | b1 :: bs1, b2 :: bs2 => (b1 && b2) :: bitmask_and bs1 bs2
  | _, _ => []
  end.

Definition trim_start (b : bool) : bitmask -> bitmask :=
  fix f bs :=
    match bs with
    | b' :: bs =>
      if Bool.eqb b' b then
        f bs
      else
        b' :: bs
    | [] => []
    end.

Definition trim_end (b : bool) (bs : bitmask) : bitmask :=
  List.rev (trim_start b (List.rev bs)).

Section dearg.
Record mib_masks := {
  (** Bitmask specifying which parameters to remove *)
  param_mask : bitmask;
  (** Bitmask specifying which _non-parameter_ data to remove from
      each constructor. The full mask used for each constructor is the
      concatenation of the param_mask and this mask *)
  ctor_masks : list (nat * nat * bitmask); }.

Import BasicAst.

Context (ind_masks : list (kername * mib_masks)).
Context (const_masks : list (kername * bitmask)).

Definition get_mib_masks (kn : kername) : option mib_masks :=
  option_map snd (find (fun '(kn', _) => eq_kername kn' kn) ind_masks).

Fixpoint dearg_single (mask : bitmask) (t : term) (args : list term) : term :=
  match mask, args with
  | true :: mask, arg :: args => dearg_single mask t args
  | false :: mask, arg :: args => dearg_single mask (tApp t arg) args
  | true :: mask, [] => tLambda nAnon (dearg_single mask (lift0 1 t) [])
  | false :: mask, [] => tLambda nAnon (dearg_single mask (tApp (lift0 1 t) (tRel 0)) [])
  | [], _ => mkApps t args
  end.

(** Get the branch for a branch of an inductive, i.e. without including parameters of the inductive *)
Definition get_branch_mask (mm : mib_masks) (ind_index : nat) (c : nat) : bitmask :=
  match find (fun '(ind', c', _) => (ind' =? ind_index) && (c' =? c))
             (ctor_masks mm) with
  | Some (_, _, mask) => mask
  | None => []
  end.

(** Get mask for a constructor, i.e. combined parameter and branch mask *)
Definition get_ctor_mask (ind : inductive) (c : nat) : bitmask :=
  match get_mib_masks (inductive_mind ind) with
  | Some mm => param_mask mm ++ get_branch_mask mm (inductive_ind ind) c
  | None => []
  end.

Definition get_const_mask (kn : kername) : bitmask :=
  match find (fun '(kn', _) => eq_kername kn' kn) const_masks with
  | Some (_, mask) => mask
  | None => []
  end.

Open Scope erasure.

Fixpoint masked {X} (mask : bitmask) (xs : list X) :=
  match mask with
  | [] => xs
  | b :: mask =>
    match xs with
    | [] => []
    | x :: xs =>
      match b with
      | true => masked mask xs
      | false => x :: masked mask xs
      end
    end
  end.

(** Remove lambda abstractions based on bitmask *)
Fixpoint dearg_lambdas (mask : bitmask) (body : term) : term :=
  match body with
  | tLetIn na val body => tLetIn na val (dearg_lambdas mask body)
  | tLambda na lam_body =>
    match mask with
    | true :: mask => (dearg_lambdas mask lam_body) { 0 := tBox }
    | false :: mask => tLambda na (dearg_lambdas mask lam_body)
    | [] => body
    end
  | _ => body
  end.

Definition dearg_branch_body_rec (i : nat) (mask : bitmask) (t : term) : nat * term :=
  fold_left (fun '(i,t) (bit : bool) => if bit then (i,t {i := tBox}) else (S i, t)) mask (i,t).

Lemma dearg_branch_body_rec_count_zeros i mask t :
  (dearg_branch_body_rec i mask t).1 = count_zeros mask + i.
Proof.
  induction mask in t, i |- *;cbn in *;auto.
  destruct a.
  * easy.
  * cbn. unfold dearg_branch_body_rec in *.
    rewrite IHmask.
    unfold count_zeros;lia.
Qed.

(** Context masks are build by reversing the original mask and
    prepending [false], if the original mask is shorter than the contex *)
Definition complete_ctx_mask (mask : bitmask) (ctx : list name) : bitmask :=
  repeat false (#|ctx| - #|mask|) ++ List.rev mask.

Lemma complete_ctx_mask_length mask ctx :
  #|mask| <= #|ctx| ->
  #|complete_ctx_mask mask ctx| = #|ctx|.
Proof.
  intros Hlen.
  unfold complete_ctx_mask.
  rewrite app_length,repeat_length, List.rev_length.
  lia.
Qed.

Definition dearg_branch_body (mask : bitmask) (bctx : list name) (t : term) : list name * term :=
  let bctx_mask := complete_ctx_mask mask bctx in
  (masked bctx_mask bctx, (dearg_branch_body_rec 0 bctx_mask t).2).

(* Compute dearg_lambdas [true;false]
                      (tLambda (nNamed "a")
                        (tLambda (nNamed "b")
                          (tLambda (nNamed "c")
                            (tApp (tApp (tRel 0) (tRel 1)) (tRel 2))))). *)
(* Compute dearg_branch_body [true;false]
                          [nNamed "c";nNamed "b"; nNamed "a"]
                          (tApp (tApp (tRel 0) (tRel 1)) (tRel 2)). *)

Definition dearged_npars (mm : option mib_masks) (npars : nat) : nat :=
  match mm with
  | Some mm => count_zeros (param_mask mm)
  | None => npars
  end.

Definition dearg_case_branch
           (mm : mib_masks) (ind : inductive) (c : nat)
           (br : list name × term) : list name × term :=
  let mask := get_branch_mask mm (inductive_ind ind) c in
  if #|mask| <=? #|br.1| then dearg_branch_body mask br.1 br.2
  else (* never happens for valid masks *)
    br.

Definition dearg_case_branches
           (mm : option mib_masks)
           (ind : inductive)
           (brs : list (list name × term)) :=
  match mm with
  | Some mm => mapi (dearg_case_branch mm ind) brs
  | None => brs
  end.

Definition dearged_proj_arg (mm : option mib_masks) (ind : inductive) (arg : nat) : nat :=
  match mm with
  | Some mm => let mask := get_branch_mask mm (inductive_ind ind) 0 in
               arg - count_ones (firstn arg mask)
  | None => arg
  end.

Definition dearg_case
           (ind : inductive)
           (npars : nat)
           (discr : term)
           (brs : list (list name * term)) : term :=
  let mm := get_mib_masks (inductive_mind ind) in
  tCase (ind, dearged_npars mm npars) discr (dearg_case_branches mm ind brs).

Definition dearg_proj (ind : inductive) (npars arg : nat) (discr : term) : term :=
  let mm := get_mib_masks (inductive_mind ind) in
  tProj (mkProjection ind (dearged_npars mm npars) (dearged_proj_arg mm ind arg)) discr.

Fixpoint dearg_aux (args : list term) (t : term) : term :=
  match t with
  | tApp hd arg => dearg_aux (dearg_aux [] arg :: args) hd
  | tConstruct ind c _ =>
      (** NOTE: we don't support constructors-as-blocks at the moment,
          Therefore, we ignore the block argument list assuming it's empty *)
      dearg_single (get_ctor_mask ind c) t args
  | tConst kn => dearg_single (get_const_mask kn) t args
  | tCase (ind, npars) discr brs =>
    let discr := dearg_aux [] discr in
    let brs := map (on_snd (dearg_aux [])) brs in
    mkApps (dearg_case ind npars discr brs) args
  | tProj (mkProjection ind npars arg) t =>
    mkApps (dearg_proj ind npars arg (dearg_aux [] t)) args
  | t => mkApps (map_subterms (dearg_aux []) t) args
  end.

Definition dearg (t : term) : term :=
  dearg_aux [] t.

Fixpoint dearg_cst_type_top (mask : bitmask) (type : box_type) : box_type :=
  match mask, type with
  | true :: mask, TArr _ cod => dearg_cst_type_top mask cod
  | false :: mask, TArr dom cod => TArr dom (dearg_cst_type_top mask cod)
  | _, _ => type
  end.

(** Remove lambda abstractions from top level declaration and remove
    all unused args in applications *)
Definition dearg_cst (kn : kername) (cst : constant_body) : constant_body :=
  let mask := get_const_mask kn in
  {| cst_type := on_snd (dearg_cst_type_top mask) (cst_type cst);
     cst_body := option_map (dearg ∘ dearg_lambdas mask) (cst_body cst) |}.

Definition dearg_ctor (par_mask : bitmask) (ctor_mask : bitmask) (ctor : ident * list (name * box_type) * nat) :=
  let '(name, fields, orig_arity) := ctor in
  (name, masked (par_mask ++ ctor_mask) fields, orig_arity - count_ones ctor_mask).

Definition dearg_oib
           (mib_masks : mib_masks)
           (oib_index : nat)
           (oib : one_inductive_body) : one_inductive_body :=
  {| ind_name := ind_name oib;
     ind_propositional := ind_propositional oib;
     ind_kelim := ind_kelim oib;
     ind_type_vars := ind_type_vars oib;
     ind_ctors :=
       mapi (fun c ctor =>
               let ctor_mask := get_branch_mask mib_masks oib_index c in
               dearg_ctor (param_mask mib_masks) ctor_mask ctor)
            (ind_ctors oib);
     ind_projs := ind_projs oib |}.

Definition dearg_mib (kn : kername) (mib : mutual_inductive_body) : mutual_inductive_body :=
  match get_mib_masks kn with
  | Some mib_masks =>
    {| ind_npars := count_zeros (param_mask mib_masks);
       ind_bodies := mapi (dearg_oib mib_masks) (ind_bodies mib);
       ind_finite := (ind_finite mib) |}
  | None => mib
  end.

Definition dearg_decl (kn : kername) (decl : global_decl) : global_decl :=
  match decl with
  | ConstantDecl cst => ConstantDecl (dearg_cst kn cst)
  | InductiveDecl mib => InductiveDecl (dearg_mib kn mib)
  | TypeAliasDecl _ => decl
  end.

Definition dearg_env (Σ : global_env) : global_env :=
  map (fun '(kn, has_deps, decl) => (kn, has_deps, dearg_decl kn decl)) Σ.

(** Validity checks used when invoking the pass and to prove it correct *)
Fixpoint is_dead (rel : nat) (t : term) : bool :=
  match t with
  | tRel i => negb (i =? rel)
  | tEvar _ ts => forallb (is_dead rel) ts
  | tLambda _ body => is_dead (S rel) body
  | tLetIn _ val body => is_dead rel val && is_dead (S rel) body
  | tApp hd arg => is_dead rel hd && is_dead rel arg
  | tCase _ discr brs => is_dead rel discr && forallb (fun '(ctx,t) => is_dead (#|ctx| + rel) t) brs
  | tProj _ t => is_dead rel t
  | tFix defs _
  | tCoFix defs _ => forallb (is_dead (#|defs| + rel) ∘ EAst.dbody) defs
  | tConstruct _ _ args => forallb (is_dead rel) args
  | _ => true
  end.

Fixpoint valid_dearg_mask (mask : bitmask) (body : term) : bool :=
  match body, mask with
  | tLetIn na val body, _ => valid_dearg_mask mask body
  | tLambda _ body, b :: mask =>
    (if b then is_dead 0 body else true) && valid_dearg_mask mask body
  | _, [] => true
  | _, _ => false
  end.

(** INVARIANT: the mask is completed according to the context with [complete_ctx_mask]! *)
Fixpoint valid_dearg_mask_branch (i : nat) (mask : bitmask) (body : term) : bool :=
  match mask with
  | b :: mask =>
    (if b then is_dead i body else true) && valid_dearg_mask_branch (S i) mask body
  | [] => true
  end.

Definition valid_case_masks (ind : inductive) (npars : nat) (brs : list (list name * term)) : bool :=
  match get_mib_masks (inductive_mind ind) with
  | Some mm =>
    (#|param_mask mm| =? npars) &&
      alli (fun c '(ctx, br) =>
              let ar := #|ctx| in
              (#|get_branch_mask mm (inductive_ind ind) c| <=? ar) &&
                (valid_dearg_mask_branch 0 (complete_ctx_mask (get_branch_mask mm (inductive_ind ind) c) ctx) br)) 0 brs
  | None => true
  end.

Definition valid_proj (ind : inductive) (npars arg : nat) : bool :=
  match get_mib_masks (inductive_mind ind) with
  | Some mm => (#|param_mask mm| =? npars) &&
               (* Projected argument must not be removed *)
               negb (nth arg (get_branch_mask mm (inductive_ind ind) 0) false)
  | _ => true
  end.

(** Check that all cases and projections in a term are valid according
    to the masks. They must have the proper number of parameters, and
    - For cases, their branches must be compatible with the masks,
      i.e. when "true" appears in the mask, the parameter is unused
    - For projections, the projected argument must not be removed
    - For constructors, that they are not blocks *)
Fixpoint valid_cases (t : term) : bool :=
  match t with
  | tEvar _ ts => forallb valid_cases ts
  | tLambda _ body => valid_cases body
  | tLetIn _ val body => valid_cases val && valid_cases body
  | tApp hd arg => valid_cases hd && valid_cases arg
  | tCase (ind, npars) discr brs =>
    valid_cases discr && forallb (valid_cases ∘ snd) brs && valid_case_masks ind npars brs
  | tProj (mkProjection ind npars arg) t => valid_cases t && valid_proj ind npars arg
  | tFix defs _
  | tCoFix defs _ => forallb (valid_cases ∘ EAst.dbody) defs
  | tConstruct _ _ (_ :: _) => false (* check whether constructors are not blocks*)
  | _ => true
  end.

Definition valid_masks_decl (p : kername * bool * global_decl) : bool :=
  match p with
  | (kn, _, ConstantDecl {| cst_body := Some body |}) =>
    valid_dearg_mask (get_const_mask kn) body && valid_cases body
  | (kn, _, TypeAliasDecl typ) => #|get_const_mask kn| =? 0
  | (kn, _, InductiveDecl mib) =>
      match get_mib_masks kn with
      | Some mask => #|mask.(param_mask)| =? mib.(ind_npars)
      | _ => false
      end
  | _ => true
  end.

(** Proposition representing whether masks are valid for entire environment.
    We should be able to prove that our analysis produces masks that satisfy
    this predicate. *)
Definition valid_masks_env (Σ : global_env) : bool :=
  forallb valid_masks_decl Σ.

(** Check if all applications are applied enough to be deboxed without eta expansion. *)
Fixpoint is_expanded_aux (nargs : nat) (t : term) : bool :=
  match t with
  | tBox => true
  | tRel _ => true
  | tVar _ => true
  | tEvar _ ts => forallb (is_expanded_aux 0) ts
  | tLambda _ body => is_expanded_aux 0 body
  | tLetIn _ val body => is_expanded_aux 0 val && is_expanded_aux 0 body
  | tApp hd arg => is_expanded_aux 0 arg && is_expanded_aux (S nargs) hd
  | tConst kn => #|get_const_mask kn| <=? nargs
  | tConstruct ind c _ =>
      (** NOTE: we don't support constructors-as-blocks at the moment,
          Therefore, we ignore the block argument list assuming it's empty *)
      #|get_ctor_mask ind c| <=? nargs
  | tCase _ discr brs => is_expanded_aux 0 discr && forallb (is_expanded_aux 0 ∘ snd) brs
  | tProj _ t => is_expanded_aux 0 t
  | tFix defs _
  | tCoFix defs _ => forallb (is_expanded_aux 0 ∘ EAst.dbody) defs
  | tPrim _ => true
  end.

(** Check if all applications are applied enough to be deboxed without eta expansion *)
Definition is_expanded (t : term) : bool :=
  is_expanded_aux 0 t.

(** Like above, but check all bodies in environment.
    This assumption does not necessarily hold,
    but we should try to make it hold by eta expansion before quoting *)
Definition is_expanded_env (Σ : global_env) : bool :=
  forallb (fun '(kn, decl) =>
             match decl with
             | ConstantDecl {| cst_body := Some body |} => is_expanded body
             | _ => true
             end) Σ.

End dearg.

Section dearg_types.

Context (Σ : global_env).

Definition keep_tvar tvar :=
  tvar_is_arity tvar && negb (tvar_is_logical tvar).

Fixpoint dearg_single_bt (tvars : list type_var_info) (t : box_type) (args : list box_type)
  : box_type :=
  match tvars, args with
  | tvar :: tvars, arg :: args =>
    if keep_tvar tvar then
      dearg_single_bt tvars (TApp t arg) args
    else
      dearg_single_bt tvars t args
  | _, _ => mkTApps t args
  end.

Definition get_inductive_tvars (ind : inductive) : list type_var_info :=
  match lookup_inductive Σ ind with
  | Some oib => ind_type_vars oib
  | None => []
  end.

Fixpoint debox_box_type_aux (args : list box_type) (bt : box_type) : box_type :=
  match bt with
  | TArr dom codom =>
    TArr (debox_box_type_aux [] dom) (debox_box_type_aux [] codom)
  | TApp ty1 ty2 =>
    debox_box_type_aux (debox_box_type_aux [] ty2 :: args) ty1
  | TInd ind => dearg_single_bt (get_inductive_tvars ind) bt args
  | TConst kn => match lookup_env Σ kn with
                | Some (TypeAliasDecl (Some (vs, ty))) =>
                  dearg_single_bt vs bt args
                | _ => bt
                end
  | _ => mkTApps bt args
  end.

Definition debox_box_type (bt : box_type) : box_type :=
  debox_box_type_aux [] bt.

Definition debox_type_constant (cst : constant_body) : constant_body :=
  {| cst_type := on_snd debox_box_type (cst_type cst);
     cst_body := cst_body cst; |}.

Definition reindex (tvars : list type_var_info) :=
  fix f (bt : box_type) : box_type :=
    match bt with
    | TArr dom cod => TArr (f dom) (f cod)
    | TApp hd arg => TApp (f hd) (f arg)
    | TVar i => TVar #|filter keep_tvar (firstn i tvars)|
    | _ => bt
    end.

Definition debox_type_oib (oib : one_inductive_body) : one_inductive_body :=
  let debox := reindex (ind_type_vars oib) ∘ debox_box_type in
  {| ind_name := ind_name oib;
     ind_propositional := ind_propositional oib;
     ind_kelim := ind_kelim oib;
     ind_type_vars := filter keep_tvar (ind_type_vars oib);
     ind_ctors := map (fun '(nm, fields, orig_arity) => (nm, map (on_snd debox) fields, orig_arity)) (ind_ctors oib);
     ind_projs := map (on_snd debox) (ind_projs oib); |}.

Definition debox_type_mib (mib : mutual_inductive_body) : mutual_inductive_body :=
  {| ind_npars := ind_npars mib; ind_bodies := map debox_type_oib (ind_bodies mib); ind_finite := ind_finite mib |}.

Definition debox_type_decl (decl : global_decl) : global_decl :=
  match decl with
  | ConstantDecl cst => ConstantDecl (debox_type_constant cst)
  | InductiveDecl mib => InductiveDecl (debox_type_mib mib)
  | TypeAliasDecl ta => match ta with
                       | Some (ty_vars, ty) =>
                         TypeAliasDecl (Some (filter keep_tvar ty_vars,
                                              reindex ty_vars (debox_box_type ty)))
                       | None => TypeAliasDecl None
                       end
  end.

End dearg_types.

Definition debox_env_types (Σ : global_env) : global_env :=
  map (on_snd (debox_type_decl Σ)) Σ.

Fixpoint clear_bit (n : nat) (bs : bitmask) : bitmask :=
  match n, bs with
  | 0, _ :: bs => false :: bs
  | S n, b :: bs => b :: clear_bit n bs
  | _, _ => []
  end.

(** Pair of bitmask and inductive masks.
    The first projection is a bitmask of dead local variables, i.e. when a use is found,
    a bit in this is set to false.
    The second projection is a list of dead constructor datas. When a use of a constructor
    parameter is found, this is set to false. *)
Definition analyze_state := bitmask × list (kername × mib_masks).

Definition set_used (s : analyze_state) (n : nat) : analyze_state :=
  (clear_bit n s.1, s.2).

Definition new_vars (s : analyze_state) (n : nat) : analyze_state :=
  (List.repeat true n ++ s.1, s.2).

Definition new_var (s : analyze_state) : analyze_state :=
  (true :: s.1, s.2).

Definition remove_vars (s : analyze_state) (n : nat) : analyze_state :=
  (skipn n s.1, s.2).

Definition remove_var (s : analyze_state) : analyze_state :=
  (tl s.1, s.2).

Definition update_mib_masks
           (s : analyze_state)
           (kn : kername)
           (mm : mib_masks) : analyze_state :=
  let fix update_list l :=
      match l with
      | [] => []
      | (kn', mm') :: l =>
        if eq_kername kn' kn then
          (kn, mm) :: l
        else
          (kn', mm') :: update_list l
      end in
  (s.1, update_list s.2).

Fixpoint update_ind_ctor_mask
         (ind : nat)
         (c : nat)
         (ctor_masks : list (nat * nat * bitmask))
         (f : bitmask -> bitmask) : list (nat * nat * bitmask) :=
  match ctor_masks with
  | [] => []
  | (ind', c', mask') :: ctor_masks =>
    if (ind' =? ind) && (c' =? c) then
      (ind', c', f mask') :: ctor_masks
    else
      (ind', c', mask') :: update_ind_ctor_mask ind c ctor_masks f
  end.

Definition fold_lefti {A B} (f : nat -> A -> B -> A) :=
  fix fold_lefti (n : nat) (l : list B) (a0 : A) :=
    match l with
    | [] => a0
    | b :: t => fold_lefti (S n) t (f n a0 b)
    end.

Section AnalyzeTop.
  Context (analyze : analyze_state -> term -> analyze_state).
  (** Analyze iterated let-in and lambdas to find dead variables inside body.
      Return bitmask of max length n indicating which lambda arguments are unused. *)
  Fixpoint analyze_top_level
           (state : analyze_state)
           (max_lams : nat)
           (t : term) {struct t} : bitmask × analyze_state :=
    match t, max_lams with
    | tLetIn na val body, _ =>
      let state := analyze state val in
      let (mask, state) := analyze_top_level (new_var state) max_lams body in
      (* Add nothing to mask *)
      (mask, remove_var state)
    | tLambda na body, S max_lams =>
      let (mask, state) := analyze_top_level (new_var state) max_lams body in
      (* Add to mask indicating whether this arg is unused *)
      (hd true state.1 :: mask, remove_var state)
    | t, _ => ([], analyze state t)
    end.
End AnalyzeTop.

(** NOTE: analysis assumes that constructors are in the form [tConstruct ind i [] ],
    that is, constructors-as-blocks is disabled *)
Fixpoint analyze (state : analyze_state) (t : term) {struct t} : analyze_state :=
  match t with
  | tBox => state
  | tRel i => set_used state i
  | tVar n => state
  | tEvar _ ts => fold_left analyze ts state
  | tLambda _ cod => remove_var (analyze (new_var state) cod)
  | tLetIn _ val body => remove_var (analyze (new_var (analyze state val)) body)
  | tApp hd arg => analyze (analyze state hd) arg
  | tConst _ => state
  | tConstruct _ _ _ =>
      (** NOTE: we don't support constructors-as-blocks at the moment,
          Therefore, we ignore the block argument list assuming it's empty *)
      state
  | tCase (ind, npars) discr brs =>
    let state := analyze state discr in
    match get_mib_masks state.2 (inductive_mind ind) with
    | Some mm =>
      let analyze_case c '(state, ctor_masks) (brs : list BasicAst.name * term) :=
        let state := analyze (new_vars state #|brs.1|) brs.2 in
        (remove_vars state #|brs.1|, ctor_masks) in
        (* let mask := List.rev (firstn #|brs.1| state.1) in *)
        (* (remove_vars state #|brs.1|, update_ind_ctor_mask (inductive_ind ind) c ctor_masks (bitmask_and mask)) in *)
      let (state, ctor_masks) := fold_lefti analyze_case 0 brs (state, ctor_masks mm) in
      let mm := {| param_mask := param_mask mm; ctor_masks := ctor_masks |} in
      update_mib_masks state (inductive_mind ind) mm
    | None => state
    end
  | tProj (mkProjection ind npars arg) t =>
    let state := analyze state t in
    match get_mib_masks state.2 (inductive_mind ind) with
    | Some mm =>
      let ctor_masks :=
          update_ind_ctor_mask (inductive_ind ind) 0 (ctor_masks mm) (clear_bit arg) in
      let mm := {| param_mask := param_mask mm; ctor_masks := ctor_masks |} in
      update_mib_masks state (inductive_mind ind) mm
    | None => state
    end
  | tFix defs _
  | tCoFix defs _ =>
    let state := new_vars state #|defs| in
    let state := fold_left (fun state d => analyze state (dbody d)) defs state in
    remove_vars state #|defs|
  | tPrim _ => state
  end.

Fixpoint decompose_TArr (bt : box_type) : list box_type × box_type :=
  match bt with
  | TArr dom cod => map_fst (cons dom) (decompose_TArr cod)
  | _ => ([], bt)
  end.

Definition is_box_or_any (bt : box_type) : bool :=
  match bt with
  | TBox
  | TAny => true
  | _ => false
  end.

Definition analyze_constant
           (cst : constant_body)
           (inds : list (kername × mib_masks)) : bitmask × list (kername × mib_masks) :=
  let '(doms, codom) := decompose_TArr (cst_type cst).2 in
  match cst_body cst with
  | Some body =>
    let max_lams := #|doms| in
    let '(mask, (_, inds)) := analyze_top_level analyze ([], inds) max_lams body in
    (* NOTE: if all the arguments are logical, we keep the first one in order to prevent
       contstans like [false_rect] to be evaluated eagerly in the extracted code *)
    if forallb is_box_or_any doms then
      (clear_bit 0 mask, inds)
    else (mask, inds)
  | None => (map is_box_or_any doms, inds)
  end.

Record dearg_set := {
  const_masks : list (kername * bitmask);
  ind_masks : list (kername * mib_masks); }.

Fixpoint analyze_env
         (overridden_masks : kername -> option bitmask)
         (Σ : global_env) : dearg_set :=
  match Σ with
  | [] => {| const_masks := []; ind_masks := [] |}
  | (kn, has_deps, decl) :: Σ =>
    let (consts, inds) := analyze_env overridden_masks Σ in
    let (consts, inds) :=
        match decl with
        | ConstantDecl cst =>
          let '(mask, inds) := analyze_constant cst inds in
          let mask := option_get mask (overridden_masks kn) in
          ((kn, mask) :: consts, inds)
        | InductiveDecl mib =>
          let ctor_masks :=
              List.concat
                (mapi (fun ind oib =>
                         mapi (fun c '(_, args, _) =>
                                 (ind, c, map (is_box_or_any ∘ snd)
                                              (skipn (ind_npars mib) args)))
                              (ind_ctors oib))
                      (ind_bodies mib)) in
          let mm := {| param_mask := List.repeat true (ind_npars mib);
                       ctor_masks := ctor_masks |} in
          (consts, (kn, mm) :: inds)
        | TypeAliasDecl _ => (consts, inds)
        end in
    {| const_masks := consts; ind_masks := inds |}
  end.

(** Remove trailing "false" bits in masks *)
Definition trim_const_masks (cm : list (kername × bitmask)) :=
  map (on_snd (trim_end false)) cm.

Definition trim_ctor_masks (cm : list ((nat × nat) × bitmask)) :=
  map (fun '(ind, c, mask) => (ind, c, trim_end false mask)) cm.

Definition trim_mib_masks (mm : mib_masks) :=
  {| param_mask := param_mask mm;
     ctor_masks := trim_ctor_masks (ctor_masks mm) |}.

Definition trim_ind_masks (im : list (kername × mib_masks)) :=
  map (on_snd trim_mib_masks) im.

Import MCMonadNotation.

Definition throwIf (b : bool) (err : string) : (fun x => result x string) unit :=
  if b then Err err else Ok tt.

From Coq Require Import String.

Definition dearg_transform
           (overridden_masks : kername -> option bitmask)
           (** If true, trim ends of constant masks to avoid unnecessary eta expansion. *)
           (do_trim_const_masks : bool)
           (** If true, trim ends of constructor masks to avoid unnecessary eta expansion. *)
           (do_trim_ctor_masks : bool)
           (** Check if erased environment is closed *)
           (check_closed : bool)
           (** Check that environment is expanded enough before dearging *)
           (check_expanded : bool)
           (** Check that the dearg masks generated by analysis are valid for dearging *)
           (check_valid_masks : bool) : ExtractTransform :=
  fun (Σ : global_env) => throwIf (check_closed && negb (env_closed (trans_env Σ)))
        "Erased environment is not closed" ;;
    let (const_masks, ind_masks) := timed "Dearg analysis"%string
                                          (fun _ => analyze_env overridden_masks Σ) in

    let const_masks := (if do_trim_const_masks then trim_const_masks else id) const_masks in
    let ind_masks := (if do_trim_ctor_masks then trim_ind_masks else id) ind_masks in

    throwIf (check_expanded && negb (is_expanded_env ind_masks const_masks Σ))
            "Erased environment is not expanded enough for dearging to be provably correct" ;;

    throwIf (check_valid_masks && negb (valid_masks_env ind_masks const_masks Σ))
            "Analysis produced masks that ask to remove live arguments" ;;
    Ok (debox_env_types (timed "Dearging" (fun _ => dearg_env ind_masks const_masks Σ))).


From Formalisation Require Import Nom SizeNat.

Open Scope N_scope.

Definition IkeTransformType := nat8.

Definition IkeTransformEncType := nat16.

Definition is_aead (n : IkeTransformEncType) : bool :=
  match val n with
  | 14 | 15 | 16 | 18 | 19 | 20 | 25 | 26 | 27 | 28 => true
  | _ => false
  end.

Definition is_unassigned_enc (n : IkeTransformEncType): bool :=
  let v := val n in
  (23 <=? v) && (v <=? 1023).

Definition is_private_use_enc (n : IkeTransformEncType): bool :=
  1024 <=? val n.

Definition IkeTransformPRFType := nat16.

Definition is_unassigned_prf (n : IkeTransformPRFType) : bool :=
  let v := val n in
  (23 <=? v) && (v <=? 1023).

Definition is_private_use_prf (n : IkeTransformPRFType) : bool :=
  val n <=? 1024.

Definition IkeTransformAuthType := nat16.

Definition is_unassigned_auth (n : IkeTransformAuthType) : bool :=
  let v := val n in
  (15 <=? v) && (v <=? 1023).

Definition is_private_use_auth (n : IkeTransformAuthType) : bool :=
  let v := val n in
  v <=? 1024.

Definition IkeTransformDHType := nat16.

Definition is_unassigned_dh (n : IkeTransformDHType) : bool :=
  let v := val n in
  (15 <=? v) && (v <=? 1023).

Definition is_private_use_dh (n : IkeTransformDHType) : bool :=
  val n <=? 1024.

Definition IkeTransformESNType := nat16.

Record IkeV2RawTransformS (S : Type) :=
  mk_raw {
      last : nat8;
      reserved1 : nat8;
      transform_length : nat16;
      transform_type : IkeTransformType;
      reserved2 : nat8;
      transform_id : nat16;
      attributes : option S
    }.

Definition IkeV2RawTransform := @IkeV2RawTransformS span.

Global Instance Foldable_IkeV2Transform : Foldable (@IkeV2RawTransformS).
econstructor.
intros.
destruct (attributes _ X0). eapply (X a). eapply Monoid.mempty.
Defined.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import Init_ext ssrZ ZArith_ext uniq_tac.
Require Import machine_int multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import copy_s_s_prg copy_s_s_triple copy_s_s_termination.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope asm_expr_scope.
Local Open Scope zarith_ext_scope.

Lemma safe_termination_copy_s_s u x d L rk ru rx a0 a1 a2 a3 a4 : uniq(u, x) ->
  uniq(rk, ru, rx, a0, a1, a2, a3, a4, r0) ->
  safe_termination
  (fun s st h => state_mint (u |=> signed L ru \U+ (x |=> signed L rx \U+ d)) s st h /\
                 L = '| u2Z ([rk]_st) |)
  (copy_s_s rk ru rx a0 a1 a2 a3 a4).
Proof.
move=> Hvars Hregs.
rewrite /safe_termination.
move=> s st h s_st_h.
move/copy_s_s_termination : (Hregs).
case/(_ st h) => si Hsi.
move/copy_s_s_triple : (Hregs).
move: ((proj1 (proj1 s_st_h)) u (signed L ru)).
rewrite assoc.get_union_sing_eq.
case/(_ (refl_equal _)) => lu pu U ru_fit [U_L lu_L lu_u u_U] pu_fit mem_u.
move: ((proj1 (proj1 s_st_h)) x (signed L rx)).
rewrite assoc.get_union_sing_neq; last by Uniq_neq.
rewrite assoc.get_union_sing_eq.
case/(_ (refl_equal _)) => lx px X rx_fit [X_L lx_L lx_x x_X] px_fit mem_x.
move/(_ U X L U_L X_L _ _ pu_fit _ _ px_fit).
move/(_ _ _ _ lx_L).
rewrite -x_X.
move/(_ lu ([rx]_st) lx_x) => hoare_triple.
apply constructive_indefinite_description'.
apply (triple_exec_precond _ _ _ hoare_triple _ _ _ Hsi
  (heap.dom (heap_mint (signed L ru) st h \U
             heap_mint (signed L rx) st h))).
split => //.
split.
  case: s_st_h => _ ->.
  rewrite Z_of_nat_Zabs_nat //.
  by apply min_u2Z.
suff : h |P| heap.dom (heap_mint (signed L ru) st h \U
         heap_mint (signed L rx) st h) =
       heap_mint (signed L ru) st h \U heap_mint (signed L rx) st h.
  move=> ->.
  apply assert_m.con_cons => //.
  apply (proj2 (proj1 s_st_h) u x) => //.
  by Uniq_neq.
  by rewrite assoc.get_union_sing_eq.
  rewrite assoc.get_union_sing_neq; last by Uniq_neq.
  by rewrite assoc.get_union_sing_eq.
rewrite -heap.incluE.
apply heap_prop_m.inclu_union; by apply heap_inclu_heap_mint_signed.
Qed.