Require Import RelationClasses Le.
Require Import Forcing.
Import NatForcing.
Import NatCondition.
Open Scope forcing_scope.

Forcing Operator eqf : (forall A, A -> A -> Prop).

Next Obligation.
red; simpl; intros.
apply (H (ι r2) s2 arg2).
Qed.

Next Obligation.
red; simpl; intros.
split; red; intros.
reflexivity.
reflexivity.
Qed.

Next Obligation.
red; simpl; intros.
apply (H (ι r1) s1 arg1).
Qed.

Next Obligation.
red; simpl; intros.
split; red; intros.
reflexivity.
reflexivity.
Qed.

Inductive eqf_sheaf_ind {p:nat} (A:sheaf p) (x : sheaf_f A (embed p)) : (sheaf_f A (embed p)) -> Prop :=
| eqf_refl : eqf_sheaf_ind A x x.

Hint Resolve eqf_refl : core.

Instance eqf_sheaf_ind_refl p A : Reflexive (@eqf_sheaf_ind p A).
Proof eqf_refl A.

Instance eqf_sheaf_ind_sym p A : Symmetric (@eqf_sheaf_ind p A).
Proof. red. now induction 1. Qed.

Instance eqf_sheaf_ind_trans p A : Transitive (@eqf_sheaf_ind p A).
Proof. red. now induction 1. Qed.

Instance eqf_sheaf_ind_equiv p A : Equivalence (@eqf_sheaf_ind p A) := {}.

Program Definition eqf_sheaf {p} := fun (q:subp p) {A:sheaf q} (r : subp q) (x : sheaf_f A r)
  (s : subp r) (y : sheaf_f A (ι s)) (t : subp s) => forall (u: subp t),
    (eqf_sheaf_ind (sheafC p q (ι u) A) (Θ A r (ι u) x) (Θ A (ι s) (ι u) y)).

Program Definition eqf_transp {p} (q:subp p) (A:sheaf q) (r : subp q) (x : sheaf_f A r)
  (s : subp r) (y : sheaf_f A (ι s)) : prop_transport (eqf_sheaf q r x s y) := λ q0 r0 H u, H u.

Definition eqf_sheaf_f_1 {p} (q:subp p) (A : sheaf q) (r : subp q) (x : sheaf_f A r) :
  eqf_transty6 p {Σ p, le_refl p} q A (ι q) r (ι r).
red; intros s y.
exists (eqf_sheaf q r x s y).
exact (eqf_transp q A r x s y).
Defined.

Require Import FunctionalExtensionality.
Require Import ClassicalFacts.

Axiom prop_ext : prop_extensionality.

Lemma exist_eq {A : Type} {P : A -> Prop} (x y : A) (p : P x) (q : P y) : x = y -> exist x p = exist y q.
Proof. intros; subst; reflexivity. Qed.
Notation " '{Σ'  x } " := (exist x _).

Hint Extern 10 (Iota _ _ _) => progress (unfold iota; simpl) : typeclass_instances.

Program Definition eqf_sheaf_f_2 {p} (q:subp p) (A : sheaf q): eqf_transty7 p (embed p) q A (ι q) :=
          fun r x => eqf_sheaf_f_1 q A r x.

Next Obligation of eqf_sheaf_f_2.
Proof.
  unfold eqf_transprop; simpl.
  intros s t y.
  apply exist_eq.
  unfold eqf_sheaf_f_1, eqf_transp, eqf_sheaf.
  unfold prop_sheafC; simpl.
  extensionality s0.
  apply prop_ext; split; intros H v; specialize (H v).
  pose (sheaf_trans A (iota s) (iota t) (iota v) y).
  simpl in *.
  setoid_rewrite <- e in H.
  apply H.
  pose (sheaf_trans A (iota s) (iota t) (iota v) y).
  simpl in e.
  setoid_rewrite <- e. apply H.
Qed.

Program Definition eqf_sheaf_f_3 {p} : eqf_transty8 p (embed p) :=
          eqf_sheaf_f_2 (p:=p).
Next Obligation of eqf_sheaf_f_3.
Proof.
  red; intros.
  simpl; intros.
  apply exist_eq.
  extensionality s2.
  extensionality y.
  apply exist_eq.
  unfold eqf_sheaf.
  extensionality t.
  apply prop_ext.
  split; intros.
  pose proof (sheaf_trans x0).
  red in H0.
  unfold compose in H0.
  setoid_rewrite (H0  (ι r1) s1 (ι u) arg1).
  apply H.

  pose proof (sheaf_trans x0).
  red in H0.
  unfold compose in H0; simpl.
  specialize (H u). symmetry in H0.
  specialize (H0 r1 (iota s1)).
  simpl in H0.
  setoid_rewrite <- H0 in H; simpl in H.
  apply H.
Qed.

Next Obligation.
  red. intros.
  refine (exist eqf_sheaf_f_3 _).
  red; intros.
  reflexivity.
Defined.


From mathcomp Require Import all_ssreflect.
Require Import String.
Require Import Ascii.

Require Import htmlescape.listutils.
Require Import htmlescape.assoc.
Require Import htmlescape.ssrstr.

