Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^235 - 15
Base: 47
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 47;
    bitwidth := 64;
    s := 2^235;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^212 - 29
Base: 53
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 53;
    bitwidth := 64;
    s := 2^212;
    c := [(1, 29)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import list_examples.

Definition append_code :=
  Over::If (Over::While (Plus1++Dup 0::Load::Dup 0::nil) Nip
  ::Drop::Store::nil) Nip::Ret::nil.

Inductive append_spec : cfg -> (cfg -> Prop) -> Prop :=
  | append_claim : forall lx ly, fun_claim append_spec
    "append" append_code
      2 (fun y x => rep_list lx x :* rep_list ly y)
      1 (rep_list (lx++ly))
  | loop_claim : forall lx a lp ly, loop_claim append_spec
    0 append_code
      3 (fun p y x => constraint (p <> 0) :*
         rep_list ly y :* rep_seg lx p x :* p |-> a :*
         existsP p', p + 1 |-> p' :* rep_list lp p')
      1 (rep_list (lx++a::lp++ly)).

Lemma append_proof : sound stack_step append_spec.
Proof. list_solver;
rewrite app_ass in * |- *;
list_run. Qed.


Require Export Base.

Definition is_terminal {C: Category} (o: C) :=
  forall x: C, exists f: x ~> o, forall g, f = g.

Definition ex_terminal (C: Category) :=
  exists x: C, is_terminal x.

Instance is_terminal_iso (C: Category): Proper (isomorphic C ==> iff) is_terminal.
Proof.
  enough (Proper (isomorphic C ==> impl) is_terminal).
  now split; apply H.
  intros X Y [i] H Z.
  specialize (H Z).
  destruct H as [f H].
  exists (i ∘ f).
  intros g.
  specialize (H (i⁻¹ ∘ g)).
  subst f.
  rewrite comp_assoc.
  rewrite inv_r.
  apply comp_id_l.
Qed.

Lemma terminal_euniqueness (C: Category): euniqueness (@is_terminal C).
Proof.
  intros x y Hx Hy.
  destruct (Hx y) as [f _].
  destruct (Hy x) as [g _].
  specialize (Hx x).
  specialize (Hy y).
  destruct Hx as [x' Hx].
  destruct Hy as [y' Hy].
  constructor.
  exists g, f.
  transitivity x'.
  symmetry.
  1, 2: apply Hx.
  transitivity y'.
  symmetry.
  all: apply Hy.
Qed.

Lemma ex_terminal_eunique (C: Category): ex_terminal C <-> exists!! x: C, is_terminal x.
Proof.
  rewrite <- eunique_existence.
  split.
  + intros H.
    split.
    exact (is_terminal_iso C).
    split.
    exact H.
    exact (terminal_euniqueness C).
  + intros [_ [H _]].
    exact H.
Qed.

Instance ex_terminal_iso: Proper (isomorphic Cat ==> iff) ex_terminal.
Proof.
  enough (Proper (isomorphic Cat ==> impl) ex_terminal).
  now split; apply H.
  intros C D [I] [o H].
  exists (to I o).
  intros x'.
  destruct (ex_fobj_iso I x') as [x].
  subst x'.
  specialize (H x).
  destruct H as [f H].
  exists (fmap (to I) f).
  intros g'.
  destruct (ex_fmap_iso I g') as [g].
  subst g'.
  f_equal.
  apply H.
Qed.

Module TopCategory.

Structure mixin_of (C: Category) := Mixin {
  one: C;
  to_one {a: C}: a ~> one;
  to_one_unique {a: C} (f: a ~> one): @to_one a = f;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Lemma mixin_eq {C: Category} (m n: mixin_of C): m = n <-> one C m = one C n.
Proof.
  split.
  intros H.
  now subst n.
  destruct m as [a f Hf], n as [b g Hg]; simpl.
  intros H.
  subst b.
  enough (f = g).
  subst g.
  f_equal; apply proof_irrelevance.
  extensionality x.
  apply Hf.
Qed.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation TopCategory := type.

End Exports.

End TopCategory.

Export TopCategory.Exports.

Section Terminal.
Context {C: TopCategory}.

Definition one: C := TopCategory.one C (TopCategory.class C).
Definition to_one: forall {a: C}, a ~> one := @TopCategory.to_one C (TopCategory.class C).

Lemma to_one_unique {a: C} (f: a ~> one): to_one = f.
Proof. apply TopCategory.to_one_unique. Qed.

Lemma to_one_comp {a b: C} (f: a ~> b): to_one ∘ f = to_one.
Proof.
  symmetry.
  apply to_one_unique.
Qed.

Lemma one_to_one: @to_one one = id one.
Proof. apply to_one_unique. Qed.

Lemma to_one_eq {a: C} (f g: a ~> one): f = g.
Proof.
  transitivity (@to_one a).
  symmetry.
  all: apply to_one_unique.
Qed.

Lemma one_is_terminal: is_terminal one.
Proof.
  intros x.
  exists to_one.
  apply to_one_unique.
Qed.

End Terminal.

Notation "1" := one.
Notation "!" := to_one.

Lemma terminal_correct C: inhabited (TopCategory.mixin_of C) <-> ex_terminal C.
Proof.
  split.
  + intros [[o f Hf]].
    exists o.
    intros a.
    exists (f a).
    apply Hf.
  + intros [o H].
    apply ex_forall in H.
    destruct H as [f Hf].
    constructor.
    now exists o f.
Qed.


Require Import List.
Import ListNotations.
Require Import Relations.
Require Import Omega.

Require Import StructTact.StructTactics.
Require Import StructTact.Update.
Require Import StructTact.Dedup.
Require Import StructTact.ListTactics.
Require Import StructTact.ListUtil.
Require Import InfSeqExt.infseq.
Require Import InfSeqExt.classical.
Require Import Chord.InfSeqTactics.

Require Import Chord.Chord.

Require Import Chord.HandlerLemmas.
Require Import Chord.SystemReachable.
Require Import Chord.SystemLemmas.
Require Import Chord.LabeledLemmas.
Require Import Chord.ChannelLemmas.
Require Import Chord.LiveNodesNotClients.
Require Import Chord.QueryInvariant.
Require Import Chord.NodesHaveState.

Set Bullet Behavior "Strict Subproofs".

Set Implicit Arguments.

Section find_chain.

  Variable A : Type.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.
  Variable all : list A.
  Variable nodup_all : NoDup all.
  Variable next : A -> option A.

  Variable next_in_all :
    forall a a',
      In a all ->
      next a = Some a' ->
      In a' all.

  Fixpoint nextn a n : option A :=
    match n with
    | 0 => Some a
    | S n => match next a with
            | None => None
            | Some a => nextn a n
            end
    end.

  Variable no_cycles :
    forall a n,
      nextn a n <> Some a.

  Lemma nextn_in_all :
    forall n a a',
      In a all ->
      nextn a n = Some a' ->
      In a' all.
  Proof.
    induction n; intros; simpl in *.
    - solve_by_inversion.
    - break_match; try congruence. eauto.
  Qed.

  Fixpoint chain (a : A) (fuel : nat) :=
    match fuel with
    | 0 => None
    | S fuel =>
      match (next a) with
      | None => Some [a]
      | Some a' =>
        match (chain a' fuel) with
        | None => None
        | Some c =>
          Some (a :: c)
        end
      end
    end.

  Lemma more_fuel_preserves_some :
    forall n n' a c,
      n <= n' ->
      chain a n = Some c ->
      chain a n' = Some c.
  Proof.
    induction n; intros; simpl in *.
    - congruence.
    - destruct n'; try omega.
      simpl.
      break_match; intuition.
      destruct (chain a0 n) eqn:chain_def; try congruence.
      specialize (IHn n').
      eapply IHn in chain_def; eauto; try omega.
      repeat find_rewrite. auto.
  Qed.

  Lemma sufficient_fuel' :
    forall fuel l a,
      NoDup l ->
      (forall a' n, nextn a n = Some a' -> In a' l) ->
      S (length l) <= fuel ->
      exists c,
        chain a fuel = Some c.
  Proof.
    induction fuel; intros.
    - simpl in *. omega.
    - simpl.
      break_match; eauto.
      specialize (IHfuel (remove A_eq_dec a0 l) a0).
      conclude_using ltac:(eauto using remove_NoDup).
      forward IHfuel.
      {
        intros.
        apply remove_preserve.
        - intro. subst. intuition. eauto.
        - cut (nextn a (S n) = Some a'); eauto.
          simpl. repeat find_rewrite. auto.
      }
      concludes.
      assert (length l <> 0).
      {
        destruct l; simpl in *; auto.
        cut (nextn a 1 = Some a0); eauto.
        simpl. repeat find_rewrite. auto.
      }
      forward IHfuel.
      {
        cut (S (length (remove A_eq_dec a0 l)) = length l); [omega|].
        eapply remove_length_in; eauto.
        cut (nextn a 1 = Some a0); eauto.
        simpl. repeat find_rewrite. auto.
      } concludes.
      break_exists. repeat find_rewrite. eauto.
  Qed.

  Lemma sufficient_fuel :
    forall a,
      In a all ->
      exists c,
        chain a (length all) = Some c.
  Proof.
    intros.
    eapply sufficient_fuel' with (l := (remove A_eq_dec a all)).
    - eauto using remove_NoDup.
    - intros. apply remove_preserve; eauto. eauto using nextn_in_all.
    - erewrite remove_length_in; eauto.
  Qed.

End find_chain.


(**************************************************************************)
(*                                                                        *)
(*  This file is part of octant-proof.                                    *)
(*                                                                        *)
(*  Copyright (C) 2019-2020 Orange                                        *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, either version 3 of the License, or (at your option)      *)
(*  any later version.                                                    *)
(*                                                                        *)
(*  It 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 Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  You should have received a copy of the GNU Lesser General Public      *)
(*  License along with the software. If not, see                          *)
(*  <https://www.gnu.org/licenses/>.                                      *)
(*                                                                        *)
(**************************************************************************)

Require Import syntax.

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype tuple finset bigop finfun.

Require Import bigop_aux.
Require Import utils.
Require Import finseqs.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Occurrences of atoms or terms *)
Section occurrences.

Section t_occ.

Variable p : program.

(** ** Atom occurrence *)
(** [occ] is a pair representing a position in
   a program. (occ x y) is the yth atom in the
   body of the xth clause of the program *)
Definition occ := ('I_(size p) * 'I_bn)%type.

(** ** Term occurrence *)
(** a term occurrence is a triple made of a clause
 position in the program, atom position in the body of the clause and term position in the atom *)
Record t_occ := T_occ {r_ind : 'I_(size p) ; b_ind : 'I_bn ; t_ind : 'I_max_ar}.

(** Type for the representation of [t_occ]*)
Definition tocc_countprod := prod_countType (prod_countType (ordinal_countType (size p)) (ordinal_countType bn)) (ordinal_countType max_ar).

(** Representation and cancellation lemma for [t_occ] *)
Definition t_occ_rep (a : t_occ) : tocc_countprod :=
  let: T_occ b c d := a in (b,c,d).
Definition t_occ_pre (a : tocc_countprod) :=
  let: (b,c,d) := a in T_occ b c d.

Lemma prod_of_t_occK : cancel t_occ_rep t_occ_pre.
Proof.
by case.
Qed.

(** [t_occ] is a finite type *)
Definition t_occ_eqMixin :=
  CanEqMixin prod_of_t_occK.
Canonical t_occ_eqType :=
  Eval hnf in EqType t_occ t_occ_eqMixin.
Definition t_occ_choiceMixin :=
  CanChoiceMixin prod_of_t_occK.
Canonical t_occ_choiceType :=
  Eval hnf in ChoiceType t_occ t_occ_choiceMixin.
Definition t_occ_countMixin :=
  (@CanCountMixin tocc_countprod _ t_occ_rep t_occ_pre prod_of_t_occK).
Canonical t_occ_countType :=
  Eval hnf in CountType t_occ t_occ_countMixin.
Definition t_occ_finMixin :=
  CanFinMixin prod_of_t_occK.
Canonical t_occ_finType :=
  Eval hnf in FinType t_occ t_occ_finMixin.

(** Accessing the atom matching a given t_occ *)
Definition at_at (o : t_occ) : option atom :=
  match nth_error p (r_ind o) with
    | None => None
    | Some cl => nth_error (body_cl cl) (b_ind o) end.

(** Accessing the term matching a given t_occ *)
Definition t_at (o : t_occ) : option term.
destruct (at_at o).
- destruct o as [x y z].
  apply (nth_error (arg_atom a) z).
- apply None.
Defined.

(** Accessing the predicate matching a given t_occ *)
Definition p_at (t : t_occ) := match (at_at t) with
  | None => None
  | Some ato => Some (sym_atom ato) end.

(** If [t_at] returns a variable, it an actual var of a clause. *)
Lemma t_at_vars_in (tocc : t_occ) v cl :
    t_at tocc = Some (Var v)
  -> Some cl = nth_error p (r_ind tocc)
  -> v \in tail_vars (body_cl cl).
Proof.
unfold tail_vars.
move => Htat Heq. apply/bigcup_seqP.
unfold t_at in Htat.
unfold at_at in Htat. rewrite -Heq in Htat.
assert (Haex : exists a, nth_error (body_cl cl) (b_ind tocc) = Some a).
destruct (nth_error (body_cl cl) (b_ind tocc)) as [a|] ; [|inversion Htat].
by exists a.
destruct Haex as [a Ha].
rewrite Ha in Htat.
exists a.
apply (nth_error_in Ha).
apply/andP ; split ; [|trivial].
apply/bigcup_seqP ; exists (Var v) ; [|apply/andP ; split ; by [|apply/set1P|]].
destruct tocc. apply (nth_error_in Htat).
Qed.

End t_occ.

Section a_occ.

Variable p : program.

(** ** Atom occurrence *)
(** an atom occurrence is a couple made of a clause
 position in the program and atom position in the body of the clause *)
Record a_occ := A_occ {ar_ind : 'I_(size p) ; ab_ind : 'I_bn}.

(** Extract the atom occurence from the term occurence*)
Definition atom_occ (t : t_occ p) := A_occ (r_ind t) (b_ind t).

(** Type for the representation of [t_occ]*)
Definition aocc_countprod := prod_countType (ordinal_countType (size p)) (ordinal_countType bn).

(** Representation and cancellation lemma for [t_occ] *)
Definition a_occ_rep (a : a_occ) : aocc_countprod :=
  let: A_occ b c := a in (b,c).
Definition a_occ_pre (a : aocc_countprod) :=
  let: (b,c) := a in A_occ b c.

Lemma prod_of_a_occK : cancel a_occ_rep a_occ_pre.
Proof.
by case.
Qed.

(** [a_occ] is a finite type *)
Definition a_occ_eqMixin :=
  CanEqMixin prod_of_a_occK.
Canonical a_occ_eqType :=
  Eval hnf in EqType a_occ a_occ_eqMixin.
Definition a_occ_choiceMixin :=
  CanChoiceMixin prod_of_a_occK.
Canonical a_occ_choiceType :=
  Eval hnf in ChoiceType a_occ a_occ_choiceMixin.
Definition a_occ_countMixin :=
  (@CanCountMixin aocc_countprod _ a_occ_rep a_occ_pre prod_of_a_occK).
Canonical a_occ_countType :=
  Eval hnf in CountType a_occ a_occ_countMixin.
Definition a_occ_finMixin :=
  CanFinMixin prod_of_a_occK.
Canonical a_occ_finType :=
  Eval hnf in FinType a_occ a_occ_finMixin.

End a_occ.

Section prog_occ.

(** ** Collecting occurrences of a variable *)
(** Set of term occurrences for p *)
Definition tocs p := {set (t_occ p)}.

(** ** Computing of occurrences of variables in terms, atoms, clauses *)
(** Given a list of pair with a bounded number as first element gives back the list with the
   numbers incremented *)
Definition shift1 {k : nat} {A : finType} (l : {set ('I_k * A)%type}) : {set ('I_k.+1 * A)%type} :=
  [set ((ord_shift x.1), x.2) | x in l].

(** For a given list of terms [l] gives back the set of indices of terms of l that are a variable *)
Definition occsInTermList (v : 'I_n) (l : seq term) : {set 'I_max_ar} :=
  [set i : 'I_max_ar | nth_error l i == Some (Var v)].

(** Gives back the indexes of the variables in an atom *)
Definition occsInAtom (a : atom) (v : 'I_n) : {set 'I_max_ar} :=
  (@occsInTermList v (arg_atom a)).

(** Accessing the term in atom [a] at an index from [occsInAtom a] will indeed give back a
  variable *)
Lemma occsInAtomV occ a v : occ \in occsInAtom a v -> nth_error (arg_atom a) occ = Some (Var v).
Proof.
rewrite in_set.
by move=>/eqP.
Qed.

(** Given a list of atoms, computes the positions of the variables in that list *)
Fixpoint occsInAtomList (al : seq atom) (v : 'I_n) : {set ('I_(size al) * 'I_max_ar)} :=
  match al with
  | [::] => set0
  | a::al => ([set (Ordinal (ltn0Sn _), x) | x in (occsInAtom a v)] :|: (shift1 (@occsInAtomList al v))) end.

(** [occsInAtomList] computes correct positions coresponding
  to atoms and to variables in those atoms *)
Lemma occsInAtomListVint (tl : seq atom) v aton termn :
               ((aton, termn) \in occsInAtomList tl v)
            -> (exists ato, nth_error tl aton = Some ato /\ nth_error (arg_atom ato) termn = Some (Var v)).
Proof.
move:aton termn.
induction tl.
- by move => aton termn; rewrite in_set0.
- move => aton termn /setUP [/imsetP [occ Hocc Heq]|Hrec].
  + exists a.
    inversion Heq. split.
    - auto.
    - by apply occsInAtomV.
  + destruct (imsetP Hrec) as [[atonm1 termnm1] Hinrec Heqrec].
    inversion Heqrec.
    apply/IHtl/Hinrec.
Qed.

(** [occsInAtomList] can be augmented with the clause index to get
  a tocc that references to a variable term in the program *)
Lemma occsInAtomListV {p} (cl : clause) (cln : 'I_(size p)) v aton termn : Some cl = nth_error p cln
            -> ((aton, termn) \in occsInAtomList (body_cl cl) v)
            -> @t_at p {| r_ind := cln; b_ind := widen_ord
                (wlist_to_seq_size (body_cl cl)) aton;
                      t_ind := termn |} = Some (Var v).
Proof.
destruct cl as [h tl].
move:tl aton.
apply (@wlist_ind atom_finType bn (fun tl => forall (aton : ordinal_finType (size (body_cl (Clause h tl))))
(Hcleq : Some (Clause h tl) = nth_error p cln)
(Hin : (aton, termn) \in occsInAtomList (body_cl (Clause h tl)) v),
t_at {| r_ind := cln; b_ind := widen_ord (wlist_to_seq_size (body_cl (Clause h tl))) aton;
  t_ind := termn |} = Some (Var v))).
repeat (unfold wlist_to_seq_co).
move => s Ps aton Hcleq Hin.
destruct (occsInAtomListVint Hin) as [ato [Hato Hterm]].
unfold t_at. unfold at_at.
by rewrite -Hcleq Hato.
Qed.

(** [occsInRule] is ocssInAtomList where the first element of the pairs
is widened to be 'I_bn *)
Definition occsInRule (v : 'I_n) (cl : clause) : {set ('I_bn * 'I_max_ar)} :=
  [set ((widen_ord (wlist_to_seq_size (body_cl cl)) (fst x)), (snd x)) | x in (occsInAtomList (body_cl cl) v)].

(** [ocssInRule] designates also valid variable indexes *)
Lemma occsInRuleV {p} cl v aton termn : ((aton, termn) \in occsInRule v (tnth (in_tuple p) cl))
                             -> t_at {| r_ind := cl; b_ind := aton; t_ind := termn |} = Some (Var v).
Proof.
move => /imsetP [[atonbis termnbis] Hin Heq]. inversion Heq as [[Hatoneq Htermneq]].
apply occsInAtomListV. simpl in *. by rewrite tnth_nth_error. apply Hin.
Qed.

(** A function to compute t_occs from a clause index and a list of pairs
  of bounded indexes. *)
Definition attach_cl_nb p (cl_nb : 'I_(size p)) (occs : {set ('I_bn * 'I_max_ar)}) : tocs p :=
  [set @T_occ p cl_nb (fst x) (snd x) | x in occs].
(** Computes all the variables t_occurence of a program *)
Definition occsInProgram p (v : 'I_n) : tocs p :=
  \bigcup_(cln in 'I_(size p)) attach_cl_nb cln (@occsInRule v (tnth (in_tuple p) cln)).

(** There is a variable indexed by each element of [occsInProgram p] *)
Lemma occsInProgramV {p} v (xocc : t_occ p) : xocc \in occsInProgram p v -> t_at (xocc) = Some (Var v).
Proof.
move => /bigcupP [cl Hclp /imsetP [[aton termn] HoccsInR Hocceq]].
rewrite Hocceq. by apply occsInRuleV.
Qed.

(** All vars of an atom arguments are in [atom_vars] *)
Lemma arg_atom_vars_in (v : 'I_n) (ato : atom) : (Var v \in arg_atom ato) <-> v \in atom_vars ato.
Proof.
destruct ato as [[ha tla] Ha].
simpl. unfold atom_vars. simpl. unfold raw_atom_vars. clear Ha.
induction tla.
- split ; [|rewrite big_nil in_set0] ; move => //.
- split ; [|rewrite big_cons] ; rewrite in_cons ; [move=>/orP ; rewrite big_cons |move=>/setUP] ; move => [Hnew | Hold].
  + apply/setUP. left. rewrite <- (eqP Hnew). by apply/set1P.
  + apply/setUP. right. apply/IHtla/Hold.
  + apply/orP. left. destruct a as [vv | cv].
    - by rewrite (set1P Hnew).
    - by rewrite in_set0 in Hnew.
  + apply/orP. right. apply/IHtla/Hold.
Qed.

End prog_occ.

(** default values *)
Variable dt : term.
Variable dv : 'I_n.
Variable df : symtype.

Definition term_to_var (t : term) :=
  match t with
    | Val c => dv
    | Var v => v end.

(** Returns (as a variable) the [j]th term in the head of [cl] *)
Definition get_cl_var (cl : clause) (j : nat) : 'I_n :=
  term_to_var (nth dt (arg_atom (head_cl cl)) j).

Lemma get_cl_var_leq (cl : clause) (j : nat) :
   only_variables_head cl
-> j < size (arg_atom (head_cl cl))
-> Var (get_cl_var cl j) \in arg_atom (head_cl cl).
Proof.
destruct cl as [[[f args] Hhcl] tlcl]. simpl. unfold get_cl_var. unfold hsym_cl.
unfold arg_atom. unfold only_variables_head. unfold only_variables_atom. unfold arg_atom.
simpl. clear Hhcl. clear tlcl.
move:j. induction args as [|hargs args];move=>[|j]//.
- move=>/= /andP [Hv1 _] _. destruct hargs as [x|x].
  simpl. apply/mem_head.
  inversion Hv1.
- move=>/andP [Hv1 Hv2] Hj. apply/mem_body.
  apply/IHargs;auto.
Qed.

End occurrences.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P I : Universe, ((wd_ P I /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A I /\ (wd_ B P /\ (wd_ B I /\ (wd_ C P /\ (wd_ C I /\ (wd_ A I /\ (wd_ I B /\ (wd_ A B /\ (wd_ P I /\ (col_ A I B /\ (col_ P I I /\ col_ A P B)))))))))))))))) -> col_ A P I)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ C Cprime /\ (wd_ A B /\ (wd_ C B /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ C P /\ (wd_ B P /\ (wd_ A P /\ (col_ P Q Aprime /\ (col_ P Q Cprime /\ (col_ A B C /\ col_ A B Aprime)))))))))))))))) -> col_ C A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Lists.List Coq.Bool.Bool.
Require Import MirrorShard.Expr.
Require Import MirrorShard.ExprUnify.
Require Import MirrorShard.Instantiation.

Module Make (S : Subst) <: SyntacticUnifier S.
  Section typed.
    Variable types : list type.

    Section unify.
      Variable exprUnify : expr types -> expr types -> S.Subst types -> option (S.Subst types).

      Fixpoint unify (l r : expr types) (sub : S.Subst types) : option (S.Subst types) :=
        match l , r with
          | Const t v , Const t' v' =>
            match equiv_dec t t' with
              | left pf => match pf in _ = k return tvarD _ k -> _ with
                             | refl_equal => fun v' =>
                               if get_Eq types t v v'
                                 then Some sub
                                 else None
                           end v'
              | right _ => None
            end
          | Var v , Var v' =>
            if Peano_dec.eq_nat_dec v v'
              then Some sub
              else None
          | Func f1 args1 , Func f2 args2 =>
            if EqNat.beq_nat f1 f2 then
              (fix unifyArgs (args1 args2 : list (expr types)) (s : S.Subst types)
                : option (S.Subst types) :=
                match args1 , args2 with
                  | nil , nil => Some s
                  | nil , _ :: _ => None
                  | _ :: _ , nil => None
                  | arg1 :: args1 , arg2 :: args2 =>
                    match unify arg1 arg2 s with
                      | None => None
                      | Some s => unifyArgs args1 args2 s
                    end
                end) args1 args2 sub
              else None
          | Equal t1 e1 f1 , Equal t2 e2 f2 =>
            if equiv_dec t1 t2 then
              match unify e1 e2 sub with
                | None => None
                | Some sub => unify f1 f2 sub
              end
              else
                None
          | Not e1 , Not e2 =>
            unify e1 e2 sub
          | UVar l , UVar r =>
            if EqNat.beq_nat l r then Some sub
              else
                match S.Subst_lookup l sub with
                  | None => S.Subst_set l (UVar r) sub
                  | Some l' =>
                    match S.Subst_lookup r sub with
                      | None => S.Subst_set r l' sub
                      | Some r' =>
                        exprUnify l' r' sub
                    end
                end
          | UVar u , r =>
            match S.Subst_lookup u sub with
              | None =>
                S.Subst_set u r sub
              | Some l' =>
                exprUnify l' r sub
            end
          | l , UVar u =>
            match S.Subst_lookup u sub with
              | None =>
                S.Subst_set u l sub
              | Some r' =>
                exprUnify l r' sub
            end
          | _ , _ => None
        end.
    End unify.

    Fixpoint exprUnify (bound : nat) : expr types -> expr types -> (S.Subst types) -> option (S.Subst types) :=
      match bound with
        | 0 => fun _ _ _ => None
        | S bound =>
          fix unify (l r : expr types) (sub : S.Subst types) : option (S.Subst types) :=
            match l , r with
              | Const t v , Const t' v' =>
                match equiv_dec t t' with
                  | left pf => match pf in _ = k return tvarD _ k -> _ with
                                 | refl_equal => fun v' =>
                                   if get_Eq types t v v'
                                     then Some sub
                                     else None
                               end v'
                  | right _ => None
                end
              | Var v , Var v' =>
                if EqNat.beq_nat v v'
                  then Some sub
                  else None
              | Func f1 args1 , Func f2 args2 =>
                if EqNat.beq_nat f1 f2 then
                  (fix unifyArgs (args1 args2 : list (expr types)) (s : S.Subst types)
                    : option (S.Subst types) :=
                    match args1 , args2 with
                      | nil , nil => Some s
                      | nil , _ :: _ => None
                      | _ :: _ , nil => None
                      | arg1 :: args1 , arg2 :: args2 =>
                        match unify arg1 arg2 s with
                          | None => None
                          | Some s => unifyArgs args1 args2 s
                        end
                    end) args1 args2 sub
                  else None
              | Equal t1 e1 f1 , Equal t2 e2 f2 =>
                if equiv_dec t1 t2 then
                  match unify e1 e2 sub with
                    | None => None
                    | Some sub => unify f1 f2 sub
                  end
                  else
                    None
              | Not e1 , Not e2 =>
                unify e1 e2 sub
              | UVar l , UVar r =>
                if EqNat.beq_nat l r then Some sub
                  else
                    match S.Subst_lookup l sub with
                      | None => S.Subst_set l (UVar r) sub
                      | Some l' =>
                        match S.Subst_lookup r sub with
                          | None => S.Subst_set r l' sub
                          | Some r' =>
                            exprUnify bound l' r' sub
                        end
                    end
              | UVar u , r =>
                match S.Subst_lookup u sub with
                  | None =>
                    S.Subst_set u r sub
                  | Some l' =>
                    exprUnify bound l' r sub
                end
              | l , UVar u =>
                match S.Subst_lookup u sub with
                  | None =>
                    S.Subst_set u l sub
                  | Some r' =>
                    exprUnify bound l r' sub
                end
              | _ , _ => None
            end
      end.

    Hint Rewrite S.exprInstantiate_Func S.exprInstantiate_Equal S.exprInstantiate_Not
      S.exprInstantiate_UVar S.exprInstantiate_Var S.exprInstantiate_Const : subst_simpl.

    Opaque S.Subst_lookup S.Subst_set S.exprInstantiate.

    Require Import ExtLib.Tactics.Consider.

    Theorem unify_uvar : forall (u : uvar) (sub sub' : S.Subst types)
      (o : expr types -> expr types -> S.Subst types -> option (S.Subst types)),
      (forall (l r : expr types) (sub0 sub'0 : S.Subst types),
        o l r sub0 = Some sub'0 ->
        S.exprInstantiate sub'0 l = S.exprInstantiate sub'0 r /\
        S.Subst_Extends sub'0 sub0 /\
        (forall (funcs : tfunctions) (U G : tenv) (t : tvar),
          is_well_typed funcs U G l t = true ->
          is_well_typed funcs U G r t = true ->
          S.Subst_WellTyped funcs U G sub0 -> S.Subst_WellTyped funcs U G sub'0)) ->
      forall e : expr types,
        match S.Subst_lookup u sub with
          | Some r' => o e r' sub
          | None => S.Subst_set u e sub
        end = Some sub' ->
        S.exprInstantiate sub' e = S.exprInstantiate sub' (UVar u) /\
        S.Subst_Extends sub' sub /\
        (forall (funcs : tfunctions) (U G : tenv) (t1 : tvar),
          is_well_typed funcs U G e t1 = true ->
          is_well_typed (types := types) funcs U G (UVar u) t1 = true ->
          S.Subst_WellTyped funcs U G sub -> S.Subst_WellTyped funcs U G sub').
    Proof.
      intros. consider (S.Subst_lookup u sub); intros.
      { specialize (H _ _ _ _ H1). rewrite S.exprInstantiate_UVar.
        intuition.
        { erewrite S.Subst_lookup_Extends by eassumption. auto. }
        { eapply H4; try eassumption.
          destruct (S.WellTyped_lookup H6 H0). intuition. simpl in H5.
          rewrite H8 in *.
          destruct (nth_error U u); try congruence.
          consider (tvar_seqb t1 x); congruence. } }
      { clear H; intuition.
        { erewrite S.Subst_set_exprInstantiate by eassumption; auto. }
        { eapply S.Subst_set_Extends; eauto. }
        { eapply S.Subst_set_WellTyped; try eassumption. simpl in H2.
          destruct (nth_error U u); try congruence.
          consider (tvar_seqb t1 t); congruence. } }
    Qed.

    Lemma exprUnify_all : forall n l r sub sub',
      exprUnify n l r sub = Some sub' ->
         (S.exprInstantiate sub' l = S.exprInstantiate sub' r)
      /\ (S.Subst_Extends sub' sub)
      /\ (forall funcs U G t,
            is_well_typed funcs U G l t = true ->
            is_well_typed funcs U G r t = true ->
            S.Subst_WellTyped funcs U G sub ->
            S.Subst_WellTyped funcs U G sub').
    Proof.
      induction n; simpl in *; try congruence.
      induction l; simpl in *.
      { destruct r; simpl in *; intros; try congruence.
        { consider (equiv_dec t t1); unfold equiv in *; simpl in *; intros; subst; try congruence.
          consider (get_Eq types t1 t0 t2); try congruence; simpl in *; intros.
          inversion H0; clear H0; subst. split; [ reflexivity | split; [ reflexivity | ] ].
          intros. consider (tvar_seqb t1 t); intros; subst; auto. }
        { eapply unify_uvar; eauto. } }
      { destruct r; simpl in *; intros; try congruence.
        { consider (EqNat.beq_nat x v); try congruence; subst; intros.
          inversion H0; clear H0; subst. intuition. }
        { eapply unify_uvar; eauto. } }
      { do 4 intro.
        assert ((exists u, r = UVar u) \/
                match S.Subst_lookup x sub with
                  | Some l' => exprUnify n l' r sub
                  | None => S.Subst_set x r sub
                end = Some sub').
        { destruct r; auto. left. eauto. }
        destruct H0.
        { destruct H0; subst.
          consider (EqNat.beq_nat x x0); intros; subst.
          { inversion H0; clear H0; subst. intuition. }
          { consider (S.Subst_lookup x sub); intros.
            { consider (S.Subst_lookup x0 sub); intros.
              { repeat rewrite S.exprInstantiate_UVar.
                specialize (IHn _ _ _ _ H2). destruct IHn as [ ? [ ? ? ] ].
                repeat erewrite S.Subst_lookup_Extends by eassumption.
                intuition.
                simpl in *; consider (nth_error U x); consider (nth_error U x0); intros.
                consider (tvar_seqb t t0); consider (tvar_seqb t t1); intros.
                subst. subst.
                destruct (S.WellTyped_lookup H8 H0).
                destruct (S.WellTyped_lookup H8 H1).
                rewrite H6 in *. rewrite H9 in *.
                intuition. inversion H11; inversion H7; subst. subst.
                eapply H5; eauto. }
              { intuition.
                { erewrite S.Subst_set_exprInstantiate with (x := x0) by eassumption.
                  rewrite S.exprInstantiate_UVar.
                  erewrite S.Subst_lookup_Extends; try eassumption.
                  reflexivity. eapply S.Subst_set_Extends; eauto. }
                { eapply S.Subst_set_Extends; eauto. }
                { simpl in *.
                  consider (nth_error U x); consider (nth_error U x0); intros.
                  consider (tvar_seqb t t0); consider (tvar_seqb t t1); intros; subst.
                  eapply S.Subst_set_WellTyped; try eassumption.
                  subst.
                  destruct (S.WellTyped_lookup H5 H0); intuition.
                  rewrite H6 in *. inversion H7. subst. auto. } } }
            { intuition.
              { erewrite S.Subst_set_exprInstantiate with (x := x) by eassumption.
                reflexivity. }
              { eapply S.Subst_set_Extends; eauto. }
              { simpl in *.
                consider (nth_error U x); consider (nth_error U x0); intros.
                consider (tvar_seqb t t0); consider (tvar_seqb t t1); intros; subst.
                eapply S.Subst_set_WellTyped; try eassumption.
                subst. simpl. rewrite H2. consider (tvar_seqb t0 t0); auto. } } } }
        { clear H. consider (S.Subst_lookup x sub); intros.
          { specialize (IHn _ _ _ _ H0); intuition.
            { rewrite S.exprInstantiate_UVar.
              erewrite S.Subst_lookup_Extends; try eassumption. }
            { eapply H4; try eassumption.
              destruct (S.WellTyped_lookup H6 H).
              destruct (nth_error U x); try congruence.
              intuition. inversion H8; clear H8; subst.
              consider (tvar_seqb t x0); try congruence. } }
          { intuition.
            { erewrite S.Subst_set_exprInstantiate by eassumption. auto. }
            { eapply S.Subst_set_Extends; eauto. }
            { eapply S.Subst_set_WellTyped; eauto.
              destruct (nth_error U x); try congruence.
              consider (tvar_seqb t t0); try congruence. } } } }
      { destruct r; simpl in *; intros; try congruence.
        { consider (EqNat.beq_nat f f0); try congruence; intros; subst.
          intros. apply and_assoc.
          split.
          { generalize dependent l0; generalize dependent sub; generalize dependent sub'.
            induction H.
            { destruct l0; try congruence. inversion 1; subst. intuition. }
            { destruct l0; try congruence; intros.
              match goal with
                | [ H : match ?X _ _ _ with _ => _ end = _ |- _ ] =>
                  generalize dependent X; intros
              end.
              consider (o x e sub); try congruence; intros.
              specialize (H _ _ _ H1). specialize (IHForall _ _ _ H2). clear H2.
              intuition.
              { simpl. inversion H; clear H; subst.
                repeat rewrite S.exprInstantiate_Func in *.
                simpl. f_equal. inversion H7; f_equal; auto.
                erewrite <- S.exprInstantiate_Extends with (y := s); eauto. rewrite H2.
                rewrite S.exprInstantiate_Extends; auto. }
              { etransitivity; eauto. } } }
          { intros. destruct (nth_error funcs f0); try congruence.
            destruct t0. simpl in *.
            generalize dependent l0; generalize dependent sub; generalize dependent sub';
              generalize dependent TDomain.
            induction H.
            { destruct l0; try congruence. } (*inversion 1; subst.
              destruct (tvar_seqb t TRange); try congruence. auto. } *)
            { destruct l0; try congruence. intros.
              match goal with
                | [ H : match ?X _ _ _ with _ => _ end = _ |- _ ] =>
                  generalize dependent X; intros
              end.
              consider (o x e sub); intros; try congruence.
              specialize (H _ _ _ H2).
              consider (tvar_seqb t TRange); intros; subst. simpl in *.
              destruct TDomain; try congruence.
              consider (is_well_typed funcs U G x t).
              consider (is_well_typed funcs U G e t).
              intuition. eapply H7. 3: eapply H5. eassumption. eauto. eauto. } } }
        { eapply unify_uvar; eauto. } }
      { destruct r; intros; try congruence.
        { consider (equiv_dec t t0); try congruence; unfold equiv in *; simpl in *; intros; subst.
          match goal with
            | [ H : match ?X _ _ _ with _ => _ end = _ |- _ ] =>
              generalize dependent X; intros
          end.
          consider (o l1 r1 sub); try congruence; intros.
          specialize (IHl1 _ _ _ H). specialize (IHl2 _ _ _ H0).
          intuition.
          { do 2 rewrite S.exprInstantiate_Equal. f_equal; auto.
            erewrite <- S.exprInstantiate_Extends with (y := s); eauto. rewrite H1.
            rewrite S.exprInstantiate_Extends; auto. }
          { etransitivity; eauto. }
          { destruct t; try congruence.
            eapply andb_true_iff in H4. eapply andb_true_iff in H8. intuition eauto. } }
        { eapply unify_uvar; eauto. } }
      { destruct r; intros; try congruence.
        { specialize (IHl _ _ _ H). clear H. intuition eauto.
          repeat rewrite S.exprInstantiate_Not. rewrite H. auto.
          destruct t; try congruence. simpl in *. eauto. }
        { eapply unify_uvar; eauto. } }
    Qed.

    Theorem exprUnify_sound_syn : forall n l r sub sub',
      exprUnify n l r sub = Some sub' ->
      S.exprInstantiate sub' l = S.exprInstantiate sub' r.
    Proof.
      intros. specialize (exprUnify_all _ _ _ _ _ H); intuition.
    Qed.

    Theorem exprUnify_sound_sem : forall n l r sub sub',
      exprUnify n l r sub = Some sub' ->
      forall funcs U G t,
      exprD funcs U G (S.exprInstantiate sub' l) t =
      exprD funcs U G (S.exprInstantiate sub' r) t.
    Proof.
      intros. f_equal. specialize (exprUnify_all _ _ _ _ _ H); intuition.
    Qed.

    Theorem exprUnify_Extends : forall n l r sub sub',
      exprUnify n l r sub = Some sub' ->
      S.Subst_Extends sub' sub.
    Proof.
      intros. specialize (exprUnify_all _ _ _ _ _ H); intuition.
    Qed.

    Theorem exprUnify_WellTyped : forall n l r sub sub',
      exprUnify n l r sub = Some sub' ->
      forall funcs U G t,
        is_well_typed funcs U G l t = true ->
        is_well_typed funcs U G r t = true ->
        S.Subst_WellTyped funcs U G sub ->
        S.Subst_WellTyped funcs U G sub'.
    Proof.
      do 6 intro. specialize (exprUnify_all _ _ _ _ _ H); intuition.
    Qed.

  End typed.
End Make.


(* This file is developed by Qinxiang Cao, Aquinas Hobor and Shengyi Wang in 2015. *)

Require Import VST.veric.base.
Require Import VST.veric.val_lemmas.
Require Import VST.veric.Memory.

Lemma range_overlap_spec: forall l1 n1 l2 n2,
  n1 > 0 ->
  n2 > 0 ->
  (range_overlap l1 n1 l2 n2 <-> adr_range l1 n1 l2 \/ adr_range l2 n2 l1).
Proof.
  intros.
  unfold range_overlap, adr_range.
  destruct l1, l2.
  split; intros.
  + destruct H1 as [[? ?] [[? ?] [? ?]]].
    subst.
    destruct (zle z z0); [left | right].
    - split; auto.
      lia.
    - split; auto.
      lia.
  + destruct H1 as [[? ?] | [? ?]].
    - exists (b0, z0). repeat split; auto; lia.
    - exists (b, z). repeat split; auto; lia.
Qed.

Lemma range_overlap_comm: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> range_overlap l2 n2 l1 n1.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l ?].
  exists l.
  tauto.
Qed.

Lemma range_overlap_non_zero: forall l1 n1 l2 n2, range_overlap l1 n1 l2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  unfold range_overlap.
  intros.
  destruct H as [l [? ?]].
  apply adr_range_non_zero in H.
  apply adr_range_non_zero in H0.
  auto.
Qed.

Definition pointer_range_overlap p n p' n' :=
  exists l l', val2adr p l /\ val2adr p' l' /\ range_overlap l n l' n'.

Lemma pointer_range_overlap_dec: forall p1 n1 p2 n2, {pointer_range_overlap p1 n1 p2 n2} + {~ pointer_range_overlap p1 n1 p2 n2}.
Proof.
  unfold pointer_range_overlap.
  intros.
  destruct p1;
  try solve
   [right;
    intros [[? ?] [[? ?] [HH [_ _]]]];
    inversion HH].
  destruct p2;
  try solve
   [right;
    intros [[? ?] [[? ?] [_ [HH _]]]];
    inversion HH].
  destruct (zlt 0 n1); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; lia].
  destruct (zlt 0 n2); [| right; intros [[? ?] [[? ?] [_ [_ HH]]]]; apply range_overlap_non_zero in HH; lia].
  destruct (eq_block b b0).
  (*destruct (Clight_lemmas.block_eq_dec b b0).*)
  + subst b0.
    unfold val2adr.
    forget (Ptrofs.unsigned i) as i1;
    forget (Ptrofs.unsigned i0) as i2;
    clear i i0.
    destruct (range_dec i1 i2 (i1 + n1)); [| destruct (range_dec i2 i1 (i2 + n2))].
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try lia.
      left; simpl; auto.
    - left.
      exists (b, i1), (b, i2); repeat split; auto.
      apply range_overlap_spec; try lia.
      right; simpl; auto.
    - right.
      intros [[? ?] [[? ?] [? [? HH]]]].
      inversion H; inversion H0; subst.
      apply range_overlap_spec in HH; [| lia | lia].
      simpl in HH; lia.
  + right.
    intros [[? ?] [[? ?] [? [? HH]]]].
    simpl in H, H0.
    inversion H; inversion H0; subst.
    apply range_overlap_spec in HH; [| lia | lia].
    simpl in HH.
    pose proof @eq_sym _ b0 b.
    tauto.
Qed.

Lemma pointer_range_overlap_refl: forall p n1 n2,
  isptr p ->
  n1 > 0 ->
  n2 > 0 ->
  pointer_range_overlap p n1 p n2.
Proof.
  intros.
  destruct p; try inversion H.
  exists (b, Ptrofs.unsigned i), (b, Ptrofs.unsigned i).
  repeat split; auto.
  apply range_overlap_spec; auto.
  left.
  simpl.
  split; auto; lia.
Qed.

Lemma pointer_range_overlap_comm: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 <->
  pointer_range_overlap p2 n2 p1 n1.
Proof.
  cut (forall p1 n1 p2 n2,
         pointer_range_overlap p1 n1 p2 n2 ->
         pointer_range_overlap p2 n2 p1 n1). {
    intros.
    pose proof H p1 n1 p2 n2.
    pose proof H p2 n2 p1 n1.
    tauto.
  }
  unfold pointer_range_overlap.
  intros.
  destruct H as [l [l' [? [? ?]]]].
  exists l', l.
  repeat split; auto.
  apply range_overlap_comm.
  auto.
Qed.

Lemma pointer_range_overlap_non_zero: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> n1 > 0 /\ n2 > 0.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  eapply range_overlap_non_zero; eauto.
Qed.

Lemma pointer_range_overlap_isptr: forall p1 n1 p2 n2,
  pointer_range_overlap p1 n1 p2 n2 -> isptr p1 /\ isptr p2.
Proof.
  intros.
  destruct H as [? [? [? [? ?]]]].
  destruct p1, p2; try solve [inversion H | inversion H0].
  simpl; auto.
Qed.


(* ** Imports and settings *)
Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
Require Import strings utils gen_map type ident.
Require Import Utf8.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* ** Variables map, to be used when computation is needed
 * -------------------------------------------------------------------- *)

Module MvMake (I:IDENT).

  Import I Mid.
#[global]
  Existing Instance K.cmpO.

  Record var := Var { vtype : stype; vname : ident }.

  Definition var_beq (v1 v2:var) :=
    let (t1,n1) := v1 in
    let (t2,n2) := v2 in
    (t1 == t2) && (n1 == n2).

  Lemma var_eqP : Equality.axiom var_beq.
  Proof.
    move=> [t1 n1] [t2 n2];apply:(iffP idP) => /= [/andP[]/eqP->/eqP->| []->->] //.
      by rewrite !eq_refl.
  Qed.

  Definition var_eqMixin := EqMixin var_eqP.
  Canonical  var_eqType  := EqType var var_eqMixin.

  Definition var_cmp (x y:var) :=
    Lex (stype_cmp x.(vtype) y.(vtype)) (K.cmp x.(vname) y.(vname)).

#[global]
  Instance varO : Cmp var_cmp.
  Proof.
    constructor=> [x y | y x z c | [??] [??]] ;rewrite /var_cmp !Lex_lex.
    + by apply lex_sym;apply cmp_sym.
    + by apply lex_trans=> /=; apply cmp_ctrans.
    by move=> /lex_eq [] /= /(@cmp_eq _ _ stypeO) -> /(@cmp_eq _ _ K.cmpO) ->.
  Qed.

  Lemma var_surj (x:var) : x = Var x.(vtype) x.(vname).
  Proof. by case: x. Qed.

  Module Mv.

  Record rt_ (to:stype -> Type) := MkT {
    dft : forall (x:var) ,to x.(vtype);
    tbl : Mt.t (fun ty => Mid.t (to ty));
  }.

  Definition t := rt_.

  Definition empty {to} (dft : forall (x:var), to x.(vtype)) : t to := {|
     dft := dft;
     tbl := Mt.empty _;
  |}.

  Definition get {to} (m: t to) (x:var) : to x.(vtype) :=
    match (m.(tbl).[x.(vtype)])%mt with
    | Some mi =>
      match mi.[x.(vname)] with
      | Some v => v
      | None   => m.(dft) x
      end
    | None =>  m.(dft) x
    end.

  Definition set {to} (m: t to) (x:var) (v:to x.(vtype)) : t to :=
    let mi :=
      match (m.(tbl).[x.(vtype)])%mt with
      | Some mi => mi
      | None    => Mid.empty _
      end in
    let mi := mi.[x.(vname) <- v] in
    {| dft := m.(dft);
       tbl := (m.(tbl).[x.(vtype) <- mi])%mt; |}.

  Definition remove to (m: t to) x :=
    match (m.(tbl).[x.(vtype)])%mt with
    | Some mi =>
      {| dft := m.(dft);
         tbl :=  m.(tbl).[x.(vtype) <- Mid.remove mi x.(vname)]%mt; |}
    | None    => m
    end.

  Definition indom to x (m: t to) :=
    match (m.(tbl).[x.(vtype)])%mt with
    | Some mi =>
      match mi.[x.(vname)] with
      | Some _ => true
      | None   => false
      end
    | None => false
    end.

  Definition map {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) : t to2 :=
    {| dft := fun (x:var) => f x.(vtype) (dft m x);
       tbl := Mt.map (fun t mi => Mid.map (f t) mi) m.(tbl); |}.

  Definition map2 {to1 to2 to3}
     (fd:forall x, to3 x.(vtype))
     (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype))
     (m1: t to1) (m2: t to2): t to3 :=
    let dft1 := m1.(dft) in
    let dft2 := m2.(dft) in
    let doty ty mi1 mi2 :=
       match mi1, mi2 with
       | None, None => None
       | Some mi1, None     =>
         Some (Mid.mapi
           (fun id (v1:to1 ty) => let x := Var ty id in (f x v1 (dft2 x):to3 ty))
           mi1)
       | None    , Some mi2 =>
         Some (Mid.mapi
           (fun id (v2:to2 ty) => let x := Var ty id in (f x (dft1 x) v2:to3 ty))
           mi2)
       | Some mi1, Some mi2 =>
         Some (Mid.map2 (fun id (o1:option (to1 ty)) (o2: option (to2 ty))  =>
           match o1, o2 with
           | None   , None    => None
           | Some v1, None    => let x := Var ty id in Some (f x v1 (dft2 x))
           | None   , Some v2 => let x := Var ty id in Some (f x (dft1 x) v2)
           | Some v1, Some v2 => let x := Var ty id in (Some (f x v1 v2): option (to3 ty))
           end) mi1 mi2)
        end in
    {| dft := fd;
       tbl := Mt.map2 doty m1.(tbl) m2.(tbl) |}.

  Local Notation "vm .[ x ]" := (@get _ vm x).
  Local Notation "vm .[ x  <- v ]" := (@set _ vm x v).

  Lemma get0 {to} (dft: forall x, to x.(vtype)) (x:var) : (empty dft).[x] = dft x.
  Proof. by rewrite /empty /get Mt.get0. Qed.

  Lemma setP_eq {to} (m:t to) (x:var) (v:to x.(vtype)) : m.[x <- v].[x] = v.
  Proof. by rewrite /set /get Mt.setP_eq Mid.setP_eq. Qed.

  Lemma setP_neq {to} (m:t to) x y (v:to x.(vtype)) :
    x != y ->   m.[x <- v].[y] = m.[y].
  Proof.
    move=> neq;rewrite /set /get.
    case : (boolP ((vtype x) == (vtype y))) => [/eqP eq | ?] /=;
      last by rewrite Mt.setP_neq.
    move: v;rewrite eq => v; rewrite Mt.setP_eq Mid.setP_neq.
    + by case: (_.[_])%mt => //; rewrite Mid.get0.
    by apply: contra neq=> /eqP eqn;rewrite (var_surj x) eq eqn -var_surj.
  Qed.

  Lemma indom0 {to} (dft: forall x, to x.(vtype)) (x:var): ~~indom x (empty dft).
  Proof. by rewrite /indom Mt.get0. Qed.

  Lemma indom_set_eq {to} (m:t to) (x:var) (v:to x.(vtype)): indom x m.[x<-v].
  Proof. by rewrite /indom /set /= Mt.setP_eq Mid.setP_eq. Qed.

  Lemma indom_set_neq {to} (m:t to) (x y:var) (v:to x.(vtype)):
     x !=y -> indom y m.[x<- v] = indom y m.
  Proof.
    move=> H;rewrite /indom /set /=.
    case: (vtype x =P vtype y)=> [Heq | /eqP ?];last by rewrite Mt.setP_neq.
    rewrite -Heq Mt.setP_eq Mid.setP_neq.
    + by case: (_.[_])%mt => //;rewrite Mid.get0.
    by apply: contra H=> /eqP eqn;rewrite (var_surj x) Heq eqn -var_surj.
  Qed.

  Lemma indom_setP {to} (m:t to) (x y:var) (v:to x.(vtype)):
     indom y m.[x<-v] = (x == y) || indom y m.
  Proof.
   case : (boolP (x==y)) => [/eqP <-| ] /=;first by rewrite indom_set_eq.
   by apply indom_set_neq.
  Qed.

  Lemma indom_getP  {to} (m:t to) x: ~~indom x m -> m.[x] = dft m x.
  Proof.
    by rewrite /indom /get;case: Mt.get => // ?;case: Mid.get.
  Qed.

  Lemma dft_setP {to} (m:t to) (x:var) (v:to x.(vtype)): dft (set m v) = dft m.
  Proof. done. Qed.

  Lemma removeP_eq to (m: t to) x: (remove m x).[x] = dft m x.
  Proof.
    rewrite /remove/get;case H: (tbl m).[_]%mt => [mi|] /=;last by rewrite H.
    by rewrite Mt.setP_eq removeP_eq.
  Qed.

  Lemma removeP_neq to (m: t to) x y: x != y -> (remove m x).[y] = m.[y].
  Proof.
    rewrite /remove/get=> Hxy;case: (vtype x =P vtype y) => /= [Heq | /eqP Hneq].
    + rewrite Heq;case H: (tbl m).[_]%mt => [mi|] /=;last by rewrite H.
      rewrite Mt.setP_eq Mid.removeP_neq //.
      by apply: contra Hxy => /eqP Hn;rewrite (var_surj x) (var_surj y) Heq Hn.
    by case H: (tbl m).[_]%mt => [mi|] //=;rewrite Mt.setP_neq.
  Qed.

  Lemma indom_removeP to (m: t to) x y:
    indom y (remove m x) = (x != y) && indom y m.
  Proof.
    rewrite /remove/indom.
    case: (vtype x =P vtype y) => /= [Heq | /eqP Hneq].
    + rewrite -Heq;case H: ((tbl m).[_]%mt) => [mi|]/=;last by rewrite H andbC.
      rewrite Mt.setP_eq Mid.removeP.
      case: (_ =P _) => [Heqn | Hneqn ].
      + by rewrite {1}(var_surj x) {1}(var_surj y) -Heq Heqn eq_refl.
      have -> // : x != y.
      by apply /eqP=> Hx;apply Hneqn;rewrite Hx.
    have -> : x != y.
    + by apply /eqP=> Hx;move:Hneq;rewrite Hx eq_refl.
    by case H: ((tbl m).[_]%mt) => [mi|] //=;rewrite Mt.setP_neq.
  Qed.

  Lemma indom_removeP_eq to (m: t to) x:
    ~~indom x (remove m x).
  Proof. by rewrite indom_removeP eq_refl. Qed.

  Lemma indom_removeP_neq to (m: t to) x y: x != y ->
    indom y (remove m x) = indom y m.
  Proof. by rewrite indom_removeP=> ->. Qed.

  Lemma dft_removeP to (m: t to) x: dft (remove m x) = dft m.
  Proof. by rewrite /dft/remove;case:(tbl m).[_]%mt. Qed.

  Lemma mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) x:
    (map f m).[x] = f x.(vtype) m.[x].
  Proof.
    rewrite /map /get /=.
    rewrite Mt.mapP;case: Mt.get => //= mi.
    by rewrite Mid.mapP; case: Mid.get.
  Qed.

  Lemma indom_mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) x:
     indom x (map f m) = indom x m.
  Proof.
    rewrite /map /indom /= Mt.mapP.
    by case: Mt.get => //= ?;rewrite Mid.mapP;case Mid.get.
  Qed.

  Lemma dft_mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1):
     dft (map f m) = fun x : var => f (vtype x) (dft m x).
  Proof. done. Qed.

  Lemma map2Pred {to1 to2 to3}
    (fd: forall x,  to3 x.(vtype))
    (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x P:
    (~~indom x m1 -> ~~indom x m2 -> P (f x (dft m1 x) (dft m2 x)) -> P (fd x)) ->
    P (f x m1.[x] m2.[x]) -> P (map2 fd f m1 m2).[x].
  Proof.
    rewrite /indom /map2 /get /= Mt.map2P //.
    case: ((tbl m1).[vtype x])%mt=>[mi1|];case: ((tbl m2).[vtype x])%mt=>[mi2|];last by auto.
    + rewrite Mid.map2P //.
      by case: (Mid.get mi1 (vname x));case: (Mid.get mi2 (vname x))=> //;
         last (by auto); case: (x) P.
    + by rewrite Mid.mapiP //;case: (Mid.get mi1 (vname x));case: (x) P =>//=;auto.
    by rewrite Mid.mapiP //;case: (Mid.get mi2 (vname x));case: (x) P=> //=;auto.
  Qed.

  Lemma map2P {to1 to2 to3}
    (fd: forall x,  to3 x.(vtype))
    (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x:
    (~~indom x m1 -> ~~indom x m2 -> fd x = f x (dft m1 x) (dft m2 x)) ->
    (map2 fd f m1 m2).[x] = f x m1.[x] m2.[x].
  Proof. by apply map2Pred => // ?? H1 H2;rewrite H2 // H1. Qed.

  Lemma indom_map2P {to1 to2 to3} fd
      (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x:
     indom x (map2 fd f m1 m2) = indom x m1 || indom x m2.
  Proof.
    rewrite /map2 /indom /= Mt.map2P //.
    case: ((tbl m1).[vtype x])%mt=> [mi1 | ];case: ((tbl m2).[vtype x])%mt => [mi2 | ] //.
    + by rewrite Mid.map2P //; case: Mid.get => [?|] /=;case: Mid.get.
    + by rewrite Mid.mapiP;case: Mid.get.
    by rewrite Mid.mapiP;case: Mid.get.
  Qed.

  Lemma dft_map2P {to1 to2 to3} fd
      (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2:
     dft (map2 fd f m1 m2) = fd.
  Proof. done. Qed.

  End Mv.

End MvMake.

(* ** Types for idents
 * -------------------------------------------------------------------- *)

Module Var := MvMake Ident.
Export Var.
Notation var   := Var.var.
Notation vtype := Var.vtype.
Notation vname := Var.vname.
Notation Var   := Var.Var.
Notation vbool i := {| vtype := sbool; vname := i; |}.

Declare Scope mvar_scope.
Delimit Scope mvar_scope with mv.
Notation "vm .[ x ]" := (@Mv.get _ vm x) : mvar_scope.
Notation "vm .[ x  <- v ]" := (@Mv.set _ vm x v) : mvar_scope.
Arguments Mv.get to m%mvar_scope x.
Arguments Mv.set to m%mvar_scope x v.

Lemma vtype_diff x x': vtype x != vtype x' -> x != x'.
Proof. by apply: contra => /eqP ->. Qed.

Lemma vname_diff x x': vname x != vname x' -> x != x'.
Proof. by apply: contra => /eqP ->. Qed.

(* ** Variables function: to be not used if computation is needed,
 *                       but extentianality is permited
 * -------------------------------------------------------------------- *)

Module Type FvT.
  Parameter t : (stype -> Type) -> Type.
  Parameter empty :
    forall {to:stype -> Type} (dval : forall (x:var), to x.(vtype)), t to.

  Parameter get :
    forall {to:stype -> Type} (vm:t to) (x:var), to x.(vtype).

  Parameter set :
    forall {to:stype -> Type} (vm : t to) x (v : to x.(vtype)), t to.

  Axiom get0 : forall to dval x, @get to (empty dval) x = dval x.

  Axiom setP_eq : forall to (vm:t to) x (v:to x.(vtype)),
    get (@set _ vm x v) x = v.

  Axiom setP_neq : forall to (vm:t to) x y (v:to x.(vtype)),
    x != y -> get (@set _ vm x v) y = get vm y.

  Axiom setP : ∀ to (vm: t to) x y (v: to x.(vtype)),
      get (@set _ vm x v) y =
      match x =P y with
      | ReflectT x_eq_y => ecast _ _ x_eq_y v
      | _ => get vm y
      end.

  Definition ext_eq  {to} (vm1 vm2 : t to) :=
    forall x, get vm1 x = get vm2 x.

End FvT.

Module Fv : FvT.

  Definition t := Mv.t.

  Definition empty := @Mv.empty.

  Definition get := @Mv.get.

  Definition set := @Mv.set.

  Lemma get0 to dval x : @get to (empty dval) x = dval x.
  Proof. by apply: Mv.get0. Qed.

  Lemma setP_eq to (vm:t to) x (v:to x.(vtype)) :
    get (@set _ vm x v) x = v.
  Proof. apply Mv.setP_eq. Qed.

  Lemma setP_neq to (vm:t to) x y (v:to x.(vtype)) :
    x != y -> get (@set _ vm x v) y = get vm y.
  Proof. apply Mv.setP_neq. Qed.

  Lemma setP to (vm: t to) x y (v: to x.(vtype)) :
      get (@set _ vm x v) y =
      match x =P y with
      | ReflectT x_eq_y => ecast _ _ x_eq_y v
      | _ => get vm y
      end.
  Proof.
    case: (x =P y).
    + move => ?; subst; exact: setP_eq.
    move => /eqP; exact: setP_neq.
  Qed.

  Definition ext_eq  {to} (vm1 vm2 : t to) :=
    forall x, get vm1 x = get vm2 x.

End Fv.

Declare Scope vmap_scope.
Delimit Scope vmap_scope with vmap.
Notation "vm .[ id ]" := (Fv.get vm id) : vmap_scope.
Notation "vm .[ k  <- v ]" := (@Fv.set _ vm k v) : vmap_scope.
Notation "vm1 =v vm2" := (Fv.ext_eq vm1 vm2) (at level 70, no associativity) : vmap_scope.
Arguments Fv.get to vm%vmap_scope x.
Arguments Fv.set to vm%vmap_scope x v.
Arguments Fv.ext_eq to vm1%vmap_scope vm2%vmap_scope.

(* Attempt to simplify goals of the form [vm.[y0 <- z0]...[yn <- zn].[x]]. *)
Ltac t_vm_get :=
  repeat (
    rewrite Fv.setP_eq
    || (rewrite Fv.setP_neq; last (apply/eqP; by [|apply/nesym]))
  ).

(* Deduce inequalities from [~ Sv.In x (Sv.add y0 (... (Sv.add yn s)))]. *)
Ltac t_notin_add :=
  repeat (move=> /Sv.add_spec /Decidable.not_or [] ?);
  move=> ?.

Module Type Vmap.

  Parameter t : (stype -> Type) -> Type.

  Parameter empty : forall to, (forall (x:var), to x.(vtype)) -> t to.

  Parameter get : forall {to}, t to -> forall (x:var), to x.(vtype).

  Parameter set : forall {to}, t to -> forall (x:var), to x.(vtype) -> t to.

  Parameter get0 :
    forall {to} (dft: forall x, to x.(vtype)) (x:var),
      get (empty dft) x = dft x.

  Parameter setP_eq :
    forall {to} (m:t to) (x:var) (v:to x.(vtype)),
      get (@set to m x v) x = v.

  Parameter setP_neq :
    forall {to} (m:t to) x y (v:to x.(vtype)),
      x != y -> get (@set to m x v) y = get m y.

End Vmap.

(* ** Finite set of variables (computable)
 *
 * -------------------------------------------------------------------- *)

Module CmpVar.

  Definition t := [eqType of var].

  Definition cmp : t -> t -> comparison := var_cmp.

  Definition cmpO : Cmp cmp := varO.

End CmpVar.

Module SExtra (T : CmpType).

Module Sv := Smake T.
Module SvP := MSetEqProperties.EqProperties Sv.
Module SvD := MSetDecide.WDecide Sv.

Lemma Sv_memP x s: reflect (Sv.In x s) (Sv.mem x s).
Proof.
  apply: (@equivP (Sv.mem x s));first by apply idP.
  by rewrite -Sv.mem_spec.
Qed.

Lemma Sv_elemsP x s : reflect (Sv.In x s) (x \in Sv.elements s).
Proof.
  apply: (equivP idP);rewrite SvD.F.elements_iff.
  elim: (Sv.elements s) => /= [|v vs H]; split => //=.
  + by move /SetoidList.InA_nil.
  + by rewrite inE => /orP [ /eqP -> | /H];auto.
  case/SetoidList.InA_cons => [ -> |]; rewrite inE ?eq_refl //.
  by move /H => ->; rewrite orbT.
Qed.

Lemma Sv_elems_eq x s : Sv.mem x s = (x \in (Sv.elements s)).
Proof. by apply: sameP (Sv_memP x s) (Sv_elemsP x s). Qed.

Definition disjoint s1 s2 := Sv.is_empty (Sv.inter s1 s2).

#[global]
Instance disjoint_m :
  Proper (Sv.Equal ==> Sv.Equal ==> eq) disjoint.
Proof.
  by move => s1 s1' Heq1 s2 s2' Heq2;rewrite /disjoint Heq1 Heq2.
Qed.

#[global]
Instance disjoint_sym : Symmetric disjoint.
Proof.
  move=> x y h; rewrite/disjoint.
  erewrite SvD.F.is_empty_m. exact h.
  SvD.fsetdec.
Qed.

Lemma disjoint_w x x' y :
  Sv.Subset x x' →
  disjoint x' y →
  disjoint x y.
Proof.
  move=> le e; apply SvD.F.is_empty_iff in e.
  apply SvD.F.is_empty_iff.
  SvD.fsetdec.
Qed.

Lemma disjointP s1 s2 :
  reflect (forall x, Sv.In x s1 -> ~ Sv.In x s2) (disjoint s1 s2).
Proof.
  case: (@idP (disjoint s1 s2)) => hdisj; constructor.
  + move=> x h1 h2.
    move: hdisj; rewrite /disjoint => /Sv.is_empty_spec /(_ x) /Sv.inter_spec.
    by apply.
  move=> h; apply: hdisj.
  rewrite /disjoint.
  by apply /Sv.is_empty_spec => x /Sv.inter_spec []; apply h.
Qed.

Lemma disjoint_diff A B :
  disjoint A B →
  Sv.Equal (Sv.diff B A) B.
Proof.
  rewrite /disjoint /is_true Sv.is_empty_spec.
  SvD.fsetdec.
Qed.

Lemma in_disjoint_diff x a b c :
  Sv.In x a →
  Sv.In x b →
  disjoint a (Sv.diff b c) →
  Sv.In x c.
Proof. rewrite /disjoint /is_true Sv.is_empty_spec; SvD.fsetdec. Qed.

(* ---------------------------------------------------------------- *)
Lemma Sv_mem_add (s: Sv.t) (x y: Sv.elt) :
  Sv.mem x (Sv.add y s) = (x == y) || Sv.mem x s.
Proof.
  case: eqP.
  - move => <-; exact: SvP.add_mem_1.
  move => ne; exact: (SvD.F.add_neq_b _ (not_eq_sym ne)).
Qed.

Lemma Sv_Subset_union_left (a b c: Sv.t) :
  Sv.Subset a b → Sv.Subset a (Sv.union b c).
Proof. SvD.fsetdec. Qed.

Lemma Sv_Subset_union_right (a b c: Sv.t) :
  Sv.Subset a c → Sv.Subset a (Sv.union b c).
Proof. SvD.fsetdec. Qed.

Lemma Sv_union_empty (a : Sv.t) :
  Sv.Equal (Sv.union Sv.empty a) a.
Proof. SvD.fsetdec. Qed.

(* ---------------------------------------------------------------- *)
Definition sv_of_list T (f: T → Sv.elt) : seq T → Sv.t :=
  foldl (λ s r, Sv.add (f r) s) Sv.empty.

Lemma sv_of_listE T (f: T → Sv.elt) x m :
  Sv.mem x (sv_of_list f m) = (x \in map f m).
Proof.
  suff h : forall s, Sv.mem x (foldl (λ (s : Sv.t) (r : T), Sv.add (f r) s) s m) = (x \in map f m) || Sv.mem x s by rewrite h orbF.
  elim: m => //= z m hrec s.
  rewrite hrec in_cons SvD.F.add_b /SvD.F.eqb.
  case: SvD.F.eq_dec => [-> | /eqP]; first by rewrite eqxx /= orbT.
  by rewrite eq_sym => /negbTE ->.
Qed.

Lemma sv_of_listP T (f: T → Sv.elt) x m :
  reflect (Sv.In x (sv_of_list f m)) (x \in map f m).
Proof. rewrite -sv_of_listE; apply Sv_memP. Qed.

Lemma sv_of_list_map A B (f: A → B) (g: B → Sv.elt) m :
  sv_of_list g (map f m) = sv_of_list (g \o f) m.
Proof.
  rewrite /sv_of_list.
  elim: m Sv.empty => // a m ih z.
  by rewrite /= ih.
Qed.

Lemma sv_of_list_mem_head X f (x : X) xs :
  Sv.mem (f x) (sv_of_list f (x :: xs)).
Proof. rewrite sv_of_listE. exact: mem_head. Qed.

Lemma sv_of_list_mem_tail X f v (x : X) xs :
  Sv.mem v (sv_of_list f xs)
  -> Sv.mem v (sv_of_list f (x :: xs)).
Proof.
  rewrite !sv_of_listE.
  rewrite in_cons.
  move=> ->.
  exact: orbT.
Qed.

Lemma disjoint_subset_diff xs ys :
  disjoint xs ys
  -> Sv.Subset xs (Sv.diff xs ys).
Proof.
  move=> /disjoint_sym /disjoint_diff /SvP.MP.equal_sym.
  exact: SvP.MP.subset_equal.
Qed.

Lemma in_add_singleton x y :
  Sv.In x (Sv.add y (Sv.singleton x)).
Proof. apply: SvD.F.add_2. exact: SvD.F.singleton_2. Qed.

Lemma disjoint_equal_l xs ys zs:
  Sv.Equal xs ys
  -> disjoint xs zs
  -> disjoint ys zs.
Proof.
  move=> heq /Sv.is_empty_spec h. apply/Sv.is_empty_spec. SvD.fsetdec.
Qed.

Lemma disjoint_equal_r xs ys zs:
  Sv.Equal xs ys
  -> disjoint ys zs
  -> disjoint xs zs.
Proof.
  move=> heq /Sv.is_empty_spec h. apply/Sv.is_empty_spec. SvD.fsetdec.
Qed.

Lemma disjoint_union xs ys zs :
  disjoint (Sv.union xs ys) zs
  -> disjoint xs zs /\ disjoint ys zs.
Proof.
 move=> /Sv.is_empty_spec H.
 split.
 all: apply/Sv.is_empty_spec.
 all: SvD.fsetdec.
Qed.

Lemma disjoint_add x xs ys :
  disjoint (Sv.add x xs) ys
  -> disjoint (Sv.singleton x) ys /\ disjoint xs ys.
Proof.
  move=> /Sv.is_empty_spec h.
  split.
  all: apply/Sv.is_empty_spec.
  all: move: h.
  all: SvD.fsetdec.
Qed.

Lemma union_disjoint xs ys zs :
  disjoint xs zs
  -> disjoint ys zs
  -> disjoint (Sv.union xs ys) zs.
Proof.
  rewrite /disjoint.
  move=> /Sv.is_empty_spec h0.
  move=> /Sv.is_empty_spec h1.
  apply/Sv.is_empty_spec.
  move: h0 h1.
  clear.
  SvD.fsetdec.
Qed.

Lemma Sv_equal_add_add x s :
  Sv.Equal (Sv.add x (Sv.add x s)) (Sv.add x s).
Proof. SvD.fsetdec. Qed.

Lemma Sv_neq_not_in_singleton x y :
  x <> y
  -> ~ Sv.In y (Sv.singleton x).
Proof. SvD.fsetdec. Qed.

End SExtra.

Module SvExtra := SExtra CmpVar.
Export SvExtra.

(* Non dependant map *)
Module Mvar :=  Mmake CmpVar.

Definition Mvar_eq T (m1 m2:Mvar.t T) :=
  forall x, Mvar.get m1 x = Mvar.get m2 x.

#[global]
Polymorphic Instance equiv_Mvar_eq T : Equivalence (@Mvar_eq T).
Proof.
  split=> //.
  + by move=> m1 m2 Hm z;rewrite Hm.
  by move=> m1 m2 m3 Hm1 Hm2 z;rewrite Hm1 Hm2.
Qed.

#[global]
Instance Mvar_get_m T:
  Proper (@Mvar_eq T ==> eq ==> eq) Mvar.get.
Proof. by move=> m1 m2 Hm ?? <-. Qed.

#[global]
Instance Mvar_set_m T:
  Proper (@Mvar_eq T ==> eq ==> eq ==> @Mvar_eq T) Mvar.set.
Proof. by move=> m1 m2 Hm ?? <- ?? <- z;rewrite !Mvar.setP;case:ifP. Qed.

#[global]
Instance Mvar_remove_m T:
  Proper (@Mvar_eq T ==> eq ==> @Mvar_eq T) Mvar.remove.
Proof. by move=> m1 m2 Hm ?? <- z;rewrite !Mvar.removeP;case:ifP. Qed.


(*
 * © 2019-2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
Inductive label {A} : Type :=
  Silent : label
| Action : A -> label
.

Inductive type : Set :=
| Access
| Bool
| Nat
| Unit
| TPair (t1 t2 : type)
.

Module Type GRANT_ACCESS.
  Parameter access : Set.
End GRANT_ACCESS.

Module Messages (GA : GRANT_ACCESS).

  Inductive message : type -> Type :=
  | Permission (acc : GA.access) : message Access
  | Content (n : nat) : message Nat
  | MsgPair {t1 t2} (m1 : message t1) (m2 : message t2) : message (TPair t1 t2)
  .

  Fixpoint typeDenote (t : type) :=
    match t with
    | Access => GA.access
    | Bool => bool
    | Nat => nat
    | Unit => unit
    | TPair t1 t2 => (typeDenote t1 * typeDenote t2)%type
    end
  .

  Definition extractContent (msg : message Nat) : nat :=
    match msg with
    | Content t => t
    end.

  Definition extractPermission (msg : message Access) : GA.access :=
    match msg with
    | Permission a => a
    end.

  Definition msgFst {t1 t2} (msg : message (TPair t1 t2)) : (message t1) :=
    match msg with
    | MsgPair m1 _ => m1
    end.

  Definition msgSnd {t1 t2} (msg : message (TPair t1 t2)) : (message t2) :=
    match msg with
    | MsgPair _ m2 => m2
    end.

End Messages.