(******************************************)
(*   Finite multiset library              *)
(*   Developped for the PACTOLE project   *)
(*   L. Rieg                              *)
(*                                        *)
(*   This file is distributed under       *)
(*   the terms of the CeCILL-C licence    *)
(*                                        *)
(******************************************)

Require Import MMapInterface.
Require Import Arith_base.
Require Import Omega.
Require Import PArith.
Require Import RelationPairs.
Require Import Equalities.
Require Import MMultisets.Preliminary.
Require Import MMultisets.MMultisetInterface.

Module FMultisets (MMap : WSfun) (E : DecidableType) : MMultisetsOn E.

Module M := MMap(E).

Definition eq_pair := RelProd E.eq (@Logic.eq nat).
Definition eq_elt := RelCompFun E.eq (@fst E.t nat).

Instance Meq_equiv A : Equivalence (@M.eq_key_elt A).
Proof. split.
  intro. reflexivity.
  intros ? ?. now symmetry.
  intros ? y ? ? ?. now transitivity y.
Qed.

Instance Meq_key_equiv A : Equivalence (@M.eq_key A).
Proof. split.
  intro. reflexivity.
  intros ? ?. now symmetry.
  intros ? y ? ? ?. now transitivity y.
Qed.

Instance eq_pair_equiv : Equivalence eq_pair.
Proof. split. easy. easy. intros ? y ? ? ?. now transitivity y. Qed.

Lemma Meq_dec : forall x y : E.t * positive, {M.eq_key_elt x y} + {~M.eq_key_elt x y}.
Proof.
intros [t1 n1] [t2 n2].
destruct (E.eq_dec t1 t2). destruct (Pos.eq_dec n1 n2).
  left. now split.
  right. intros []. contradiction.
  right. intros []. contradiction.
Defined.

Lemma eq_key_elt_eq_key_weak_In B : forall x y n m l,
  E.eq x y -> InA (@M.eq_key_elt B) (x, n) l -> InA (@M.eq_key B) (y, m) l.
Proof.
intros x y n m l Heq Hin. induction l.
+ now inversion Hin.
+ inversion_clear Hin.
  - left. destruct a. compute in *. destruct H. now transitivity x; auto.
  - right. now apply IHl.
Qed.

Lemma NoDup_pair_In : forall A x y n m l, NoDupA (@M.eq_key A) l ->
  InA (@M.eq_key_elt _) (x, n) l -> InA (@M.eq_key_elt _) (y, m) l -> E.eq x y -> n = m.
Proof.
intros A x y n m l Hl Hinx Hiny Heq. induction Hl as [| [z p] l]. inversion_clear Hiny.
inversion_clear Hinx; inversion_clear Hiny.
- compute in H0, H1. destruct H0 as [H0 ?], H1 as [H1 ?]. now subst p m.
- compute in H0. destruct H0 as [H0 ?]. subst p. elim H.
  apply eq_key_elt_eq_key_weak_In with y m. now transitivity x. assumption.
- compute in H1. destruct H1 as [H1 ?]. subst p. elim H.
  apply eq_key_elt_eq_key_weak_In with x n. now transitivity y; auto. assumption.
- now apply IHHl.
Qed.

Lemma Melements_InA : forall A x n s, InA (@M.eq_key_elt A) (x, n) (M.bindings s) <-> M.MapsTo x n s.
Proof. intros. now apply M.bindings_spec1. Qed.

Instance Mfind_compat {A} : Proper (E.eq ==> @M.Equal A ==> Logic.eq) (@M.find A).
Proof.
intros x1 x2 Hx s1 s2 Hs. rewrite Hs. clear s1 Hs. destruct (M.find x1 s2) eqn:Hin.
- rewrite M.find_spec, Hx, <- M.find_spec in Hin. auto.
- destruct (M.find x2 s2) eqn:Hin'; trivial. rewrite M.find_spec, <- Hx, <- M.find_spec, Hin in Hin'. discriminate.
Qed.

Definition elt := E.t.
Definition t := M.t positive.

Definition empty : t := @M.empty positive.
Definition is_empty (s : t) := M.is_empty s.
Definition multiplicity x (s : t) := match M.find x s with Some n => Pos.to_nat n | None => 0 end.
Definition add (x : elt) (n : nat) (s : t) : t :=
  if eq_nat_dec n 0 then s else M.add x (Pos.of_nat (multiplicity x s + n)) s.
Definition singleton x n := add x n empty.
Definition remove (x : elt) (n : nat) (s : t) : t :=
  if eq_nat_dec n 0 then s else
  if le_lt_dec (multiplicity x s) n then M.remove x s else M.add x (Pos.of_nat (multiplicity x s - n)) s.
Definition union (s s' : t) := M.fold (fun x n acc => add x (Pos.to_nat n) acc) s s'.
Definition inter (s s' : t) :=
  M.fold (fun x n acc => add x ((fun x n => min (multiplicity x s) (Pos.to_nat n)) x n) acc) s' empty.
Definition diff (s s' : t) := M.fold (fun x n acc => add x (Pos.to_nat n - multiplicity x s') acc) s empty.
Definition lub (s s' : t) := M.fold (fun x n acc => add x (Pos.to_nat n - multiplicity x s') acc) s s'.
Definition equal (s s' : t) := M.equal Pos.eqb s s'.
Definition subset s s' := is_empty (diff s s').
Definition fold {A} f (s : t) := @M.fold positive A (fun x y => f x (Pos.to_nat y)) s.
Definition for_all f (s : t) := M.fold (fun x n b => b && f x (Pos.to_nat n)) s true.
Definition exists_ f (s : t) := M.fold (fun x n b => b || f x (Pos.to_nat n)) s false.
Definition nfilter f (s : t) :=
  M.fold (fun x n acc => if f x (Pos.to_nat n) : bool then add x (Pos.to_nat n) acc else acc) s empty.
Definition filter f (s : t) := nfilter (fun x _ => f x) s.
Definition npartition f (s : t) :=
  M.fold (fun x n acc => if f x (Pos.to_nat n) : bool then (add x (Pos.to_nat n) (fst acc), snd acc)
                                                      else (fst acc, add x (Pos.to_nat n) (snd acc))) s (empty,empty).
Definition partition f (s : t) := npartition (fun x _ => f x) s.
Definition cardinal (s : t) := M.fold (fun _ n acc => Pos.to_nat n + acc) s 0.
Definition size (s : t) := M.fold (fun _ _ n => S n) s 0.
Definition elements (s : t) := List.map (fun xy => (fst xy, Pos.to_nat (snd xy))) (M.bindings s).
Definition support (s : t) := M.fold (fun x _ l => cons x l) s nil.
Definition choose (s : t) := M.fold (fun x _ _ => Some x) s None.

Definition In := fun x s => multiplicity x s > 0.
Definition eq s s' := forall x, multiplicity x s = multiplicity x s'.
Definition Subset s s' := forall x, multiplicity x s <= multiplicity x s'.
Definition For_all (P : elt -> nat -> Prop) s := forall x, In x s -> P x (multiplicity x s).
Definition Exists (P : elt -> nat -> Prop) s := exists x, In x s /\ P x (multiplicity x s).

Global Notation "s  [=]  t" := (eq s t) (at level 70, no associativity).
Global Notation "s  [c=]  t" := (Subset s t) (at level 70, no associativity).