Definition html_char_entities :=
  map (fun p => (p.1, seq_of_str p.2)) [::
  ("&"%char, "amp");
  ("<"%char, "lt");
  (">"%char, "gt");
  (""""%char, "quot");
  ("'"%char, "apos")
  (* ... more character entities here ... *)
].

(* HTML character and text specification.
 * https://html.spec.whatwg.org/multipage/syntax.html#text-2
 * Note: Unicode is not considered.
 *)
Inductive char_spec : ascii -> seq ascii -> Prop :=
  | char_normal : forall c, c != "&"%char -> char_spec c [:: c]
  | char_named : forall c entity, (c, entity) \in html_char_entities ->
      char_spec c ("&" ++ entity ++ ";")
  | char_dec : forall m digs, digs != nil -> decode_decimal digs = Some m ->
      char_spec (ascii_of_nat m) ("&#" ++ digs ++ ";")
  | char_hex : forall x m xdigs,
      downcase_ascii x == "x"%char -> xdigs != nil -> decode_hex xdigs = Some m ->
      char_spec (ascii_of_nat m) ("&#" ++ x :: xdigs ++ ";").

Inductive text_spec : seq ascii -> seq ascii -> Prop :=
  | text_empty : text_spec [::] [::]
  | text_cons : forall c s raw escaped,
      char_spec c s -> text_spec raw escaped -> text_spec (c :: raw) (s ++ escaped).


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files gives an implementation of finite sets using finite maps with
elements of the unit type. Since maps enjoy extensional equality, the
constructed finite sets do so as well. *)
From stdpp Require Export fin_map_dom.
(* FIXME: This file needs a 'Proof Using' hint. *)

Record mapset (M : Type → Type) : Type :=
  Mapset { mapset_car: M (unit : Type) }.
Arguments Mapset {_} _ : assert.
Arguments mapset_car {_} _ : assert.

Section mapset.
Context `{FinMap K M}.

Global Instance mapset_elem_of: ElemOf K (mapset M) := λ x X,
  mapset_car X !! x = Some ().
Global Instance mapset_empty: Empty (mapset M) := Mapset ∅.
Global Instance mapset_singleton: Singleton K (mapset M) := λ x,
  Mapset {[ x := () ]}.
Global Instance mapset_union: Union (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∪ m2).
Global Instance mapset_intersection: Intersection (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∩ m2).
Global Instance mapset_difference: Difference (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∖ m2).
Global Instance mapset_elements: Elements K (mapset M) := λ X,
  let (m) := X in (map_to_list m).*1.

Lemma mapset_eq (X1 X2 : mapset M) : X1 = X2 ↔ ∀ x, x ∈ X1 ↔ x ∈ X2.
Proof.
  split; [by intros ->|].
  destruct X1 as [m1], X2 as [m2]. simpl. intros E.
  f_equal. apply map_eq. intros i. apply option_eq. intros []. by apply E.
Qed.

Instance mapset_collection: Collection K (mapset M).
Proof.
  split; [split | | ].
  - unfold empty, elem_of, mapset_empty, mapset_elem_of.
    simpl. intros. by simpl_map.
  - unfold singleton, elem_of, mapset_singleton, mapset_elem_of.
    simpl. by split; intros; simplify_map_eq.
  - unfold union, elem_of, mapset_union, mapset_elem_of.
    intros [m1] [m2] ?. simpl. rewrite lookup_union_Some_raw.
    destruct (m1 !! x) as [[]|]; tauto.
  - unfold intersection, elem_of, mapset_intersection, mapset_elem_of.
    intros [m1] [m2] ?. simpl. rewrite lookup_intersection_Some.
    assert (is_Some (m2 !! x) ↔ m2 !! x = Some ()).
    { split; eauto. by intros [[] ?]. }
    naive_solver.
  - unfold difference, elem_of, mapset_difference, mapset_elem_of.
    intros [m1] [m2] ?. simpl. rewrite lookup_difference_Some.
    destruct (m2 !! x) as [[]|]; intuition congruence.
Qed.
Global Instance mapset_leibniz : LeibnizEquiv (mapset M).
Proof. intros ??. apply mapset_eq. Qed.
Global Instance mapset_fin_collection : FinCollection K (mapset M).
Proof.
  split.
  - apply _.
  - unfold elements, elem_of at 2, mapset_elements, mapset_elem_of.
    intros [m] x. simpl. rewrite elem_of_list_fmap. split.
    + intros ([y []] &?& Hy). subst. by rewrite <-elem_of_map_to_list.
    + intros. exists (x, ()). by rewrite elem_of_map_to_list.
  - unfold elements, mapset_elements. intros [m]. simpl.
    apply NoDup_fst_map_to_list.
Qed.

Section deciders.
  Context `{EqDecision (M unit)}.
  Global Instance mapset_eq_dec : EqDecision (mapset M) | 1.
  Proof.
   refine (λ X1 X2,
    match X1, X2 with Mapset m1, Mapset m2 => cast_if (decide (m1 = m2)) end);
    abstract congruence.
  Defined.
  Global Instance mapset_equiv_dec : RelDecision (@equiv (mapset M)_) | 1.
  Proof. refine (λ X1 X2, cast_if (decide (X1 = X2))); abstract (by fold_leibniz). Defined.
  Global Instance mapset_elem_of_dec : RelDecision (@elem_of _ (mapset M) _) | 1.
  Proof. refine (λ x X, cast_if (decide (mapset_car X !! x = Some ()))); done. Defined.
  Global Instance mapset_disjoint_dec : RelDecision (@disjoint (mapset M) _).
  Proof.
   refine (λ X1 X2, cast_if (decide (X1 ∩ X2 = ∅)));
    abstract (by rewrite disjoint_intersection_L).
  Defined.
  Global Instance mapset_subseteq_dec : RelDecision (@subseteq (mapset M) _).
  Proof.
   refine (λ X1 X2, cast_if (decide (X1 ∪ X2 = X2)));
    abstract (by rewrite subseteq_union_L).
  Defined.
End deciders.

Definition mapset_map_with {A B} (f : bool → A → option B)
    (X : mapset M) : M A → M B :=
  let (mX) := X in merge (λ x y,
    match x, y with
    | Some _, Some a => f true a | None, Some a => f false a | _, None => None
    end) mX.
Definition mapset_dom_with {A} (f : A → bool) (m : M A) : mapset M :=
  Mapset $ merge (λ x _,
    match x with
    | Some a => if f a then Some () else None | None => None
    end) m (@empty (M A) _).

Lemma lookup_mapset_map_with {A B} (f : bool → A → option B) X m i :
  mapset_map_with f X m !! i = m !! i ≫= f (bool_decide (i ∈ X)).
Proof.
  destruct X as [mX]. unfold mapset_map_with, elem_of, mapset_elem_of.
  rewrite lookup_merge by done. simpl.
  by case_bool_decide; destruct (mX !! i) as [[]|], (m !! i).
Qed.
Lemma elem_of_mapset_dom_with {A} (f : A → bool) m i :
  i ∈ mapset_dom_with f m ↔ ∃ x, m !! i = Some x ∧ f x.
Proof.
  unfold mapset_dom_with, elem_of, mapset_elem_of.
  simpl. rewrite lookup_merge by done. destruct (m !! i) as [a|].
  - destruct (Is_true_reflect (f a)); naive_solver.
  - naive_solver.
Qed.
Instance mapset_dom {A} : Dom (M A) (mapset M) := mapset_dom_with (λ _, true).
Instance mapset_dom_spec: FinMapDom K M (mapset M).
Proof.
  split; try apply _. intros. unfold dom, mapset_dom, is_Some.
  rewrite elem_of_mapset_dom_with; naive_solver.
Qed.
End mapset.

Arguments mapset_eq_dec : simpl never.


Require Import lib Size Omega List ssreflect ssrfun util MMap.

Delimit Scope subst_scope with subst.
Open Scope subst_scope.

Definition scons {X : Type} s sigma x : X := match x with S x' => sigma x' | _ => s end.
Infix ".:" := scons (at level 60, right associativity) : subst_scope.

Definition lift (x y : var) : var := plus x y.

Arguments lift !x !y.

Notation "( + x )" := (lift x) (format "( + x )").

Definition upr xi := 0 .: (fun x => (+1) (xi x)).

Class Subst (term : Type) := {
  Var : var -> term;
  rename : (var -> var) -> term -> term;
  subst : (var -> term) -> term -> term
}.

Definition rcomp (xi zeta : var -> var) := zeta \o xi.
Arguments rcomp xi zeta x /.

Notation "xi >>> zeta" := (rcomp xi zeta) (at level 55, left associativity) : subst_scope.
Notation "sigma >> tau" := (subst tau \o sigma) (at level 55, left associativity) : subst_scope.
(*Notation "sigma >>' tau" := (mmap(subst tau) \o sigma) (at level 55, left associativity) : subst_scope.*)
Notation "s .[ sigma ]" := (subst sigma s) (at level 2, sigma at level 200, left associativity, format "s .[ sigma ]" ) : subst_scope.
(*Notation "s ..[ sigma ]" := (mmap (subst sigma) s) (at level 2, sigma at level 200, left associativity, format "s ..[ sigma ]" ) : subst_scope.*)
Notation " l ,, x" := (cons x l) (at level 4, left associativity, format "l ,, x") : subst_scope.
Notation " l1 ,,, l2" := (l2 ++ l1) (at level 4, left associativity, format "l1 ,,, l2") : subst_scope.

Notation beta s := (s .: Var) (only parsing).

Definition ren {term : Type}{subst_funs : Subst term} xi (x : var) := Var (xi x).
Arguments ren {_ _} xi x/.
Notation up sigma := ((Var 0) .: sigma >> ren(+1)).

Class SubstLemmas (term : Type) (subst_funs : Subst term) := {
  rename_subst xi : rename xi = subst (ren xi);
  subst_id s : subst Var s = s;
  id_subst x sigma : subst sigma (Var x) = sigma x;
  subst_comp s sigma tau : subst tau (subst sigma s) = subst (sigma >> tau) s
}.

Section Subst.

Context {term : Type}.
Context {subst_funs : Subst term}.
Context {subst_lemmas : SubstLemmas _ subst_funs}.

Ltac ssimpl :=
  msimpl;
  repeat match goal with
             [|- context[?s]] =>
             first[
                 progress change s with rename
               | progress change s with subst
               | progress change s with Var
               | progress match s with ?s1 _ => change s1 with Var end]
         end;
  try rewrite rename_subst;
  try rewrite subst_id;
  try rewrite id_subst;
  try rewrite subst_comp.

Lemma to_lift x : Var(S x) = (Var x).[ren(+1)].
Proof.
now ssimpl.
Qed.

Lemma Var_comp_l (sigma : var -> term) : Var >> sigma = sigma.
Proof.
  f_ext. intros. now ssimpl.
Qed.

Lemma Var_comp_r (sigma : var -> term) : sigma >> Var = sigma.
Proof.
  f_ext. intros. now ssimpl.
Qed.

Lemma zero_scons s sigma : (Var 0).[s .: sigma] = s.
Proof.
  now ssimpl.
Qed.

Lemma comp_assoc (sigma1 sigma2 sigma3 : var -> term) : (sigma1 >> sigma2) >> sigma3 = sigma1 >> sigma2 >> sigma3.
Proof.
  f_ext. intros. now ssimpl.
Qed.

Lemma comp_dist (sigma tau : var -> term) s : (s .: sigma) >> tau = s.[tau] .: sigma >> tau.
Proof.
  f_ext. intros x. now destruct x.
Qed.

Lemma scons_lift (x : var) : x .: lift (S x) = lift x.
Proof.
  unfold var in *.
  f_ext; intro y; destruct y; unfold lift; simpl; omega.
Qed.

Lemma lift_scons_comp s sigma : ren(+1) >> (s .: sigma) = sigma.
Proof.
  f_ext. intros. destruct x; now ssimpl.
Qed.

Lemma scons_Var_ren x xi : Var x .: ren xi = ren (x .: xi).
Proof.
  f_ext. intros y. now destruct y.
Qed.

Lemma lift_comp n m: (+n) >>> (+m) = (+(n+m)).
Proof.
  unfold lift. f_ext. intro. simpl. unfold var in *. omega.
Qed.

Lemma ren_comp xi zeta : ren xi >> ren zeta = ren (xi >>> zeta).
Proof.
  f_ext. intro. now ssimpl.
Qed.

Lemma fold_ren (xi zeta : var -> var) : (fun x => Var (xi (zeta x))) = ren (fun x => xi (zeta x)). reflexivity. Qed.

Lemma subst_comp' sigma tau : subst sigma \o subst tau = subst (tau >> sigma).
Proof.
  f_ext. intro. now ssimpl.
Qed.

Lemma ren_uncomp A xi zeta : A.[ren (xi >>> zeta)] = A.[ren xi].[ren zeta].
Proof.
  ssimpl. now rewrite ren_comp.
Qed.

(*
Fixpoint interp_ctxt Gamma A :=
  match Gamma with
    | nil => A
    | Gamma,, B => A.[interp_ctxt Gamma B .: (fun x => interp_ctxt Gamma (Var x))]
  end.
*)
End Subst.

Hint Rewrite
     @rename_subst @subst_id @id_subst @subst_comp @to_lift @Var_comp_l @Var_comp_r
     @zero_scons @comp_assoc @comp_dist @scons_lift @lift_scons_comp @scons_Var_ren @lift_comp @ren_comp @fold_ren @subst_comp'
NPeano.Nat.add_1_r : subst.

Arguments rename {_ _}  xi s : simpl never.
Arguments subst {_ _} sigma s : simpl never.

Notation "'up' sigma" := ((Var 0) .: sigma >> ren(+1)) (at level 1) : subst_scope.

Ltac ssimpl' :=
  try unfold rename;
  try unfold subst;
  simpl;
  repeat match goal with
             [|- context[?s]] =>
             let T := typeof s in
             match T with
               | (var -> _) -> ?term -> ?term =>
                 let inst := fresh "inst" in
                 (* assert(inst : Subst term);[
                     now eauto with typeclass_instances | *)
                     first[
                         progress cutrewrite (s = subst);[idtac|reflexivity] |
                         progress cutrewrite (s = rename);[idtac|reflexivity] ]
               | (var -> ?term) =>
                 (*assert(Subst term);[
                     now eauto with typeclass_instances | *)
                         progress cutrewrite (s = Var);[idtac|reflexivity]
             end
         end
.

Ltac ssimpl'H H :=
  try unfold rename in H;
  try unfold subst in H;
  simpl in H;
  repeat (
      let T := typeof H in
      match T with context[?s] =>
        first[
            progress change s with Var in H
          | progress change s with rename in H
          | progress change s with subst in H
          ]
      end
    ).

Ltac ssimpl :=
  repeat(
     msimpl;
     ssimpl';
     try(autorewrite with subst; [idtac | now eauto with typeclass_instances ..])
    ); trivial.

Ltac ssimplH H :=
  repeat(
     msimplH H;
     ssimpl'H H;
      autorewrite with subst in H; [idtac | now eauto with typeclass_instances ..]
    ); trivial.

Tactic Notation "ssimpl" "in" ident(H) := ssimplH H.

Tactic Notation "ssimpl" "in" "*" := (in_all ssimplH); ssimpl.

Ltac gen_rename :=
fix rename 2; intros xi s;
destruct s eqn:E;
let term := typeof s in
match goal with
    [E : s = ?s' |- _] =>
    let rec map s :=
        (match s with
             ?s1 ?s2 =>
             let s1' := map s1 in
             let s2_T := typeof s2 in
             let s2' := match s2_T with
                         | term => constr:(rename xi s2)
                         | bind term => constr:(rename (upr xi) s2)
                         | var => constr:(xi s2)
                         | _ => s2
                       end in
             constr:(s1' s2')
           | _ => s end) in
    let t' := map s' in
    exact t'
end.

Ltac has_var s :=
  match s with
    | ?s1 ?s2 =>
      match has_var s1 with
        | Some ?x => constr:(Some x)
        | _ =>
          match typeof s2 with
            | var => constr:(Some s2)
            | _ => None
          end
      end
    | _ => None
  end.

Notation "'_up_' ( rename , Var , sigma )" :=
  ((Var 0) .: (rename (+1) \o sigma)) (only parsing).

Ltac gen_subst Var rename :=
fix subst 2; intros sigma s;
destruct s eqn:E;
let term := typeof s in
match goal with
    [E : s = ?s' |- _] =>
    let rec map s :=
        (match s with
             ?s1 ?s2 =>
             let s1' := map s1 in
             let s2_T := typeof s2 in
             let s2' := match s2_T with
                         | term => constr:(subst sigma s2)
                         | bind term => constr:(subst (_up_(rename, Var, sigma)) s2)
                         | var => constr:(sigma s2)
                         | _ => s2
                       end in
             constr:(s1' s2')
           | _ => s end) in
    match has_var s' with
        | Some ?v => exact (sigma v)
        | _ => let t' := map s' in try exact t'
    end
end.

Ltac app_var := match goal with [ |- var] => assumption end.

Ltac gen_Subst :=
match goal with [|- Subst ?term] =>
assert (Var : var -> term); [intro; solve[constructor 1; [app_var] | constructor 2; [app_var] | constructor 3; [app_var] | constructor 4; [app_var] | constructor 5; [app_var] | constructor 6; [app_var] | constructor 7; [app_var] | constructor 8; [app_var] | constructor 9; [app_var] | constructor 10; [app_var] | constructor 11; [app_var] | constructor 12; [app_var] | constructor 13; [app_var] | constructor 14; [app_var] | constructor 15; [app_var] | constructor 16; [app_var] | constructor 17; [app_var] | constructor 18; [app_var] | constructor 19; [app_var] | constructor 20] | idtac];
assert (rename : (var -> var) -> term -> term ); [gen_rename | ..];
assert (subst : (var -> term) -> term -> term); [gen_subst Var rename | ..];
refine (Build_Subst _ Var rename subst)
end.

Ltac gen_SubstLemmas :=
repeat match goal with [H : _ |- _] => clear H end;
match goal with [ |- @SubstLemmas ?term ?subst_funs] =>
let rename := constr:(@rename term subst_funs) in
let subst := constr:(@subst term subst_funs) in
let Var := constr:(@Var term subst_funs) in
assert(rename_subst : forall xi : var -> var, rename xi = subst (ren xi));[
let xi := fresh "xi" in intros xi;
f_ext;
let s := fresh "s" in intros s;
revert xi; induction s;
intros; ssimpl'; f_equal; eauto;
autorew; ssimpl; f_equal; f_ext;
let x := fresh "x" in intros x; now destruct x
| idtac];

assert(subst_id : forall s : term, subst Var s = s);[
let s := fresh "s" in intros s; induction s;
ssimpl'; f_equal; eauto;
match goal with [H : _ |- _ ] => rewrite <- H end;
f_equal; solve[ f_ext; intros [|]; reflexivity | assumption]
| idtac];

assert(id_subst : forall (x : var) (sigma : var -> term), subst sigma (Var x) = sigma x);
[intros; reflexivity | idtac];
assert(rename_subst_comp : forall s sigma xi, (rename xi s).[sigma] = s.[ren xi >> sigma]);[
let s := fresh "s" in intros s; induction s;
intros; ssimpl'; f_equal; eauto; ssimpl';
autorew; f_equal; f_ext; intros [|]; reflexivity
| idtac];

assert(rename_comp : forall xi1 xi2 x, rename xi1 (rename xi2 x) = rename (fun x => xi1(xi2 x)) x);[
intros; rewrite rename_subst;
rewrite rename_subst_comp; now rewrite rename_subst
| idtac];

assert(up_rename_comm: forall sigma xi, up (sigma >> (ren xi)) = up sigma >> (ren (upr xi)));[
intros; f_ext; intros [|]; ssimpl'; trivial;
intros; repeat rewrite <- rename_subst; now repeat rewrite rename_comp
| idtac];

assert(subst_rename_comp : forall s sigma xi, rename xi s.[sigma] = s.[sigma >> (ren xi)]);[
let s := fresh "s" in intros s; induction s; unfold funcomp in *;
solve[
match goal with [x : var |- _ ] => destruct x; ssimpl'; intros; now rewrite rename_subst end |
intros; ssimpl'; unfold funcomp; f_equal; now autorew]
| idtac];

assert(subst_up_S : forall sigma s, rename S s.[sigma] = (rename S s).[up sigma]);[
intros;
rewrite subst_rename_comp; rewrite rename_subst_comp;
f_equal; f_ext; intros; ssimpl'; now rewrite rename_subst
| idtac];

assert(subst_comp : forall (s : term) (sigma tau : var -> term),
                 subst tau (subst sigma s) =
                 subst (fun x : var => subst tau (sigma x)) s );[
intros s; induction s; intros; ssimpl'; f_equal; autorew; f_equal; trivial;
f_ext; intros [|]; intros; ssimpl'; autorew; trivial; repeat rewrite <- rename_subst; now autorew
| idtac];

constructor; assumption
end.
(*
Inductive term : Type :=
| Universe : nat -> term
| Lam : term -> bind term -> term
| CCVar : var -> term
| Prod : term -> bind term -> term
| App : term -> term -> term
.

Instance SubstTerm : Subst term.
gen_Subst. Defined.

Instance SubstLemmasTerm : SubstLemmas term SubstTerm.
gen_SubstLemmas. Defined.

Lemma beta_subst (s t : term) sigma :
  s.[t .: Var].[sigma] = s.[Var 0 .: sigma >> lift].[t.[sigma] .: Var]. now ssimpl. Qed.
*)


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export pointer_bits.

Inductive bit (K : iType) : iType :=
  | BIndet : bit K
  | BBit : bool → bit K
  | BPtr : ptr_bit K → bit K.
Arguments BIndet {_}.
Arguments BBit {_} _.
Arguments BPtr {_} _.
#[global] Instance bit_eq_dec `{EqDecision K}: EqDecision (bit K).
Proof. solve_decision. Defined.

#[global] Instance maybe_BBit {K} : Maybe (@BBit K) := λ b,
  match b with BBit b => Some b | _ => None end.
#[global] Instance maybe_BPtr {K} : Maybe (@BPtr K) := λ b,
  match b with BPtr pb => Some pb | _ => None end.

Section operations.
  Context `{Env K}.

  Inductive bit_valid' (Γ : env K) (Δ : memenv K) : bit K → Prop :=
    | BIndet_valid' : bit_valid' Γ Δ BIndet
    | BBit_valid' β : bit_valid' Γ Δ (BBit β)
    | BPtr_valid' pb : ✓{Γ,Δ} pb → bit_valid' Γ Δ (BPtr pb).
  Global Instance bit_valid:
    Valid (env K * memenv K) (bit K) := uncurry bit_valid'.

  Inductive bit_weak_refine : relation (bit K) :=
    | bit_weak_refine_refl b : bit_weak_refine b b
    | BIndet_weak_refine b : bit_weak_refine BIndet b.
  Definition bit_join (b1 b2 : bit K) : option (bit K) :=
    match b1, b2 with
    | BIndet, b2 => Some b2
    | b1, BIndet => Some b1
    | b1, b2 => guard (b1 = b2); Some b1
    end.
  Fixpoint bits_join (bs1 bs2 : list (bit K)) : option (list (bit K)) :=
    match bs1, bs2 with
    | [], [] => Some []
    | b1 :: bs1, b2 :: bs2 =>
       b3 ← bit_join b1 b2; bs3 ← bits_join bs1 bs2; Some (b3 :: bs3)
    | _, _ => None
    end.
  Fixpoint bits_list_join (sz : nat)
      (bss : list (list (bit K))) : option (list (bit K)) :=
    match bss with
    | [] => Some (replicate sz BIndet)
    | bs :: bss => bits_list_join sz bss ≫= bits_join (resize sz BIndet bs)
    end.
End operations.

Section bits.
Context `{EnvSpec K}.
Implicit Types Γ : env K.
Implicit Types Δ : memenv K.
Implicit Types α β : bool.
Implicit Types βs : list bool.
Implicit Types pb : ptr_bit K.
Implicit Types b : bit K.
Implicit Types bs : list (bit K).

Local Infix "⊑" := bit_weak_refine (at level 70).
Local Infix "⊑*" := (Forall2 bit_weak_refine) (at level 70).
Local Hint Extern 0 (_ ⊑ _) => reflexivity: core.
Local Hint Extern 0 (_ ⊑* _) => reflexivity: core.

#[global] Instance bit_valid_dec ΓΔ (b : bit K) : Decision (✓{ΓΔ} b).
Proof.
 refine
  match b with
  | BIndet | BBit _ => left _ | BPtr pb => cast_if (decide (✓{ΓΔ} pb))
  end; destruct ΓΔ; first [by constructor | abstract by inversion 1].
Defined.
#[global] Instance: Inj (=) (=) (@BBit K).
Proof. by injection 1. Qed.
#[global] Instance: Inj (=) (=) (@BPtr K).
Proof. by injection 1. Qed.
Lemma BIndet_valid Γ Δ : ✓{Γ,Δ} BIndet.
Proof. constructor. Qed.
Lemma BIndets_valid Γ Δ bs : Forall (BIndet =.) bs → ✓{Γ,Δ}* bs.
Proof. by induction 1; simplify_equality'; repeat constructor. Qed.
Lemma BBit_valid Γ Δ β : ✓{Γ,Δ} (BBit β).
Proof. constructor. Qed.
Lemma BPtr_valid Γ Δ pb : ✓{Γ,Δ} pb → ✓{Γ,Δ} (BPtr pb).
Proof. by constructor. Qed.
Lemma BPtrs_valid Γ Δ pbs : ✓{Γ,Δ}* pbs → ✓{Γ,Δ}* (BPtr <$> pbs).
Proof. induction 1; csimpl; auto using BPtr_valid. Qed.
Lemma BPtr_valid_inv Γ Δ pb : ✓{Γ,Δ} (BPtr pb) → ✓{Γ,Δ} pb.
Proof. by inversion 1. Qed.
Lemma BPtrs_valid_inv Γ Δ pbs : ✓{Γ,Δ}* (BPtr <$> pbs) → ✓{Γ,Δ}* pbs.
Proof.
  induction pbs; inversion_clear 1; constructor; auto using BPtr_valid_inv.
Qed.
Lemma bit_valid_weaken Γ1 Γ2 Δ1 Δ2 b :
  ✓ Γ1 → ✓{Γ1,Δ1} b → Γ1 ⊆ Γ2 → Δ1 ⇒ₘ Δ2 → ✓{Γ2,Δ2} b.
Proof. destruct 2; econstructor; eauto using ptr_bit_valid_weaken. Qed.

Lemma maybe_BBits_spec bs βs : mapM (maybe BBit) bs = Some βs ↔ bs = BBit <$> βs.
Proof.
  split.
  * intros ?. symmetry; apply (mapM_fmap_Some_inv _ _ _ _ H1).
    by intros [] ? ?; simplify_equality'.
  * intros ->. by apply mapM_fmap_Some.
Qed.
#[global] Instance BBits_dec bs : Decision (∃ βs, bs = BBit <$> βs).
Proof.
 refine (cast_if (decide (is_Some (mapM (maybe BBit) bs))));
  abstract (by setoid_rewrite <-maybe_BBits_spec).
Defined.
Lemma maybe_BPtrs_spec bs pbs :
  mapM (maybe BPtr) bs = Some pbs ↔ bs = BPtr <$> pbs.
Proof.
  split.
  * intros ?. symmetry; apply (mapM_fmap_Some_inv _ _ _ _ H1).
    by intros [] ? ?; simplify_equality'.
  * intros ->. by apply mapM_fmap_Some.
Qed.
#[global] Instance BPtrs_dec bs : Decision (∃ pbs, bs = BPtr <$> pbs).
Proof.
 refine (cast_if (decide (is_Some (mapM (maybe BPtr) bs))));
  abstract (by setoid_rewrite <-maybe_BPtrs_spec).
Defined.

(** ** Weak Refinements *)
#[global] Instance: PartialOrder (@bit_weak_refine K).
Proof.
  repeat split.
  * intros ?; constructor.
  * destruct 1. done. constructor.
  * by destruct 1; inversion 1.
Qed.
Lemma bits_subseteq_eq bs1 bs2 : bs1 ⊑* bs2 → bs1 = bs2 ∨ BIndet ∈ bs1.
Proof.
  induction 1 as [|???? [] ? IH]; rewrite ?elem_of_cons; naive_solver.
Qed.
Lemma bits_subseteq_indet bs1 bs2 : BIndet ∈ bs1 → bs2 ⊑* bs1 → BIndet ∈ bs2.
Proof.
  intros Hbs. induction 1 as [|????[]];
    rewrite ?elem_of_cons in Hbs |- *; naive_solver.
Qed.
Lemma bits_subseteq_indets bs1 bs2 :
  Forall (BIndet =.) bs2 → bs1 ⊑* bs2 → bs1 = bs2.
Proof. induction 2 as [|???? []]; decompose_Forall_hyps; f_equal; auto. Qed.
Lemma bit_join_valid Γ Δ b1 b2 b3 :
  bit_join b1 b2 = Some b3 → ✓{Γ,Δ} b1 → ✓{Γ,Δ} b2 → ✓{Γ,Δ} b3.
Proof. destruct 2,1; simplify_option_eq; constructor; auto. Qed.
#[global] Instance: Comm (@eq (option (bit K))) bit_join.
Proof. intros [] []; intros; simplify_option_eq; auto. Qed.
Lemma bit_join_indet_l b : bit_join BIndet b = Some b.
Proof. by destruct b; simplify_option_eq. Qed.
Lemma bit_join_indet_r b : bit_join b BIndet = Some b.
Proof. by destruct b; simplify_option_eq. Qed.
Lemma bit_join_diag b : bit_join b b = Some b.
Proof. by destruct b; simplify_option_eq. Qed.
Lemma bit_join_Some_l b1 b2 b3 : bit_join b1 b2 = Some b3 → b1 ⊑ b3.
Proof. destruct b1, b2; intros; simplify_option_eq; constructor. Qed.
Lemma bit_join_Some_r b1 b2 b3 : bit_join b1 b2 = Some b3 → b2 ⊑ b3.
Proof. destruct b1, b2; intros; simplify_option_eq; constructor. Qed.
Lemma bit_join_exists b1 b2 b4 :
  b1 ⊑ b4 → b2 ⊑ b4 → ∃ b3, bit_join b1 b2 = Some b3 ∧ b3 ⊑ b4.
Proof.
  destruct 1; inversion_clear 1; eauto using
    bit_join_diag, bit_join_indet_l, bit_join_indet_r, BIndet_weak_refine.
Qed.

Lemma bits_join_valid Γ Δ bs1 bs2 bs3 :
  bits_join bs1 bs2 = Some bs3 → ✓{Γ,Δ}* bs1 → ✓{Γ,Δ}* bs2 → ✓{Γ,Δ}* bs3.
Proof.
  intros Hbs Hbs1. revert bs2 bs3 Hbs. induction Hbs1; destruct 2;
    simplify_option_eq; constructor; eauto using bit_join_valid.
Qed.
#[global] Instance: Comm (@eq (option (list (bit K)))) bits_join.
Proof.
  intros bs1. induction bs1 as [|b1 bs1 IH]; intros [|b2 bs2]; simpl; try done.
  rewrite (comm bit_join). by destruct bit_join; simpl; rewrite ?IH.
Qed.
Lemma bits_join_indet_l bs :
  bits_join (replicate (length bs) BIndet) bs = Some bs.
Proof. induction bs as [|b bs IH]; simpl; [done|]. by rewrite IH. Qed.
Lemma bits_join_indet_r bs :
  bits_join bs (replicate (length bs) BIndet) = Some bs.
Proof. rewrite (comm bits_join). apply bits_join_indet_l. Qed.
Lemma bits_join_diag bs : bits_join bs bs = Some bs.
Proof. by induction bs as [|b bs IH]; simpl; rewrite ?bit_join_diag, ?IH. Qed.
Lemma bits_join_Some_l bs1 bs2 bs3 : bits_join bs1 bs2 = Some bs3 → bs1 ⊑* bs3.
Proof.
  revert bs2 bs3. induction bs1; intros [|??] [|??] ?;
    simplify_option_eq; constructor; eauto using bit_join_Some_l.
Qed.
Lemma bits_join_Some_r bs1 bs2 bs3 : bits_join bs1 bs2 = Some bs3 → bs2 ⊑* bs3.
Proof.
  revert bs2 bs3. induction bs1; intros [|??] [|??] ?;
    simplify_option_eq; constructor; eauto using bit_join_Some_r.
Qed.
Lemma bits_join_exists bs1 bs2 bs4 :
  bs1 ⊑* bs4 → bs2 ⊑* bs4 → ∃ bs3, bits_join bs1 bs2 = Some bs3 ∧ bs3 ⊑* bs4.
Proof.
  intros Hbs14. revert bs2. induction Hbs14 as [|b1 b4 bs1 bs4 ?? IH];
    inversion_clear 1 as [|b2]; [by eexists []|].
  edestruct IH as (?&Hbs2&?); eauto.
  edestruct (bit_join_exists b1 b2 b4) as (?&Hb2&?); eauto.
  simpl; rewrite Hbs2; simpl; rewrite Hb2; csimpl; eauto.
Qed.
Lemma bits_join_min bs1 bs2 bs3 bs4 :
  bits_join bs1 bs2 = Some bs3 → bs1 ⊑* bs4 → bs2 ⊑* bs4 → bs3 ⊑* bs4.
Proof. intros. destruct (bits_join_exists bs1 bs2 bs4); naive_solver. Qed.
Lemma bits_join_length_l bs1 bs2 bs3 :
  bits_join bs1 bs2 = Some bs3 → length bs3 = length bs1.
Proof.
  revert bs2 bs3. induction bs1; intros [|??] ??;
    simplify_option_eq; f_equal; eauto.
Qed.
Lemma bits_join_length_r bs1 bs2 bs3 :
  bits_join bs1 bs2 = Some bs3 → length bs3 = length bs2.
Proof. rewrite (comm bits_join). apply bits_join_length_l. Qed.

Lemma bits_list_join_length sz bss bs :
  bits_list_join sz bss = Some bs → length bs = sz.
Proof.
  revert bs. induction bss; intros; simplify_option_eq.
  * by rewrite replicate_length.
  * erewrite bits_join_length_r by eauto; eauto.
Qed.
Lemma bits_list_join_valid Γ Δ sz bss bs :
  bits_list_join sz bss = Some bs → Forall (✓{Γ,Δ}*) bss → ✓{Γ,Δ}* bs.
Proof.
  intros Hbs Hbss. revert bs Hbs.
  induction Hbss as [|bs' bss IH]; intros bs Hbs; simplify_equality'.
  { eauto using Forall_replicate, BIndet_valid. }
  destruct (bits_list_join sz bss) as [bs''|] eqn:Hbs'; simplify_equality'.
  eapply bits_join_valid; eauto using Forall_resize, BIndet_valid.
Qed.
Lemma bits_list_join_Some sz bss bs bs' :
  bits_list_join sz bss = Some bs → bs' ∈ bss → resize sz BIndet bs' ⊑* bs.
Proof.
  intros Hbs Hbs'. revert bs Hbs. induction Hbs'; intros;
    simplify_option_eq; eauto using bits_join_Some_l.
  etransitivity; [|eapply bits_join_Some_r; eauto]; eauto.
Qed.
Lemma bits_list_join_Some_alt sz bss bs :
  bits_list_join sz bss = Some bs →
  Forall (λ bs', resize sz BIndet bs' ⊑* bs) bss.
Proof. rewrite Forall_forall. eauto using bits_list_join_Some. Qed.
Lemma bits_list_join_exists sz bss bs' :
  length bs' = sz → Forall (λ bs, resize sz BIndet bs ⊑* bs') bss →
  ∃ bs, bits_list_join sz bss = Some bs ∧ bs ⊑* bs'.
Proof.
  induction 2 as [|bs bss ?? (bs2&Hbs2&?)]; simpl.
  { eauto using Forall2_replicate_l, Forall_true, BIndet_weak_refine. }
  destruct (bits_join_exists (resize sz BIndet bs) bs2 bs')
    as (bs3&Hbs3&?); auto. simplify_option_eq; eauto.
Qed.
Lemma bits_list_join_min sz bss bs bs' :
  length bs' = sz → bits_list_join sz bss = Some bs →
  Forall (λ bs'', resize sz BIndet bs'' ⊑* bs') bss → bs ⊑* bs'.
Proof.
  intros ? Hbs Hbss. revert bs Hbs.
  induction Hbss; intros; simplify_option_eq; eauto using
    Forall2_replicate_l, Forall_true, BIndet_weak_refine, bits_join_min.
Qed.
End bits.


From Transitions Require Import RelationDefs Rewriting.
From Classes Require Import Classes.

Import RelationNotations.

(*
Theorem seq_star_invariant A (r: relation A A unit) P :
  (test P;; r) ---> (test P;; r;; test P) ->
  (test P;; seq_star r) ---> (test P;; seq_star r;; test P).
Proof.
  intros.
  rewrite <- bind_assoc in H.
  apply simulation_seq in H.
  rewrite H.
  rewrite star_expand; norm.
  apply rel_or_elim_rx; norm.
  - setoid_rewrite <- seq_star_none; norm.
    rewrite test_idem; norm.
  - setoid_rewrite <- seq_star1 at 2; norm.
    setoid_rewrite test_to_id at 2; norm.
Qed.
*)

Fixpoint seq_rep_n {A T} (n: nat) (p: relation A A T) : relation A A T :=
  match n with
  | O => identity
  | S n' => p ;; seq_rep_n n' p
  end.

Fixpoint bind_rep_n {A T} (n: nat) (p: T -> relation A A T) (o: T) : relation A A T :=
  match n with
  | O => pure o
  | S n' => x <- p o; bind_rep_n n' p x
  end.

Fixpoint bind_rep_r_n {A T} (n: nat) (p: T -> relation A A T) (o: T) : relation A A T :=
  match n with
  | O => pure o
  | S n' => x <- bind_rep_r_n n' p o; p x
  end.

Lemma seq_star_inv_rep_n A T (p: relation A A T) a1 a2:
  seq_star p a1 a2 ->
  exists n, seq_rep_n n p a1 a2.
Proof.
  induction 1.
  - exists O. do 2 econstructor.
  - destruct IHseq_star as (n&?). exists (S n). destruct_return.
    * simpl. econstructor. do 2 eexists; intuition eauto.
    * simpl. right. do 2 eexists; intuition eauto.
  - exists 1. econstructor; eauto.
Qed.

Lemma bind_star_inv_rep_n A T (p: T -> relation A A T) (o: T) a1 a2:
  bind_star p o a1 a2 ->
  exists n, bind_rep_n n p o a1 a2.
Proof.
  induction 1.
  - exists O; firstorder.
  - destruct IHbind_star as (n&?). exists (S n). destruct_return.
    * simpl. do 2 eexists; intuition eauto.
    * simpl. right. do 2 eexists; intuition eauto.
  - exists 1. econstructor; eauto.
Qed.

Lemma bind_star_rep_n_to_bind_star A T (p: T -> relation A A T) (o: T) a1 a2 n:
  bind_rep_n n p o a1 a2 ->
  bind_star p o a1 a2.
Proof.
  revert o a1 a2. induction n; intros o a1 a2.
  - simpl. inversion 1; subst. apply bind_star_pure.
  - simpl. destruct_return.
    * intros (v&a'&?&?). econstructor; eauto.
    * intros [?|(?&?&?&?)].
      ** eapply bind_star_one_more_err; eauto.
      ** eapply bind_star_one_more_valid; eauto 10.
Qed.

Lemma seq_star_rep_n_ind {A1 A2 T1 T2} (p: relation A1 A2 T1) q (r: relation A1 A2 T2):
  (forall n, (p ;; seq_rep_n n q) ---> r) ->
  (p ;; seq_star q) ---> r.
Proof.
  intros.
  intros a1 a2 Hl.
  destruct_return.
  * destruct Hl as (t1&a2'&Hp&Hstar).
    eapply seq_star_inv_rep_n in Hstar as (n&?).
    eapply H; do 2 eexists; intuition eauto.
  * destruct Hl as [Hhd|(?&?&Hp&Hstar)].
    ** eapply (H O). left; eauto.
    ** eapply seq_star_inv_rep_n in Hstar as (n&?).
       eapply H. right. eauto.
Qed.

Lemma bind_star_rep_n_ind {A1 A2 T1} (p: relation A1 A2 T1) q (r: relation A1 A2 T1):
  (forall n, (o <- p; bind_rep_n n q o) ---> r) ->
  (o <- p; bind_star q o) ---> r.
Proof.
  intros.
  intros a1 a2 Hl.
  destruct_return.
  * destruct Hl as (t1&a2'&Hp&Hstar).
    eapply bind_star_inv_rep_n in Hstar as (n&?).
    eapply H; do 2 eexists; intuition eauto.
  * destruct Hl as [Hhd|(?&?&Hp&Hstar)].
    ** eapply (H O). left; eauto.
    ** eapply bind_star_inv_rep_n in Hstar as (n&?).
       eapply H. right. eauto.
Qed.

Theorem bind_rep_r_n_err_inv A T (r: T -> relation A A T) n o a:
  bind_rep_r_n n r o a (@Err _ _) ->
  exists n' o' a', n' <= n /\
  bind_rep_r_n n' r o a (Val a' o') /\
  r o' a' (@Err _ _).
Proof.
  induction n.
  - inversion 1.
  - intros [Hleft|(o'&a'&?)].
    * edestruct IHn as (n'&o'&a'&?); eauto.
      exists n', o', a'. intuition.
    * exists n, o', a'. intuition.
Qed.

Lemma seq_star_alt A T r (x : A) (y: Return A T):
  seq_star r x y <-> (exists n, seq_rep_n n r x y).
Proof.
  split.
  - induction 1.
    * exists O. econstructor; eauto.
    * destruct IHseq_star as (n&Hseq).
      exists (S n). destruct_return.
      ** econstructor; eauto.
      ** right. eauto 10.
    * exists (S O). econstructor; eauto.
  - intros (n&Hseq). revert x y Hseq.
    induction n; intros x y Hseq.
    * inversion Hseq; subst; econstructor.
    * destruct_return.
      ** destruct Hseq as (t'&?&?&?).
         econstructor; eauto.
      ** destruct Hseq as [Hhd|(?&?&?&?)].
         *** eapply seq_star_one_more_err; eauto.
         *** eapply seq_star_one_more_valid; eauto.
Qed.

Lemma bind_rep_lr_n A T (r: T -> relation A A T) o n:
  bind_rep_n n r o <---> bind_rep_r_n n r o.
Proof.
  revert o. induction n; intros o.
  { reflexivity. }
  simpl. setoid_rewrite IHn. clear.
  induction n.
  - simpl. rew bind_right_id.
  - simpl. rew<- IHn.
Qed.

Lemma bind_rep_lr_n_val A T (r: T -> relation A A T) o n a a' o':
  bind_rep_n n r o a (Val a' o') <-> bind_rep_r_n n r o a (Val a' o').
Proof.
  revert o a a' o'. induction n; intros o a a' o'.
  { reflexivity. }
  split.
  - intros (omid&amid&Hr&Hn). eapply IHn in Hn.
    clear -Hr Hn. revert o a amid omid a' o' Hr Hn.  induction n; intros.
    * inversion Hn; subst. do 2 eexists; split; eauto.
      econstructor.
    * destruct Hn as (omid''&amid''&?&?).
      eapply IHn in H; eauto. do 2 eexists; split; eauto.
  - intros (omid&amid&Hn&Hr). eapply IHn in Hn.
    clear -Hr Hn. revert o a amid omid a' o' Hr Hn.  induction n; intros.
    * inversion Hn; subst. do 2 eexists; split; eauto.
      econstructor.
    * destruct Hn as (omid''&amid''&?&?).
      eapply IHn in H0; eauto. do 2 eexists; split; eauto.
Qed.

Lemma bind_star_alt A T r (x : A) o (y: Return A T):
  bind_star r o x y <-> (exists n, bind_rep_n n r o x y).
Proof.
  split.
  - induction 1.
    * exists O. econstructor; eauto.
    * destruct IHbind_star as (n&Hseq).
      exists (S n). destruct_return.
      ** econstructor; eauto.
      ** right. eauto 10.
    * exists (S O). econstructor; eauto.
  - intros (n&Hseq). revert o x y Hseq.
    induction n; intros o x y Hseq.
    * inversion Hseq; subst; econstructor.
    * destruct_return.
      ** destruct Hseq as (t'&?&?&?).
         eapply bind_star_one_more_valid; eauto.
      ** destruct Hseq as [Hhd|(?&?&?&?)].
         *** eapply bind_star_one_more_err; eauto.
         *** eapply bind_star_one_more_valid; eauto.
Qed.

Lemma seq_star_mid_invariant A (p: relation A A unit) (q: relation A A unit) P:
  (test P;; p) ---> (q ;; test P) ->
  (q;; seq_star q) ---> q ->
  (q;; test P;; seq_star p) ---> (q;; test P).
Proof.
  intros Hinv Htrans.
  setoid_rewrite <-bind_assoc.
  apply seq_star_rep_n_ind.
  induction n.
  - simpl. rewrite bind_assoc.
    setoid_rewrite unit_identity.
    setoid_rewrite bind_right_id_unit.
    reflexivity.
  - simpl. setoid_rewrite bind_assoc.
    setoid_rewrite <-bind_assoc at 2.
    setoid_rewrite Hinv.
    setoid_rewrite IHn.
    setoid_rewrite <-bind_assoc.
    setoid_rewrite <-(seq_star1) in Htrans.
    setoid_rewrite <-(seq_star_none) in Htrans.
    setoid_rewrite unit_identity in Htrans.
    setoid_rewrite bind_right_id_unit in Htrans.
    rew Htrans.
Qed.

Lemma any_seq_star_any A T:
  (@any A A T;; seq_star (@any A A T)) ---> any.
Proof.
  eapply seq_star_rep_n_ind.
  induction n; simpl.
  - firstorder.
  - setoid_rewrite IHn.
    apply any_idem.
Qed.

Theorem bind_star_ind_r A B T1 (q x: relation A B T1) (p: T1 -> relation B B T1) :
  q + and_then x p ---> x ->
  and_then q (bind_star p) ---> x.
Proof.
  intros Himpl.
  assert (q ---> x) as ->.
  { rew<- Himpl. Left. }
  assert (and_then x p ---> x) as Himpl'.
  { setoid_rewrite <-Himpl at 2. Right. }
  eapply bind_star_rep_n_ind. intros n.
  induction n.
  - simpl. rew bind_right_id.
  - simpl. setoid_rewrite <-bind_assoc. rew Himpl'. eauto.
Qed.

Theorem bind_star_ind_r_pure A T1 t (x: relation A A T1) (p: T1 -> relation A A T1):
  (pure t) + and_then x p ---> x ->
  bind_star p t ---> x.
Proof.
  specialize (@bind_star_ind_r A A _ (pure t) x p).
  setoid_rewrite bind_left_id; auto.
Qed.

Theorem simulation_seq A B
        (p: relation A B unit)
        (q: relation B B unit)
        (r: relation A A unit) :
  (p;; q) ---> (r;; p) ->
  (p;; seq_star q) ---> (seq_star r;; p).
Proof.
  intros Hconv.
  apply seq_star_rep_n_ind. intros n.

  induction n. simpl.
  - setoid_rewrite <-seq_star_none.
    rew unit_identity.
    rew bind_right_id_unit.
  - simpl.
    setoid_rewrite <-bind_assoc.
    rew Hconv. rew IHn.
    setoid_rewrite <-bind_assoc.
    setoid_rewrite seq_star_fold; reflexivity.
Qed.

Theorem simulation_seq_value A B T (_:Default T)
        (p: relation A B unit)
        (q: relation B B T)
        (r: relation A A T) :
  (p;; q) ---> (v <- r; (p;; pure v)) ->
  (p;; seq_star q) ---> (v <- seq_star r; (p;; pure v)).
Proof.
  intros Hconv.
  apply seq_star_rep_n_ind. intros n.

  induction n. simpl.
  - setoid_rewrite <-seq_star_none.
    intros a1 a2. destruct_return.
    * intros ([]&?&?&?).
      right.
      do 2 eexists; split; eauto.
      econstructor; eauto.
      do 2 eexists; split; eauto.
      inversion H0; subst. inversion H1; subst.
      econstructor; eauto.
    * intros [?|([]&?&?&?)].
      ** left. right.
         unshelve (do 2 eexists; split; eauto; econstructor; eauto); eauto.
      ** inversion H0; congruence.
  - simpl.
    setoid_rewrite <-bind_assoc.
    rew Hconv. rew IHn.
    setoid_rewrite <-bind_assoc.
    setoid_rewrite seq_star_fold; reflexivity.
Qed.

Theorem simulation_seq_value_no_err A B T
        (p: relation A B unit)
        (q: relation B B T)
        (r: relation A A T) :
  (forall a, p a (Err _ _) -> False) ->
  (p;; q) ---> (v <- r; (p;; pure v)) ->
  (p;; seq_star q) ---> (v <- seq_star r; (p;; pure v)).
Proof.
  intros Herr Hconv.
  apply seq_star_rep_n_ind. intros n.

  induction n. simpl.
  - setoid_rewrite <-seq_star_none.
    intros a1 a2. destruct_return.
    * intros ([]&?&?&?).
      right.
      do 2 eexists; split; eauto.
      econstructor; eauto.
      do 2 eexists; split; eauto.
      inversion H0; subst. inversion H1; subst.
      econstructor; eauto.
    * intros [?|([]&?&?&?)].
      ** exfalso; eauto.
      ** inversion H0; congruence.
  - simpl.
    setoid_rewrite <-bind_assoc.
    rew Hconv. rew IHn.
    setoid_rewrite <-bind_assoc.
    setoid_rewrite seq_star_fold; reflexivity.
Qed.

Theorem bind_pure_no_err A B C T (p: relation A B T) (f: T -> C) a:
  (x <- p; pure (f x)) a (@Err _ _) ->
  p a (@Err _ _).
Proof.
  eapply bind_with_no_err; intros; eapply pure_no_err; eauto.
Qed.

Lemma fst_lift_non_err {A1 A2 B T} (r: relation A1 A2 T) s (b : B) :
  ~ r s (@Err _ _) ->
  ~ fst_lift r (s, b) (@Err _ _).
Proof. intuition. Qed.

Lemma snd_lift_non_err {A1 A2 B T} (r: relation A1 A2 T) s (b : B) :
  ~ r s (@Err _ _) ->
  ~ snd_lift r (b, s) (@Err _ _).
Proof. intuition. Qed.


(** ** Common Definitions for Operator Overloading *)

Definition SuchThat(R: Type)(P: R -> Prop) := R.
Existing Class SuchThat.

Notation "'annotate!' x T" := (match x return T with b => b end)
  (at level 10, x at level 0, T at level 0, only parsing).

Notation "'infer!' P" :=
  (match _ as ResType return ResType with
   | ResType =>
       match P with
       | Fun => annotate! (annotate! _ (SuchThat ResType Fun)) ResType
       end
   end)
  (at level 0, P at level 100, only parsing).

Global Hint Extern 1 (SuchThat ?RRef ?FRef) =>
  let R := eval cbv delta [RRef] in RRef in
  let r := open_constr:(_ : R) in
  let G := eval cbv beta delta [RRef FRef] in (FRef r) in
  let t := open_constr:(ltac:(cbv beta; typeclasses eauto) : G) in
  match r with
  | ?y => exact y (* match gets rid of type annotation *)
  end
: typeclass_instances.

Declare Scope oo_scope. (* Operator-overloading notation scope *)

(* syntactic reflexivity, for tests *)
Ltac srefl :=
  lazymatch goal with
  | |- ?x = ?y => constr_eq x y; reflexivity
  end.

(** ** Definition of Overloadable Operators *)

(* In most cases, A=B=R, but for pair types like (nat * Type), we'd get a universe
   inconsistency (while (Type * nat) works), and it might also be useful to allow
   eg A=Z, B=nat, C=Z and have the hints insert a coercion from nat to Z. *)
Class Multiplication{A B R: Type}(a: A)(b: B)(r: R) := {}.
(* Note: a and b are not really outputs, but we still mark them as outputs so that
   (@Multiplication Z Z _ ?evar1 ?evar2 _) can be resolved with (Z.mul ?evar1 ?evar2) *)
Global Hint Mode Multiplication ! ! - - - - : typeclass_instances.
Notation "a * b" := (infer! Multiplication a b) (only parsing) : oo_scope.

Class Addition{A B R: Type}(a: A)(b: B)(r: R) := {}.
Global Hint Mode Addition ! ! - - - - : typeclass_instances.
Notation "a + b" := (infer! Addition a b) (only parsing) : oo_scope.

Class Subtraction{A B R: Type}(a: A)(b: B)(r: R) := {}.
(* Note: a and b are not really outputs, but we still mark them as outputs so that
   (@Subtraction Z Z _ ?evar1 ?evar2 _) can be resolved with (Z.mul ?evar1 ?evar2) *)
Global Hint Mode Subtraction ! ! - - - - : typeclass_instances.
Notation "a - b" := (infer! Subtraction a b) (only parsing) : oo_scope.

Notation "a =? b" := (infer! BoolSpec (a = b) (a <> b))
  (at level 70, only parsing) : oo_scope.

Class BracketGet{A B C: Type}(a: A)(b: B)(c: C) := {}.
Global Hint Mode BracketGet ! ! - - - - : typeclass_instances.
Notation "a [ i ]" := (infer! (BracketGet a i))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

Class BracketSet{R1 R2 Key Value: Type}(r1: R1)(k: Key)(v: Value)(r2: R2) := {}.
Global Hint Mode BracketSet ! - ! + ! ! + - : typeclass_instances.
Notation "a [ i := v ]" := (infer! (BracketSet a i v))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

Class BracketUpdate{R1 R2 K V1 V2: Type}(r1: R1)(k: K)(f: V1 -> V2)(r2: R2) := {}.
Global Hint Mode BracketUpdate ! - ! + + + ! + - : typeclass_instances.
Notation "a [ i ::= f ]" := (infer! (BracketUpdate a i f))
  (at level 8, i at level 99, left associativity, only parsing) : oo_scope.

(* List literal notations from standard library don't work any more, so we use [| ... |].
   Note, though, that this breaks parsing of Ltac like `tac1; [tac2|]`, and separating
   the bracket and bar into two tokens would bring the notation in conflict with
   BracketGet/Set/Update again. *)
Notation "[| x |]" := (cons x nil) (format "[|  x  |]"): oo_scope.
Notation "[| x ; y ; .. ; z |]" :=
  (cons x (cons y .. (cons z nil) .. )) (format "[|  x ;  y ;  .. ;  z  |]") : oo_scope.

(* since list_scope should not be opened when using oo_scope, we add ++ to oo_scope: *)
Infix "++" := Coq.Init.Datatypes.app : oo_scope.

Goal True /\ True.
  split; [ |exact I]. (* space between [ and | is required *)
Abort.

(** ** Common arithmetic operator instances *)

Require Import Coq.ZArith.ZArith.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.

#[export] Instance MulNat(a b: nat): Multiplication a b (Nat.mul a b) := {}.
Notation "a * b" := (Nat.mul a b) (only printing) : oo_scope.

#[export] Instance MulN(a b: N): Multiplication a b (N.mul a b) := {}.
Notation "a * b" := (N.mul a b) (only printing) : oo_scope.

#[export] Instance MulZ(a b: Z): Multiplication a b (Z.mul a b) := {}.
Notation "a * b" := (Z.mul a b) (only printing) : oo_scope.

#[export] Instance MulTypeType(a b: Type): Multiplication a b (prod a b) := {}.
#[export] Instance MulTypeSet(a: Type)(b: Set): Multiplication a b (prod a b) := {}.
#[export] Instance MulSetType(a: Set)(b: Type): Multiplication a b (prod a b) := {}.
#[export] Instance MulSetSetSet(a: Set)(b: Set):
  @Multiplication Set Set Set a b (prod a b) | 5 := {}.
#[export] Instance MulSetSetType(a: Set)(b: Set):
  @Multiplication Set Set Type a b (prod a b) | 6 := {}.
Notation "a * b" := (prod a b) (only printing) : oo_scope.

#[export] Instance MulWord{width: Z}{word: word.word width}(a b: word):
  Multiplication a b (word.mul a b) := {}.
Notation "a * b" := (word.mul a b) (only printing) : oo_scope.

#[export] Instance AddNat(a b: nat): Addition a b (Nat.add a b) := {}.
Notation "a + b" := (Nat.add a b) (only printing) : oo_scope.

#[export] Instance AddN(a b: N): Addition a b (N.add a b) := {}.
Notation "a + b" := (N.add a b) (only printing) : oo_scope.

#[export] Instance AddZ(a b: Z): Addition a b (Z.add a b) := {}.
Notation "a + b" := (Z.add a b) (only printing) : oo_scope.

#[export] Instance AddWord{width: Z}{word: word.word width}(a b: word):
  Addition a b (word.add a b) := {}.
Notation "a + b" := (word.add a b) (only printing) : oo_scope.

#[export] Instance SubNat(a b: nat): Subtraction a b (Nat.sub a b) := {}.
Notation "a - b" := (Nat.sub a b) (only printing) : oo_scope.

#[export] Instance SubN(a b: N): Subtraction a b (N.sub a b) := {}.
Notation "a - b" := (N.sub a b) (only printing) : oo_scope.

#[export] Instance SubZ(a b: Z): Subtraction a b (Z.sub a b) := {}.
Notation "a - b" := (Z.sub a b) (only printing) : oo_scope.

#[export] Instance SubWord{width: Z}{word: word.word width}(a b: word):
  Subtraction a b (word.sub a b) := {}.
Notation "a - b" := (word.sub a b) (only printing) : oo_scope.

Require Import coqutil.Decidable. (* already defines several BoolSpec instances *)
Notation "a =? b" := (Nat.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (Byte.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (N.eqb a b) (only printing) : oo_scope.
Notation "a =? b" := (Z.eqb a b) (only printing) : oo_scope.

Section TestArith.
  (* Note: this one works by using the notation from nat_scope, which is open by default *)
  Goal forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z. intros. srefl. Abort.

  Local Open Scope bool_scope.
  Local Open Scope oo_scope.
  Local Set Printing Implicit.
  Local Set Printing Coercions.

  Goal Some (fun (m n: nat) => Some (m * n)) <> None. Abort.

  Goal Some (fun (m n: N) => m * n) <> None. Abort.

  Goal Some (forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z) <> None. Abort.

  Goal forall (m1 m2: nat) (n1 n2: N) (z1 z2: Z) (b1 b2: Byte.byte),
      (m1 =? m2) && (n1 =? n2) && (z1 =? z2) && (b1 =? b2) = false.
  Abort.

  Goal forall (m n: N), m * n = N.mul m n. intros. srefl. Abort.

  Goal forall (x y: N), x * y = N.mul x y. intros. srefl. Abort.

  Goal forall (x y z: nat), x * y * z = Nat.mul (Nat.mul x y) z. intros. srefl. Abort.
  Goal forall (x y: N), x * y = N.mul x y. intros. srefl. Abort.
  Goal forall (x y z: N), x * y * z = N.mul (N.mul x y) z. intros. srefl. Abort.
  Goal forall (w x y z: N), w * (x * y) * z = N.mul (N.mul w (N.mul x y)) z.
    intros. srefl.
  Abort.
  Goal forall (x: N), False.
    intros.
    assert_fails (pose (1%nat * x)).
    epose (x * (_ : N)).
    epose ((_ : N) * x).
    epose ((_ : N) * (_ : N) * (_ : N)).
    epose (x * (_ : N) * (_ : N)).
    epose ((_ : N) * x * (_ : N)).
    epose ((_ : N) * (_ : N) * x).
    epose (Some ((_: N) * (_: N))).
    epose (_ * x). (* doesn't infer the operator, but succeeds with (SuchThat ...) type *)
  Abort.

  Goal forall (x y: Z), x * y = y * x. intros. apply Z.mul_comm. Abort.
  Goal forall (x y z: Z), x * (y * z) = x * y * z. intros. apply Z.mul_assoc. Abort.

  Goal nat * Z = prod nat Z. srefl. Abort.
  Goal nat * Type = prod nat Type. srefl. Abort.
  Goal Type * nat = prod Type nat. srefl. Abort.
  Goal nat * Type * Set = prod (prod nat Type) Set. srefl. Abort.

  Context {word: word.word 32} {mem: map.map word Byte.byte}.

  Goal forall (x y: word), x * y = word.mul x y. intros. srefl. Abort.
  Goal forall (x y z: word), x * y * z = word.mul (word.mul x y) z.
    intros. srefl.
  Abort.

  Goal forall (x y z: word), Some (x * y * z) <> None. Abort.
  Goal forall (x y z: word), Some (x + y * z - x) = Some (x + (y * z) - x).
    intros. srefl.
  Abort.

  Goal forall (x y z: word) (a b: Z), False.
    intros.
    epose (cons (x * y) nil).
    epose (Some (x * y - z)).
    epose (cons (x * y) nil).
    epose (cons (y - z) nil).
    epose (x * y - z).
    epose (cons (x * y - z) nil).
    epose ((x * y) 1). (* works, but shelves unsatisfiable typeclass goals *)
    epose (cons (x * y - z) nil).
    epose (cons (x * y - z) (cons (word.of_Z (a - b))
                                   (cons (y + z * (word.of_Z (a * b))) nil))).
  Abort.
End TestArith.

(** ** Data access instances for records *)

(* Given a label l (field name) and a type R, returns a getter that
   projects l out of R *)
Class Getter{Label: Type}(l: Label)(R E: Type) :=
  get: R -> E.
Arguments get {Label} l {R E} {Getter} r.

(* Label, l, R are inputs, E is an output of typeclass search.
   For Label and label, we use `!` instead of `+` to require that just the
   head is not an evar, so that getters of parameterized records whose parameters
   are evars are allowed.
   For R, we conservatively choose `+`, but might relax it to `!` later. *)
Global Hint Mode Getter ! ! + - : typeclass_instances.

#[export]
Instance BracketGetFromGetter{R Label E: Type}(r: R)(label: Label){g: Getter label R E}:
  @BracketGet R Label E r label (@get Label label R E g r) := {}.
Notation "r [ label ]" := (get label r)
  (at level 8, label at level 99, left associativity, only printing) : oo_scope.

(* Given a key k (field name) and a type R1, returns an updater that applies
   a transformation function (of type V1 -> V2) to field k of R1.
   Usually V1=V2 and R1=R2, but some transformers might return a different V2
   than the V1 returned by the getter, which might change the container type
   from R1 to R2.
   Usually, k is a getter of R1, so K = R1->V1, but it might also be a getter
   of a superclass of R1, in which case K = Superclass->V1 *)
Class Updater{K: Type}(k: K)(R1 R2 V1 V2: Type) :=
  update: (V1 -> V2) -> R1 -> R2.
Arguments update {K} k {R1 R2 V1 V2} {Updater}.

(* For K and k, we use `!` instead of `+` to require that just the
   head is not an evar, so that getters of parameterized records whose parameters
   are evars are allowed. *)
Global Hint Mode Updater ! ! + - - - : typeclass_instances.

#[export] Instance BracketUpdateFromUpdater{R1 R2 Label V1 V2: Type}
 (r1: R1)(label: Label)(f: V1 -> V2){u: @Updater Label label R1 R2 V1 V2}:
  @BracketUpdate R1 R2 Label V1 V2 r1 label f (@update Label label R1 R2 V1 V2 u f r1) := {}.
Notation "r [ label ::= f ]" := (update label f r)
  (at level 8, label at level 99, left associativity,
   format "r [ label  ::=  f ]", only printing) : oo_scope.

Require Coq.Program.Basics.

#[export] Instance BracketSetFromUpdater{R1 R2 Label V1 V2: Type}
 (r1: R1)(label: Label)(v: V2){u: @Updater Label label R1 R2 V1 V2}:
  @BracketSet R1 R2 Label V2 r1 label v
              (@update Label label R1 R2 V1 V2 u (Basics.const v) r1) := {}.
Notation "r [ label := v ]" := (update label (Basics.const v) r)
  (at level 8, label at level 99, left associativity,
   format "r [ label  :=  v ]", only printing) : oo_scope.

(* Automatically deriving Updater instances for records *)

Ltac eta X :=
  let s := constr:(ltac:(
        let x := fresh "x" in
        intro x; unshelve eexists;
        [ unshelve econstructor; destruct x | destruct x; reflexivity ])
    : forall x : X, { x' : X | x' = x }) in
  lazymatch s with
  (* `eval cbv beta` would get rid of superfluous eta expansions in each branch that
     were created by `destruct`, but we commment it out because `cbv beta` is called
     again in `setter` *)
  | fun x => exist _ (@?w x) _ => (* eval cbv beta in *) w
  end.

Ltac head t :=
  lazymatch t with
  | ?f _ => head f
  | _ => t
  end.

(* needed for "strong updates" where the type of a field changes, which requires
   changing the corresponding type parameter, so we replace all type parameters
   by underscores, so that they get reinferred *)
Ltac replace_type_args_by_underscores t :=
  (* t is an application of a constructor to a list of arguments, each of which
     either is a type, or an unfolded getter applied to the original record (match) *)
  lazymatch t with
  | ?f ?arg =>
      let f' := replace_type_args_by_underscores f in
      lazymatch arg with
      | match _ with _ => _ end => uconstr:(f' arg) (* arg is an applied getter: keep *)
      | _ => uconstr:(f' _) (* arg is a type: replace by _ so that it's reinferred *)
      end
  | _ => t
  end.

Ltac replace_arg t oldArg newArg :=
  lazymatch t with
  | ?f oldArg => let f' := replace_type_args_by_underscores f in uconstr:(f' newArg)
  | ?f ?a => let f' := replace_arg f oldArg newArg in uconstr:(f' a)
  end.

Ltac derive_record_setter :=
  lazymatch goal with
  | |- @Updater (?R1 -> ?V1) ?getter ?R1 ?R2 ?V1 ?V2 =>
      (* Note: this goal is convertible to `(V1 -> V2) -> R1 -> R2` *)
      let updateV := fresh "updateV" in
      let r := fresh "r" in
      intros updateV r;
      let h := head getter in
      let oldV := eval cbv beta delta [h] in (getter r) in
      let etaR := eta R1 in
      let b := eval cbv beta in (etaR r) in
      let b' := replace_arg b oldV (updateV oldV) in
      exact b'
  end.

Global Hint Extern 5 (@Updater (?R1 -> ?V1) ?getter ?R1' ?R2 ?V1' ?V2) =>
  (* unify is needed if record type takes parameters, because then, the type
     of getter is (Record ?Param -> something maybe depending on ?Param),
     whereas R1' and V1' might be concrete, or different evars *)
  unify R1 R1';
  unify V1 V1';
  derive_record_setter : typeclass_instances.

(* Used to mark A as a subclass of B in order to lift operations of B to A *)
Class Subclass(A B: Type) := {
  coerce: A -> B;
  lift: (B -> B) -> A -> A;
}.

(* `Subclass A B` could be defined for any A that contains a B, but you should
   only define it if you want all getters/setters that apply to B to become also
   applicable to A. Therefore, the following is a Definition rather than an Instance: *)
Definition declare_subclass{Label: Type}(l: Label)(A B: Type)
           {g: Getter l A B}{s: Updater l A A B B}: Subclass A B := {|
  coerce := get l;
  lift := update l;
|}.

#[export] Instance SubGetter{Label: Type}(l: Label)(ROuter RInner E: Type)
         {sub: Subclass ROuter RInner}{getter: Getter l RInner E}: Getter l ROuter E :=
  fun (r: ROuter) => get l (coerce r).

#[export] Instance SubUpdater{Label: Type}(l: Label)(RInner ROuter E: Type)
                            {sub: Subclass ROuter RInner}{u: Updater l RInner RInner E E}
  : Updater l ROuter ROuter E E := fun (f: E -> E) => lift (update l f).

(* If the label is of type (R -> _), it's a projection that we can use as a getter: *)
Global Hint Extern 1 (@Getter (?R -> _) ?label ?R' _) =>
  let h := head R in
  let h' := head R' in
  constr_eq h h';
  unify R R';
  exact label
: typeclass_instances.

(** ** Data access instances for lists *)

Require Import coqutil.Datatypes.Inhabited.
Require Coq.Lists.List coqutil.Datatypes.List.

#[export] Instance BracketGetInList{A: Type}{inh: inhabited A}(l: list A)(i: nat):
  @BracketGet (list A) nat A l i (List.nth i l default) := {}.
Notation "a [ i ]" := (List.nth i a default)
  (at level 8, i at level 99, left associativity, format "a [ i ]", only printing)
: oo_scope.

(* setting a single element in a list *)
#[export] Instance BracketSetInList{A: Type}(l: list A)(i: nat)(x: A):
  @BracketSet (list A) (list A) nat A l i x (List.upd l i x) := {}.
Notation "l [ i := x ]" := (List.upd l i x)
  (at level 8, i at level 99, left associativity,
   format "l [ i  :=  x ]", only printing) : oo_scope.

(* setting multiple elements in a list (disambiguation is type-based) *)
#[export] Instance BracketSetListInList{A: Type}(l: list A)(i: nat)(xs: list A):
  @BracketSet (list A) (list A) nat (list A) l i xs (List.upds l i xs) := {}.
Notation "l [ i := xs ]" := (List.upds l i xs)
  (at level 8, i at level 99, left associativity,
   format "l [ i  :=  xs ]", only printing) : oo_scope.

(** ** Data access instances for maps *)

#[export] Instance BracketGetInMap{K V: Type}{M: map.map K V}(k: K)(m: M):
  @BracketGet (@map.rep K V M) K (option V) m k (@map.get K V M m k) := {}.
Notation "m [ k ]" := (map.get m k)
  (at level 8, k at level 99, left associativity, format "m [ k ]", only printing)
: oo_scope.

#[export] Instance BracketSetInMap{K V: Type}{M: map.map K V}(k: K)(v: V)(m: M):
  @BracketSet (@map.rep K V M) (@map.rep K V M) K V m k v (@map.put K V M m k v) := {}.
Notation "m [ k := v ]" := (map.put m k v)
  (at level 8, k at level 99, left associativity,
   format "m [ k  :=  v ]", only printing) : oo_scope.

Module TestDataAccess.

  Record foo(A: Type)(n: nat) := {
    fieldA: A;
    fieldB: n = n;
    fieldC: bool;
  }.

  Record bar := {
    fieldD: bool;
    fieldE: foo nat 2;
  }.

  Arguments fieldA {_ _}.
  Arguments fieldB {_ _}.
  Arguments fieldC {_ _}.

  Example testFoo(b: bool): foo nat 2 :=
    {| fieldA := 3; fieldB := eq_refl; fieldC := b |}.

  Local Open Scope oo_scope.

  (* Set Printing Implicit. *)

  Goal forall f: foo nat 1, Some (f[fieldA := 2]) <> None. Abort.

  Goal forall f: foo nat 1, f[fieldA := 2] = f[fieldA := 2]. Abort.

  Goal forall b,
      (testFoo b)[fieldA := 2] = {| fieldA := 2; fieldB := eq_refl; fieldC := b |}.
  Proof. intros. reflexivity. Abort.

  Goal forall b, (testFoo b)[fieldA] = 3. intros. reflexivity. Qed.

  Goal forall b, (testFoo b)[fieldA := 3][fieldA] = 3. intros. reflexivity. Qed.

  (*
  Check _[S := 3].
  Check (testFoo true)[S := 3].
  Fail Goal forall (g: foo nat 2 -> nat), (testFoo true)[g := 3] = testFoo true.
  *)

  Goal forall b,
      (testFoo b)[fieldC := true][fieldC := false][fieldA ::= Nat.add 2] =
      (testFoo b)[fieldA ::= Nat.add 1][fieldC := false][fieldA ::= Nat.add 1].
  Proof.
    intros. unfold update. unfold Basics.const. cbn. srefl.
  Qed.

  Goal forall r: foo (foo nat 4) 2,
      r[fieldA := r[fieldA][fieldA ::= Nat.add 1]][fieldA][fieldA] = S r[fieldA][fieldA].
  Proof. intros. reflexivity. Qed.

  Goal forall f: foo bool 1, fieldA f[fieldC ::= andb true] = fieldA f.
  Proof. intros. reflexivity. Qed.

  (* test cases from coq-record-update: *)
  Module SimpleExample.

    Record X := mkX { A: nat; B: nat; C: unit }.

    Definition setAB(a b: nat)(x: X) := x[A := a][B := b].
    Definition updateAB(a b: nat)(x: X) := x[A ::= plus a][B ::= minus b].
  End SimpleExample.

  Module IndexedType.
    Record X {T} := mkX { A: T; B: T; C: unit }.
    Arguments X T : clear implicits.

    Definition setAB T (a b: T) (x: X T) := x [A := a] [B := b].
  End IndexedType.

  Module DependentExample.
    Record X := mkX { T: Type; A: T; B: nat }.

    Definition setB(b: nat)(x: X) := x[B := b].
    (* setting A, whose type depends on a field in X, is not supported yet *)
    (* Definition setA(x: X)(a: T x) := x[A := a]. *)
  End DependentExample.

(*
  Module NestedExample.
    Record C := mkC { n : nat }.
    Record B := mkB { c : C }.
    Record A := mkA { b : B }.

    Definition setNested n' x := x [ b; c; n := n' ].
    Definition updNested f x := x [ b; c; n ::= f ].
  End NestedExample.
*)

  Module SubclassExample.
    Record A := mkA { n: nat }.
    Record A' := mkA' { a: A; m: nat }.

    Local Instance A_sub_A': Subclass A' A := declare_subclass a A' A.

    Definition get_n(x: A'): nat := x[n].
    Definition set_n(x: A')(v: nat): A' := x[n := v].
  End SubclassExample.

  Module TypeParameterExample.
    Record X T := mkX { a: nat; b: T; c: T * T; }.
    Arguments a {T}.
    Arguments b {T}.
    Arguments c {T}.

    Definition set_a (x: X unit) := x[a := 3].
    Definition set_b (x: X unit) := x[b := tt].
    Definition set_b' {T} (x:X T) (v:T) := x[b := v].
    Definition set_c {T} (x:X T) (v:T) := x[c := (v,v)].
  End TypeParameterExample.

  Module TypeParameterChanges.
    Set Implicit Arguments.

    Record X T := mkX { a: nat; b: T; }.
    Arguments a {T}.
    Arguments b {T}.

    Definition set_a (x:X unit) := x[a := 3].
    Definition set_b {T} (x:X T) (v:T) := x[b := v].

    (* type of record changes from `X T1` to `X T2` *)
    Definition strong_update_to_b{T1 T2}(x: X T1)(v: T2): X T2 := x[b := v].
  End TypeParameterChanges.

  Section Tests.
    Context (A: Type) {inh: inhabited A} (xs ys zs: list A) (a b c: A) (i j k: nat)
            (f: A -> A) (g: list A -> list A).

    Goal xs[i] = ys[j]. Abort.
    Goal [| a; b |] = [| b; a |]. Abort.
    Goal [| f a; b |] = [| b; a |]. Abort.
    Goal g nil = nil. Abort.
    Goal g [| f a; b |] = [| b; a |]. Abort.
    Goal g [| a |] = [| xs[i] |]. Abort.

    Goal (g [| a |])[0] = b.  Abort.
  End Tests.
End TestDataAccess.

(* TODO notations for nested updates

Notation "a [ i , j := v ]" := (update i (set j v) a)
  (at level 10, i at level 99, j at level 99, v at level 99,
   left associativity, format "a [ i ,  j  :=  v ]")
    : oo_scope.

Notation "a [ i , j , k := v ]" := (update i (update j (set k v)) a)
  (at level 10, i at level 99, j at level 99, k at level 99, v at level 99,
   left associativity, format "a [ i ,  j ,  k  :=  v ]")
    : oo_scope.

Notation "a [ i , j1 , .. , jn , k := v ]" :=
  (update i (update j1 .. (update jn (set k v)) ..) a)
  (at level 10, i at level 99, j1 at level 99, jn at level 99, k at level 99, v at level 99,
      left associativity, format "a [ i ,  j1 ,  .. ,  jn ,  k  :=  v ]")
    : oo_scope.
*)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

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

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

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

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

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

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cvterm2.
Require Export subst_tacs2.

Lemma isprog_add_implies {p} :
  forall (a b : @NTerm p),
    isprog a
    -> isprog b
    -> isprog (mk_add a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_nil_iff_isprog.
  apply isprog_vars_add; sp.
Qed.

Definition mkc_add {p} (t1 t2 : @CTerm p) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist isprog (mk_add a b) (isprog_add_implies a b x y).

Lemma mkcv_add_substc {o} :
  forall v a b (t : @CTerm o),
    substc t v (mkcv_add [v] a b)
    = mkc_add (substc t v a) (substc t v b).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  repeat unfsubst.
Qed.

Lemma lsubstc_mk_add {p} :
  forall t1 t2 sub,
  forall w1 : wf_term t1,
  forall w2 : @wf_term p t2,
  forall w  : wf_term (mk_add t1 t2),
  forall c1 : cover_vars t1 sub,
  forall c2 : cover_vars t2 sub,
  forall c  : cover_vars (mk_add t1 t2) sub,
    lsubstc (mk_add t1 t2) w sub c
    = mkc_add (lsubstc t1 w1 sub c1)
              (lsubstc t2 w2 sub c2).
Proof.
  sp; unfold lsubstc; simpl.
  apply cterm_eq; simpl.
  unfold csubst; simpl.
  change_to_lsubst_aux4; simpl.
  rw @sub_filter_nil_r; allrw @fold_nobnd; sp.
Qed.

Lemma lsubstc_mk_add_ex {p} :
  forall t1 t2 sub,
  forall w  : wf_term (@mk_add p t1 t2),
  forall c  : cover_vars (mk_add t1 t2) sub,
    {w1 : wf_term t1
     & {w2 : wf_term t2
     & {c1 : cover_vars t1 sub
     & {c2 : cover_vars t2 sub
        & lsubstc (mk_add t1 t2) w sub c
             = mkc_add (lsubstc t1 w1 sub c1)
                       (lsubstc t2 w2 sub c2)}}}}.
Proof.
  introv.

  assert (wf_term t1) as w1.
  { allrw @wf_arithop_iff; sp. }

  assert (wf_term t2) as w2.
  { allrw @wf_arithop_iff; sp. }

  assert (cover_vars t1 sub) as c1.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  assert (cover_vars t2 sub) as c2.
  { unfold cover_vars in c.
    simpl in c.
    repeat (rw remove_nvars_nil_l in c).
    rw app_nil_r in c.
    repeat (rw @over_vars_app_l in c); sp. }

  exists w1 w2 c1 c2.
  apply lsubstc_mk_add.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/")
*** End:
*)


(*
 * © 2019 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     FSets.FMapList
     FSets.FMapFacts
     Structures.OrderedType
     Structures.OrderedTypeEx
     Logic.ProofIrrelevance
     Program.Equality
.

From Coq Require List.

From SPICY Require Import
     MyPrelude
     Tactics.

Set Implicit Arguments.

Module MyOrderedMap (OT : UsualOrderedType).
  Import OT.

  Module Import Map := FMapList.Make( OT ).
  Definition t := Map.t.

  Module Import P := WProperties_fun OT Map.
  Module Import F := P.F.
  Module Import O := OrdProperties Map.
  Module Import OTF := OrderedType.OrderedTypeFacts OT.

  Local Notation "$0" := (empty _).
  Local Notation "m $+ ( k , v )" := (add k v m) (at level 50, left associativity).
  Local Notation "m $- k" := (remove k m) (at level 50, left associativity).
  Local Notation "m $? k" := (find k m) (at level 50, left associativity).

  Lemma lookup_empty_none : forall V k,
      (@empty V) $? k = None.
  Proof. unfold find, Raw.find; trivial. Qed.

  Lemma map_not_none : forall V k (m : Map.t V),
      m $? k <> None
      -> exists v, m $? k = Some v.
  Proof.  unfold not; intros; cases (m $? k); try contradiction; eauto. Qed.

  Ltac context_map_rewrites1 :=
    match goal with
    | [ H : ?m $? ?k = _ |- context[?m $? ?k] ] => rewrite H
    | [ H : context [ match ?matchee with _ => _ end ]
      , H1 : ?matchee = _ |- _] => rewrite H1 in H
    end.

  Ltac contra_map_lookup1 :=
    match goal with
    | [ H : ?ks $? ?k = ?v -> _, ARG : ?ks $? ?k = ?v |- _ ] => specialize (H ARG)
    | [ H1 : ?ks $? ?k = _, H2 : ?ks $? ?k = _ |- _ ] => rewrite H1 in H2; invert H2
    | [ H : ?ks $? ?k = _ |- context [ ?ks $? ?k <> _] ] => unfold not; intros
    end.

  Local Ltac clean_map_lookups1' :=
    invert_base_equalities1
    || contra_map_lookup1
    || context_map_rewrites1
    || match goal with
      | [ H : context [ $0 $? _ ] |- _ ] =>
        rewrite lookup_empty_none in H
        ; try discriminate H
      | [ |- context [ $0 $? _ ] ] =>
        rewrite lookup_empty_none
      | [ H : context [ _ $+ (_,_) $? _ ] |- _ ] =>
        progress (
            repeat (
                ( rewrite add_eq_o in H by trivial )
              || ( rewrite add_neq_o in H by auto 2 )
              || ( rewrite lookup_empty_none in H ) ) )

      | [ |- context [ _ $+ (_,_) $? _ ] ] =>
        progress (
            repeat (
                ( rewrite add_eq_o by trivial )
              || ( rewrite add_neq_o by auto 2 )
              || ( rewrite lookup_empty_none ) ) )

      | [ H : context [ _ $- _ $? _ ] |- _ ] =>
        progress (
            repeat (
                ( rewrite remove_eq_o in H by trivial )
              || ( rewrite remove_neq_o in H by auto 2 ) ) )

      | [ |- context [ _ $- _ $? _ ] ] =>
        progress (
            repeat (
                ( rewrite remove_eq_o by trivial )
              || ( rewrite remove_neq_o by auto 2 ) ) )

      | [ H : ~ In _ _ |- _ ] => rewrite not_find_in_iff in H
      | [ |- ~ In _ _ ] => rewrite not_find_in_iff
      | [ H : In _ _ |- _ ] => rewrite in_find_iff in H
      | [ H1 : ?m $? ?k1 = _ , H2 : ?m $? ?k2 = _ |- _] =>
        assert (k1 = k2) as RW by auto 2; rewrite RW in H1; clear RW; rewrite H1 in H2
      | [ H : ?m $? ?k = None -> False |- _ ] =>
        change (m $? k = None -> False) with (m $? k <> None) in H
      | [ H : ?m $? ?k <> None |- _ ] =>
        apply map_not_none in H; split_ex
      | [ H : MapsTo _ _ _ |- _ ] => rewrite find_mapsto_iff in H
      | [ |- context [ MapsTo _ _ _ ] ] => rewrite find_mapsto_iff
      end.

  Ltac contra_map_lookup := repeat (invert_base_equalities1 || contra_map_lookup1).
  Local Ltac clean_map_lookups' := repeat clean_map_lookups1'.
  Ltac context_map_rewrites := repeat context_map_rewrites1.

  Lemma lookup_some_implies_in : forall V (m : Map.t V) k v,
      m $? k = Some v
      -> List.In (k,v) (to_list m).
  Proof.
    intros * H.

    rewrite <- find_mapsto_iff, elements_mapsto_iff, InA_alt in H.
    split_ex.
    unfold eq_key_elt, Raw.PX.eqke in H; simpl in H.
    destruct x; simpl in *; split_ands; subst; eauto.
  Qed.

  Lemma lookup_split : forall V (m : Map.t V) k v k' v',
      (m $+ (k, v)) $? k' = Some v'
      -> (k' <> k /\ m $? k' = Some v') \/ (k' = k /\ v' = v).
  Proof.
    intros;
      case (eq_dec k k'); intros; subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_eq_fields_eq :
    forall V (th th' : Raw.t V) s s',
      th = th'
      -> {| this := th ; sorted := s |} = {| this := th' ; sorted := s' |}.
  Proof.
    intros; subst; f_equal; apply proof_irrelevance.
  Qed.

  Lemma map_eq_elements_eq :
    forall {V} (m m' : Map.t V),
      elements m = elements m'
      -> m = m'.
  Proof.
    intros. destruct m. destruct m'.
    simpl in *;
      eapply map_eq_fields_eq;
      eauto.
  Qed.

  Lemma Equal_hd_tl :
    forall {V} (m1 m1' m2 m2' : t V) x xs y ys sx sy,
      m1 = {| this := x :: xs ; sorted := sx |}
      -> m2 = {| this := y :: ys ; sorted := sy |}
      -> Equal m1 m2
      -> m1' = m1 $- fst x
      -> m2' = m2 $- fst y
      -> x = y /\ Equal m1' m2'.
  Proof.
    intros.

    destruct x as [n1 v1]; destruct y as [n2 v2]; simpl in *.

    assert ( (n1,v1) = (n2,v2) ).
    - unfold Equal in *; subst; simpl in *.
      match goal with
      | [ H : forall _, _ |- _ ] =>
        generalize (H n1); generalize (H n2); intros
      end;
        unfold find, Raw.find in *; simpl in *.

      pose proof (Raw.MX.elim_compare_eq (eq_refl n1)) as EQn1.
      pose proof (Raw.MX.elim_compare_eq (eq_refl n2)) as EQn2.
      split_ex.
      rewrite H2, H3 in *.

      cases (compare n1 n2);
        cases (compare n2 n1);
        try discriminate; subst; repeat invert_base_equalities1; eauto;
          repeat
            match goal with
            | [ H : eq _ _ |- _ ] => unfold eq in H; subst
            end; eauto.

      pose proof (lt_trans l0 l) as CONTRA;
        apply lt_not_eq in CONTRA; assert (eq n1 n1) by auto; contradiction.

    - split; auto; subst.
      invert H4.
      unfold Equal in *; simpl in *.
      intro k.
      case (eq_dec k n2); intros; subst;
        (rewrite !remove_eq_o by auto 2)
        || (rewrite !remove_neq_o by auto 2); eauto.
  Qed.

  Lemma remove_hd :
    forall {V} n (v : V) xs sx hdrel,
      {| this := (n,v) :: xs ; sorted := Sorted.Sorted_cons sx hdrel |} $- n = {| this := xs ; sorted := sx |}.
  Proof.
    intros.
    unfold remove, Raw.remove. simpl.
    eapply map_eq_elements_eq; simpl.

    pose proof (Raw.MX.elim_compare_eq (eq_refl n)); split_ex.
    rewrite H; trivial.
  Qed.

  Lemma Empty_eq_empty :
    forall {V} m,
      Empty (elt:=V) m
      -> $0 = m.
  Proof.
    intros.
    apply elements_Empty in H.
    apply map_eq_elements_eq. auto.
  Qed.

  Lemma map_eq_Equal :
    forall {V} (m m' : t V),
      Equal m m'
      -> m = m'.
  Proof.
    destruct m as [l sl].
    generalize dependent l.
    induction l; intros.

    - unfold Equal in H. simpl in *.
      apply map_eq_elements_eq; simpl.
      symmetry in H.

      destruct m'; simpl in *.
      cases this0; trivial.
      exfalso.
      destruct p. specialize (H t0).
      unfold find, Raw.find in *; simpl in *.

      pose proof (elim_compare_eq (eq_refl t0)) as RW; destruct RW as [?e RW];
        rewrite RW in *; discriminate.

    - simpl.
      destruct m'; cases this0; simpl in *.
      + destruct a as [n v].
        unfold Equal in H; specialize (H n).
        unfold find, Raw.find in H; simpl in H.
        pose proof (Raw.MX.elim_compare_eq) as P; specialize (P n n (eq_refl n)); destruct P.
        rewrite H0 in H; discriminate.

      + eapply Equal_hd_tl in H; eauto; split_ands; subst.
        unfold Equal in H0; simpl in *.

        dependent destruction sl.
        dependent destruction sorted0.
        specialize (IHl sl {| this := this0 ; sorted := sorted0 |}).

        assert (tlEQ : Equal {| this := l ; sorted := sl |} {| this := this0 ; sorted := sorted0 |} ).
        * destruct p;
            unfold Equal; intro k;
              specialize (H0 k); rewrite !remove_hd in H0; eauto.
        * specialize (IHl tlEQ).
          dependent destruction IHl.
          eapply map_eq_elements_eq; simpl; f_equal.
  Qed.

  Lemma empty_Empty :
    forall {V}, Empty (elt:=V) $0.
  Proof.
    intros.
    unfold Empty, Raw.Empty, Raw.PX.MapsTo, not; intros.
    invert H.
  Qed.

  Lemma map_add_eq :
    forall {V} (m : Map.t V) k v1 v2,
      m $+ (k,v1) $+ (k,v2) = m $+ (k,v2).
  Proof.
    intros; apply map_eq_Equal; unfold Equal; intros;
      destruct (eq_dec k y); subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_add_remove_eq :
    forall {V} (m : Map.t V) k v1,
      m $+ (k, v1) $- k = m $- k.
  Proof.
    intros. apply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec k y); subst; clean_map_lookups'; eauto.
  Qed.

  Lemma map_add_remove_neq :
    forall {V} (m : Map.t V) k1 v1 k2,
      k1 <> k2
      -> m $+ (k1, v1) $- k2 = m $- k2 $+ (k1, v1).
  Proof.
    intros. apply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec k2 y); destruct (eq_dec k1 y); intros; subst; clean_map_lookups'; eauto.
  Qed.

  Lemma remove_empty :
    forall V k,
      (@empty V) $- k = $0.
  Proof.
    intros; eapply map_eq_Equal; unfold Equal; intros; eauto.
  Qed.

  Lemma map_ne_swap :
    forall {V} (m : Map.t V) k v k' v',
      k <> k'
      -> m $+ (k,v) $+ (k',v') = m $+ (k',v') $+ (k,v).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.
    cases (eq_dec y k); cases (eq_dec y k'); subst; clean_map_lookups'; auto; contradiction.
  Qed.

  Lemma map_remove_not_in_idempotent :
    forall {V} (m : Map.t V) k1,
      m $? k1 = None
      -> m $- k1 = m.
  Proof.
    intros.
    eapply map_eq_Equal; unfold Equal; intros.
    destruct (eq_dec y k1); subst; clean_map_lookups'; eauto.
  Qed.

  Ltac Equal_eq :=
    repeat
      match goal with
      | [ H : Equal _ _ |- _] => apply map_eq_Equal in H; subst
      end.

  Lemma remove_not_in_map_idempotent :
    forall {V} (m : Map.t V) k,
      m $? k = None
      -> m $- k = m.
  Proof.
    intros; apply map_eq_Equal. unfold Equal; intros;
      destruct (eq_dec k y); subst; context_map_rewrites; clean_map_lookups'; trivial.
  Qed.

  Ltac clean_map_lookups1 :=
    clean_map_lookups1'
    || match goal with
      | [ H : context [ $0 $- _ ] |- _ ] =>
        rewrite remove_empty in H
      | [ H : context [ _ $+ (_,_) $- _ ] |- _ ] =>
        progress (
            repeat (
                (rewrite map_add_remove_neq in H by congruence)
                || (rewrite map_add_remove_eq in H by trivial)
                || (rewrite remove_empty in H)
          ) )
      end.

  Ltac clean_map_lookups := repeat clean_map_lookups1.

  Ltac solve_simple_maps1 :=
    clean_map_lookups1
    || match goal with
      | [ |- context [ _ $+ (?k1,_) $? ?k2 ] ] => destruct (eq_dec k1 k2); subst
      | [ H : context [ _ $+ (?k1,_) $? ?k2 ] |- _ ] => destruct (eq_dec k1 k2); subst
      | [ |- context [ match ?m $? ?k with _ => _ end ]] => cases (m $? k)
      | [ H : context [ match ?m $? ?k with _ => _ end ] |- _ ] => cases (m $? k)
      | [ |- context [ ?m $+ (?k,_) $+ (?k,_) ]] => rewrite map_add_eq by trivial
      (* maybe a little too specific? *)
      | [ |- context [ ?m $+ (?k1,_) $+ (?k2,_) = ?m $+ (?k2,_) $+ (?k1,_)]] => rewrite map_ne_swap by auto 2; trivial
      end.

  Ltac solve_simple_maps := repeat solve_simple_maps1.

  Ltac maps_equal1 :=
    match goal with
    | [ |- _ $+ (_,_) = _ ] => apply map_eq_Equal; unfold Equal; intros
    | [ |- _ = _ $+ (_,_) ] => apply map_eq_Equal; unfold Equal; intros
    end
    || solve_simple_maps1.

  (* TODO -- think of how to eliminate this *)
  Ltac maps_equal :=
    apply map_eq_Equal; unfold Equal; intros;
    (repeat solve_simple_maps1); trivial.

  Local Ltac dupKey k m :=
    match m with
    | add k _ _  => idtac
    | add _ _ ?m' => dupKey k m'
    end.

  Ltac canonicalize_map m :=
    match m with
    | context [ add ?k ?v ?m1 ] =>
      dupKey k m1;
      let CANON := fresh "CANON" in
      assert ( CANON : m = m $- k $+ (k,v) ) by maps_equal;
      repeat
        (rewrite map_add_remove_eq in CANON by trivial)
      || (rewrite map_add_remove_neq in CANON by eauto)
      || (rewrite remove_not_in_map_idempotent in CANON by eauto)
      ; rewrite !CANON;
      match type of CANON with
      | _ = ?m' => clear CANON; try canonicalize_map m'
      end
    end.

  Lemma canonicalize_map_test1 :
    forall {V} (m : Map.t V) k1 k2 (v1 v2 v3 : V),
      k1 <> k2
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) = m $+ (k2,v2) $+ (k1,v3).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end. maps_equal.
  Qed.

  Lemma canonicalize_map_test2 :
    forall {V} (m : Map.t V) k1 k2 k3 (v1 v2 v3 v4 : V),
      k1 <> k2
      -> k1 <> k3
      -> k2 <> k3
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) $+ (k3,v4) = m $+ (k2,v2) $+ (k1,v3) $+ (k3,v4).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end; maps_equal.
  Qed.

  Lemma canonicalize_map_test3 :
    forall {V} (m : Map.t V) k1 k2 k3 (v1 v2 v3 v4 : V),
      k1 <> k2
      -> k1 <> k3
      -> k2 <> k3
      -> m $? k1 = None
      -> m $+ (k1,v1) $+ (k2,v2) $+ (k1,v3) $+ (k2,v4) $+ (k3,v4) = m $+ (k2,v4) $+ (k1,v3) $+ (k3,v4).
  Proof.
    intros.
    match goal with
    | [ |- ?m = _ ] => canonicalize_map m
    end; maps_equal.
  Qed.

  Definition canon_map {V} (m : Map.t V) :=
    of_list (to_list m).

  Lemma canon_map_ok :
    forall {V} (m : Map.t V),
      m = canon_map m.
  Proof.
    intros.
    unfold canon_map.
    pose proof (of_list_3 m).
    apply map_eq_Equal in H.
    rewrite H.
    trivial.
  Qed.

  (* Use if the keys are concrete. Faster and it sorts by key so order is consistent *)
  Definition canonicalize_concrete_map {V} (m : Map.t V) : Map.t V.
    destruct m.
    unfold Raw.t in this0.
    let f := constr:(fun (acc : Map.t V) (cur : OT.t * V) =>
                       let (k, v) := cur
                       in acc $+ (k, v))
    in let m' := (eval simpl in (fold_left f this0 $0))
       in apply m'.
  Defined.

  Ltac canonicalize_concrete_map m :=
    let m' := (eval simpl in (canonicalize_concrete_map m))
    in replace m with m' in * by maps_equal.

  Section MapPredicates.
    Variable V : Type.
    Variable P : V -> Prop.

    Inductive Forall_natmap : Map.t V -> Prop :=
    | Empty_Natmap : Forall_natmap $0
    | Add_Natmap k v (m : Map.t V) :
        P v
        -> Forall_natmap m
        -> Forall_natmap ( m $+ (k,v)).

    Lemma Forall_natmap_forall :
      forall m,
        Forall_natmap m <-> (forall k v, m $? k = Some v -> P v).
    Proof.
      split.
      - induction 1; intros; solve_simple_maps; eauto.
      - induction m using P.map_induction_bis; intros; Equal_eq; eauto.
        econstructor; solve_simple_maps; eauto.

        assert (Forall_natmap m).
        eapply IHm; intros.
        apply H0 with (k:=k); solve_simple_maps; eauto.

        econstructor; eauto.
        eapply H0 with (k := x); clean_map_lookups; auto.
    Qed.

    Lemma Forall_natmap_in_prop :
      forall k v m,
        Forall_natmap m
        -> m $? k = Some v
        -> P v.
    Proof.
      intros.
      rewrite Forall_natmap_forall in H; eauto.
    Qed.

    Lemma Forall_natmap_in_prop_add :
      forall k v m,
        Forall_natmap (m $+ (k,v))
        -> P v.
    Proof.
      intros.
      eapply Forall_natmap_in_prop with (k:=k); eauto; clean_map_lookups; trivial.
    Qed.

    Lemma Forall_natmap_split :
      forall k v m,
        Forall_natmap (m $+ (k,v))
        -> ~ In k m
        -> Forall_natmap m
          /\ P v.
    Proof.
      intros.
      rewrite Forall_natmap_forall in *; intros.
      assert (P v) by (eapply H with (k0:=k); clean_map_lookups; trivial).
      split; auto; intros.
      destruct (eq_dec k k0); subst; clean_map_lookups; eauto.
      eapply H with (k0:=k0); clean_map_lookups; trivial.
    Qed.

  End MapPredicates.

  Export Map F P.

End MyOrderedMap.

Module Export NatMap := MyOrderedMap( Nat_as_OT ).
Module NatMapNotation.
  Notation "$0" := (empty _).
  Notation "m $+ ( k , v )" := (add k v m) (at level 50, left associativity).
  Notation "m $- k" := (remove k m) (at level 50, left associativity).
  Notation "m $? k" := (find k m) (at level 50, left associativity).
End NatMapNotation.

Export NatMapNotation.

Definition merge_maps {V : Type} (m1 m2 : Map.t V) : Map.t V :=
  fold (fun k v m => m $+ (k,v) ) m1 m2.

Notation "m1 $++ m2" := (merge_maps m2 m1) (at level 50, left associativity).

Lemma add_empty_idempotent :
  forall V (m : Map.t V),
    m $++ $0 = m.
Proof.
  intros; unfold merge_maps, Map.fold, Map.Raw.fold; simpl; auto.
Qed.

Lemma empty_add_idempotent :
  forall {V}(m : Map.t V),
    $0 $++ m = m.
Proof.
  intros; unfold merge_maps.
  apply P.fold_rec.
  - intros.
    apply P.elements_Empty in H; simpl in *.
    apply map_eq_elements_eq; auto.

  - intros. subst.
    apply map_eq_Equal. unfold Map.Equal; intros.
    unfold P.Add in H1. specialize (H1 y). symmetry; auto.
Qed.

Ltac m_equal :=
  repeat match goal with
         | [ |- context[_ $+ (?k,_) $? ?k ] ]  =>
           rewrite add_eq_o by (simple apply @eq_refl)
         | [ |- context[_ $+ (?k',_) $? ?k] ] =>
           rewrite add_neq_o by ( (unfold not; intros ?SIMPLEQ; invert SIMPLEQ) || intuition idtac )
         | [ |- context[$0 $++ _ ] ] => rewrite empty_add_idempotent
         | [ |- context[_ $++ $0 ] ] => rewrite add_empty_idempotent
         | [ |- (_ $+ (_,_)) = _ ] => unfold Map.add, Map.Raw.add; simpl
         | [ |- {| Map.this := _ ; Map.sorted := _ |} = _ ] => eapply map_eq_fields_eq
         | [ H : Map.Empty ?m |- $0 = ?m ] => eapply Empty_eq_empty; exact H
         | [ H : Map.Empty ?m |- ?m = $0 ] => symmetry
         | [ |- Map.empty _ = _ ] => unfold Map.empty, Map.Raw.empty, remove, Map.Raw.remove; simpl
         end.

Section ConcreteMaps.

  Definition next_key {V} (m : Map.t V) : nat :=
    match O.max_elt m with
    | None => 0
    | Some (k,v) => S k
    end.

  Lemma next_key_not_in :
    forall {V} (m : Map.t V) k,
      k = next_key m
      -> m $? k = None.
  Proof.
    unfold next_key; intros.
    cases (O.max_elt m); subst.
    - destruct p; simpl.
      cases (m $? S k); eauto.
      exfalso.

      assert (O.Above k (m $- k)) by eauto using O.max_elt_Above.
      specialize (H (S k)).

      assert (In (S k) (m $- k)).
      rewrite in_find_iff; unfold not; intros.
      rewrite remove_neq_o in H0 by eauto; contra_map_lookup.
      specialize (H H0).

      assert (k < S k) by eauto using Nat.lt_succ_diag_r.
      assert (S k < S k) by eauto using Nat.lt_trans.

      assert (~ (S k < S k)) by eauto using OTF.lt_antirefl.
      contradiction.

    - apply O.max_elt_Empty in Heq.
      apply Empty_eq_empty in Heq; subst.
      apply lookup_empty_none.
  Qed.

End ConcreteMaps.