(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  - definition of pushforward of comodules along a comonad morphism
  - definition of comodule morphism induced by a comonad morphism
  - commutativity of pushforward with precomposition w. product

*)

Require Import Category.RComonad.
Require Import Category.RComod.
Require Import Category.RComonadWithCut.
Require Import Theory.Category.
Require Import Theory.Isomorphism.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.
Require Import Theory.RelativeComonadWithCut.
Require Import Theory.Comodule.
Require Import Theory.Product.
Require Import Theory.ProductPreservingFunctor.
Require Import Theory.PrecompositionWithProduct.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＰＵＳＨＦＯＲＷＡＲＤ  ＣＯＭＯＤＵＬＥ
  ----------------------------------------------------------------------------*)
(** * Pushforward comodule **)

(** ** Definition **)
Section Pushforward_construction.

  Context `{F : Functor 𝒞 𝒟} {T S : RelativeComonad F}
           (τ : T ⇒ S) `(M : Comodule T ℰ).

  Program Definition pushforward : Comodule S ℰ :=
    Comodule.make  ⦃ M        ≔ M
                   ; mcobind  ≔ λ C D ∙ λ f ↦ M⋅mcobind (f ∘ τ(C)) ⦄.
  Next Obligation. (* mcobind_cong *)
    solve_proper.
  Qed.
  Next Obligation. (* mcobind_counit *)
    rewrite <- τ_counit. now rewrite mcobind_counit.
  Qed.
  Next Obligation. (* mcobind_mcobind *)
    now rewrite compose_assoc,
                <- τ_commutes,
                mcobind_mcobind,
                <- compose_assoc.
  Qed.

End Pushforward_construction.

(*------------------------------------------------------------------------------
  -- ＦＵNＣＴＯＲＩＡＬＩＴＹ
  ----------------------------------------------------------------------------*)
(** ** Functoriality of pushforward **)

Section Functoriality.

  Context `{F : Functor 𝒞 𝒟} {T S : RelativeComonad F} {ℰ : Category} {M N : Comodule S ℰ}
          (τ : S ⇒ T) (α : M ⇒ N).

  Infix "⁎" := pushforward (at level 0).

  Program Definition pushforward_mor : ‵ τ⁎M ⇒ τ⁎N ′ :=
    Comodule.make ⦃ α ≔ α ⦄.
  Next Obligation. (* α_commutes *)
    now rewrite α_commutes.
  Qed.

End Functoriality.

Program Definition Pushforward
             `{F : Functor 𝒞 𝒟} {T S : RelativeComonad F} (τ : T ⇒ S) {ℰ} : Functor (𝑹𝑪𝒐𝒎𝒐𝒅 T ℰ) (𝑹𝑪𝒐𝒎𝒐𝒅 S ℰ) :=
  Functor.make  ⦃ F    ≔ pushforward τ
                ; map  ≔ λ A B ∙ λ f ↦ pushforward_mor τ f ⦄.
Next Obligation.
  intros f g eq_fg x. simpl. now apply eq_fg.
Qed.
Next Obligation.
  reflexivity.
Qed.
Next Obligation.
  reflexivity.
Qed.

Notation "τ ⁎" := (Pushforward τ) (at level 0).

(** ** Tautological comodule **)
Section tautological_comodule.

  Context `{F : Functor 𝒞 𝒟} (T : RelativeComonad F).

  Program Definition tcomod : Comodule T 𝒟 :=
    Comodule.make  ⦃ M        ≔ T
                   ; mcobind  ≔ λ C D ∙ T⋅cobind ⦄.
  (** mcobind-counit *)
  Next Obligation.
    now rewrite cobind_counit.
  Qed.
  (** mcobind-mcobind *)
  Next Obligation.
    now rewrite cobind_cobind.
  Qed.

End tautological_comodule.

Local Coercion tcomod : RelativeComonad >-> Comodule.
Notation "[ T ]" := (tcomod T) (only parsing).

(** ** Induced morphism **)

Section induced_morphism.

  Context `{F : Functor 𝒞 𝒟} {T S : RelativeComonad F}
          (τ : T ⇒ S).

  Program Definition induced_morphism : ‵ τ⁎T ⇒ S ′ :=
    Comodule.make ⦃ α ≔ λ C ∙ τ(C) ⦄.
  (** α-commutes **)
  Next Obligation.
    now rewrite τ_commutes.
  Qed.

End induced_morphism.

Notation "⟨ τ ⟩" := (induced_morphism τ) (at level 0).

Section Commutes.

  Context `{BinaryProduct 𝒞} `{BinaryProduct 𝒟} {F : Functor 𝒞 𝒟}
          {E : 𝒞} `{!ProductPreservingFunctor F} {T S : RelativeComonadWithCut F E}
          {τ : T ⇒ S} `{M : Comodule T ℰ}.

  Program Definition Φ : ‵ τ⁎(M[E×─]) ⇒ (τ⁎M)[E×─] ′ :=
    Comodule.make ⦃ α ≔ λ X ∙ id[M (E × X)] ⦄.
  Next Obligation.
    rewrite left_id, right_id.
    apply Π.cong.
    repeat rewrite compose_assoc.
    apply Π₂.cong; [ reflexivity |].
    rewrite ∘-×; apply Π₂.cong.
    rewrite compose_assoc; apply Π₂.cong; [ reflexivity |].
    apply τ_counit.
    rewrite compose_assoc. apply Π₂.cong; [ reflexivity |].
    symmetry. apply τ_cut.
  Qed.

End Commutes.


Require Import SpecCert.x86.Architecture.
Require Import SpecCert.Address.

Definition receive_interrupt_post
           {Label: Type}
           (i:     Interrupt)
           (a a':Architecture Label) :=
  let p' := receive_interrupt (proc a) i in
  a' = update_proc a p'.


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.