Lemma eq_Meq : forall s s', s [=] s' <-> M.Equal s s'.
Proof.
intros s s'. unfold eq, multiplicity, M.Equal. split; intros Heq x.
+ specialize (Heq x). destruct (M.find x s), (M.find x s').
  - apply Pos2Nat.inj in Heq. now subst.
  - assert (Hpos := Pos2Nat.is_pos p). omega.
  - assert (Hpos := Pos2Nat.is_pos p). omega.
  - reflexivity.
+ now rewrite Heq.
Qed.

Instance multiplicity_compat : Proper (E.eq ==> eq ==> Logic.eq) multiplicity.
Proof.
intros x y Hxy s s' Hs. rewrite eq_Meq in Hs. unfold multiplicity. now rewrite (Mfind_compat _ _ Hxy _ _ Hs).
Qed.

Global Instance eq_equiv : Equivalence eq.
Proof. split; try easy. intros x y z Hxy Hyz a. now rewrite Hxy, Hyz. Qed.
(** [eq] is obviously an equivalence, for subtyping only. *)

Instance In_compat : Proper (E.eq ==> eq ==> iff) In.
Proof. intros x y Hxy s s' ?. unfold In. now rewrite H, Hxy. Qed.

Theorem In_dec : forall x s, {In x s} + {~In x s}.
Proof. unfold In. intros. apply gt_dec. Qed.

Lemma In_MIn : forall x s, In x s <-> M.In x s.
Proof.
intros x s. split; intro H.
- exists (Pos.of_nat (multiplicity x s)). rewrite <- M.find_spec. unfold In, multiplicity in *.
  destruct (M.find x s). now rewrite Pos2Nat.id. now inversion H.
- destruct H as [n Hn]. rewrite <- M.find_spec in Hn. unfold In, multiplicity. rewrite Hn. now apply Pos2Nat.is_pos.
Qed.

Lemma Mequal_Mequivb_equiv : forall s s' : M.t positive, M.Equal s s' <-> M.Equivb Pos.eqb s s'.
Proof.
intros s s'. split.
+ intro Heq. split.
  - intro x. split; intros [e Hin]; exists e.
      now rewrite <- M.find_spec, <- Heq, M.find_spec.
      now rewrite <- M.find_spec, Heq, M.find_spec.
  - intros x e e' He He'. rewrite <- M.find_spec in *.
    rewrite Heq in He. rewrite He in He'. inversion_clear He'. unfold Cmp. now apply Pos.eqb_refl.
+ intros [Heq1 Heq2] x.
  destruct (M.find x s) as [e |] eqn:Hfind, (M.find x s') as [e' |] eqn:Hfind'.
  - f_equal. apply Pos.eqb_eq. apply (Heq2 x); now rewrite <- M.find_spec.
  - assert (Habs : M.In x s'). { rewrite <- Heq1. exists e. now rewrite <- M.find_spec. }
    destruct Habs as [e' Habs]. rewrite <- M.find_spec, Hfind' in Habs. discriminate Habs.
  - assert (Habs : M.In x s). { rewrite Heq1. exists e'. now rewrite <- M.find_spec. }
    destruct Habs as [e Habs]. rewrite <- M.find_spec, Hfind in Habs. discriminate Habs.
  - reflexivity.
Qed.

Lemma multiplicity_find_in : forall x s, In x s -> M.find x s = Some (Pos.of_nat (multiplicity x s)).
Proof.
intros x s Hin. unfold In, multiplicity in *. destruct (M.find x s) eqn:Hfind.
- now rewrite Pos2Nat.id.
- now inversion Hin.
Qed.

Lemma multiplicity_out : forall x s, multiplicity x s = 0 <-> M.find x s = None.
Proof.
unfold multiplicity. intros x s. split; intro Hs.
+ destruct (M.find x s).
  - elim (lt_irrefl 0). rewrite <- Hs at 2. now apply Pos2Nat.is_pos.
  - reflexivity.
+ now rewrite Hs.
Qed.

Lemma equal_spec : forall s s', equal s s' = true <-> s[=]s'.
Proof.
intros s s'. unfold equal. simpl. destruct (M.equal Pos.eqb s s') eqn:Heq.
+ split; intro H; trivial || clear H. rewrite M.equal_spec, <- Mequal_Mequivb_equiv in Heq.
  unfold eq, multiplicity. intro. now rewrite Heq.
+ split; intro Habs; try discriminate Habs. exfalso.
  assert (Hneq : ~M.Equivb Pos.eqb s s').
  { intro Habs'. rewrite <- M.equal_spec, Heq in Habs'. discriminate Habs'. }
  rewrite <- Mequal_Mequivb_equiv in Hneq. apply Hneq. intro x.
  unfold eq, multiplicity in Habs. specialize (Habs x). simpl in Habs.
  destruct (M.find x s) eqn:Hin1, (M.find x s') eqn:Hin2.
  - f_equal. now apply Pos2Nat.inj.
  - elim (lt_irrefl 0). rewrite <- Habs at 2. now apply Pos2Nat.is_pos.
  - elim (lt_irrefl 0). rewrite Habs at 2. now apply Pos2Nat.is_pos.
  - reflexivity.
Qed.

Corollary eq_dec : forall s s' : t, {s [=] s'} + {~s [=] s'}.
Proof.
intros s s'. destruct (equal s s') eqn:Heq.
- left. now rewrite <- equal_spec.
- right. rewrite <- equal_spec. rewrite Heq. discriminate.
Qed.

Lemma empty_spec : forall x, multiplicity x empty = 0.
Proof.
intro x. unfold multiplicity, empty.
destruct (M.find x M.empty) eqn:Hin.
- rewrite (M.empty_spec positive x) in Hin. discriminate Hin.
- reflexivity.
Qed.

Lemma is_empty_spec : forall s, is_empty s = true <-> s [=] empty.
Proof.
intros s. unfold is_empty. split; intro H.
+ rewrite M.is_empty_spec in H. intros x. rewrite empty_spec.
  unfold multiplicity. now rewrite H.
+ rewrite M.is_empty_spec. intro x. rewrite eq_Meq in H. rewrite H. apply M.empty_spec.
Qed.

Corollary is_empty_multiplicity : forall x s, is_empty s = true -> multiplicity x s = 0.
Proof.
intros x s Hs. unfold multiplicity. destruct (M.find x s) eqn:Hin; trivial.
rewrite is_empty_spec in Hs. rewrite eq_Meq in Hs. rewrite Hs, M.empty_spec in Hin. discriminate.
Qed.

Lemma add_same : forall x n s, multiplicity x (add x n s) = multiplicity x s + n.
Proof.
intros x n s. unfold add. destruct (eq_nat_dec n 0). omega.
unfold multiplicity at 1. simpl.
rewrite (M.add_spec1 s x (Pos.of_nat (multiplicity x s + n))).
rewrite Nat2Pos.id. reflexivity. omega.
Qed.

Lemma add_other : forall x y n s, ~E.eq y x -> multiplicity y (add x n s) = multiplicity y s.
Proof.
intros x y n s Hyx. unfold add. destruct (eq_nat_dec n 0); trivial. unfold multiplicity at 1 3.
rewrite (M.add_spec2 s (Pos.of_nat (multiplicity x s + n))). reflexivity. now intro; apply Hyx.
Qed.

Lemma remove_same : forall x n s, multiplicity x (remove x n s) = multiplicity x s - n.
Proof.
intros x n s. unfold remove. destruct (eq_nat_dec n 0). omega.
destruct (le_lt_dec (multiplicity x s) n) as [Hle | Hlt]; unfold multiplicity at 1; simpl.
- rewrite M.remove_spec1. omega.
- rewrite M.add_spec1. rewrite Nat2Pos.id. reflexivity. omega.
Qed.

Lemma remove_other : forall x y n s, ~E.eq y x -> multiplicity y (remove x n s) = multiplicity y s.
Proof.
intros x y n s Hyx. unfold remove. destruct (eq_nat_dec n 0); trivial.
assert (Hxy : ~E.eq x y) by (intro; now apply Hyx).
destruct (le_lt_dec (multiplicity x s) n) as [Hle | Hlt]; unfold multiplicity at 1; simpl.
- now rewrite M.remove_spec2.
- now rewrite M.add_spec2.
Qed.

Lemma singleton_same : forall x n, multiplicity x (singleton x n) = n.
Proof.
intros x n. unfold singleton, add. destruct (eq_nat_dec n 0).
+ subst n. apply empty_spec.
+ rewrite empty_spec. simpl. unfold multiplicity. rewrite M.add_spec1. now apply Nat2Pos.id.
Qed.

Lemma singleton_other : forall x y n, ~E.eq y x -> multiplicity y (singleton x n) = 0.
Proof.
intros x y n Heq. unfold singleton, add. destruct (eq_nat_dec n 0).
+ subst n. apply empty_spec.
+ rewrite empty_spec. simpl. unfold multiplicity. rewrite M.add_spec2, M.empty_spec; trivial. intro; now apply Heq.
Qed.

Lemma fold_add_out_list : forall f x n l s, ~InA (@M.eq_key positive) (x, n) l -> NoDupA (@M.eq_key _) l ->
  multiplicity x (fold_left (fun acc xn => add (fst xn) (f (fst xn) (snd xn)) acc) l s) = multiplicity x s.
Proof.
intros f x n l s Hin Hdup. revert s. induction l as [| [y m] l]; intro s; simpl.
- reflexivity.
- rewrite IHl. apply add_other. intro Habs. apply Hin. left. compute. auto. auto. now inversion_clear Hdup.
Qed.

Lemma fold_add_out : forall f x (s s' : t), ~M.In x s ->
  multiplicity x (M.fold (fun x n acc => add x (f x n) acc) s s') = multiplicity x s'.
Proof.
intros f x s s' Hin. rewrite M.fold_spec.
assert (Hs : forall n, ~(InA (@M.eq_key_elt _) (x, n) (M.bindings s))).
{ intros n Habs. apply Hin. exists n. now rewrite <- M.bindings_spec1. }
revert s'. induction (M.bindings s) as [| [y m] l]; intro s'; simpl.
+ reflexivity.
+ assert ( Hxy : ~E.eq x y). { intro Habs. apply (Hs m). left. now split. }
  rewrite IHl.
  - apply add_other. now auto.
  - intros n Habs. apply (Hs n). now right.
Qed.

Notation compatb := (Proper (E.eq ==> Logic.eq ==> Logic.eq)) (only parsing).

Lemma fold_add : forall f x (s s' : t), compatb f -> M.In x s ->
  multiplicity x (M.fold (fun x n acc => add x (f x (Pos.to_nat n)) acc) s s')
  = f x (multiplicity x s) + multiplicity x s'.
Proof.
intros f x s s' Hf [n Hin]. rewrite M.fold_spec.
assert (Hs : InA (@M.eq_key_elt positive) (x, n) (M.bindings s)) by now rewrite M.bindings_spec1.
assert (Hdup := M.bindings_spec2w s).
revert s'. induction (M.bindings s) as [| [y m] l]; intro s'; simpl; [now inversion Hs |].
destruct (Meq_dec (x, n) (y, m)) as [[H1 H2] | Hneq]; simpl in *; try subst m.
* transitivity (multiplicity x (add y (f y (Pos.to_nat n)) s')).
  + rewrite (fold_add_out_list (fun x y => f x (Pos.to_nat y)) x n).
    - reflexivity.
    - inversion_clear Hdup. clear -H H1. intro Habs. apply H. revert Habs. apply InA_eqA; trivial. refine _.
    - now inversion_clear Hdup.
  + rewrite H1, add_same, plus_comm. f_equal. unfold multiplicity.
    rewrite H1, <- M.find_spec in Hin. now rewrite Hin.
* rewrite IHl.
  + f_equal. apply add_other. intro Habs. apply Hneq. compute. split. now auto.
    apply (NoDup_pair_In _ x y n m ((y, m) :: l)); trivial. left. compute. now auto.
  + inversion_clear Hs. contradiction. assumption.
  + now inversion_clear Hdup.
Qed.

Lemma union_spec : forall x s s', multiplicity x (union s s') = multiplicity x s + multiplicity x s'.
Proof.
intros x s s'. unfold union. destruct (M.find x s) eqn:Hin.
- apply (fold_add (fun x n => n)). now intros until 2. exists p. now rewrite <- M.find_spec.
- unfold multiplicity at 2. rewrite Hin. simpl. apply fold_add_out.
  intros [n Habs]. now rewrite <- M.find_spec, Hin in Habs.
Qed.

Lemma inter_spec : forall x s s', multiplicity x (inter s s') = min (multiplicity x s) (multiplicity x s').
Proof.
intros x s s'. unfold inter. destruct (M.find x s') eqn:Hin.
+ rewrite (fold_add (fun x n => min (multiplicity x s) n) x s' empty).
  - rewrite (empty_spec x). now rewrite plus_0_r.
  - intros ? ? Heq ? ? ?. simpl. subst. now rewrite Heq.
  - exists p. now rewrite <- M.find_spec.
+ rewrite fold_add_out.
  - unfold multiplicity at 3. rewrite Hin. rewrite Min.min_0_r. now apply empty_spec.
  - intros [n Habs]. now rewrite <- M.find_spec, Hin in Habs.
Qed.

Lemma diff_spec : forall x s s', multiplicity x (diff s s') = multiplicity x s - multiplicity x s'.
Proof.
intros x s s'. unfold diff. destruct (M.find x s) eqn:Hin.
+ rewrite (fold_add (fun x n => n - multiplicity x s') x s empty).
  - rewrite empty_spec. now rewrite plus_0_r.
  - intros ? ? Heq ? ? ?. subst. now rewrite Heq.
  - exists p. now rewrite <- M.find_spec.
+ rewrite fold_add_out.
  - unfold multiplicity at 2. rewrite Hin. simpl. now apply empty_spec.
  - intros [n Habs]. now rewrite <- M.find_spec, Hin in Habs.
Qed.

Lemma lub_spec : forall x s s', multiplicity x (lub s s') = max (multiplicity x s) (multiplicity x s').
Proof.
Proof.
intros x s s'. unfold lub.
replace (max (multiplicity x s) (multiplicity x s'))
  with (multiplicity x s - multiplicity x s'  + multiplicity x s') by (apply Max.max_case_strong; omega).
destruct (M.find x s) eqn:Hin.
+ apply (fold_add (fun x n => n - multiplicity x s')).
  - intros ? ? Heq ? ? ?. subst. now rewrite Heq.
  - exists p. now rewrite <- M.find_spec.
+ rewrite fold_add_out.
  - unfold multiplicity at 2. rewrite Hin. simpl. reflexivity.
  - intros [n Habs]. now rewrite <- M.find_spec, Hin in Habs.
Qed.

Lemma subset_spec : forall s s', subset s s' = true <-> s [c=] s'.
Proof.
intros s s'. split; intro Hle.
- intro x. apply (is_empty_multiplicity x) in Hle. rewrite diff_spec in Hle. omega.
- unfold subset. rewrite is_empty_spec. intro x. unfold In. rewrite diff_spec.
  specialize (Hle x). rewrite empty_spec. omega.
Qed.

Lemma fold_spec : forall (A : Type) s (i : A) (f : elt -> nat -> A -> A),
    fold f s i = fold_left (fun acc xn => f (fst xn) (snd xn) acc) (elements s) i.
Proof. intros A i f s. unfold fold, elements. now rewrite M.fold_spec, fold_left_map. Qed.

Lemma cardinal_spec : forall s, cardinal s = fold (fun x n acc => n + acc) s 0.
Proof. intro. unfold cardinal. rewrite fold_spec. unfold elements. now rewrite fold_left_map, M.fold_spec. Qed.

Lemma size_spec : forall s, size s = length (support s).
Proof.
intro. unfold size, support. now rewrite M.fold_spec, fold_left_length, M.fold_spec, fold_left_cons_length.
Qed.

Lemma Melements_multiplicity : forall s x n,
  InA (@M.eq_key_elt _) (x, n) (M.bindings s)
  <-> multiplicity x s = Pos.to_nat n /\ Pos.to_nat n > 0.
Proof.
intros s x n. split; intro H.
+ apply M.bindings_spec1, M.find_spec in H. unfold multiplicity.
  rewrite H. split. reflexivity. apply Pos2Nat.is_pos.
+ destruct H as [H1 H2]. unfold multiplicity in H1. destruct (M.find x s) eqn:Hin.
  - rewrite M.bindings_spec1, <- M.find_spec. rewrite Hin. f_equal. now apply Pos2Nat.inj.
  - rewrite  <- H1 in H2. inversion H2.
Qed.

Corollary elements_spec : forall x n s,
  InA eq_pair (x, n) (elements s) <-> multiplicity x s = n /\ n > 0.
Proof.
intros x n s. unfold elements. rewrite InA_map_iff.
split; intro H.
+ destruct H as [[y m] [[Heq1 Heq2] Hin]]. rewrite Melements_multiplicity in Hin.
  hnf in Heq1, Heq2. simpl in *. subst n. now rewrite <- Heq1.
+ exists (x, Pos.of_nat n). destruct H as [H1 H2]. simpl in *. split.
  - split; hnf; simpl. reflexivity. apply Nat2Pos.id. omega.
  - rewrite Melements_multiplicity. simpl. rewrite H1. rewrite Nat2Pos.id. now split. omega.
+ apply Meq_equiv.
+ apply Meq_equiv.
+ clear. intros [] [] []. intros. split; simpl in *. assumption. now subst.
Qed.

Lemma elements_NoDupA : forall s, NoDupA (@M.eq_key _) (elements s).
Proof.
intro s. unfold elements. rewrite NoDupA_inj_map;
apply M.bindings_spec2w || apply Meq_key_equiv || (intros [] [] ?; assumption).
Qed.

Lemma support_elements_aux : forall x l1 l2, NoDupA (@M.eq_key _) (l1 ++ l2) ->
  ((InA E.eq x (fold_left (fun acc xn => fst xn :: acc) l1 (map (@fst _ _) l2)) <->
  exists n, InA eq_pair (x, n) (map (fun xn => (fst xn, Pos.to_nat (snd xn))) (l1 ++ l2)))).
Proof.
intros x l1. induction l1; simpl; intros l2 Hdup.
* split; intro H.
  + induction l2.
    - now inversion H.
    - destruct a as [y m]. inversion_clear H.
        exists (Pos.to_nat m). left. now split.
        apply IHl2 in H0. destruct H0 as [n Hn]. exists n. simpl. now right. now inversion_clear Hdup.
  + destruct H as [n Hn]. induction l2; simpl.
    - now inversion Hn.
    - destruct a as [y m]. inversion_clear Hdup. inversion_clear Hn.
        left. now destruct H1.
        right. now apply IHl2.
* destruct a as [y m]. simpl. split; intro H.
  + destruct (E.eq_dec x y). exists (Pos.to_nat m). left. now split.
    change (y :: map (fst (B:=positive)) l2) with (map (fst (B:=positive)) ((y,m) :: l2)) in H.
    rewrite IHl1 in H.
    - destruct H as [p Hp]. exists p. rewrite map_app in *. rewrite InA_app_iff in Hp.
        simpl in Hp. destruct Hp.
          right. rewrite InA_app_iff. now left.
          inversion_clear H.
             now left.
             right. rewrite InA_app_iff. now right.
    - rewrite NoDupA_swap_iff. assumption. refine _.
  + change (y :: map (fst (B:=positive)) l2) with (map (fst (B:=positive)) ((y,m) :: l2)).
    rewrite IHl1. destruct H as [n Hn]. exists n. rewrite map_app, InA_app_iff. inversion_clear Hn.
    - right. now left.
    - rewrite map_app, InA_app_iff in H. destruct H. now left. now do 2 right.
    - rewrite NoDupA_swap_iff. assumption. now apply Meq_key_equiv.
Qed.

Lemma support_elements : forall x s, InA E.eq x (support s) <-> InA eq_pair (x, multiplicity x s) (elements s).
Proof.
intros x s. unfold support, elements. rewrite M.fold_spec.
change nil with (map (@fst E.t nat) nil).
rewrite (support_elements_aux x (M.bindings s) nil); rewrite app_nil_r; [split; intro H |].
+ destruct H as [n Hn].
  assert (n = multiplicity x s).
  { rewrite (InA_map_iff (Meq_equiv _) eq_pair_equiv) in Hn.
    - destruct Hn as [[y m] [[Heqx Heqn] Hin]]. rewrite Melements_multiplicity in Hin.
      hnf in *. simpl in *. subst. symmetry. destruct Hin. rewrite <- Heqx. assumption.
    - intros [? ?] [? ?] Heq; simpl in *. hnf in Heq. destruct Heq; split; hnf; simpl in *; subst; auto. }
  now subst n.
+ now exists (multiplicity x s).
+ apply M.bindings_spec2w.
Qed.

Corollary support_spec : forall x s, InA E.eq x (support s) <-> In x s.
Proof. intros x s. rewrite support_elements. rewrite elements_spec. intuition. Qed.

Lemma support_NoDupA_aux : forall A B (l1 : list (A*B)) l2,
  fold_left (fun acc p => fst p :: acc) l1 l2 = rev (map (@fst _ _) l1) ++ l2.
Proof.
intros A B l1. induction l1; intro l2; simpl.
  reflexivity.
  rewrite IHl1. now rewrite <- app_assoc.
Qed.

Lemma support_NoDupA : forall s, NoDupA E.eq (support s).
Proof.
intro s. unfold support. rewrite M.fold_spec, support_NoDupA_aux, app_nil_r.
apply NoDupA_rev. now auto with typeclass_instances.
rewrite NoDupA_inj_map; (now apply M.bindings_spec2w) || (now auto with typeclass_instances) || (now intros ? ? ?).
Qed.

Lemma fold_nfilter_out_list : forall f x n l s, ~InA (@M.eq_key positive) (x, n) l -> NoDupA (@M.eq_key _) l ->
  multiplicity x (fold_left (fun acc xn => if f (fst xn) (snd xn) : bool
                                           then add (fst xn) (Pos.to_nat (snd xn)) acc else acc) l s)
  = multiplicity x s.
Proof.
intros f x n l s Hin Hdup. revert s. induction l as [| [y m] l]; intro s; simpl.
  reflexivity.
  rewrite IHl.
    destruct (f y m). apply add_other. intro Habs. apply Hin. left. compute. auto. auto.
    intro Habs. apply Hin. now right.
    now inversion_clear Hdup.
Qed.

Lemma nfilter_spec_In : forall f s s' x, compatb f -> In x s ->
  multiplicity x
    (M.fold
       (fun (x0 : M.key) (n : positive) (acc : t) =>
        if f x0 (Pos.to_nat n) : bool then add x0 (Pos.to_nat n) acc else acc) s s')
  = if f x (multiplicity x s) then multiplicity x s + multiplicity x s' else multiplicity x s'.
Proof.
intros f s s' x Hf Hin. rewrite M.fold_spec. revert s'. unfold In in Hin.
assert (Hs : InA (@M.eq_key_elt _) (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA (@M.eq_key _) (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup.
induction (M.bindings s); simpl; intro s'; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m].
  destruct (Meq_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_nfilter_out_list (fun x y => f x (Pos.to_nat y)) _ (Pos.of_nat (multiplicity y s))).
    - rewrite Nat2Pos.id; try omega.
      destruct (f y (multiplicity y s)) eqn:Htest.
        rewrite add_same, H1. now apply plus_comm.
        now rewrite H1.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff.
        exists (y, Pos.of_nat (multiplicity y s)). split. reflexivity. eassumption.
        apply Meq_key_equiv.
        apply Meq_key_equiv.
        clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0.
        eassumption.
        now apply Meq_key_equiv.
        now apply Meq_key_equiv.
        now intros [] [].
        now intros [] [].
  + inversion_clear Hs.
    - elim Hneq. destruct H. split. assumption. simpl in *. now rewrite H0, Pos2Nat.id.
    - inversion_clear Hdup. assert (Hxy : ~E.eq x y).
      { intro Habs. apply H0. now apply (eq_key_elt_eq_key_weak_In _ x y (multiplicity x s)). }
      rewrite IHl; try assumption. simpl.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || rewrite add_other; reflexivity || now auto.
Qed.

Lemma nfilter_spec_out : forall f s s' x, ~In x s ->
  multiplicity x
    (M.fold
       (fun (x0 : M.key) (n : positive) (acc : t) =>
        if f x0 (Pos.to_nat n) : bool then add x0 (Pos.to_nat n) acc else acc) s s')
  = multiplicity x s'.
Proof.
intros f s s' x Hin. rewrite M.fold_spec.
assert (Hs : forall n, ~(InA (@M.eq_key_elt _) (x, n) (M.bindings s))).
{ intros n Habs. apply Hin. rewrite M.bindings_spec1, <- M.find_spec in Habs.
  unfold In, multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (M.bindings s) as [| [y m] l]; intro s'; simpl.
  reflexivity.
  assert ( Hxy : ~E.eq x y). { intro Habs. apply (Hs m). left. now split. }
  rewrite IHl. destruct (f y (Pos.to_nat m)). apply add_other. now auto. reflexivity.
  intros n Habs. apply (Hs n). now right.
Qed.

Corollary nfilter_spec : forall f x s, compatb f ->
    multiplicity x (nfilter f s) = if f x (multiplicity x s) then multiplicity x s else 0.
Proof.
intros f x s Hf. unfold nfilter.
destruct (multiplicity x s) eqn:Hin.
  rewrite nfilter_spec_out.
    now destruct (f x 0); apply empty_spec.
    unfold In. omega.
  rewrite nfilter_spec_In.
    now rewrite empty_spec, Hin, plus_0_r.
    assumption.
    unfold In. rewrite Hin. omega.
Qed.

Theorem filter_nfilter : forall f s, filter f s [=] nfilter (fun x _ => f x) s.
Proof. now unfold filter. Qed.

Corollary filter_spec : forall f x s, Proper (E.eq ==> Logic.eq) f ->
    multiplicity x (filter f s) = if f x then multiplicity x s else 0.
Proof.
intros f x s Hf. rewrite filter_nfilter, nfilter_spec.
- reflexivity.
- repeat intro. now apply Hf.
Qed.

Lemma choose_spec_aux : forall x s o, ~M.In x s ->
  fold_left (fun (_ : option M.key) (p : M.key * positive) => Some (fst p)) (M.bindings s) o = Some x ->
  o = Some x.
Proof.
intros x s o Hs.
assert (Hs' : forall n, ~InA (@M.eq_key_elt _) (x, n) (M.bindings s)).
{ intros n Habs. apply Hs. exists n. now apply M.bindings_spec1. } clear Hs.
revert o. induction (M.bindings s); simpl; intros o Hin.
+ assumption.
+ apply IHl in Hin.
  - elim (Hs' (snd a)). left. split; simpl. now inversion Hin. reflexivity.
  - intros n Habs. apply (Hs' n). now right.
Qed.

Lemma choose_Some : forall x s, choose s = Some x -> In x s.
Proof.
intros x s Hin. destruct (In_dec x s). assumption. unfold choose in Hin.
rewrite M.fold_spec in Hin. apply choose_spec_aux in Hin. now inversion Hin. now rewrite <- In_MIn.
Qed.

Lemma choose_None : forall s, choose s = None <-> s [=] empty.
Proof.
intros s. split; intro Hs.
+ intro x. unfold choose in Hs. rewrite M.fold_spec in Hs. rewrite empty_spec, multiplicity_out.
  destruct (M.find x s) eqn:Habs.
  - rewrite M.find_spec, <- M.bindings_spec1 in Habs. destruct (M.bindings s).
      now inversion Habs.
      clear -Hs. simpl in Hs. revert p0 Hs. induction l. discriminate. intros. simpl in Hs. now apply (IHl _ Hs).
  - reflexivity.
+ destruct (choose s) eqn:H.
  - apply choose_Some in H. rewrite Hs in H. unfold In in H. rewrite empty_spec in H. omega.
  - reflexivity.
Qed.

Lemma fold_and_true_base_step : forall A f (l : list A) b,
  fold_left (fun a x => a && f x) l b = true -> b = true.
Proof.
intros A f l. induction l; simpl; intros b Hl.
- assumption.
- apply IHl in Hl. destruct b. reflexivity. simpl in Hl. discriminate Hl.
Qed.

Lemma fold_and_true_inductive_step : forall A f (l : list A) a b,
  fold_left (fun a x => a && f x) (a :: l) b = true -> f a = true.
Proof.
simpl. intros A f l a b Hl. apply fold_and_true_base_step in Hl.
destruct (f a). reflexivity. destruct b; simpl in Hl; discriminate Hl.
Qed.

Lemma for_all_spec_aux : forall (f : M.key -> nat -> bool) s b, compatb f ->
  (M.fold (fun x n b => b && (f x (Pos.to_nat n))) s b = true
   <-> b = true /\ For_all (fun x n => f x n = true) s).
Proof.
intros f s b Hf. rewrite M.fold_spec. unfold For_all. split; intro H.
+ split. now apply fold_and_true_base_step in H.
  intros x Hin. rewrite In_MIn in Hin. destruct Hin as [n Hin]. apply M.bindings_spec1 in Hin.
  assert (Hn : multiplicity x s = Pos.to_nat n) by now rewrite Melements_multiplicity in Hin.
  revert b H x n Hn Hin. induction (M.bindings s); intros b H x n Hn Hin; inversion_clear Hin.
  - simpl in H. apply fold_and_true_base_step in H. rewrite andb_true_iff in H.
    destruct H as [_ H ], a, H0 as [H1 H2]. simpl in *. rewrite Hn, H1. now subst p.
  - simpl in H. apply (IHl _ H _ _ Hn H0).
+ destruct H as [Hb H]. subst b.
  assert (forall xn, InA (@M.eq_key_elt _) xn (M.bindings s) -> f (fst xn) (Pos.to_nat (snd xn)) = true).
  { intros [x n] Hx. simpl. rewrite Melements_multiplicity in Hx. destruct Hx as [Hm Hp].
    setoid_rewrite <- Pos2Nat.id. rewrite <- Hm. rewrite Nat2Pos.id. apply H. unfold In. now rewrite Hm. omega. }
  clear H. revert H0. induction (M.bindings s); simpl; intro Hin; trivial.
  rewrite Hin. apply IHl. intros x Hx. apply Hin. now right. now left.
Qed.

Corollary for_all_spec : forall f s, compatb f ->
  (for_all f s = true <-> For_all (fun x n => f x n = true) s).
Proof. intros. unfold for_all. rewrite for_all_spec_aux; intuition. Qed.

Lemma exists_spec_aux : forall (f : M.key -> nat -> bool) s b, compatb f ->
  (M.fold (fun x n b => b || (f x (Pos.to_nat n))) s b = true
   <-> b = true \/ Exists (fun x n => f x n = true) s).
Proof.
intros f s b Hf.
assert (Hequiv : Exists (fun x n => f x n = true) s <->
        exists x, exists n, InA (@M.eq_key_elt _) (x, n) (M.bindings s) /\ f x (Pos.to_nat n) = true).
{ split; intros [x Hx].
  destruct Hx as [Hin Hfx]. exists x. exists (Pos.of_nat (multiplicity x s)). split.
    rewrite Melements_multiplicity. unfold In in Hin. simpl. rewrite Nat2Pos.id. now split. omega.
    rewrite Nat2Pos.id. assumption. unfold In in Hin. omega.
  destruct Hx as [n [Hin Hfx]]. exists x. rewrite Melements_multiplicity in Hin. destruct Hin as [Hn Hp]. split.
    simpl in *. unfold In. now rewrite Hn.
    simpl in *. now rewrite Hn. }
rewrite Hequiv. clear Hequiv. rewrite M.fold_spec. unfold For_all. split; intro H.
+ revert b H. induction (M.bindings s); intros b H.
  - simpl in H. now left.
  - simpl in H. apply IHl in H. rewrite orb_true_iff in H. destruct H as [[H | H] | H]; (now left) || right.
      destruct a as [x n]. exists x. exists n. split. now left. assumption.
      destruct H as [x [n [Hin Hfx]]]. exists x. exists n. split. now right. assumption.
+ revert b H. induction (M.bindings s); simpl; intros b H.
  - destruct H. assumption.
    destruct H as [? [? [Habs _]]]. now inversion Habs.
  - apply IHl. rewrite orb_true_iff. destruct H as [H | H].
      now do 2 left.
      destruct H as [x [n [Hin Hfx]]]. inversion_clear Hin.
        left. right. destruct H as [H1 H2]. simpl in H1, H2. now rewrite <- H1, <- H2.
        right. exists x. exists n. now split.
Qed.

Corollary exists_spec : forall f s, compatb f ->
  (exists_ f s = true <-> Exists (fun x n => f x n = true) s).
Proof. intros. unfold exists_. rewrite exists_spec_aux; intuition discriminate. Qed.

Definition npartition_fun f := fun x n acc =>
         if f x (Pos.to_nat n) : bool
         then (add x (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add x (Pos.to_nat n) (snd acc)).

Lemma fold_npartition_fst_out_list : forall f x n l s12,
  ~InA (@M.eq_key positive) (x, n) l -> NoDupA (@M.eq_key _) l ->
  multiplicity x
  (fst
     (fold_left (fun acc xn => if f (fst xn) (Pos.to_nat (snd xn)) : bool
         then (add (fst xn) (Pos.to_nat (snd xn)) (fst acc), snd acc)
         else (fst acc, add (fst xn) (Pos.to_nat (snd xn)) (snd acc))) l s12))
  = multiplicity x (fst s12).
Proof.
intros f x n l s12 Hin Hdup. revert s12. induction l as [| [y m] l]; intros s12; simpl.
  reflexivity.
  rewrite IHl.
    destruct (f y (Pos.to_nat m)); simpl.
      apply add_other. intro Habs. apply Hin. left. compute. auto. auto.
    intro Habs. apply Hin. now right.
    now inversion_clear Hdup.
Qed.

Lemma npartition_spec_fst_In : forall f (s : t) (s12 : t * t) x, compatb f -> In x s ->
  multiplicity x (fst (M.fold (fun x n acc =>
         if f x (Pos.to_nat n) : bool
         then (add x (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add x (Pos.to_nat n) (snd acc))) s s12)) =
  (if f x (multiplicity x s) then multiplicity x s + multiplicity x (fst s12) else multiplicity x (fst s12)).
Proof.
intros f s s' x Hf Hin. rewrite M.fold_spec. revert s'. unfold In in Hin.
assert (Hs : InA (@M.eq_key_elt _) (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA (@M.eq_key _) (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup.
induction (M.bindings s); simpl; intros [s1 s2]; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m].
  destruct (Meq_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_npartition_fst_out_list f _ (Pos.of_nat (multiplicity y s))).
    - unfold npartition_fun. rewrite Nat2Pos.id; try omega.
      destruct (f y (multiplicity y s)) eqn:Htest; simpl.
        rewrite add_same, H1. now apply plus_comm.
        now rewrite H1.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff.
        exists (y, Pos.of_nat (multiplicity y s)). split. reflexivity. eassumption.
        apply Meq_key_equiv.
        apply Meq_key_equiv.
        clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0.
        eassumption.
        now apply Meq_key_equiv.
        now apply Meq_key_equiv.
        now intros [] [].
        now intros [] [].
  + inversion_clear Hs.
    - elim Hneq. destruct H. split. assumption. simpl in *. now rewrite H0, Pos2Nat.id.
    - inversion_clear Hdup. assert (Hxy : ~E.eq x y).
      { intro Habs. apply H0. now apply (eq_key_elt_eq_key_weak_In _ x y (multiplicity x s)). }
      rewrite IHl; try assumption. simpl. unfold npartition_fun.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || simpl; rewrite add_other; reflexivity || now auto.
Qed.

Lemma npartition_spec_fst_out : forall f s s12 x, ~In x s ->
  multiplicity x (fst (M.fold (fun x n acc =>
         if f x (Pos.to_nat n) : bool
         then (add x (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add x (Pos.to_nat n) (snd acc))) s s12)) = multiplicity x (fst s12).
Proof.
intros f s s' x Hin. rewrite M.fold_spec.
assert (Hs : forall n, ~(InA (@M.eq_key_elt _) (x, n) (M.bindings s))).
{ intros n Habs. apply Hin. rewrite M.bindings_spec1, <- M.find_spec in Habs.
  unfold In, multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (M.bindings s) as [| [y m] l]; intro s'; simpl.
  reflexivity.
  assert ( Hxy : ~E.eq x y). { intro Habs. apply (Hs m). left. now split. }
  rewrite IHl. unfold npartition_fun. destruct (f y (Pos.to_nat m)). apply add_other. now auto. reflexivity.
  intros n Habs. apply (Hs n). now right.
Qed.

Corollary npartition_spec_fst : forall f s, compatb f -> fst (npartition f s) [=] nfilter f s.
Proof.
intros f s Hf x. unfold npartition. rewrite nfilter_spec; trivial.
destruct (multiplicity x s) eqn:Hin.
  rewrite npartition_spec_fst_out.
    now destruct (f x 0); apply empty_spec.
    unfold In. omega.
  rewrite npartition_spec_fst_In.
    now rewrite empty_spec, Hin, plus_0_r.
    assumption.
    unfold In. rewrite Hin. omega.
Qed.

Lemma fold_npartition_snd_out_list : forall f x n l s12,
  ~InA (@M.eq_key positive) (x, n) l -> NoDupA (@M.eq_key _) l ->
  multiplicity x
  (snd
     (fold_left
        (fun acc xn =>
         if f (fst xn) (Pos.to_nat (snd xn)) : bool
         then (add (fst xn) (Pos.to_nat (snd xn)) (fst acc), snd acc)
         else (fst acc, add (fst xn) (Pos.to_nat (snd xn)) (snd acc))) l s12))
  = multiplicity x (snd s12).
Proof.
intros f x n l s12 Hin Hdup. revert s12. induction l as [| [y m] l]; intros s12; simpl.
  reflexivity.
  rewrite IHl.
    destruct (f y (Pos.to_nat m)). reflexivity. simpl. apply add_other. intro Habs. apply Hin. left. compute. auto.
    intro Habs. apply Hin. now right.
    now inversion_clear Hdup.
Qed.

Lemma npartition_spec_snd_In : forall f (s : t) (s12 : t * t) x, compatb f -> In x s ->
  multiplicity x
  (snd
     (M.fold
        (fun y n acc =>
         if f y (Pos.to_nat n) : bool
         then (add y (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add y (Pos.to_nat n) (snd acc))) s s12)) =
  (if f x (multiplicity x s) then multiplicity x (snd s12) else multiplicity x s + multiplicity x (snd s12)).
Proof.
intros f s s' x Hf Hin. rewrite M.fold_spec. revert s'. unfold In in Hin.
assert (Hs : InA (@M.eq_key_elt _) (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA (@M.eq_key _) (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup.
induction (M.bindings s); simpl; intros [s1 s2]; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m].
  destruct (Meq_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_npartition_snd_out_list f _ (Pos.of_nat (multiplicity y s))).
    - rewrite Nat2Pos.id; try omega.
      destruct (f y (multiplicity y s)) eqn:Htest; simpl.
        now rewrite H1.
        rewrite add_same, H1. now apply plus_comm.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff.
        exists (y, Pos.of_nat (multiplicity y s)). split. reflexivity. eassumption.
        apply Meq_key_equiv.
        apply Meq_key_equiv.
        clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0.
        eassumption.
        now apply Meq_key_equiv.
        now apply Meq_key_equiv.
        now intros [] [].
        now intros [] [].
  + inversion_clear Hs.
    - elim Hneq. destruct H. split. assumption. simpl in *. now rewrite H0, Pos2Nat.id.
    - inversion_clear Hdup. assert (Hxy : ~E.eq x y).
      { intro Habs. apply H0. now apply (eq_key_elt_eq_key_weak_In _ x y (multiplicity x s)). }
      rewrite IHl; try assumption. simpl.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || simpl; rewrite add_other; reflexivity || now auto.
Qed.

Lemma npartition_spec_snd_out : forall f s s12 x, ~In x s ->
  multiplicity x
  (snd
     (M.fold
        (fun y n acc =>
         if f y (Pos.to_nat n) : bool
         then (add y (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add y (Pos.to_nat n) (snd acc))) s s12)) =
  multiplicity x (snd s12).
Proof.
intros f s s' x Hin. rewrite M.fold_spec.
assert (Hs : forall n, ~(InA (@M.eq_key_elt _) (x, n) (M.bindings s))).
{ intros n Habs. apply Hin. rewrite M.bindings_spec1, <- M.find_spec in Habs.
  unfold In, multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (M.bindings s) as [| [y m] l]; intro s'; simpl.
  reflexivity.
  assert ( Hxy : ~E.eq x y). { intro Habs. apply (Hs m). left. now split. }
  rewrite IHl. destruct (f y (Pos.to_nat m)); simpl. reflexivity. apply add_other. now auto.
  intros n Habs. apply (Hs n). now right.
Qed.

Corollary npartition_spec_snd : forall f s, compatb f -> snd (npartition f s) [=] nfilter (fun x n => negb (f x n)) s.
Proof.
intros f s Hf x. unfold npartition. rewrite nfilter_spec.
destruct (multiplicity x s) eqn:Hin.
  rewrite npartition_spec_snd_out.
    now destruct (f x 0); apply empty_spec.
    unfold In. omega.
  rewrite npartition_spec_snd_In.
    rewrite empty_spec, Hin, plus_0_r. now destruct (f x (S n)).
    assumption.
    unfold In. rewrite Hin. omega.
    intros ? ? Heq ? ? ?. subst. now rewrite Heq.
Qed.

Theorem partition_npartition_fst : forall f s, fst (partition f s) [=] fst (npartition (fun x _ => f x) s).
Proof. now unfold partition. Qed.

Theorem partition_npartition_snd : forall f s, snd (partition f s) [=] snd (npartition (fun x _ => f x) s).
Proof. now unfold partition. Qed.

Corollary partition_spec_fst : forall f s, Proper (E.eq ==> Logic.eq) f -> fst (partition f s) [=] filter f s.
Proof.
intros f s Hf. rewrite partition_npartition_fst, npartition_spec_fst.
- reflexivity.
- repeat intro. now apply Hf.
Qed.

Corollary partition_spec_snd : forall f s, Proper (E.eq ==> Logic.eq) f ->
  snd (partition f s) [=] filter (fun x => negb (f x)) s.
Proof.
intros f s Hf. rewrite partition_npartition_snd, npartition_spec_snd.
- reflexivity.
- repeat intro. now apply Hf.
Qed.

Instance fold_compat A (eqA : A -> A -> Prop) `{Equivalence A eqA} : forall f,
  Proper (E.eq ==> Logic.eq ==> eqA ==> eqA) f -> transpose2 eqA f ->
  Proper (eq ==> eqA ==> eqA) (fold f).
Proof.
intros f Hf Hfcomm s1 s2 Hs x y Hxy. unfold fold. do 2 rewrite M.fold_spec.
rewrite fold_left_symmetry_PermutationA.
+ reflexivity.
+ now apply Meq_equiv.
+ assumption.
+ repeat intro. now apply Hf; rewrite H1 || rewrite H0.
+ intros. apply Hfcomm.
+ apply NoDupA_equivlistA_PermutationA.
  - now apply Meq_equiv.
  - eapply NoDupA_strengthen; try apply M.bindings_spec2w. now intros [? ?] [? ?] [? ?].
  - eapply NoDupA_strengthen; try apply M.bindings_spec2w. now intros [? ?] [? ?] [? ?].
  - clear -Hs. intros [x n]. do 2 rewrite Melements_multiplicity. now rewrite Hs.
+ assumption.
Qed.

End FMultisets.


Set Implicit Arguments.

Require Import Setoid.
Require Import util.
Require vec.
Require List.
Require Vector.

Section contents.

  Variable T: Set.

  Inductive L: Set := one: T -> L | cons: T -> L -> L.

  Fixpoint to_plain (l: L): List.list T :=
    match l with one x => List.cons x List.nil | cons x y => List.cons x (to_plain y) end.

  Coercion to_plain: L >-> List.list.

  Fixpoint from_plain (x: T) (l: List.list T): L:=
    match l with
    | List.nil => one x
    | List.cons h t => cons x (from_plain h t)
    end.

  Lemma round_trip l x: (to_plain (from_plain x l)) = List.cons x l.
  Proof with auto.
    revert l x.
    induction l... simpl. rewrite IHl...
  Qed.

  Fixpoint app (a b: L) {struct a}: L :=
    match a with
    | one x => cons x b
    | cons x y => cons x (app y b)
    end.

  Variable l: L.

  Definition head := match l with one x => x | cons x _ => x end.
  Definition tail := match l with one _ => List.nil | cons _ x => to_plain x end.

  Lemma head_in_self: List.In head l.
  Proof with auto. unfold head. destruct l; left... Qed.

  Lemma In_sound x: List.In x l -> (head = x \/ List.In x tail).
  Proof with auto. unfold head. unfold tail. destruct l... Qed.

  Lemma In_cons_head (x: T) y: List.In x (cons x y). left; reflexivity. Qed.
  Lemma In_one (x: T): List.In x (one x). left; reflexivity. Qed.

  Lemma coerced_cons_eq (h: T): List.cons h l = cons h l.
  Proof. auto. Qed.

End contents.

Definition map (A B: Set) (f: A -> B): L A -> L B :=
  fix r (l: L A): L B :=
    match l with
    | one x => one (f x)
    | cons h t => cons (f h) (r t)
    end.

Lemma plain_map (A B: Set) (f: A -> B) (l: L A): to_plain (map f l) = List.map f (to_plain l).
Proof with auto.
  induction l...
  simpl.
  rewrite IHl...
Qed.

Add Parametric Morphism (A B: Set): (@map A B)
  with signature (@ext_eq A B) ==> (@ext_eq (L A) (L B))
  as ne_list_map_ext_eq_morph.
Proof with try reflexivity.
  unfold ext_eq.
  intros.
  induction x0; simpl; rewrite H...
  rewrite IHx0...
Qed.

Lemma map_ext (T U: Set) (f g: T -> U): ext_eq f g -> forall l, map f l = map g l.
Proof.
  intros e.
  fold (ext_eq (map f) (map g)).
  rewrite e.
  reflexivity.
Qed.

Lemma In_map_inv (T U: Set) (f: T -> U) (l: L T) (y: U): List.In y (map f l) -> exists x, f x = y /\ List.In x l.
Proof. induction l; simpl; intros; destruct H; firstorder. Qed.

Lemma length_ne_0 (A: Set) (l: L A): List.length l <> 0.
Proof with auto with arith. destruct l; simpl... Qed.

Lemma map_length (A B: Set) (f: A -> B) (l: L A): List.length (map f l) = List.length l.
Proof with auto. induction l... simpl. rewrite IHl... Qed.

Lemma map_map (A B C: Set) (g: A -> B) (f: B -> C) (l: L A):
  map f (map g l) = map (f ∘ g) l.
Proof with auto. induction l... simpl. rewrite IHl... Qed.

Lemma In_round_tripped_head (T: Set) (x: T) l: List.In x (from_plain x l).
Proof with auto. intros. rewrite round_trip. left... Qed.

Hint Immediate In_one.
Hint Immediate In_cons_head.
Hint Immediate head_in_self.
Hint Immediate In_round_tripped_head.

Fixpoint from_vec (A: Set) n: Vector.t A (S n) -> L A :=
  match n return Vector.t A (S n) -> L A with
  | 0 => fun v => one (vec.head v)
  | _ => fun v => cons (vec.head v) (from_vec (vec.tail v))
  end.

Lemma from_vec_to_plain (A: Set) n (v: Vector.t A (S n)): to_plain (from_vec v) = vec.to_list v.
Proof with reflexivity.
  induction n; intros.
    rewrite (vec.eq_cons v).
    simpl.
    rewrite (vec.eq_nil (vec.tail v))...
  rewrite (vec.eq_cons v).
  simpl.
  rewrite IHn...
Qed.


(** STG in COQ by Maciej Piróg, University of Wrocław, 2010 *)

(** This library contains definitions, operations and properties
of substitutions and environments.

Environment is an association list of type [(nat * var)]. In all of the
semantic predicates we substitute only variables (hence [var] as
the second element of the product) for bound variables (represented as
[Indices], thus the type [nat] for keys).

Substitution is a function of type [var -> var]. The environment can be
transformed into substitution using the [subst_var] function.
The substitution is then performed over a term, using the [Lang.map_expr]
function (see the definition of [subst]). *)

Require Export Lang.

(** * Environments *)

Definition env : Set := list (nat * var).

Definition prod_nat_var_dec : forall (p s : nat * var),
  {p = s} + {p <> s}.
Proof.
intros.
repeat decide equality.
Qed.

(** * Assoc lists *)

Fixpoint find_assoc (nas : env) (m : nat) {struct nas} :
  option var :=
match nas with
| (n, a) :: s => if eq_nat_dec m n
    then Some a
    else find_assoc s m
| nil => None
end.

Definition assoc_keys (xs : env) : list nat :=
map (fst (A := nat) (B := var)) xs.

Theorem find_assoc_garbage :
forall (xs ys : env) (a : var) (n n0 : nat), n <> n0 ->
  find_assoc (xs ++ (n, a) :: ys) n0 = find_assoc (xs ++ ys) n0.
Proof with isa.
intros.
induction xs...
destruct eq_nat_dec...
destruct H...
destruct a0.
destruct eq_nat_dec...
Qed.

Theorem find_assoc_in :
forall (nas : env) (n : nat) (a : var),
  find_assoc nas n = Some a -> In (n, a) nas.
Proof with isa.
intros; induction nas...
discriminate.
destruct a0.
destruct eq_nat_dec; subst...
inversion H; subst...
Qed.

Theorem assoc_keys_ex_value :
forall (xs : env) (n : nat),
  In n (assoc_keys xs) -> exists a : var, In (n, a) xs.
Proof with isa.
intros.
induction xs...
contradiction.
inversion_clear H.
exists (snd a).
left; destruct a; simpl in *; subst; auto.
case IHxs; auto; intros; exists x; auto.
Qed.

Theorem assoc_value_ex_key :
forall (xs : env) (n : nat) (a : var),
  In (n, a) xs -> In n (assoc_keys xs).
Proof with isa.
intros.
induction xs...
inversion H; isa.
rewrite H0...
Qed.

Theorem assoc_keys_perm :
forall (xs ys : env), Permutation xs ys ->
  Permutation (assoc_keys xs) (assoc_keys ys).
Proof.
apply Permutation_map.
Qed.

Theorem assoc_keys_perm_in :
forall (xs ys : env) (n : nat), Permutation xs ys ->
  In n (assoc_keys xs) -> In n (assoc_keys ys).
Proof.
intros.
eapply Permutation_map in H.
eapply Permutation_in; [ apply H | auto ].
Qed.

Theorem find_assoc_notin :
forall (xs : env) (n : nat),
  ~ In n (assoc_keys xs) -> find_assoc xs n = None.
Proof with isa.
intros.
induction xs...
destruct a.
destruct eq_nat_dec; subst.
destruct H; left; auto.
case (In_dec eq_nat_dec n (assoc_keys xs)); isa.
Qed.

Lemma find_assoc_in_keys_ex_value :
forall (nas : env) (n : nat),
  In n (assoc_keys nas) ->
  exists s, find_assoc nas n = Some s.
Proof with isa.
intros.
induction nas; isa; try contradiction.
destruct (eq_nat_dec (fst a) n).
(* eq *)
destruct a.
exists v.
destruct eq_nat_dec...
subst; destruct n1...
(* neq *)
destruct H.
  (* left *)
destruct n0...
  (* right *)
destruct a.
destruct eq_nat_dec...
exists v...
Qed.

Lemma assoc_keys_app_distr :
forall mu nu,
  assoc_keys (mu ++ nu) = assoc_keys mu ++ assoc_keys nu.
Proof with isa.
intros.
induction mu...
f_equal...
Qed.

(** * Creating assoc list from list of vars *)

(** The [zip_var_list] function takes a list of variables and a number,
and makes an environment with keys descending, starting from the
predecessor of that number, for example:

[zip_var_list 6 [Index 2, Atom 5, Index 7] = [(5, Index 2),
(4, Atom 5), (3, Index 7)]]
*)

Fixpoint zip_var_list (n : nat) (ats : list var) {struct ats}
  : (env) :=
match ats with
| a :: ts => (n - 1, a) :: zip_var_list (n - 1) ts
| nil => nil
end.

Theorem zip_var_list_length_plus_n_gt :
forall (ats : list var) (n m : nat),
  In m (assoc_keys (zip_var_list (length ats + n) ats)) ->
  m < (length ats + n).
Proof with isa.
intros.
induction ats...
contradiction.
destruct H.
omega.
assert (m < length ats + n).
  apply IHats.
  rewrite arith_m_minus_O_EQ_m in H.
  auto.
omega.
Qed.

Theorem zip_var_list_gt :
forall (ats : list var) (n m : nat), n >= length ats ->
  In m (assoc_keys (zip_var_list n ats)) -> m < n.
Proof with isa.
intros.
assert (H1 : exists n0, n = length ats + n0).
  exists (n - length ats).
  omega.
case H1...
rewrite H2 in H0 |- *.
apply zip_var_list_length_plus_n_gt; isa.
Qed.

Theorem zip_var_list_domain :
forall (ats : list var) (n m : nat), m < n -> m >= n - length ats ->
  In m (assoc_keys (zip_var_list n ats)).
Proof with isa.
intros.
assert (exists n0, exists n1, n = n0 + length ats - n1).
  apply arith_n_depends_on_m.
case H1; isa.
case H2; isa.
rewrite H3 in *.
clear H3 n.
induction ats...
omega.
case (eq_nat_dec (x + S (length ats) - x0 - 1) m); isa.
right.
assert (arith : x + S (length ats) - x0 - 1 = x + length ats - x0).
  apply arith_another_S_minus_1.
rewrite arith in *.
apply IHats.
simpl_arith.
clear H1 H2 IHats arith.
omega.
simpl_arith.
omega.
exists x; exists x0; auto.
exists x0; auto.
Qed.

Theorem zip_var_list_domain2 :
forall (ats : list var) (n m : nat),
  In m (assoc_keys (zip_var_list n ats)) ->
  m <= (n - 1) /\ m >= n - length ats.
Proof with isa.
intros.
assert (exists n0, exists n1, n = n0 + length ats - n1).
  apply arith_n_depends_on_m.
case H0; isa.
case H1; isa.
clear H0; clear H1.
subst.
induction ats; isa; simpl_arith; intuition.
Qed.

Lemma In_zip_var_list:
forall a pm n m,
  In (n, a) (zip_var_list m pm) -> In a pm.
Proof with isa.
induction pm...
destruct (eq_var_dec a0 a)...
right.
destruct H.
inversion H; subst.
destruct n0...
apply IHpm with (m := m - 1) (n := n)...
Qed.

(** * Substituting for variables *)

(** The function [subst_var] maps an environment over a variable.
If the variable is an atom or is not in the domain of the environment,
the function leaves the variable untouched. *)

Definition subst_var (nas : env) (v : var) : var :=
match v with
| Index k =>
  match find_assoc nas k with
  | Some a => a
  | None => v
  end
| Atom a => v
end.

Lemma subst_var_atom :
forall f a, subst_var f (Atom a) = Atom a.
Proof.
intros.
unfold subst_var.
trivial.
Qed.

(** * Shifting, trimming and other operations on environments *)

(** The [shift] operation adds an offset to the domain of
an environment, for example:
[[

shift 3 [(1, Index 3), (7, Index 4)] = [(4, Index 3), (10, Index 4)]
]] *)

Definition shift_assoc (offset : nat) (na : nat * var) : nat * var :=
match na with
| (n, a) => (n + offset, a)
end.

Definition shift (offset : nat) (xs : env) : env :=
map (shift_assoc offset) xs.

(** The [env_find] function finds a value for a key (a variable) in
an environment. If the key is an atom, the function fails. *)

Definition env_find (e : env) (v : var) : option var :=
match v with
| Atom _ => None
| Index n => find_assoc e n
end.

(** The [trim] operation trims the domain of an environment to a
specified list of variables (atoms on the list are obviously ignored).
[[

]] *)

Definition trim (nas : env) (vs : vars) : env :=
filter (fun (x : nat * var) =>
  match x with
  | (n, a) => if In_dec eq_var_dec (Index n) vs then true else false
  end) nas.

(** [env_map] maps an environment over a list of variables.
The function fails if there is a variable on the list which is an atom or
is not in the domain of the environment.
[[

env_map [(1, Index 3), (7, Index 4), (5, Atom 4)] [Index 1, Index 5] = [Index 3, Atom 4]
env_map [(1, Index 3), (7, Index 4), (5, Atom 4)] [Atom 1, Index 5] = None
env_map [(1, Index 3), (7, Index 4), (5, Atom 4)] [Index 2, Index 5] = None
]] *)

Fixpoint env_map (e : env) (vs : vars) {struct vs} : option vars :=
match vs with
| nil => Some nil
| (Index m) :: ms =>
  match env_map e ms with
  | None => None
  | Some ks =>
    match find_assoc e m with
    | None => None
    | Some v => Some (v :: ks)
    end
  end
| (Atom _) :: _ => None
end.

Lemma subst_var_env_find :
forall x beta a,
  no_atoms_var x ->
  Atom a = subst_var beta x ->
  env_find beta x = Some (Atom a).
Proof with isa.
isa.
unfold env_find.
unfold subst_var in H0.
destruct x; [ | inversion H ].
destruct find_assoc.
subst...
discriminate.
Qed.

Lemma env_find_subst_var :
forall sigma x p,
  env_find sigma x = Some (Atom p) ->
  subst_var sigma x = Atom p.
Proof.
intros.
unfold subst_var.
unfold env_find in *.
destruct x.
rewrite H.
trivial.
discriminate.
Qed.

Lemma env_map_map_subst :
forall (beta : env) (xs : vars),
  no_atoms_vars xs ->
  closed_by_vars (assoc_keys beta) 0 xs ->
  env_map beta xs = Some (map (subst_var beta) xs).
Proof with isa.
induction xs...
destruct a...
(* Index *)
rewrite IHxs...
  (* thesis *)
inversion H0.
assert (In (Index n) (Index n :: xs)); auto with *.
apply H1 in H2.
inversion_clear H2.
  (* case 1 *)
apply find_assoc_in_keys_ex_value in H3.
destruct H3.
rewrite <- plus_n_O.
rewrite H2...
  (* case 2 *)
inversion H3.
(* premises of IHxs *)
    (* no_atoms_vars *)
constructor...
inversion_clear H.
apply H2...
    (* closed_by_vars *)
constructor...
inversion_clear H0.
apply H2...
(* Atom *)
inversion_clear H.
assert (In (Atom a) (Atom a :: xs)); auto with *.
apply H1 in H.
inversion H.
Qed.

Lemma map_subst_env_map :
forall sigma xm sigma_xm,
  env_map sigma xm = Some sigma_xm ->
  map (subst_var sigma) xm = sigma_xm.
Proof with isa.
induction xm...
inversion H...
destruct sigma_xm.
(* nil *)
destruct a...
destruct env_map...
destruct find_assoc...
inversion H.
discriminate.
discriminate.
discriminate.
(* cons *)
destruct a.
unfold subst_var.
destruct env_map.
destruct find_assoc.
inversion H; subst...
f_equal.
rewrite <- IHxm...
discriminate.
discriminate.
discriminate.
Qed.

Lemma shift_0_v :
forall tau, shift 0 tau = tau.
Proof with isa.
induction tau...
f_equal...
destruct a...
f_equal...
Qed.

Lemma In_shift :
forall m n a tau,
  In (n, a) (shift m tau) -> In (n - m, a) tau.
Proof with auto with arith; isa.
intros.
unfold shift in H.
apply in_map_iff in H.
destruct H.
destruct H.
destruct x.
unfold shift_assoc in H.
inversion H.
subst.
assert (n0 + m - m = n0).
  omega.
rewrite H1...
Qed.

Lemma shift_in :
forall m k x mu,
  In (m, x) mu -> In (m + k, x) (shift k mu).
Proof with isa.
induction mu...
destruct H; subst...
Qed.

Lemma shift_lt_subst_var_id :
forall n m tau,
  n < m ->
  subst_var (shift m tau) (Index n) = Index n.
Proof with isa.
intros.
unfold subst_var.
cutrewrite (find_assoc (shift m tau) n = None)...
induction tau...
destruct a...
destruct eq_nat_dec...
cut (n < n)...
apply n_lt_n_false in H0.
contradiction.
omega.
Qed.

Lemma find_assoc_shift_lt :
forall n m tau,
  n < m ->
  find_assoc (shift m tau) n = None.
Proof with isa.
induction tau...
destruct a...
destruct eq_nat_dec...
rewrite e in H.
assert (m < m).
  omega.
apply n_lt_n_false in H0.
contradiction.
Qed.

Lemma subst_var_app_shift_lt :
forall m n pn tau,
  n < m ->
  subst_var (zip_var_list m pn ++ shift m tau) (Index n) =
  subst_var (zip_var_list m pn) (Index n).
Proof with isa.
intros.
unfold subst_var.
induction (zip_var_list m pn)...
rewrite find_assoc_shift_lt...
destruct a.
destruct eq_nat_dec...
Qed.

Lemma subst_var_app_shift_ge :
forall n pn m tau r,
  m <= n ->
  m >= length pn ->
  r <= m ->
  subst_var (zip_var_list r pn ++ shift m tau) (Index n) =
  subst_var (shift m tau) (Index n).
Proof with isa.
intros.
assert (m = length pn + (m - length pn)).
  omega.
remember (m - length pn) as k.
clear Heqk H0.
revert k H2.
revert r H1.
induction pn...
destruct eq_nat_dec.
(* eq *)
rewrite e in H.
assert (m < m).
  omega.
apply n_lt_n_false in H0.
contradiction.
(* neq *)
apply IHpn with (k := S k); omega.
Qed.

Lemma shift_app_distr :
forall m sigma tau,
  shift m (sigma ++ tau) = shift m sigma ++ shift m tau.
Proof with isa.
induction sigma...
f_equal...
Qed.

Lemma shift_cummulative :
forall m n tau,
  shift m (shift n tau) = shift (m + n) tau.
Proof with isa.
induction tau...
f_equal...
destruct a...
f_equal.
omega.
Qed.

Lemma shift_zip_var_list :
forall m b qs,
  b >= length qs ->
  shift m (zip_var_list b qs) = zip_var_list (b + m) qs.
Proof with isa.
intros.
assert (b = length qs + (b - length qs)).
  omega.
remember (b - length qs) as k.
clear H Heqk.
revert m b k H0.
induction qs...
f_equal.
f_equal.
omega.
cutrewrite (b + m - 1 = (b - 1) + m).
apply IHqs with (k := k); omega...
omega.
Qed.

Lemma find_assoc_shift :
forall n m beta,
  n >= m ->
  find_assoc beta (n - m) = find_assoc (shift m beta) n.
Proof with isa.
intros.
induction beta...
destruct a.
destruct eq_nat_dec...
destruct eq_nat_dec...
subst.
assert (n <> n).
  omega.
case H0; auto.
destruct eq_nat_dec...
subst.
assert (n0 <> n0).
  omega.
case H0; auto.
Qed.

(** * Substitutions *)

Definition subst (xs : env) (e : expr) : expr :=
map_expr (subst_var xs) 0 e.

Notation " e ~ [ xs ] " := (subst xs e) (at level 40).

Definition subst_lf (xs : env) (lf : lambda_form) : lambda_form :=
map_lf (subst_var xs) 0 lf.

Notation " lf ~~ [ xs ] " := (subst_lf xs lf) (at level 40).

(** * Properities of substitutions *)

Lemma atoms_closed_app :
forall p ps, closed_expr 0 (App p ps) -> is_atom p /\ are_atoms ps.
Proof with intuition.
intros.
inversion H; subst.
split; [ clear H3 | clear H2 ].
inversion H2; subst.
inversion H2...
inversion H0.
unfold is_atom...
inversion H3.
unfold are_atoms.
intros.
case H0 with (v := a)...
inversion H2.
unfold is_atom...
Qed.

Lemma closed_rem_args :
forall p ps, closed_expr 0 (App p ps) -> closed_expr 0 (App p nil).
Proof with isa.
intros.
inversion H; subst; constructor...
constructor; isa; try contradiction.
Qed.

Lemma closed_0_args :
forall p ps, closed_expr 0 (App p ps) -> are_atoms ps.
Proof.
isa.
apply atoms_closed_app in H.
intuition.
Qed.

Lemma open_inv_to_closed_var :
forall ats b v,
  are_atoms ats ->
  closed_by_var nil (length ats + b) v ->
  closed_by_var nil b
    (apply_with_offset (subst_var (zip_var_list (length ats) ats)) b v).
Proof with isa.
isa.
destruct v...
(* Case index *)
inversion_clear H0.
  (* env *)
inversion H1.
  (* index *)
destruct le_lt_dec.
    (* b <= n *)
induction ats...
      (* nil *)
assert (b < b).
  omega.
assert (~ b < b).
  omega.
tauto.
      (* cons *)
destruct eq_nat_dec.
        (* eq *)
apply atoms_head in H.
to_atom a.
apply closed_by_var_atom.
        (* neq *)
rewrite arith_m_minus_O_EQ_m in *.
apply atoms_tail in H.
apply IHats...
omega.
    (* n < b *)
apply closed_by_var_index...
(* Case atom *)
apply closed_by_var_atom.
Qed.

Lemma open_inv_to_closed_vars :
forall ats b vs,
  are_atoms ats ->
  closed_by_vars nil (length ats + b) vs ->
  closed_by_vars nil b
    (map (apply_with_offset (subst_var (zip_var_list (length ats) ats))
    b) vs).
Proof with isa.
isa.
constructor...
apply in_map_iff in H1.
destruct H1.
destruct H1.
subst.
apply open_inv_to_closed_var...
inversion_clear H0.
apply H1...
Qed.

Lemma open_inv_to_closed2 :
forall ats b e0,
  are_atoms ats ->
  closed_by_expr nil (length ats + b) e0 ->
  closed_by_expr nil b
    (map_expr (subst_var (zip_var_list (length ats) ats)) b e0).
Proof with isa.
isa.
revert b H0.
induction e0 using expr_ind2 with
    (P1 := fun (lf : lambda_form) => forall b,
      closed_by_lf nil (length ats + b) lf ->
      closed_by_lf nil b
        (map_lf (subst_var (zip_var_list (length ats) ats)) b lf))
    (P2 := fun (al : alt) => forall b,
      closed_by_alt nil (length ats + b) al ->
      closed_by_alt nil b
        (map_alt (subst_var (zip_var_list (length ats) ats)) b al))...
(* Case App *)
inversion_clear H0.
constructor.
apply open_inv_to_closed_var...
apply open_inv_to_closed_vars...
(* Case Constr *)
inversion_clear H0.
constructor.
apply open_inv_to_closed_vars...
(* Case Letrec *)
constructor...
  (* defs *)
rewrite map_length.
apply in_map_iff in H2.
destruct H2.
destruct H2.
rewrite <- H2.
inversion_clear H1.
apply H0...
rewrite plus_assoc.
apply H4...
  (* expr *)
rewrite map_length.
apply IHe0.
inversion_clear H1.
rewrite plus_assoc...
(* Case Case *)
constructor...
  (* expr *)
apply IHe0.
inversion_clear H1...
  (* alts *)
apply in_map_iff in H2.
destruct H2.
destruct H2.
rewrite <- H2.
inversion_clear H1.
apply H0...
(* Case Lf *)
inversion_clear H0.
constructor.
apply IHe0...
rewrite plus_assoc...
(* Case Alt *)
inversion_clear H0.
constructor.
apply IHe0...
rewrite plus_assoc...
Qed.

Lemma split_atom_find_assoc :
forall ats n b,
  b <= n ->
  find_assoc (zip_var_list (length ats) ats) (n - b) =
  find_assoc (zip_var_list (length ats + b) ats) n.
Proof with isa.
isa.
induction ats...
destruct eq_nat_dec...
destruct eq_nat_dec...
assert (K : n = length ats + b).
  omega.
rewrite K in n0.
rewrite arith_m_minus_O_EQ_m in *.
tauto.
rewrite arith_m_minus_O_EQ_m in *.
rewrite arith_m_minus_O_EQ_m in *.
destruct eq_nat_dec...
rewrite e in n0.
assert (K0 : length ats <> length ats).
  omega.
tauto.
Qed.

Lemma split_atom_find_assoc0 :
forall b c n ats,
  b + c <= n ->
  find_assoc (zip_var_list (length ats) ats) (n - (b + c)) =
  find_assoc (zip_var_list (length ats + b) ats) (n - c).
Proof with isa.
isa.
induction ats...
destruct eq_nat_dec...
(* n - (b + c) = length ats *)
destruct eq_nat_dec...
assert (1 = 0).
  omega.
discriminate.
(* n - (b + c) = length ats *)
destruct eq_nat_dec...
assert (1 = 0).
  omega.
discriminate.
rewrite arith_m_minus_O_EQ_m in *.
rewrite arith_m_minus_O_EQ_m in *.
trivial.
Qed.

Lemma split_atom_apply_with_offset :
forall ats b c v,
  are_atoms ats ->
  apply_with_offset (subst_var (zip_var_list (length ats) ats))
    (b + c) v =
  apply_with_offset (subst_var (zip_var_list (length ats + b) ats)) c v.
Proof with isa.
intros.
destruct v...
destruct le_lt_dec...
(* b + c <= n *)
destruct le_lt_dec...
  (* c <= n *)
rewrite split_atom_find_assoc0...
unfold plus_offset.
induction ats; isa; [ auto with * | ]...
apply atoms_cons in H.
destruct a.
destruct H.
inversion H0.
destruct eq_nat_dec...
rewrite arith_m_minus_O_EQ_m in *.
tauto.
  (* n < c *)
induction ats; isa; auto with *...
destruct eq_nat_dec...
rewrite arith_m_minus_O_EQ_m in *.
apply le_lt_trans with (n := b + c) in l0...
assert (c < c).
  omega.
assert (~ c < c).
  omega.
tauto.
rewrite arith_m_minus_O_EQ_m in *.
apply IHats.
apply atoms_cons in H.
tauto.
(* n < b + c *)
destruct le_lt_dec...
induction ats; isa; auto with *...
destruct eq_nat_dec...
rewrite arith_m_minus_O_EQ_m in *.
assert (n = length ats + b - c).
  omega.
rewrite H0 in l0.
assert (length ats + b < b).
  omega.
assert (b < b).
  omega.
assert (~ b < b).
  omega.
tauto.
rewrite arith_m_minus_O_EQ_m in *.
apply IHats.
apply atoms_cons in H.
tauto.
Qed.

Hint Resolve split_atom_apply_with_offset.

Lemma split_atom_map_offset0 :
forall e b c ats,
  are_atoms ats ->
  map_expr (subst_var (zip_var_list (length ats) ats)) (b + c) e =
  map_expr (subst_var (zip_var_list (length ats + b) ats)) c e.
Proof with isa.
induction e using expr_ind2 with
    (P1 := fun (lf : lambda_form) => forall b c ats,
      are_atoms ats ->
      map_lf (subst_var (zip_var_list (length ats) ats)) (b + c) lf =
      map_lf (subst_var (zip_var_list (length ats + b) ats)) c lf)
    (P2 := fun (al : alt) => forall b c ats,
      are_atoms ats ->
      map_alt (subst_var (zip_var_list (length ats) ats)) (b + c) al =
      map_alt (subst_var (zip_var_list (length ats + b) ats)) c al)...
(* Case App *)
f_equal...
apply map_ext...
(* Constr *)
f_equal...
apply map_ext...
(* Letrec *)
f_equal...
apply map_ext_in...
rewrite <- plus_assoc...
rewrite <- plus_assoc...
(* Case Case *)
f_equal...
apply map_ext_in...
(* Lf *)
f_equal.
rewrite <- plus_assoc...
(* Alt *)
f_equal...
rewrite <- plus_assoc...
Qed.

Lemma split_atom_map_offset :
forall e b ats,
  are_atoms ats ->
  map_expr (subst_var (zip_var_list (length ats) ats)) b e =
  e~[zip_var_list (length ats + b) ats].
Proof.
isa.
assert (b = b + 0).
  trivial.
rewrite H0 at 1.
apply split_atom_map_offset0.
trivial.
Qed.

Lemma open_inv_to_closed0 :
forall b ps e pi,
  are_atoms ps ->
  length ps <= b ->
  closed_lf 0 (Lf pi b e) ->
  closed_expr (b - length ps) (e~[zip_var_list b ps]).
Proof with isa.
isa.
inversion_clear H1...
assert (K : exists k, b = length ps + k).
  exists (b - length ps).
  intuition.
destruct K.
rewrite H1 at 2.
rewrite <- split_atom_map_offset...
assert (K : x = b - length ps).
  omega.
rewrite <- K.
rewrite H1 in H2.
apply open_inv_to_closed2...
Qed.

Lemma open_inv_to_closed :
forall ps b pi e,
  are_atoms ps ->
  length ps = b -> closed_lf 0 (Lf pi b e) ->
  closed_expr 0 (e~[zip_var_list b ps]).
Proof.
intros.
assert (R : 0 = b - length ps).
  omega.
rewrite R.
apply open_inv_to_closed0 with (pi := pi); auto.
intuition.
Qed.

Lemma open_inv_to_closed1 :
forall b e ats,
  are_atoms ats ->
  b = length ats ->
  closed_by_expr nil b e -> closed_expr 0 (e~[zip_var_list b ats]).
Proof with auto.
isa.
apply open_inv_to_closed with (pi := Update)...
constructor...
Qed.

Lemma subst_var_nil_id :
subst_var nil = id.
Proof with isa.
apply functional_extensionality...
unfold subst_var...
destruct x...
Qed.

Lemma apply_with_offset_id :
forall n, apply_with_offset id n = id.
Proof with isa.
isa.
apply functional_extensionality.
unfold apply_with_offset...
destruct x...
destruct le_lt_dec...
(* why not simpl? *)
unfold id.
f_equal.
omega.
Qed.

Ltac apply_with_offset_id_map_id :=
  rewrite apply_with_offset_id;
  apply map_id.

Lemma empty_subst :
forall e : expr, e~[nil] = e.
Proof with isa; f_equal; isa.
intro.
assert (H : forall n, map_expr (subst_var nil) n e = e).
induction e using expr_ind2 with
  (P1 := fun (lf : lambda_form) => forall n,
    map_lf (subst_var nil) n lf = lf)
  (P2 := fun (al : alt) => forall n,
    map_alt (subst_var nil) n al = al)...
destruct v...
destruct le_lt_dec...
omega.
rewrite subst_var_nil_id; apply_with_offset_id_map_id.
rewrite subst_var_nil_id; apply_with_offset_id_map_id.
generalize n; clear n.
induction ds...
rewrite arith_a_plus_Sb_EQ_Sa_plus_b.
apply IHds...
generalize n; clear n.
induction als...
apply H.
Qed.

Hint Resolve atoms_closed_app atoms_app closed_rem_args open_inv_to_closed.

Lemma closed_transfer_var :
forall mu n v qk,
  length qk <= n ->
  closed_by_var (assoc_keys mu) n v ->
  closed_by_var
    (assoc_keys (zip_var_list (length qk) qk ++ shift (length qk) mu))
    (n - length qk) v.
Proof with isa.
intros.
inversion H0.
(* case *)
cutrewrite (m + n = m + n - (n - length qk) + (n - length qk));
  try omega.
apply closed_by_var_env.
rewrite assoc_keys_app_distr.
eapply in_app_right.
cutrewrite (m + n - (n - length qk) = m + length qk);
  try omega.
apply assoc_keys_ex_value in H1.
destruct H1.
apply shift_in with (k := length qk) in H1.
eapply assoc_value_ex_key; eauto.
(* case *)
subst.
destruct (le_lt_dec (n - length qk) m).
cutrewrite (m = m - (n - length qk) + (n - length qk));
  try omega.
apply closed_by_var_env...
rewrite assoc_keys_app_distr.
apply in_app_left.
apply zip_var_list_domain; omega.
apply closed_by_var_index...
(* case *)
constructor...
Qed.

Lemma closed_transfer_vars :
forall mu n vs qk,
  length qk <= n ->
  closed_by_vars (assoc_keys mu) n vs ->
  closed_by_vars
    (assoc_keys (zip_var_list (length qk) qk ++ shift (length qk) mu))
    (n - length qk) vs.
Proof with isa.
intros.
inversion H0.
constructor...
apply closed_transfer_var...
Qed.

Lemma closed_transfer :
forall mu n f qk,
  length qk <= n ->
  closed_by_expr (assoc_keys mu) n f ->
  closed_by_expr
    (assoc_keys (zip_var_list (length qk) qk ++ shift (length qk) mu))
    (n - length qk) f.
Proof with isa.
intros.
revert n qk H H0.
induction f using expr_ind2 with
    (P1 := fun (lf : lambda_form) => forall (n : nat) (qk : list var),
      length qk <= n ->
      closed_by_lf (assoc_keys mu) n lf ->
      closed_by_lf
      (assoc_keys (zip_var_list (length qk) qk ++ shift (length qk) mu))
      (n - length qk) lf)
    (P2 := fun (al : alt) => forall (n : nat) (qk : list var),
      length qk <= n ->
      closed_by_alt (assoc_keys mu) n al ->
      closed_by_alt
      (assoc_keys (zip_var_list (length qk) qk ++ shift (length qk) mu))
      (n - length qk) al)...
(* Case App *)
inversion H0; subst.
constructor.
apply closed_transfer_var...
apply closed_transfer_vars...
(* Case Constr *)
inversion H0; subst.
constructor.
apply closed_transfer_vars...
(* Case Let *)
inversion H1; subst.
constructor;
cutrewrite (n - length qk + length ds = n + length ds - length qk);
  try omega...
apply H; try omega...
apply IHf; try omega...
(* Case Case *)
inversion H1; subst.
constructor...
(* Case Lf *)
inversion H0.
constructor...
cutrewrite (n - length qk + b = n + b - length qk);
  try omega...
apply IHf; try omega...
(* Case Alt *)
inversion H0.
constructor...
cutrewrite (n - length qk + b = n + b - length qk);
  try omega...
apply IHf; try omega...
Qed.

(** * [subst_inversion] tactic*)

(** The [subst_inversion] tactic inverts equalities of the form
[e1 = e2 ~ [beta]] to guarantee that [e2] has the same basic form (has the
same outer-most constructor) as [e1]. It also produces assumptions that
the constructor arguments are also substitutions, for example:

[[
H : Case e als = a ~ [beta] |- P a

Coq < subst_inversion H

f0 : expr,
als0 : list alt,
H : Case e als =
    Case (map_expr (subst_var beta) 0 f0)
      (map (map_alt (subst_var beta) 0) als0),
H1 : e = map_expr (subst_var beta) 0 f0,
H2 : als = map (map_alt (subst_var beta) 0) als0
|- P (Case f0 als0)
]]
*)

Lemma subst_inversion_app :
forall e beta p ps,
  App p ps = e~[beta] -> exists x, exists xs, e = App x xs.
Proof with subst; isa.
intros.
destruct e; unfold subst in H; simpl in H; try discriminate.
inversion H...
exists v.
exists v0...
Qed.

Lemma subst_inversion_constr :
forall e beta C pibeta,
  Constr C pibeta = e~[beta] -> exists ps, e = Constr C ps.
Proof with subst; isa.
intros.
destruct e; unfold subst in H; simpl in H; try discriminate.
inversion H...
exists v...
Qed.

Lemma subst_inversion_let :
forall e f lfs beta,
  Letrec lfs f = e~[beta] -> exists lfs0, exists f0, e = Letrec lfs0 f0.
Proof with subst; isa.
intros.
destruct e; unfold subst in H; simpl in H; try discriminate.
inversion H...
exists l.
exists e...
Qed.

Lemma subst_inversion_case :
forall e f als beta,
  Case f als = e~[beta] -> exists f0, exists als0, e = Case f0 als0.
Proof.
intros.
destruct e; unfold subst in H; simpl in H; try discriminate.
exists e.
exists l.
trivial.
Qed.

Ltac subst_inversion_constr_tac H :=
  let R := fresh H in
  set (R := H);
  apply subst_inversion_constr in R;
  case R;
  let vs := fresh "vs" in intro vs;
  clear R;
  let h := fresh H in intro h;
  subst.

Ltac subst_inversion_app_tac H :=
  let R := fresh H in
  set (R := H);
  apply subst_inversion_app in R;
  case R;
  let x := fresh "x" in intro x;
  let exs := fresh "exs" in intro exs;
  case exs;
  let xs := fresh "xs" in intro xs;
  clear exs;
  clear R;
  let h := fresh "alala" in intro h;
  subst;
  unfold subst in H;
  simpl in H;
  simpl in H;
  rewrite apply_with_offset_0_v in H;
  rewrite apply_with_offset_0_id in H;
  inversion H.

Ltac subst_inversion_let_tac EQe :=
  let R := fresh EQe in
  set (R := EQe);
  apply subst_inversion_let in R;
  case R;
  let lfs := fresh "lfs" in intro lfs;
  let ex := fresh "ex" in intro ex;
  case ex; clear ex;
  let e := fresh "e" in intro e;
  clear R;
  let h := fresh "eq" in intro h;
  subst;
  unfold subst in EQe;
  simpl in EQe;
  inversion EQe.

Ltac subst_inversion_case_tac EQe :=
  let R := fresh EQe in
  set (R := EQe);
  apply subst_inversion_case in R;
  case R;
  let e := fresh "f" in intro e;
  let ex := fresh "ex" in intro ex;
  case ex; clear ex;
  let als := fresh "als" in intro als;
  clear R;
  let h := fresh "eq" in intro h;
  subst;
  unfold subst in EQe;
  simpl in EQe;
  inversion EQe.

Ltac subst_inversion H :=
  first
  [ subst_inversion_constr_tac H
  | subst_inversion_app_tac H
  | subst_inversion_let_tac H
  | subst_inversion_case_tac H ].

(** * More on [trim] *)

Lemma In_trim_assoc_keys :
forall m beta xs,
  In m (assoc_keys beta) ->
  In (Index m) xs ->
  In m (assoc_keys (trim beta xs)).
Proof with isa.
intros.
apply assoc_keys_ex_value in H.
destruct H.
apply assoc_value_ex_key with (a := x).
unfold trim.
apply <- filter_In.
split...
destruct In_dec...
Qed.

Lemma In_assoc_keys_trim :
forall m beta xs,
  In m (assoc_keys (trim beta xs)) ->
  In m (assoc_keys beta).
Proof with isa.
intros.
unfold trim in *.
apply assoc_keys_ex_value in H.
destruct H.
apply filter_In in H.
destruct H.
apply assoc_value_ex_key with (a := x)...
Qed.

Lemma closed_trim_var :
forall beta x,
  closed_by_var (assoc_keys beta) 0 x ->
  closed_by_var (assoc_keys (trim beta (x :: nil))) 0 x.
Proof with isa.
intros.
inversion H; subst.
(* env *)
apply closed_by_var_env.
simpl_arith.
apply In_trim_assoc_keys...
(* index *)
apply closed_by_var_index...
(* atom *)
apply closed_by_var_atom...
Qed.

Lemma closed_trim_vars :
forall beta xs,
  closed_by_vars (assoc_keys beta) 0 xs ->
  closed_by_vars (assoc_keys (trim beta xs)) 0 xs.
Proof with isa.
intros.
constructor.
inversion H; subst.
intros.
dupl H1.
apply H0 in H1.
apply closed_trim_var in H1.
inversion H1; subst.
(* env *)
apply closed_by_var_env.
simpl_arith.
apply In_trim_assoc_keys...
apply In_assoc_keys_trim with (xs := Index m :: nil)...
(* index *)
apply closed_by_var_index...
(* atom *)
apply closed_by_var_atom...
Qed.

Lemma closed_trim_var_app_nil :
forall beta x,
  closed_by_expr (assoc_keys beta) 0 (App x nil) ->
  closed_by_expr (assoc_keys (trim beta (x :: nil))) 0 (App x nil).
Proof with isa.
intros.
inversion H; subst.
constructor.
apply closed_trim_var...
constructor...
contradiction.
Qed.

Lemma filter_simpl :
forall (A : Type) (a : A) (l : list A) (f : A -> bool),
  filter f (a :: l) = if f a then a :: filter f l else filter f l.
Proof.
trivial.
Qed.

Lemma find_assoc_trim_In :
forall n beta xs,
  In (Index n) xs ->
  find_assoc beta n = find_assoc (trim beta xs) n.
Proof with isa.
induction beta.
isa.
destruct a...
destruct (eq_nat_dec n n0).
(* eq *)
subst.
destruct In_dec...
  (* in *)
destruct eq_nat_dec...
case n...
  (* not in *)
tauto.
(* neq *)
destruct In_dec...
destruct eq_nat_dec...
subst...
case n1...
Qed.

Lemma find_assoc_trim :
forall n beta,
  find_assoc beta n = find_assoc (trim beta (Index n :: nil)) n.
Proof with isa.
intros.
apply find_assoc_trim_In.
auto with *.
Qed.

Lemma subst_trim_var :
forall beta x,
  subst_var beta x = subst_var (trim beta (x :: nil)) x.
Proof with isa.
intros.
unfold subst_var.
destruct x...
rewrite <- find_assoc_trim...
Qed.

Lemma subst_trim_vars :
forall beta xs,
  map (subst_var beta) xs = map (subst_var (trim beta xs)) xs.
Proof with isa.
intros.
apply map_ext_in...
destruct a...
rewrite <- find_assoc_trim_In...
Qed.

Lemma trim_nil:
forall vs,
  trim nil vs = nil.
Proof with isa.
intros.
unfold trim...
Qed.

Lemma trim_nil_2:
forall beta,
  trim beta nil = nil.
Proof with isa.
intros.
unfold trim.
induction beta...
destruct a...
Qed.

Lemma closed_trim_not_bound_var :
forall (beta : env) (b : nat) (v : var) (ws : vars),
  In (minus_offset b v) ws ->
  closed_by_var (assoc_keys beta) b v ->
  closed_by_var (assoc_keys (trim beta ws)) b v.
Proof with isa.
intros.
destruct v.
(* index *)
inversion H0; subst; try constructor...
apply In_trim_assoc_keys...
cutrewrite (m = m + b - b)...
omega.
(* atom *)
constructor.
Qed.

Lemma not_bound_In :
forall b vs m,
  In (Index (m + b)) vs ->
  In m (not_bound_vars b vs).
Proof with isa.
intros.
induction vs...
destruct H.
(* left *)
subst.
clear IHvs.
unfold not_bound_var.
destruct le_lt_dec.
left; omega.
cut (~ m + b < b).
tauto.
omega.
(* right *)
destruct not_bound_var...
Qed.

Lemma trim_closed_app_var :
forall beta vs ws n v,
  closed_by_var (assoc_keys (trim beta vs)) n v ->
  closed_by_var (assoc_keys (trim beta (vs ++ ws))) n v.
Proof with isa.
intros.
inversion H; subst; [ | constructor; auto | constructor ].
apply closed_by_var_env.
clear H.
induction beta.
rewrite trim_nil in *...
destruct a...
destruct In_dec.
destruct In_dec...
destruct H0...
destruct H0...
subst.
apply in_app_left with (m := ws) in i.
tauto.
destruct In_dec...
Qed.

Lemma trim_closed_app_vars :
forall beta zs ws n vs,
  closed_by_vars (assoc_keys (trim beta vs)) n zs ->
  closed_by_vars (assoc_keys (trim beta (vs ++ ws))) n zs.
Proof with isa.
intros.
inversion H; subst.
constructor...
apply trim_closed_app_var...
Qed.

Lemma trim_closed_app :
forall e beta vs ws n,
  closed_by_expr (assoc_keys (trim beta vs)) n e ->
  closed_by_expr (assoc_keys (trim beta (vs ++ ws))) n e.
Proof with isa.
induction e using expr_ind2 with
    (P1 := fun lf : lambda_form => forall beta vs ws n,
      closed_by_lf (assoc_keys (trim beta vs)) n lf ->
      closed_by_lf (assoc_keys (trim beta (vs ++ ws))) n lf)
    (P2 := fun al : alt => forall beta vs ws n,
      closed_by_alt (assoc_keys (trim beta vs)) n al ->
      closed_by_alt (assoc_keys (trim beta (vs ++ ws))) n al);
  intros.
(* Case App *)
inversion H; subst.
constructor.
apply trim_closed_app_var...
apply trim_closed_app_vars...
(* Case Constr *)
inversion H; subst.
constructor.
apply trim_closed_app_vars...
(* Case Letrec *)
inversion H0; subst.
constructor...
(* Case Case *)
inversion H0; subst.
constructor...
(* Case Lf *)
inversion H; subst.
constructor...
(* Case Alt *)
inversion H; subst.
constructor...
Qed.

Lemma In_app_comm :
forall (A : Type) (vs ws : list A) (x : A),
  In x (vs ++ ws) ->
  In x (ws ++ vs).
Proof with isa.
intros.
apply in_app_or in H.
apply in_or_app.
tauto.
Qed.

Lemma trim_app_comm :
forall vs ws beta,
  trim beta (vs ++ ws) = trim beta (ws ++ vs).
Proof with isa.
intros.
induction beta...
destruct a.
destruct In_dec; destruct In_dec...
f_equal...
apply In_app_comm in i; apply n0 in i; contradiction.
apply In_app_comm in i; apply n0 in i; contradiction.
Qed.

Lemma trim_closed_app_2 :
forall e beta vs ws n,
  closed_by_expr (assoc_keys (trim beta ws)) n e ->
  closed_by_expr (assoc_keys (trim beta (vs ++ ws))) n e.
Proof with isa.
intros.
rewrite trim_app_comm.
apply trim_closed_app...
Qed.

Lemma trim_in_flat_closed :
forall ws wss beta b e,
  In ws wss ->
  closed_by_expr (assoc_keys (trim beta ws)) b e ->
  closed_by_expr (assoc_keys (trim beta (flat wss))) b e.
Proof with isa.
induction wss...
contradiction.
destruct H; subst.
apply trim_closed_app...
apply trim_closed_app_2...
Qed.

Lemma closed_trim_not_bound :
forall e beta b,
  closed_by_expr (assoc_keys beta) b e ->
  closed_by_expr (assoc_keys
    (trim beta (map Index (not_bound_expr b e)))) b e.
Proof with isa.
induction e using expr_ind2 with
  (P1 := fun lf : lambda_form => forall beta b,
    closed_by_lf (assoc_keys beta) b lf ->
    closed_by_lf (assoc_keys
      (trim beta (map Index (not_bound_lf b lf)))) b lf)
  (P2 := fun al : alt =>  forall beta b,
    closed_by_alt (assoc_keys beta) b al ->
    closed_by_alt (assoc_keys
      (trim beta (map Index (not_bound_alt b al)))) b al);
   intros.
(* Case App *)
inversion H; subst.
constructor.
  (* var *)
inversion H2; [ | constructor | constructor ]...
apply closed_trim_not_bound_var...
rewrite map_app.
apply in_app_left.
unfold not_bound_vars...
destruct le_lt_dec...
omega.
constructor...
  (* vars *)
constructor.
intros.
inversion H3.
dupl H0.
apply H1 in H4.
inversion H4; [ | constructor | constructor ]...
subst.
apply closed_trim_not_bound_var...
rewrite map_app.
apply in_app_right.
apply in_map.
cutrewrite (m + b - b = m); try omega...
apply not_bound_In...
(* Case Constr *)
inversion H; subst.
constructor.
constructor.
intros.
inversion H1.
dupl H0.
apply H1 in H3.
inversion H3; [ | constructor | constructor ]...
subst.
apply closed_trim_not_bound_var...
apply in_map.
cutrewrite (m + b - b = m); try omega...
apply not_bound_In...
(* Case Letrec *)
inversion H0; subst.
constructor...
  (* defs *)
rewrite map_app.
destruct lf.
constructor.
apply trim_closed_app...
dupl H1.
apply H3 in H1.
apply H in H1...
inversion H1; subst.
rewrite map_flat_map.
apply trim_in_flat_closed with
  (ws := map Index (not_bound_lf (b + length ds) (Lf u b0 e0)))...
assert (not_bound_lf (b + length ds) (Lf u b0 e0) =
        not_bound_expr (b + length ds + b0) e0).
  auto.
rewrite <- H5.
apply in_map.
apply in_map...
  (* expr *)
rewrite map_app.
apply trim_closed_app_2...
(* Case Case *)
inversion H0; subst.
constructor...
  (* expr *)
rewrite map_app.
apply trim_closed_app_2...
  (* alts *)
rewrite map_app.
destruct al.
constructor.
apply trim_closed_app...
dupl H1.
apply H4 in H1.
apply H in H1...
inversion H1; subst.
rewrite map_flat_map.
apply trim_in_flat_closed with
  (ws := map Index (not_bound_alt b (Alt c b0 e0)))...
assert (not_bound_alt b (Alt c b0 e0) =
        not_bound_expr (b + b0) e0).
  auto.
rewrite <- H5.
apply in_map.
apply in_map...
(* Case Lf *)
inversion H; subst.
constructor...
(* Case Alt *)
inversion H; subst.
constructor...
Qed.

Lemma closed_trim_fv :
forall beta pi b e,
  closed_by_expr (assoc_keys beta) b e ->
  closed_by_expr (assoc_keys (trim beta (fv (Lf pi b e)))) b e.
Proof.
unfold fv.
unfold not_bound_lf.
intros.
fold (not_bound_expr (0 + b) e).
simpl.
apply closed_trim_not_bound.
auto.
Qed.

Lemma trim_fv_var :
forall beta n v vs ws,
  In (minus_offset n v) vs ->
  apply_with_offset (subst_var beta) n v =
  apply_with_offset (subst_var (trim beta (vs ++ ws))) n v.
Proof with isa.
intros.
destruct v...
destruct le_lt_dec...
apply in_app_left with (m := ws) in H.
apply find_assoc_trim_In with (beta := beta) in H.
rewrite H...
Qed.

Lemma in_not_bound_list :
forall n n0 vs,
  n <= n0 ->
  In (Index n0) vs ->
  In (Index (n0 - n)) (map Index (not_bound_vars n vs)).
Proof with isa.
intros.
induction vs...
destruct H0.
(* left *)
subst...
destruct le_lt_dec...
apply le_lt_trans with (n := n) in l...
apply n_lt_n_false in l; contradiction.
(* right *)
destruct not_bound_var...
Qed.

Lemma find_assoc_trim_app_comm :
forall vs ws beta,
  find_assoc (trim beta (vs ++ ws)) =
  find_assoc (trim beta (ws ++ vs)).
Proof with isa.
induction beta...
destruct a.
destruct In_dec; destruct In_dec...
rewrite IHbeta...
apply in_app_comm in i.
tauto.
apply in_app_comm in i.
tauto.
Qed.

Lemma subst_var_trim_app_comm :
forall beta vs ws,
  subst_var (trim beta (vs ++ ws)) =
  subst_var (trim beta (ws ++ vs)).
Proof with isa.
intros.
apply functional_extensionality...
destruct x...
rewrite find_assoc_trim_app_comm...
Qed.

Lemma trim_fv_expr_pre :
forall e n beta ws,
  map_expr (subst_var beta) n e =
  map_expr (subst_var (trim beta (map Index (not_bound_expr n e) ++ ws)))
    n e.
Proof with isa.
induction e using expr_ind2 with
    (P1 := fun (lf : lambda_form) => forall n ws beta,
      map_lf (subst_var beta) n lf =
      map_lf (subst_var
        (trim beta (map Index (not_bound_lf n lf) ++ ws))) n lf)
    (P2 := fun (al : alt) =>  forall n ws beta,
      map_alt (subst_var beta) n al =
      map_alt (subst_var
        (trim beta (map Index (not_bound_alt n al) ++ ws))) n al);
  intros; intuition; isa; f_equal...
(* [7] Case App *)
  (* [7] var *)
destruct v.
    (* Index *)
case (le_lt_dec n n0); intros.
      (* n <= n0 *)
apply trim_fv_var...
rewrite map_app.
apply in_app_left.
unfold not_bound_vars...
destruct (le_lt_dec n n0)...
omega.
      (* n0 < n *)
isa.
destruct le_lt_dec...
apply le_lt_trans with (n := n) in l...
apply n_lt_n_false in l; contradiction.
    (* Atom *)
simpl...
  (* [6] vars *)
apply map_ext_in...
destruct a.
    (* Index *)
case (le_lt_dec n n0); intros.
      (* n <= n0 *)
apply trim_fv_var...
rewrite map_app.
apply in_app_right.
apply in_not_bound_list...
      (* n0 < n *)
isa.
destruct le_lt_dec...
apply le_lt_trans with (n := n) in l...
apply n_lt_n_false in l; contradiction.
    (* Atom *)
simpl...
(* [5] Case Constr *)
apply map_ext_in...
destruct a.
  (* Index *)
case (le_lt_dec n n0); intros.
    (* n <= n0 *)
apply trim_fv_var...
apply in_not_bound_list...
    (* n0 < n *)
isa.
destruct le_lt_dec...
apply le_lt_trans with (n := n) in l...
apply n_lt_n_false in l; contradiction.
    (* Atom *)
simpl...
(* [4] Case Letrec *)
  (* [4] defs *)
apply map_ext_in...
rewrite map_app.
rewrite app_ass.
remember (map Index (not_bound_expr (n + length ds) e) ++ ws) as wws.
remember (n + length ds) as m.
clear Heqm Heqwws IHe e.
rewrite flat_map_flat_map.
dupl H0.
apply flat_map_is_app with (f := not_bound_lf m) in H1.
destruct H1.
destruct H1.
rewrite H1.
rewrite map_app.
rewrite map_app.
cutrewrite (
  (map Index x ++ map Index (not_bound_lf m a) ++ map Index x0) ++ wws =
   map Index x ++ map Index (not_bound_lf m a) ++ map Index x0 ++ wws).
rewrite subst_var_trim_app_comm.
rewrite app_ass...
    (* cutrewrite *)
rewrite app_ass.
rewrite app_ass...
  (* [3] expr *)
rewrite map_app.
rewrite subst_var_trim_app_comm.
rewrite <- app_ass.
rewrite subst_var_trim_app_comm...
(* [2] Case Letrec *)
  (* [2] expr *)
rewrite map_app.
rewrite subst_var_trim_app_comm.
rewrite <- app_ass.
rewrite subst_var_trim_app_comm...
  (* [1] alts *)
apply map_ext_in...
rewrite map_app.
rewrite app_ass.
rewrite flat_map_flat_map.
dupl H0.
apply flat_map_is_app with (f := not_bound_alt n) in H1.
destruct H1.
destruct H1.
rewrite H1.
rewrite map_app.
rewrite map_app.
rewrite app_ass.
rewrite subst_var_trim_app_comm.
rewrite app_ass.
rewrite app_ass...
Qed.

Lemma trim_fv_expr :
forall e n beta,
  map_expr (subst_var beta) n e =
  map_expr (subst_var (trim beta (map Index (not_bound_expr n e)))) n e.
Proof with isa.
intros.
cutrewrite (map Index (not_bound_expr n e) =
            map Index (not_bound_expr n e) ++ nil);
  auto with *.
apply trim_fv_expr_pre.
Qed.

Lemma trim_fv_lf :
forall lf beta,
  map_lf (subst_var beta) 0 lf =
  map_lf (subst_var (trim beta (fv lf))) 0 lf.
Proof with isa.
isa.
destruct lf...
f_equal.
unfold fv...
apply trim_fv_expr.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal27.

Set Printing Depth 1000.
Definition lfind_eval  x:=
qreva x Nil.

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Nil).


From iris.algebra Require Import cmra.
From iris.heap_lang Require Import lang metatheory.
From stdpp Require Import fin_sets gmap stringmap.
From iris_ni.logrel Require Export slevel.

(** * Types *)
Inductive type :=
| tunit : type
| tint (l : slevel) : type
| tbool (l : slevel) : type
| tarrow (s t : type) (l : slevel)
| tprod (t1 t2 : type)
| tintoption (il l : slevel)
| tref (t : type).

Fixpoint type_measure (τ : type) : nat :=
  match τ with
  | tunit => 0
  | tint _ => 0
  | tbool _ => 0
  | tarrow s t _ => type_measure s + type_measure t + 1
  | tprod τ1 τ2 => type_measure τ1 + type_measure τ2 + 1
  | tintoption _ _ => 0
  | tref τ => type_measure τ + 1
  end.

(* stamp τ l = τ ⊔ l *)
Fixpoint stamp (τ : type) (l : slevel) : type :=
  match τ with
  | tunit => tunit
  | tint l2 => tint (l2 ⊔ l)
  | tbool l2 => tbool (l2 ⊔ l)
  | tprod τ1 τ2 => tprod (stamp τ1 l) (stamp τ2 l)
  | tarrow s t l2 => tarrow s t (l2 ⊔ l)
  | tintoption il l2 => tintoption il (l2 ⊔ l)
  | tref τ => tref τ
  end.

(* "Flat types" are types τ for which the following typing rule is
sound:

  ⊢ v, w : τ      ⊢ e : bool high
------------------------------------
    ⊢ if e then v else w : τ
*)
Inductive  flat_type : type → Prop :=
| tint_flat l : flat_type (tint l)
| tbool_flat l : flat_type (tbool l)
| tunit_flat : flat_type tunit
| tprod_flat τ τ' : flat_type τ →
                    flat_type τ' →
                    flat_type (tprod τ τ').

(* "Unboxed types" are types which values are unboxed *)
Inductive  unboxed_type : type → Prop :=
| tint_unboxed l : unboxed_type (tint l)
| tbool_unboxed l : unboxed_type (tbool l)
| tunit_unboxed : unboxed_type tunit
| tref_unboxed τ : unboxed_type (tref τ)
(* | tintoption_unboxed il l : unboxed_type (tintoption il l) *)
.

Definition tmutex_aux : seal (tref (tbool Low)). by eexists. Qed.
Definition tmutex : type := tmutex_aux.(unseal).
Definition tmutex_eq : tmutex = tref (tbool Low) := tmutex_aux.(seal_eq).

(* [lbl τ] is a "level approximation" of a type *)
Fixpoint lbl (τ : type) : slevel :=
  match τ with
  | tunit => Low
  | tint α => α
  | tbool α => α
  | tprod τ1 τ2 => lbl τ1 ⊔ lbl τ2
  | tarrow s t β => lbl t ⊔ β
  | tintoption il α => il ⊔ α
  | tref τ => Low
  end.

(** The subtyping relation <: *)
Reserved Notation "τ '<:' σ" (at level 50).
Inductive type_sub : type → type → Prop :=
| type_sub_refl τ :
    τ <: τ
| type_sub_trans τ₁ τ₂ τ₃ :
    τ₁ <: τ₂ →
    τ₂ <: τ₃ →
    τ₁ <: τ₃
| type_sub_int l1 l2 :
    l1 ⊑ l2 →
    tint l1 <: tint l2
| type_sub_bool l1 l2 :
    l1 ⊑ l2 →
    tbool l1 <: tbool l2
| type_sub_option il l1 l2:
    l1 ⊑ l2 →
    tintoption il l1 <: tintoption il l2
| type_sub_arrow τ₁ τ₂ τ'₁ τ'₂ l l' :
    τ'₁ <: τ₁   →
    τ₂  <: τ'₂  →
    l   ⊑  l'   →
    tarrow τ₁ τ₂ l <: tarrow τ'₁ τ'₂ l'
| type_sub_prod τ₁ τ₂ σ₁ σ₂ :
    τ₁ <: τ₂ →
    σ₁ <: σ₂ →
    tprod τ₁ σ₁ <: tprod τ₂ σ₂
where "τ '<:' σ" := (type_sub τ σ).

(* Typing for binary operations *)
Inductive bin_op_int : bin_op → Prop :=
| bin_op_int_plus : bin_op_int PlusOp
| bin_op_int_mult : bin_op_int MultOp
| bin_op_int_sub : bin_op_int MinusOp
| bin_op_int_div : bin_op_int QuotOp.

Inductive bin_op_int_bool : bin_op → Prop :=
| bin_op_int_lt : bin_op_int_bool LtOp
| bin_op_int_le : bin_op_int_bool LeOp
| bin_op_int_eq : bin_op_int_bool EqOp.

Inductive bin_op_bool : bin_op → Prop :=
| bin_op_bool_and : bin_op_bool AndOp
| bin_op_bool_or : bin_op_bool OrOp.

Inductive almost_val : gset string → expr → Prop :=
| is_a_value Γ v : almost_val Γ (Val v)
| is_a_variable (x : string) Γ :
    x ∈ Γ →
    almost_val Γ (Var x).

(**********************************************************************)
(***** Properties *)

Section local.

Local Hint Resolve join_leq_l join_leq_r join_mono_l join_mono_r : core.
Local Hint Resolve leq_join_max_1 leq_join_max_2 : core.
Local Hint Resolve meet_geq_l meet_geq_r leq_meet_min_1 leq_meet_min_2 : core.
Local Hint Constructors type_sub : core.

Global Instance type_eqdec : EqDecision type.
Proof. solve_decision. Qed.

Lemma stamp_measure (τ : type) (l : slevel) :
  type_measure τ = type_measure (stamp τ l).
Proof. induction τ; naive_solver. Qed.

Lemma lbl_stamp_leq_general τ l : lbl (stamp τ (lbl τ ⊔ l)) ⊑ lbl τ ⊔ l.
Proof.
  revert l. induction τ=>α; simpl;
                           try (by rewrite assoc idemp //);
                           rewrite ?idemp //.
  + sl_lattice_switch_goal. done.
  + rewrite -{1}(assoc _ (lbl τ1) (lbl τ2) α).
    rewrite IHτ1.
    rewrite (comm _ (lbl τ1) (lbl τ2)).
    rewrite -{1}(assoc _ (lbl τ2) (lbl τ1) α).
    rewrite IHτ2.
    sl_lattice_switch_goal. done.
  + sl_lattice_switch_goal. done.
Qed.

Lemma lbl_stamp_leq τ : lbl (stamp τ (lbl τ)) ⊑ lbl τ.
Proof.
  rewrite -(right_id Low (⊔) (lbl τ)).
  apply lbl_stamp_leq_general.
Qed.

Global Instance type_sub_reflexive : Reflexive type_sub.
Proof. by constructor. Qed.
Global Instance type_sub_transitive : Transitive type_sub.
Proof. intros ?????. by econstructor. Qed.
Global Instance type_sub_preorder : PreOrder type_sub.
Proof. split; apply _. Qed.

Lemma stamp_sub τ l : τ <: stamp τ l.
Proof. induction τ; simpl; eauto. Qed.

Lemma stamp_mono_2 τ l l' :
  l ⊑ l' →
  stamp τ l <: stamp τ l'.
Proof. intros. induction τ; simpl; eauto. Qed.

Lemma stamp_low τ : stamp τ Low = τ.
Proof.
  induction τ; simpl; rewrite ?right_id; eauto;
  by (rewrite IHτ1 IHτ2 || rewrite IHτ).
Qed.

Lemma stamp_idemp τ l : stamp (stamp τ l) l = stamp τ l.
Proof.
  induction τ; simpl; rewrite -?assoc // ?(idemp (⊔) l) //.
  by rewrite IHτ1 IHτ2.
Qed.

Lemma flat_type_stamp τ l : flat_type τ → flat_type (stamp τ l).
Proof. induction 1; econstructor; eauto. Qed.

Lemma unboxed_type_stamp τ l : unboxed_type τ → unboxed_type (stamp τ l).
Proof. induction 1; econstructor; eauto. Qed.

Lemma unboxed_type_stamp_lbl τ : unboxed_type τ → τ = stamp τ (lbl τ).
Proof. by induction 1; simpl; rewrite ?idemp_L //. Qed.

End local.

(**********************************************************************)

Lemma bin_op_int_safe (i1 i2 : Z) op :
  bin_op_int op →
  ∃ (z : Z), bin_op_eval op (LitV (LitInt i1)) (LitV (LitInt i2)) = Some (LitV (LitInt z)).
Proof.
  destruct op; inversion 1; eauto.
Qed.

Lemma bin_op_int_bool_safe (i1 i2 : Z) op :
  bin_op_int_bool op →
  ∃ (b : bool), bin_op_eval op (LitV (LitInt i1)) (LitV (LitInt i2)) = Some (LitV (LitBool b)).
Proof.
  destruct op; inversion 1; eauto.
Qed.

Lemma bin_op_bool_safe (b1 b2 : bool) op :
  bin_op_bool op →
  ∃ (b : bool), bin_op_eval op (LitV (LitBool b1)) (LitV (LitBool b2)) = Some (LitV (LitBool b)).
Proof.
  destruct op; inversion 1; eauto.
Qed.

(****** almost_val and its properties *)

Lemma almost_val_mono Γ Γ' e :
  Γ ⊆ Γ' →
  almost_val Γ e →
  almost_val Γ' e.
Proof.
  induction 2; constructor; set_solver.
Qed.

Lemma almost_val_subst_map X γ e :
  almost_val X e →
  X = dom _ γ →
  ∃ (w : val), subst_map γ e = Val w.
Proof.
  intros Hv ->. inversion Hv; simplify_eq/=.
  - eexists; eauto.
  - apply elem_of_dom in H. destruct H as [w ->].
    eexists; eauto.
Qed.

Lemma almost_val_union X Y γ e :
  almost_val (X ∪ Y) e →
  Y = dom _ γ →
  almost_val X (subst_map γ e).
Proof.
  intros He ->.
  inversion He; simplify_eq/=; first by constructor.
  destruct (γ !! x) as [v|] eqn:Hx; first by constructor.
  econstructor. apply (not_elem_of_dom (D:=stringset)) in Hx.
  set_solver.
Qed.

Delimit Scope FType_scope with ty.
Bind Scope FType_scope with type.
Infix "*" := tprod : FType_scope.
Notation "(*)" := tprod (only parsing) : FType_scope.
Notation "A '→' B" := (tarrow A B Low) : FType_scope.
Notation "τ '<:' σ" := (type_sub τ σ) (at level 50).